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 -- FIXME: no generics
35 False -- not GADT syntax
37 (Just $ mk_fam_inst pdata vect_tc)
39 orig_name = tyConName orig_tc
40 tyvars = tyConTyVars vect_tc
41 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
44 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
45 buildPDataTyConRhs orig_name vect_tc repr_tc repr
47 data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
48 return $ DataTyCon { data_cons = [data_con], is_enum = False }
50 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
51 buildPDataDataCon orig_name vect_tc repr_tc repr
53 dc_name <- cloneName mkPDataDataConOcc orig_name
54 comp_tys <- sum_tys repr
56 liftDs $ buildDataCon dc_name
58 (map (const HsNoBang) comp_tys)
65 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
68 tvs = tyConTyVars vect_tc
70 sum_tys EmptySum = return []
71 sum_tys (UnarySum r) = con_tys r
72 sum_tys (Sum { repr_sel_ty = sel_ty
74 = liftM (sel_ty :) (concatMapM con_tys cons)
76 con_tys (ConRepr _ r) = prod_tys r
78 prod_tys EmptyProd = return []
79 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
80 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
82 comp_ty r = mkPDataType (compOrigType r)
85 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
86 mk_fam_inst fam_tc arg_tc
87 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])