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