4f3112850d700e8d0170a6ebb935fc6843cf89fd
[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 = mkAlgTyCon name'
54 (mkTyBindersPreferAnon tyvars' liftedTypeKind)
55 liftedTypeKind
56 tyvars'
57 (map (const Nominal) tyvars')
58 Nothing
59 [] -- no stupid theta
60 rhs
61 (DataFamInstTyCon ax fam_tc pat_tys)
62 rec_flag -- FIXME: is this ok?
63 False -- not GADT syntax
64 ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
65 where
66 tyvars = tyConTyVars vect_tc
67 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
68
69 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
70 buildPDataTyConRhs orig_name vect_tc repr_tc repr
71 = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
72 return $ DataTyCon { data_cons = [data_con], is_enum = False }
73
74
75 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
76 buildPDataDataCon orig_name vect_tc repr_tc repr
77 = do let tvs = tyConTyVars vect_tc
78 dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
79 comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
80 fam_envs <- readGEnv global_fam_inst_env
81 rep_nm <- liftDs $ newTyConRepName dc_name
82 liftDs $ buildDataCon fam_envs dc_name
83 False -- not infix
84 rep_nm
85 (map (const no_bang) comp_tys)
86 (Just $ map (const HsLazy) comp_tys)
87 [] -- no field labels
88 tvs
89 [] -- no existentials
90 [] -- no eq spec
91 [] -- no context
92 comp_tys
93 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
94 repr_tc
95 where
96 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
97
98
99 -- buildPDatasTyCon -----------------------------------------------------------
100 -- | Build the PDatas instance tycon for a given type constructor.
101 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
102 buildPDatasTyCon orig_tc vect_tc repr
103 = fixV $ \fam_inst ->
104 do let repr_tc = dataFamInstRepTyCon fam_inst
105 name' <- mkLocalisedName mkPDatasTyConOcc orig_name
106 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
107 pdatas <- builtin pdatasTyCon
108 buildDataFamInst name' pdatas vect_tc rhs
109 where
110 orig_name = tyConName orig_tc
111
112 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
113 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
114 = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
115 return $ DataTyCon { data_cons = [data_con], is_enum = False }
116
117
118 buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
119 buildPDatasDataCon orig_name vect_tc repr_tc repr
120 = do let tvs = tyConTyVars vect_tc
121 dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
122
123 comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
124 fam_envs <- readGEnv global_fam_inst_env
125 rep_nm <- liftDs $ newTyConRepName dc_name
126 liftDs $ buildDataCon fam_envs dc_name
127 False -- not infix
128 rep_nm
129 (map (const no_bang) comp_tys)
130 (Just $ map (const HsLazy) comp_tys)
131 [] -- no field labels
132 tvs
133 [] -- no existentials
134 [] -- no eq spec
135 [] -- no context
136 comp_tys
137 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
138 repr_tc
139 where
140 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
141
142
143 -- Utils ----------------------------------------------------------------------
144 -- | Flatten a SumRepr into a list of data constructor types.
145 mkSumTys
146 :: (SumRepr -> Type)
147 -> (Type -> VM Type)
148 -> SumRepr
149 -> VM [Type]
150
151 mkSumTys repr_selX_ty mkTc repr
152 = sum_tys repr
153 where
154 sum_tys EmptySum = return []
155 sum_tys (UnarySum r) = con_tys r
156 sum_tys d@(Sum { repr_cons = cons })
157 = liftM (repr_selX_ty d :) (concatMapM con_tys cons)
158
159 con_tys (ConRepr _ r) = prod_tys r
160
161 prod_tys EmptyProd = return []
162 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
163 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
164
165 comp_ty r = mkTc (compOrigType r)
166
167 {-
168 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
169 mk_fam_inst fam_tc arg_tc
170 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
171 -}