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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
module Vectorise.Type.TyConDecl (
vectTyConDecls
) where
import Vectorise.Type.Type
import Vectorise.Monad
import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName )
import OccName
import Class
import Type
import TyCon
import DataCon
import BasicTypes
import DynFlags
import Var
import Name
import Outputable
import Util
import Control.Monad
-- |Vectorise some (possibly recursively defined) type constructors.
--
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
; zipWithM vectTyConDecl tcs names'
}
-- |Vectorise a single type constructor.
--
vectTyConDecl :: TyCon -> Name -> VM TyCon
vectTyConDecl tycon name'
-- Type constructor representing a type class
| Just cls <- tyConClass_maybe tycon
= do { unless (null $ classATs cls) $
do dflags <- getDynFlags
cantVectorise dflags "Associated types are not yet supported" (ppr cls)
-- vectorise superclass constraint (types)
; theta' <- mapM vectType (classSCTheta cls)
-- vectorise method selectors
; let opItems = classOpItems cls
Just datacon = tyConSingleDataCon_maybe tycon
argTys = dataConRepArgTys datacon -- all selector types
opTys = drop (length argTys - length opItems) argTys -- only method types
; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
-- keep the original recursiveness flag
; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
-- construct the vectorised class (this also creates the class type constructors and its
-- data constructor)
--
-- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
; cls' <- liftDs $
buildClass
name' -- new name: "V:Class"
(tyConTyVars tycon) -- keep original type vars
(map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
theta' -- superclasses
(tyConBinders tycon) -- keep original kind
(snd . classTvsFds $ cls) -- keep the original functional dependencies
[] -- no associated types (for the moment)
methods' -- method info
(classMinimalDef cls) -- Inherit minimal complete definition from cls
rec_flag -- whether recursive
-- the original dictionary constructor must map to the vectorised one
; let tycon' = classTyCon cls'
Just datacon = tyConSingleDataCon_maybe tycon
Just datacon' = tyConSingleDataCon_maybe tycon'
; defDataCon datacon datacon'
-- the original superclass and methods selectors must map to the vectorised ones
; let selIds = classAllSelIds cls
selIds' = classAllSelIds cls'
; zipWithM_ defGlobalVar selIds selIds'
-- return the type constructor of the vectorised class
; return tycon'
}
-- Regular algebraic type constructor — for now, Haskell 2011-style only
| isAlgTyCon tycon
= do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
do dflags <- getDynFlags
cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
-- vectorise the data constructor of the class tycon
; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-- keep the original recursiveness and GADT flags
; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
gadt_flag = isGadtSyntaxTyCon tycon
-- build the vectorised type constructor
; tc_rep_name <- mkDerivedName mkTyConRepOcc name'
; return $ mkAlgTyCon
name' -- new name
(tyConBinders tycon)
(tyConResKind tycon) -- keep original kind
(tyConTyVars tycon) -- keep original type vars
(map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
Nothing
[] -- no stupid theta
rhs' -- new constructor defs
(VanillaAlgTyCon tc_rep_name)
rec_flag -- whether recursive
gadt_flag -- whether in GADT syntax
}
-- some other crazy thing that we don't handle
| otherwise
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)
-- |Vectorise a class method. (Don't enter it into the vectorisation map yet.)
--
vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo
vectMethod id defMeth ty
= do { -- Vectorise the method type.
; ty' <- vectType ty
-- Create a name for the vectorised method.
; id' <- mkVectId id ty'
; return (Var.varName id', ty', defMethSpecOfDefMeth defMeth)
}
-- |Vectorise the RHS of an algebraic type.
--
vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
vectAlgTyConRhs tc (AbstractTyCon {})
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
, is_enum = is_enum
})
= do { data_cons' <- mapM vectDataCon data_cons
; zipWithM_ defDataCon data_cons data_cons'
; return $ DataTyCon { data_cons = data_cons'
, is_enum = is_enum
}
}
vectAlgTyConRhs tc (TupleTyCon { data_con = con })
= vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False })
-- I'm not certain this is what you want to do for tuples,
-- but it's the behaviour we had before I refactored the
-- representation of AlgTyConRhs to add tuples
vectAlgTyConRhs tc (NewTyCon {})
= do dflags <- getDynFlags
cantVectorise dflags noNewtypeErr (ppr tc)
where
noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
-- |Vectorise a data constructor by vectorising its argument and return types..
--
vectDataCon :: DataCon -> VM DataCon
vectDataCon dc
| not . null $ ex_tvs
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)
| not . null $ eq_spec
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)
| not . null $ dataConFieldLabels dc
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)
| not . null $ theta
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)
| otherwise
= do { name' <- mkLocalisedName mkVectDataConOcc name
; tycon' <- vectTyCon tycon
; arg_tys <- mapM vectType rep_arg_tys
; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
; fam_envs <- readGEnv global_fam_inst_env
; rep_nm <- liftDs $ newTyConRepName name'
; liftDs $ buildDataCon fam_envs
name'
(dataConIsInfix dc) -- infix if the original is
rep_nm
(dataConSrcBangs dc) -- strictness as original constructor
(Just $ dataConImplBangs dc)
[] -- no labelled fields for now
univ_tvs -- universally quantified vars
[] -- no existential tvs for now
[] -- no equalities for now
[] -- no context for now
arg_tys -- argument types
ret_ty -- return type
tycon' -- representation tycon
}
where
name = dataConName dc
rep_arg_tys = dataConRepArgTys dc
tycon = dataConTyCon dc
(univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
|
