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 -- FIXME: no generics
86 False -- not GADT syntax
88 Nothing -- not a family instance
90 -- some other crazy thing that we don't handle.
92 = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
95 -- | Vectorise a class method.
96 vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
97 vectMethod (id, defMeth)
99 -- Vectorise the method type.
100 typ' <- vectType (varType id)
102 -- Create a name for the vectorised method.
103 id' <- cloneId mkVectOcc id typ'
106 -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
107 -- to the types of each method. However, the types we get back from vectType
108 -- above already already have these, so we need to chop them off here otherwise
109 -- we'll get two copies in the final version.
110 let (_tyvars, tyBody) = splitForAllTys typ'
111 let (_dict, tyRest) = splitFunTy tyBody
113 return (Var.varName id', defMeth, tyRest)
116 -- | Vectorise the RHS of an algebraic type.
117 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
118 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
122 data_cons' <- mapM vectDataCon data_cons
123 zipWithM_ defDataCon data_cons data_cons'
124 return $ DataTyCon { data_cons = data_cons'
129 = cantVectorise "Can't vectorise type definition:" (ppr tc)
132 -- | Vectorise a data constructor.
133 -- Vectorises its argument and return types.
134 vectDataCon :: DataCon -> VM DataCon
136 | not . null $ dataConExTyVars dc
137 = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
139 | not . null $ dataConEqSpec dc
140 = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
144 name' <- cloneName mkVectDataConOcc name
145 tycon' <- vectTyCon tycon
146 arg_tys <- mapM vectType rep_arg_tys
148 liftDs $ buildDataCon
151 (map (const HsNoBang) arg_tys) -- strictness annots on args.
152 [] -- no labelled fields
153 univ_tvs -- universally quantified vars
154 [] -- no existential tvs for now
155 [] -- no eq spec for now
157 arg_tys -- argument types
158 (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
159 tycon' -- representation tycon
161 name = dataConName dc
162 univ_tvs = dataConUnivTyVars dc
163 rep_arg_tys = dataConRepArgTys dc
164 tycon = dataConTyCon dc