--- /dev/null
+module Vectorise.Type.TyConDecl
+ (vectTyConDecls)
+where
+import Vectorise.Type.Type
+import Vectorise.Monad
+import BuildTyCl
+import Class
+import Type
+import TyCon
+import DataCon
+import BasicTypes
+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
+ mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
+ mapM vectTyConDecl tcs
+
+
+-- | Vectorise a single type construcrtor.
+vectTyConDecl :: TyCon -> VM TyCon
+vectTyConDecl tycon
+ -- a type class constructor.
+ -- TODO: check for no stupid theta, fds, assoc types.
+ | isClassTyCon tycon
+ , Just cls <- tyConClass_maybe tycon
+
+ = do -- make the name of the vectorised class tycon.
+ name' <- cloneName mkVectTyConOcc (tyConName tycon)
+
+ -- vectorise right of definition.
+ rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
+
+ -- vectorise method selectors.
+ -- This also adds a mapping between the original and vectorised method selector
+ -- to the state.
+ methods' <- mapM vectMethod
+ $ [(id, defMethSpecOfDefMeth meth)
+ | (id, meth) <- classOpItems cls]
+
+ -- keep the original recursiveness flag.
+ let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
+
+ -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
+ cls' <- liftDs
+ $ buildClass
+ False -- include unfoldings on dictionary selectors.
+ name' -- new name V_T:Class
+ (tyConTyVars tycon) -- keep original type vars
+ [] -- no stupid theta
+ [] -- no functional dependencies
+ [] -- no associated types
+ methods' -- method info
+ rec_flag -- whether recursive
+
+ let tycon' = mkClassTyCon name'
+ (tyConKind tycon)
+ (tyConTyVars tycon)
+ rhs'
+ cls'
+ rec_flag
+
+ return $ tycon'
+
+ -- a regular algebraic type constructor.
+ -- TODO: check for stupid theta, generaics, GADTS etc
+ | isAlgTyCon tycon
+ = do name' <- cloneName mkVectTyConOcc (tyConName tycon)
+ rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
+ let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
+
+ liftDs $ buildAlgTyCon
+ name' -- new name
+ (tyConTyVars tycon) -- keep original type vars.
+ [] -- no stupid theta.
+ rhs' -- new constructor defs.
+ rec_flag -- FIXME: is this ok?
+ False -- FIXME: no generics
+ False -- not GADT syntax
+ Nothing -- not a family instance
+
+ -- some other crazy thing that we don't handle.
+ | otherwise
+ = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
+
+
+-- | Vectorise a class method.
+vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
+vectMethod (id, defMeth)
+ = do
+ -- Vectorise the method type.
+ typ' <- vectType (varType id)
+
+ -- Create a name for the vectorised method.
+ id' <- cloneId mkVectOcc id typ'
+ defGlobalVar id id'
+
+ -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
+ -- to the types of each method. However, the types we get back from vectType
+ -- above already already have these, so we need to chop them off here otherwise
+ -- we'll get two copies in the final version.
+ let (_tyvars, tyBody) = splitForAllTys typ'
+ let (_dict, tyRest) = splitFunTy tyBody
+
+ return (Var.varName id', defMeth, tyRest)
+
+
+-- | Vectorise the RHS of an algebraic type.
+vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
+vectAlgTyConRhs _ (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 _
+ = cantVectorise "Can't vectorise type definition:" (ppr tc)
+
+
+-- | Vectorise a data constructor.
+-- Vectorises its argument and return types.
+vectDataCon :: DataCon -> VM DataCon
+vectDataCon dc
+ | not . null $ dataConExTyVars dc
+ = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
+
+ | not . null $ dataConEqSpec dc
+ = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
+
+ | otherwise
+ = do
+ name' <- cloneName mkVectDataConOcc name
+ tycon' <- vectTyCon tycon
+ arg_tys <- mapM vectType rep_arg_tys
+
+ liftDs $ buildDataCon
+ name'
+ False -- not infix
+ (map (const HsNoBang) arg_tys) -- strictness annots on args.
+ [] -- no labelled fields
+ univ_tvs -- universally quantified vars
+ [] -- no existential tvs for now
+ [] -- no eq spec for now
+ [] -- no context
+ arg_tys -- argument types
+ (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
+ tycon' -- representation tycon
+ where
+ name = dataConName dc
+ univ_tvs = dataConUnivTyVars dc
+ rep_arg_tys = dataConRepArgTys dc
+ tycon = dataConTyCon dc
projects / ghc-hetmet.git / blobdiff