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