compiler/vectorise/Vectorise/Type/TyConDecl.hs

   1
   2 module Vectorise.Type.TyConDecl (
   3   vectTyConDecls
   4 ) where
   5
   6 import Vectorise.Type.Type
   7 import Vectorise.Monad
   8 import BuildTyCl
   9 import Class
  10 import Type
  11 import TyCon
  12 import DataCon
  13 import BasicTypes
  14 import Var
  15 import Name
  16 import Outputable
  17 import Util
  18 import Control.Monad
  19
  20
  21 -- |Vectorise some (possibly recursively defined) type constructors.
  22 --
  23 vectTyConDecls :: [TyCon] -> VM [TyCon]
  24 vectTyConDecls tcs = fixV $ \tcs' ->
  25   do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
  26      ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
  27      ; zipWithM vectTyConDecl tcs names'
  28      }
  29
  30 -- |Vectorise a single type constructor.
  31 --
  32 vectTyConDecl :: TyCon -> Name -> VM TyCon
  33 vectTyConDecl tycon name'
  34
  35       -- Type constructor representing a type class
  36   | Just cls <- tyConClass_maybe tycon
  37   = do { unless (null $ classATs cls) $
  38            cantVectorise "Associated types are not yet supported" (ppr cls)
  39
  40            -- vectorise superclass constraint (types)
  41        ; theta' <- mapM vectType (classSCTheta cls)
  42
  43            -- vectorise method selectors
  44        ; let opItems      = classOpItems cls
  45              Just datacon = tyConSingleDataCon_maybe tycon
  46              argTys       = dataConRepArgTys datacon                      -- all selector types
  47              opTys        = drop (length argTys - length opItems) argTys  -- only method types
  48        ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
  49
  50            -- keep the original recursiveness flag
  51        ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
  52
  53            -- construct the vectorised class (this also creates the class type constructors and its
  54            -- data constructor)
  55            --
  56            -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
  57        ; cls' <- liftDs $
  58                    buildClass
  59                      False                      -- include unfoldings on dictionary selectors
  60                      name'                      -- new name: "V:Class"
  61                      (tyConTyVars tycon)        -- keep original type vars
  62                      theta'                     -- superclasses
  63                      (snd . classTvsFds $ cls)  -- keep the original functional dependencies
  64                      []                         -- no associated types (for the moment)
  65                      methods'                   -- method info
  66                      rec_flag                   -- whether recursive
  67
  68            -- the original dictionary constructor must map to the vectorised one
  69        ; let tycon'        = classTyCon cls'
  70              Just datacon  = tyConSingleDataCon_maybe tycon
  71              Just datacon' = tyConSingleDataCon_maybe tycon'
  72        ; defDataCon datacon datacon'
  73
  74            -- the original superclass and methods selectors must map to the vectorised ones
  75        ; let selIds  = classAllSelIds cls
  76              selIds' = classAllSelIds cls'
  77        ; zipWithM_ defGlobalVar selIds selIds'
  78
  79            -- return the type constructor of the vectorised class
  80        ; return tycon'
  81        }
  82
  83        -- Regular algebraic type constructor — for now, Haskell 2011-style only
  84   | isAlgTyCon tycon
  85   = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
  86            cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
  87
  88            -- vectorise the data constructor of the class tycon
  89        ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
  90
  91            -- keep the original recursiveness and GADT flags
  92        ; let rec_flag  = boolToRecFlag (isRecursiveTyCon tycon)
  93              gadt_flag = isGadtSyntaxTyCon tycon
  94
  95            -- build the vectorised type constructor
  96        ; return $ buildAlgTyCon
  97                     name'                   -- new name
  98                     (tyConTyVars tycon)     -- keep original type vars
  99                     []                      -- no stupid theta
 100                     rhs'                    -- new constructor defs
 101                     rec_flag                -- whether recursive
 102                     gadt_flag               -- whether in GADT syntax
 103                     NoParentTyCon
 104        }
 105
 106   -- some other crazy thing that we don't handle
 107   | otherwise
 108   = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon)
 109
 110 -- |Vectorise a class method.  (Don't enter it into the vectorisation map yet.)
 111 --
 112 vectMethod :: Id -> DefMeth -> Type -> VM (Name, DefMethSpec, Type)
 113 vectMethod id defMeth ty
 114  = do {   -- Vectorise the method type.
 115       ; ty' <- vectType ty
 116
 117           -- Create a name for the vectorised method.
 118       ; id' <- mkVectId id ty'
 119
 120       ; return  (Var.varName id', defMethSpecOfDefMeth defMeth, ty')
 121       }
 122
 123 -- |Vectorise the RHS of an algebraic type.
 124 --
 125 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
 126 vectAlgTyConRhs tc (AbstractTyCon {})
 127   = cantVectorise "Can't vectorise imported abstract type" (ppr tc)
 128 vectAlgTyConRhs _tc DataFamilyTyCon
 129   = return DataFamilyTyCon
 130 vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
 131                                , is_enum   = is_enum
 132                                })
 133   = do { data_cons' <- mapM vectDataCon data_cons
 134        ; zipWithM_ defDataCon data_cons data_cons'
 135        ; return $ DataTyCon { data_cons = data_cons'
 136                             , is_enum   = is_enum
 137                             }
 138        }
 139 vectAlgTyConRhs tc (NewTyCon {})
 140   = cantVectorise noNewtypeErr (ppr tc)
 141   where
 142     noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
 143
 144 -- |Vectorise a data constructor by vectorising its argument and return types..
 145 --
 146 vectDataCon :: DataCon -> VM DataCon
 147 vectDataCon dc
 148   | not . null $ ex_tvs
 149   = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc)
 150   | not . null $ eq_spec
 151   = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc)
 152   | not . null $ dataConFieldLabels dc
 153   = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc)
 154   | not . null $ theta
 155   = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc)
 156   | otherwise
 157   = do { name'   <- mkLocalisedName mkVectDataConOcc name
 158        ; tycon'  <- vectTyCon tycon
 159        ; arg_tys <- mapM vectType rep_arg_tys
 160        ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
 161        ; liftDs $ buildDataCon
 162                     name'
 163                     (dataConIsInfix dc)            -- infix if the original is
 164                     (dataConStrictMarks dc)        -- strictness as original constructor
 165                     []                             -- no labelled fields for now
 166                     univ_tvs                       -- universally quantified vars
 167                     []                             -- no existential tvs for now
 168                     []                             -- no equalities for now
 169                     []                             -- no context for now
 170                     arg_tys                        -- argument types
 171                     ret_ty                         -- return type
 172                     tycon'                         -- representation tycon
 173        }
 174   where
 175     name        = dataConName dc
 176     rep_arg_tys = dataConRepArgTys dc
 177     tycon       = dataConTyCon dc
 178     (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc