module Vectorise.Type.PData
(buildPDataTyCon)
where
import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Type.Repr
import Vectorise.Utils
import BasicTypes
import BuildTyCl
import DataCon
import TyCon
import Type
import Name
import Util
import MonadUtils
import Control.Monad
buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
do
name' <- cloneName mkPDataTyConOcc orig_name
rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
pdata <- builtin pdataTyCon
liftDs $ buildAlgTyCon name'
tyvars
[]
rhs
rec_flag
False
NoParentTyCon
(Just $ mk_fam_inst pdata vect_tc)
where
orig_name = tyConName orig_tc
tyvars = tyConTyVars vect_tc
rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
buildPDataTyConRhs orig_name vect_tc repr_tc repr
= do
data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
return $ DataTyCon { data_cons = [data_con], is_enum = False }
buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
buildPDataDataCon orig_name vect_tc repr_tc repr
= do
dc_name <- cloneName mkPDataDataConOcc orig_name
comp_tys <- sum_tys repr
liftDs $ buildDataCon dc_name
False
(map (const HsNoBang) comp_tys)
[]
tvs
[]
[]
[]
comp_tys
(mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
repr_tc
where
tvs = tyConTyVars vect_tc
sum_tys EmptySum = return []
sum_tys (UnarySum r) = con_tys r
sum_tys (Sum { repr_sel_ty = sel_ty
, repr_cons = cons })
= liftM (sel_ty :) (concatMapM con_tys cons)
con_tys (ConRepr _ r) = prod_tys r
prod_tys EmptyProd = return []
prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
comp_ty r = mkPDataType (compOrigType r)
mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
mk_fam_inst fam_tc arg_tc
= (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])