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