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 Unique
  26 import qualified CoreUtils
  27
  28 import GhcTools
  29 import HsTools
  30
  31 -- | Evaluate a core Type representing type level int from the tfp
  32 -- library to a real int.
  33 eval_tfp_int :: Type.Type -> Int
  34 eval_tfp_int ty =
  35   unsafeRunGhc $ do
  36     -- Automatically import modules for any fully qualified identifiers
  37     setDynFlag DynFlags.Opt_ImplicitImportQualified
  38     --setDynFlag DynFlags.Opt_D_dump_if_trace
  39
  40     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  41     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  42     let undef = hsTypedUndef $ coreToHsType ty
  43     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  44     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  45     let expr = HsExpr.ExprWithTySig app int_ty
  46     let foo_name = mkRdrName "Types.Data.Num" "foo"
  47     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  48     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  49     let letexpr = HsExpr.HsLet
  50           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  51           (SrcLoc.noLoc expr)
  52
  53     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  54     core <- toCore modules expr
  55     execCore core
  56
  57 -- | Get the width of a SizedWord type
  58 sized_word_len :: Type.Type -> Int
  59 sized_word_len ty =
  60   eval_tfp_int len
  61   where
  62     (tycon, args) = Type.splitTyConApp ty
  63     [len] = args
  64
  65 -- | Evaluate a core Type representing type level int from the TypeLevel
  66 -- library to a real int.
  67 -- eval_type_level_int :: Type.Type -> Int
  68 -- eval_type_level_int ty =
  69 --   unsafeRunGhc $ do
  70 --     -- Automatically import modules for any fully qualified identifiers
  71 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
  72 --
  73 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
  74 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
  75 --     let undef = hsTypedUndef $ coreToHsType ty
  76 --     let app = HsExpr.HsApp (to_int) (undef)
  77 --
  78 --     core <- toCore [] app
  79 --     execCore core
  80
  81 -- | Get the length of a FSVec type
  82 tfvec_len :: Type.Type -> Int
  83 tfvec_len ty =
  84   eval_tfp_int len
  85   where
  86     (tycon, args) = Type.splitTyConApp ty
  87     [len, el_ty] = args
  88
  89 -- Is this a wild binder?
  90 is_wild :: CoreSyn.CoreBndr -> Bool
  91 -- wild binders have a particular unique, that we copied from MkCore.lhs to
  92 -- here. However, this comparison didn't work, so we'll just check the
  93 -- occstring for now... TODO
  94 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
  95 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
  96
  97 -- Is the given core expression a lambda abstraction?
  98 is_lam :: CoreSyn.CoreExpr -> Bool
  99 is_lam (CoreSyn.Lam _ _) = True
 100 is_lam _ = False
 101
 102 -- Is the given core expression of a function type?
 103 is_fun :: CoreSyn.CoreExpr -> Bool
 104 -- Treat Type arguments differently, because exprType is not defined for them.
 105 is_fun (CoreSyn.Type _) = False
 106 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
 107
 108 -- Is the given core expression polymorphic (i.e., does it accept type
 109 -- arguments?).
 110 is_poly :: CoreSyn.CoreExpr -> Bool
 111 -- Treat Type arguments differently, because exprType is not defined for them.
 112 is_poly (CoreSyn.Type _) = False
 113 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
 114
 115 -- Is the given core expression a variable reference?
 116 is_var :: CoreSyn.CoreExpr -> Bool
 117 is_var (CoreSyn.Var _) = True
 118 is_var _ = False
 119