Refactor buildClass and mkDictSelId a bit, to avoid the no_unf argument
[ghc.git] / compiler / vectorise / Vectorise / Type / TyConDecl.hs
1
2 module Vectorise.Type.TyConDecl (
3 vectTyConDecls
4 ) where
5
6 import Vectorise.Type.Type
7 import Vectorise.Monad
8 import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
9 import BuildTyCl( buildClass, buildDataCon )
10 import Class
11 import Type
12 import TyCon
13 import DataCon
14 import BasicTypes
15 import DynFlags
16 import Var
17 import Name
18 import Outputable
19 import Util
20 import Control.Monad
21
22
23 -- |Vectorise some (possibly recursively defined) type constructors.
24 --
25 vectTyConDecls :: [TyCon] -> VM [TyCon]
26 vectTyConDecls tcs = fixV $ \tcs' ->
27 do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
28 ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
29 ; zipWithM vectTyConDecl tcs names'
30 }
31
32 -- |Vectorise a single type constructor.
33 --
34 vectTyConDecl :: TyCon -> Name -> VM TyCon
35 vectTyConDecl tycon name'
36
37 -- Type constructor representing a type class
38 | Just cls <- tyConClass_maybe tycon
39 = do { unless (null $ classATs cls) $
40 do dflags <- getDynFlags
41 cantVectorise dflags "Associated types are not yet supported" (ppr cls)
42
43 -- vectorise superclass constraint (types)
44 ; theta' <- mapM vectType (classSCTheta cls)
45
46 -- vectorise method selectors
47 ; let opItems = classOpItems cls
48 Just datacon = tyConSingleDataCon_maybe tycon
49 argTys = dataConRepArgTys datacon -- all selector types
50 opTys = drop (length argTys - length opItems) argTys -- only method types
51 ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
52
53 -- keep the original recursiveness flag
54 ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
55
56 -- construct the vectorised class (this also creates the class type constructors and its
57 -- data constructor)
58 --
59 -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
60 ; cls' <- liftDs $
61 buildClass
62 name' -- new name: "V:Class"
63 (tyConTyVars tycon) -- keep original type vars
64 (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
65 theta' -- superclasses
66 (snd . classTvsFds $ cls) -- keep the original functional dependencies
67 [] -- no associated types (for the moment)
68 methods' -- method info
69 (classMinimalDef cls) -- Inherit minimal complete definition from cls
70 rec_flag -- whether recursive
71
72 -- the original dictionary constructor must map to the vectorised one
73 ; let tycon' = classTyCon cls'
74 Just datacon = tyConSingleDataCon_maybe tycon
75 Just datacon' = tyConSingleDataCon_maybe tycon'
76 ; defDataCon datacon datacon'
77
78 -- the original superclass and methods selectors must map to the vectorised ones
79 ; let selIds = classAllSelIds cls
80 selIds' = classAllSelIds cls'
81 ; zipWithM_ defGlobalVar selIds selIds'
82
83 -- return the type constructor of the vectorised class
84 ; return tycon'
85 }
86
87 -- Regular algebraic type constructor — for now, Haskell 2011-style only
88 | isAlgTyCon tycon
89 = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
90 do dflags <- getDynFlags
91 cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
92
93 -- vectorise the data constructor of the class tycon
94 ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
95
96 -- keep the original recursiveness and GADT flags
97 ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
98 gadt_flag = isGadtSyntaxTyCon tycon
99
100 -- build the vectorised type constructor
101 ; return $ buildAlgTyCon
102 name' -- new name
103 (tyConTyVars tycon) -- keep original type vars
104 (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
105 Nothing
106 [] -- no stupid theta
107 rhs' -- new constructor defs
108 rec_flag -- whether recursive
109 False -- Not promotable
110 gadt_flag -- whether in GADT syntax
111 NoParentTyCon
112 }
113
114 -- some other crazy thing that we don't handle
115 | otherwise
116 = do dflags <- getDynFlags
117 cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)
118
119 -- |Vectorise a class method. (Don't enter it into the vectorisation map yet.)
120 --
121 vectMethod :: Id -> DefMeth -> Type -> VM (Name, DefMethSpec, Type)
122 vectMethod id defMeth ty
123 = do { -- Vectorise the method type.
124 ; ty' <- vectType ty
125
126 -- Create a name for the vectorised method.
127 ; id' <- mkVectId id ty'
128
129 ; return (Var.varName id', defMethSpecOfDefMeth defMeth, ty')
130 }
131
132 -- |Vectorise the RHS of an algebraic type.
133 --
134 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
135 vectAlgTyConRhs tc (AbstractTyCon {})
136 = do dflags <- getDynFlags
137 cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
138 vectAlgTyConRhs _tc DataFamilyTyCon
139 = return DataFamilyTyCon
140 vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
141 , is_enum = is_enum
142 })
143 = do { data_cons' <- mapM vectDataCon data_cons
144 ; zipWithM_ defDataCon data_cons data_cons'
145 ; return $ DataTyCon { data_cons = data_cons'
146 , is_enum = is_enum
147 }
148 }
149 vectAlgTyConRhs tc (NewTyCon {})
150 = do dflags <- getDynFlags
151 cantVectorise dflags noNewtypeErr (ppr tc)
152 where
153 noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
154
155 -- |Vectorise a data constructor by vectorising its argument and return types..
156 --
157 vectDataCon :: DataCon -> VM DataCon
158 vectDataCon dc
159 | not . null $ ex_tvs
160 = do dflags <- getDynFlags
161 cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)
162 | not . null $ eq_spec
163 = do dflags <- getDynFlags
164 cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)
165 | not . null $ dataConFieldLabels dc
166 = do dflags <- getDynFlags
167 cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)
168 | not . null $ theta
169 = do dflags <- getDynFlags
170 cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)
171 | otherwise
172 = do { name' <- mkLocalisedName mkVectDataConOcc name
173 ; tycon' <- vectTyCon tycon
174 ; arg_tys <- mapM vectType rep_arg_tys
175 ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
176 ; fam_envs <- readGEnv global_fam_inst_env
177 ; liftDs $ buildDataCon fam_envs
178 name'
179 (dataConIsInfix dc) -- infix if the original is
180 (dataConStrictMarks dc) -- strictness as original constructor
181 [] -- no labelled fields for now
182 univ_tvs -- universally quantified vars
183 [] -- no existential tvs for now
184 [] -- no equalities for now
185 [] -- no context for now
186 arg_tys -- argument types
187 ret_ty -- return type
188 tycon' -- representation tycon
189 }
190 where
191 name = dataConName dc
192 rep_arg_tys = dataConRepArgTys dc
193 tycon = dataConTyCon dc
194 (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc