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