A collection of type-inference refactorings.
[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 BuildTyCl
18 import DataCon
19 import TyCon
20 import Type
21 import FamInst
22 import FamInstEnv
23 import TcMType
24 import Name
25 import Util
26 import MonadUtils
27 import Control.Monad
28
29
30 -- buildPDataTyCon ------------------------------------------------------------
31 -- | Build the PData instance tycon for a given type constructor.
32 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
33 buildPDataTyCon orig_tc vect_tc repr
34 = fixV $ \fam_inst ->
35 do let repr_tc = dataFamInstRepTyCon fam_inst
36 name' <- mkLocalisedName mkPDataTyConOcc orig_name
37 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
38 pdata <- builtin pdataTyCon
39 buildDataFamInst name' pdata vect_tc rhs
40 where
41 orig_name = tyConName orig_tc
42
43 buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
44 buildDataFamInst name' fam_tc vect_tc rhs
45 = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
46
47 ; (_, tyvars') <- liftDs $ freshenTyVarBndrs tyvars
48 ; let ax = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty
49 tys' = mkTyVarTys tyvars'
50 rep_ty = mkTyConApp rep_tc tys'
51 pat_tys = [mkTyConApp vect_tc tys']
52 rep_tc = mkAlgTyCon name'
53 (mkTyConBindersPreferAnon tyvars' liftedTypeKind)
54 liftedTypeKind
55 (map (const Nominal) tyvars')
56 Nothing
57 [] -- no stupid theta
58 rhs
59 (DataFamInstTyCon ax fam_tc pat_tys)
60 False -- not GADT syntax
61 ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
62 where
63 tyvars = tyConTyVars vect_tc
64
65 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
66 buildPDataTyConRhs orig_name vect_tc repr_tc repr
67 = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
68 return $ DataTyCon { data_cons = [data_con], is_enum = False }
69
70
71 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
72 buildPDataDataCon orig_name vect_tc repr_tc repr
73 = do let tvs = tyConTyVars vect_tc
74 dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
75 comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
76 fam_envs <- readGEnv global_fam_inst_env
77 rep_nm <- liftDs $ newTyConRepName dc_name
78 liftDs $ buildDataCon fam_envs dc_name
79 False -- not infix
80 rep_nm
81 (map (const no_bang) comp_tys)
82 (Just $ map (const HsLazy) comp_tys)
83 [] -- no field labels
84 (mkTyVarBinders Specified tvs)
85 [] -- no existentials
86 [] -- no eq spec
87 [] -- no context
88 comp_tys
89 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
90 repr_tc
91 where
92 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
93
94
95 -- buildPDatasTyCon -----------------------------------------------------------
96 -- | Build the PDatas instance tycon for a given type constructor.
97 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
98 buildPDatasTyCon orig_tc vect_tc repr
99 = fixV $ \fam_inst ->
100 do let repr_tc = dataFamInstRepTyCon fam_inst
101 name' <- mkLocalisedName mkPDatasTyConOcc orig_name
102 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
103 pdatas <- builtin pdatasTyCon
104 buildDataFamInst name' pdatas vect_tc rhs
105 where
106 orig_name = tyConName orig_tc
107
108 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
109 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
110 = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
111 return $ DataTyCon { data_cons = [data_con], is_enum = False }
112
113
114 buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
115 buildPDatasDataCon orig_name vect_tc repr_tc repr
116 = do let tvs = tyConTyVars vect_tc
117 dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
118
119 comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
120 fam_envs <- readGEnv global_fam_inst_env
121 rep_nm <- liftDs $ newTyConRepName dc_name
122 liftDs $ buildDataCon fam_envs dc_name
123 False -- not infix
124 rep_nm
125 (map (const no_bang) comp_tys)
126 (Just $ map (const HsLazy) comp_tys)
127 [] -- no field labels
128 (mkTyVarBinders Specified tvs)
129 [] -- no existentials
130 [] -- no eq spec
131 [] -- no context
132 comp_tys
133 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
134 repr_tc
135 where
136 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
137
138
139 -- Utils ----------------------------------------------------------------------
140 -- | Flatten a SumRepr into a list of data constructor types.
141 mkSumTys
142 :: (SumRepr -> Type)
143 -> (Type -> VM Type)
144 -> SumRepr
145 -> VM [Type]
146
147 mkSumTys repr_selX_ty mkTc repr
148 = sum_tys repr
149 where
150 sum_tys EmptySum = return []
151 sum_tys (UnarySum r) = con_tys r
152 sum_tys d@(Sum { repr_cons = cons })
153 = liftM (repr_selX_ty d :) (concatMapM con_tys cons)
154
155 con_tys (ConRepr _ r) = prod_tys r
156
157 prod_tys EmptyProd = return []
158 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
159 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
160
161 comp_ty r = mkTc (compOrigType r)
162
163 {-
164 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
165 mk_fam_inst fam_tc arg_tc
166 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
167 -}