compiler/vectorise/Vectorise/Type/PData.hs

   1
   2 module Vectorise.Type.PData
   3         (buildPDataTyCon)
   4 where
   5 import VectUtils
   6 import Vectorise.Monad
   7 import Vectorise.Builtins
   8 import Vectorise.Type.Repr
   9
  10 import BasicTypes
  11 import BuildTyCl
  12 import DataCon
  13 import TyCon
  14 import Type
  15 import OccName
  16 import Name
  17 import Util
  18 import MonadUtils
  19 import Control.Monad
  20
  21
  22
  23 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
  24 buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
  25   do
  26     name' <- cloneName mkPDataTyConOcc orig_name
  27     rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
  28     pdata <- builtin pdataTyCon
  29
  30     liftDs $ buildAlgTyCon name'
  31                            tyvars
  32                            []          -- no stupid theta
  33                            rhs
  34                            rec_flag    -- FIXME: is this ok?
  35                            False       -- FIXME: no generics
  36                            False       -- not GADT syntax
  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])