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       -- FIXME: no generics
  35                            False       -- not GADT syntax
  36                            NoParentTyCon
  37                            (Just $ mk_fam_inst pdata vect_tc)
  38   where
  39     orig_name = tyConName orig_tc
  40     tyvars = tyConTyVars vect_tc
  41     rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
  42
  43
  44 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
  45 buildPDataTyConRhs orig_name vect_tc repr_tc repr
  46   = do
  47       data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
  48       return $ DataTyCon { data_cons = [data_con], is_enum = False }
  49
  50 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
  51 buildPDataDataCon orig_name vect_tc repr_tc repr
  52   = do
  53       dc_name  <- cloneName mkPDataDataConOcc orig_name
  54       comp_tys <- sum_tys repr
  55
  56       liftDs $ buildDataCon dc_name
  57                             False                  -- not infix
  58                             (map (const HsNoBang) comp_tys)
  59                             []                     -- no field labels
  60                             tvs
  61                             []                     -- no existentials
  62                             []                     -- no eq spec
  63                             []                     -- no context
  64                             comp_tys
  65                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
  66                             repr_tc
  67   where
  68     tvs   = tyConTyVars vect_tc
  69
  70     sum_tys EmptySum = return []
  71     sum_tys (UnarySum r) = con_tys r
  72     sum_tys (Sum { repr_sel_ty = sel_ty
  73                  , repr_cons   = cons })
  74       = liftM (sel_ty :) (concatMapM con_tys cons)
  75
  76     con_tys (ConRepr _ r) = prod_tys r
  77
  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
  81
  82     comp_ty r = mkPDataType (compOrigType r)
  83
  84
  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])