1 module Vectorise.Type.TyConDecl
4 import Vectorise.Type.Type
19 -- | Vectorise some (possibly recursively defined) type constructors.
20 vectTyConDecls :: [TyCon] -> VM [TyCon]
21 vectTyConDecls tcs = fixV $ \tcs' ->
23 mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
24 mapM vectTyConDecl tcs
27 -- | Vectorise a single type construcrtor.
28 vectTyConDecl :: TyCon -> VM TyCon
30 -- a type class constructor.
31 -- TODO: check for no stupid theta, fds, assoc types.
33 , Just cls <- tyConClass_maybe tycon
35 = do -- make the name of the vectorised class tycon.
36 name' <- cloneName mkVectTyConOcc (tyConName tycon)
38 -- vectorise right of definition.
39 rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
41 -- vectorise method selectors.
42 -- This also adds a mapping between the original and vectorised method selector
44 methods' <- mapM vectMethod
45 $ [(id, defMethSpecOfDefMeth meth)
46 | (id, meth) <- classOpItems cls]
48 -- keep the original recursiveness flag.
49 let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
51 -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
54 False -- include unfoldings on dictionary selectors.
55 name' -- new name V_T:Class
56 (tyConTyVars tycon) -- keep original type vars
58 [] -- no functional dependencies
59 [] -- no associated types
60 methods' -- method info
61 rec_flag -- whether recursive
63 let tycon' = mkClassTyCon name'
72 -- a regular algebraic type constructor.
73 -- TODO: check for stupid theta, generaics, GADTS etc
75 = do name' <- cloneName mkVectTyConOcc (tyConName tycon)
76 rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
77 let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
79 liftDs $ buildAlgTyCon
81 (tyConTyVars tycon) -- keep original type vars.
82 [] -- no stupid theta.
83 rhs' -- new constructor defs.
84 rec_flag -- FIXME: is this ok?
85 False -- not GADT syntax
87 Nothing -- not a family instance
89 -- some other crazy thing that we don't handle.
91 = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
94 -- | Vectorise a class method.
95 vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
96 vectMethod (id, defMeth)
98 -- Vectorise the method type.
99 typ' <- vectType (varType id)
101 -- Create a name for the vectorised method.
102 id' <- cloneId mkVectOcc id typ'
105 -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
106 -- to the types of each method. However, the types we get back from vectType
107 -- above already already have these, so we need to chop them off here otherwise
108 -- we'll get two copies in the final version.
109 let (_tyvars, tyBody) = splitForAllTys typ'
110 let (_dict, tyRest) = splitFunTy tyBody
112 return (Var.varName id', defMeth, tyRest)
115 -- | Vectorise the RHS of an algebraic type.
116 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
117 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
121 data_cons' <- mapM vectDataCon data_cons
122 zipWithM_ defDataCon data_cons data_cons'
123 return $ DataTyCon { data_cons = data_cons'
128 = cantVectorise "Can't vectorise type definition:" (ppr tc)
131 -- | Vectorise a data constructor.
132 -- Vectorises its argument and return types.
133 vectDataCon :: DataCon -> VM DataCon
135 | not . null $ dataConExTyVars dc
136 = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
138 | not . null $ dataConEqSpec dc
139 = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
143 name' <- cloneName mkVectDataConOcc name
144 tycon' <- vectTyCon tycon
145 arg_tys <- mapM vectType rep_arg_tys
147 liftDs $ buildDataCon
150 (map (const HsNoBang) arg_tys) -- strictness annots on args.
151 [] -- no labelled fields
152 univ_tvs -- universally quantified vars
153 [] -- no existential tvs for now
154 [] -- no eq spec for now
156 arg_tys -- argument types
157 (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
158 tycon' -- representation tycon
160 name = dataConName dc
161 univ_tvs = dataConUnivTyVars dc
162 rep_arg_tys = dataConRepArgTys dc
163 tycon = dataConTyCon dc