2 module Vectorise.Type.PData
6 import Vectorise.Builtins
7 import Vectorise.Type.Repr
22 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
23 buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
25 name' <- cloneName mkPDataTyConOcc orig_name
26 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
27 pdata <- builtin pdataTyCon
29 liftDs $ buildAlgTyCon name'
33 rec_flag -- FIXME: is this ok?
34 False -- not GADT syntax
36 (Just $ mk_fam_inst pdata vect_tc)
38 orig_name = tyConName orig_tc
39 tyvars = tyConTyVars vect_tc
40 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
43 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
44 buildPDataTyConRhs orig_name vect_tc repr_tc repr
46 data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
47 return $ DataTyCon { data_cons = [data_con], is_enum = False }
49 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
50 buildPDataDataCon orig_name vect_tc repr_tc repr
52 dc_name <- cloneName mkPDataDataConOcc orig_name
53 comp_tys <- sum_tys repr
55 liftDs $ buildDataCon dc_name
57 (map (const HsNoBang) comp_tys)
64 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
67 tvs = tyConTyVars vect_tc
69 sum_tys EmptySum = return []
70 sum_tys (UnarySum r) = con_tys r
71 sum_tys (Sum { repr_sel_ty = sel_ty
73 = liftM (sel_ty :) (concatMapM con_tys cons)
75 con_tys (ConRepr _ r) = prod_tys r
77 prod_tys EmptyProd = return []
78 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
79 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
81 comp_ty r = mkPDataType (compOrigType r)
84 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
85 mk_fam_inst fam_tc arg_tc
86 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])