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
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do
mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
mapM vectTyConDecl tcs
vectTyConDecl :: TyCon -> VM TyCon
vectTyConDecl tycon
| isClassTyCon tycon
, Just cls <- tyConClass_maybe tycon
= do
name' <- cloneName mkVectTyConOcc (tyConName tycon)
rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
methods' <- mapM vectMethod
$ [(id, defMethSpecOfDefMeth meth)
| (id, meth) <- classOpItems cls]
let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
cls' <- liftDs
$ buildClass
False
name'
(tyConTyVars tycon)
[]
[]
[]
methods'
rec_flag
let tycon' = mkClassTyCon name'
(tyConKind tycon)
(tyConTyVars tycon)
rhs'
cls'
rec_flag
return $ tycon'
| isAlgTyCon tycon
= do name' <- cloneName mkVectTyConOcc (tyConName tycon)
rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
liftDs $ buildAlgTyCon
name'
(tyConTyVars tycon)
[]
rhs'
rec_flag
False
NoParentTyCon
Nothing
| otherwise
= cantVectorise "Can't vectorise type constructor: " (ppr tycon)
vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
vectMethod (id, defMeth)
= do
typ' <- vectType (varType id)
id' <- cloneId mkVectOcc id typ'
defGlobalVar id id'
let (_tyvars, tyBody) = splitForAllTys typ'
let (_dict, tyRest) = splitFunTy tyBody
return (Var.varName id', defMeth, tyRest)
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)
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
(map (const HsNoBang) arg_tys)
[]
univ_tvs
[]
[]
[]
arg_tys
(mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs))
tycon'
where
name = dataConName dc
univ_tvs = dataConUnivTyVars dc
rep_arg_tys = dataConRepArgTys dc
tycon = dataConTyCon dc