compiler/vectorise/Vectorise/Type/PData.hs

   1
   2 module Vectorise.Type.PData
   3         (buildPDataTyCon)
   4 where
   5 import Vectorise.Monad
   6 import Vectorise.Builtins
   7 import Vectorise.Type.Repr
   8 import Vectorise.Utils
   9
  10 import BasicTypes
  11 import BuildTyCl
  12 import DataCon
  13 import TyCon
  14 import Type
  15 import Name
  16 import Util
  17 import MonadUtils
  18 import Control.Monad
  19
  20
  21
  22 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
  23 buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
  24   do
  25     name' <- cloneName mkPDataTyConOcc orig_name
  26     rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
  27     pdata <- builtin pdataTyCon
  28
  29     liftDs $ buildAlgTyCon name'
  30                            tyvars
  31                            []          -- no stupid theta
  32                            rhs
  33                            rec_flag    -- FIXME: is this ok?
  34                            False       -- not GADT syntax
  35                            NoParentTyCon
  36                            (Just $ mk_fam_inst pdata vect_tc)
  37   where
  38     orig_name = tyConName orig_tc
  39     tyvars = tyConTyVars vect_tc
  40     rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
  41
  42
  43 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
  44 buildPDataTyConRhs orig_name vect_tc repr_tc repr
  45   = do
  46       data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
  47       return $ DataTyCon { data_cons = [data_con], is_enum = False }
  48
  49 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
  50 buildPDataDataCon orig_name vect_tc repr_tc repr
  51   = do
  52       dc_name  <- cloneName mkPDataDataConOcc orig_name
  53       comp_tys <- sum_tys repr
  54
  55       liftDs $ buildDataCon dc_name
  56                             False                  -- not infix
  57                             (map (const HsNoBang) comp_tys)
  58                             []                     -- no field labels
  59                             tvs
  60                             []                     -- no existentials
  61                             []                     -- no eq spec
  62                             []                     -- no context
  63                             comp_tys
  64                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
  65                             repr_tc
  66   where
  67     tvs   = tyConTyVars vect_tc
  68
  69     sum_tys EmptySum = return []
  70     sum_tys (UnarySum r) = con_tys r
  71     sum_tys (Sum { repr_sel_ty = sel_ty
  72                  , repr_cons   = cons })
  73       = liftM (sel_ty :) (concatMapM con_tys cons)
  74
  75     con_tys (ConRepr _ r) = prod_tys r
  76
  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
  80
  81     comp_ty r = mkPDataType (compOrigType r)
  82
  83
  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])