Fold base.git into ghc.git (re #8545)
[ghc.git] / compiler / vectorise / Vectorise / Generic / PData.hs
1
2 -- | Build instance tycons for the PData and PDatas type families.
3 --
4 -- TODO: the PData and PDatas cases are very similar.
5 -- We should be able to factor out the common parts.
6 module Vectorise.Generic.PData
7 ( buildPDataTyCon
8 , buildPDatasTyCon )
9 where
10
11 import Vectorise.Monad
12 import Vectorise.Builtins
13 import Vectorise.Generic.Description
14 import Vectorise.Utils
15 import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
16
17 import BasicTypes
18 import BuildTyCl
19 import DataCon
20 import TyCon
21 import Type
22 import FamInst
23 import FamInstEnv
24 import TcMType
25 import Name
26 import Util
27 import MonadUtils
28 import Control.Monad
29
30
31 -- buildPDataTyCon ------------------------------------------------------------
32 -- | Build the PData instance tycon for a given type constructor.
33 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
34 buildPDataTyCon orig_tc vect_tc repr
35 = fixV $ \fam_inst ->
36 do let repr_tc = dataFamInstRepTyCon fam_inst
37 name' <- mkLocalisedName mkPDataTyConOcc orig_name
38 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
39 pdata <- builtin pdataTyCon
40 buildDataFamInst name' pdata vect_tc rhs
41 where
42 orig_name = tyConName orig_tc
43
44 buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
45 buildDataFamInst name' fam_tc vect_tc rhs
46 = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
47
48 ; (_, tyvars') <- liftDs $ tcInstSigTyVarsLoc (getSrcSpan name') tyvars
49 ; let ax = mkSingleCoAxiom axiom_name tyvars' fam_tc pat_tys rep_ty
50 tys' = mkTyVarTys tyvars'
51 rep_ty = mkTyConApp rep_tc tys'
52 pat_tys = [mkTyConApp vect_tc tys']
53 rep_tc = buildAlgTyCon name'
54 tyvars'
55 (map (const Nominal) tyvars')
56 Nothing
57 [] -- no stupid theta
58 rhs
59 rec_flag -- FIXME: is this ok?
60 False -- Not promotable
61 False -- not GADT syntax
62 (FamInstTyCon ax fam_tc pat_tys)
63 ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
64 where
65 tyvars = tyConTyVars vect_tc
66 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
67
68 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
69 buildPDataTyConRhs orig_name vect_tc repr_tc repr
70 = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
71 return $ DataTyCon { data_cons = [data_con], is_enum = False }
72
73
74 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
75 buildPDataDataCon orig_name vect_tc repr_tc repr
76 = do let tvs = tyConTyVars vect_tc
77 dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
78 comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
79 fam_envs <- readGEnv global_fam_inst_env
80 liftDs $ buildDataCon fam_envs dc_name
81 False -- not infix
82 (map (const HsNoBang) comp_tys)
83 [] -- no field labels
84 tvs
85 [] -- no existentials
86 [] -- no eq spec
87 [] -- no context
88 comp_tys
89 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
90 repr_tc
91
92
93 -- buildPDatasTyCon -----------------------------------------------------------
94 -- | Build the PDatas instance tycon for a given type constructor.
95 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
96 buildPDatasTyCon orig_tc vect_tc repr
97 = fixV $ \fam_inst ->
98 do let repr_tc = dataFamInstRepTyCon fam_inst
99 name' <- mkLocalisedName mkPDatasTyConOcc orig_name
100 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
101 pdatas <- builtin pdatasTyCon
102 buildDataFamInst name' pdatas vect_tc rhs
103 where
104 orig_name = tyConName orig_tc
105
106 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
107 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
108 = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
109 return $ DataTyCon { data_cons = [data_con], is_enum = False }
110
111
112 buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
113 buildPDatasDataCon orig_name vect_tc repr_tc repr
114 = do let tvs = tyConTyVars vect_tc
115 dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
116
117 comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
118 fam_envs <- readGEnv global_fam_inst_env
119 liftDs $ buildDataCon fam_envs dc_name
120 False -- not infix
121 (map (const HsNoBang) comp_tys)
122 [] -- no field labels
123 tvs
124 [] -- no existentials
125 [] -- no eq spec
126 [] -- no context
127 comp_tys
128 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
129 repr_tc
130
131
132 -- Utils ----------------------------------------------------------------------
133 -- | Flatten a SumRepr into a list of data constructor types.
134 mkSumTys
135 :: (SumRepr -> Type)
136 -> (Type -> VM Type)
137 -> SumRepr
138 -> VM [Type]
139
140 mkSumTys repr_selX_ty mkTc repr
141 = sum_tys repr
142 where
143 sum_tys EmptySum = return []
144 sum_tys (UnarySum r) = con_tys r
145 sum_tys d@(Sum { repr_cons = cons })
146 = liftM (repr_selX_ty d :) (concatMapM con_tys cons)
147
148 con_tys (ConRepr _ r) = prod_tys r
149
150 prod_tys EmptyProd = return []
151 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
152 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
153
154 comp_ty r = mkTc (compOrigType r)
155
156 {-
157 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
158 mk_fam_inst fam_tc arg_tc
159 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
160 -}
161