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 -- GHC API
   8 import qualified DynFlags
   9 import qualified Type
  10 import qualified HsExpr
  11 import qualified HsTypes
  12 import qualified RdrName
  13 import qualified HsBinds
  14 import qualified OccName
  15 import qualified HsBinds
  16 import qualified SrcLoc
  17
  18 import qualified HsTools
  19
  20 -- | Evaluate a core Type representing type level int from the tfp
  21 -- library to a real int.
  22 eval_tfp_int :: Type.Type -> Int
  23 eval_tfp_int ty =
  24   unsafeRunGhc $ do
  25     -- Automatically import modules for any fully qualified identifiers
  26     setDynFlag DynFlags.Opt_ImplicitImportQualified
  27     --setDynFlag DynFlags.Opt_D_dump_if_trace
  28
  29     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  30     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  31     let undef = hsTypedUndef $ coreToHsType ty
  32     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  33     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  34     let expr = HsExpr.ExprWithTySig app int_ty
  35     let foo_name = mkRdrName "Types.Data.Num" "foo"
  36     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  37     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  38     let letexpr = HsExpr.HsLet
  39           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  40           (SrcLoc.noLoc expr)
  41
  42     core <- toCore expr
  43     execCore core