CoreTools.hs

   1 -- | This module provides a number of functions to find out things about Core
   2 -- programs. This module does not provide the actual plumbing to work with
   3 -- Core and Haskell (it uses HsTools for this), but only the functions that
   4 -- know about various libraries and know which functions to call.
   5 module CoreTools where
   6
   7 --Standard modules
   8 import qualified Maybe
   9
  10 -- GHC API
  11 import qualified GHC
  12 import qualified Type
  13 import qualified HsExpr
  14 import qualified HsTypes
  15 import qualified HsBinds
  16 import qualified RdrName
  17 import qualified Name
  18 import qualified OccName
  19 import qualified TysWiredIn
  20 import qualified Bag
  21 import qualified DynFlags
  22 import qualified SrcLoc
  23 import qualified CoreSyn
  24 import qualified Var
  25 import qualified VarSet
  26 import qualified Unique
  27 import qualified CoreUtils
  28 import qualified CoreFVs
  29
  30 -- Local imports
  31 import GhcTools
  32 import HsTools
  33 import Pretty
  34
  35 -- | Evaluate a core Type representing type level int from the tfp
  36 -- library to a real int.
  37 eval_tfp_int :: Type.Type -> Int
  38 eval_tfp_int ty =
  39   unsafeRunGhc $ do
  40     -- Automatically import modules for any fully qualified identifiers
  41     setDynFlag DynFlags.Opt_ImplicitImportQualified
  42     --setDynFlag DynFlags.Opt_D_dump_if_trace
  43
  44     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  45     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  46     let undef = hsTypedUndef $ coreToHsType ty
  47     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  48     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  49     let expr = HsExpr.ExprWithTySig app int_ty
  50     let foo_name = mkRdrName "Types.Data.Num" "foo"
  51     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  52     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  53     let letexpr = HsExpr.HsLet
  54           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  55           (SrcLoc.noLoc expr)
  56
  57     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  58     core <- toCore modules expr
  59     execCore core
  60
  61 -- | Get the width of a SizedWord type
  62 sized_word_len :: Type.Type -> Int
  63 sized_word_len ty =
  64   eval_tfp_int len
  65   where
  66     (tycon, args) = Type.splitTyConApp ty
  67     [len] = args
  68
  69 -- | Get the upperbound of a RangedWord type
  70 ranged_word_bound :: Type.Type -> Int
  71 ranged_word_bound ty =
  72   eval_tfp_int len
  73   where
  74     (tycon, args) = Type.splitTyConApp ty
  75     [len]         = args
  76
  77 -- | Evaluate a core Type representing type level int from the TypeLevel
  78 -- library to a real int.
  79 -- eval_type_level_int :: Type.Type -> Int
  80 -- eval_type_level_int ty =
  81 --   unsafeRunGhc $ do
  82 --     -- Automatically import modules for any fully qualified identifiers
  83 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
  84 --
  85 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
  86 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
  87 --     let undef = hsTypedUndef $ coreToHsType ty
  88 --     let app = HsExpr.HsApp (to_int) (undef)
  89 --
  90 --     core <- toCore [] app
  91 --     execCore core
  92
  93 -- | Get the length of a FSVec type
  94 tfvec_len :: Type.Type -> Int
  95 tfvec_len ty =
  96   eval_tfp_int len
  97   where
  98     args = case Type.splitTyConApp_maybe ty of
  99       Just (tycon, args) -> args
 100       Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
 101     [len, el_ty] = args
 102
 103 -- | Get the element type of a TFVec type
 104 tfvec_elem :: Type.Type -> Type.Type
 105 tfvec_elem ty = el_ty
 106   where
 107     args = case Type.splitTyConApp_maybe ty of
 108       Just (tycon, args) -> args
 109       Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
 110     [len, el_ty] = args
 111
 112 -- Is this a wild binder?
 113 is_wild :: CoreSyn.CoreBndr -> Bool
 114 -- wild binders have a particular unique, that we copied from MkCore.lhs to
 115 -- here. However, this comparison didn't work, so we'll just check the
 116 -- occstring for now... TODO
 117 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
 118 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
 119
 120 -- Is the given core expression a lambda abstraction?
 121 is_lam :: CoreSyn.CoreExpr -> Bool
 122 is_lam (CoreSyn.Lam _ _) = True
 123 is_lam _ = False
 124
 125 -- Is the given core expression of a function type?
 126 is_fun :: CoreSyn.CoreExpr -> Bool
 127 -- Treat Type arguments differently, because exprType is not defined for them.
 128 is_fun (CoreSyn.Type _) = False
 129 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
 130
 131 -- Is the given core expression polymorphic (i.e., does it accept type
 132 -- arguments?).
 133 is_poly :: CoreSyn.CoreExpr -> Bool
 134 -- Treat Type arguments differently, because exprType is not defined for them.
 135 is_poly (CoreSyn.Type _) = False
 136 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
 137
 138 -- Is the given core expression a variable reference?
 139 is_var :: CoreSyn.CoreExpr -> Bool
 140 is_var (CoreSyn.Var _) = True
 141 is_var _ = False
 142
 143 -- Can the given core expression be applied to something? This is true for
 144 -- applying to a value as well as a type.
 145 is_applicable :: CoreSyn.CoreExpr -> Bool
 146 is_applicable expr = is_fun expr || is_poly expr
 147
 148 -- Does the given CoreExpr have any free type vars?
 149 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
 150 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
 151
 152 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 153 -- simple Var CoreExprs, not complexer ones.
 154 exprToVar :: CoreSyn.CoreExpr -> Var.Id
 155 exprToVar (CoreSyn.Var id) = id