fc0192c7446afc0a979602e60176a7b230fc878a
[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 Representational 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 no_bang) comp_tys)
83 (Just $ map (const HsLazy) comp_tys)
84 [] -- no field labels
85 tvs
86 [] -- no existentials
87 [] -- no eq spec
88 [] -- no context
89 comp_tys
90 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
91 repr_tc
92 where
93 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
94
95
96 -- buildPDatasTyCon -----------------------------------------------------------
97 -- | Build the PDatas instance tycon for a given type constructor.
98 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
99 buildPDatasTyCon orig_tc vect_tc repr
100 = fixV $ \fam_inst ->
101 do let repr_tc = dataFamInstRepTyCon fam_inst
102 name' <- mkLocalisedName mkPDatasTyConOcc orig_name
103 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
104 pdatas <- builtin pdatasTyCon
105 buildDataFamInst name' pdatas vect_tc rhs
106 where
107 orig_name = tyConName orig_tc
108
109 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
110 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
111 = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
112 return $ DataTyCon { data_cons = [data_con], is_enum = False }
113
114
115 buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
116 buildPDatasDataCon orig_name vect_tc repr_tc repr
117 = do let tvs = tyConTyVars vect_tc
118 dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
119
120 comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
121 fam_envs <- readGEnv global_fam_inst_env
122 liftDs $ buildDataCon fam_envs dc_name
123 False -- not infix
124 (map (const no_bang) comp_tys)
125 (Just $ map (const HsLazy) comp_tys)
126 [] -- no field labels
127 tvs
128 [] -- no existentials
129 [] -- no eq spec
130 [] -- no context
131 comp_tys
132 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
133 repr_tc
134 where
135 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
136
137
138 -- Utils ----------------------------------------------------------------------
139 -- | Flatten a SumRepr into a list of data constructor types.
140 mkSumTys
141 :: (SumRepr -> Type)
142 -> (Type -> VM Type)
143 -> SumRepr
144 -> VM [Type]
145
146 mkSumTys repr_selX_ty mkTc repr
147 = sum_tys repr
148 where
149 sum_tys EmptySum = return []
150 sum_tys (UnarySum r) = con_tys r
151 sum_tys d@(Sum { repr_cons = cons })
152 = liftM (repr_selX_ty d :) (concatMapM con_tys cons)
153
154 con_tys (ConRepr _ r) = prod_tys r
155
156 prod_tys EmptyProd = return []
157 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
158 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
159
160 comp_ty r = mkTc (compOrigType r)
161
162 {-
163 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
164 mk_fam_inst fam_tc arg_tc
165 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
166 -}