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