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