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 GHC
   9 import qualified Type
  10 import qualified HsExpr
  11 import qualified HsTypes
  12 import qualified HsBinds
  13 import qualified RdrName
  14 import qualified OccName
  15 import qualified TysWiredIn
  16 import qualified Bag
  17 import qualified DynFlags
  18 import qualified SrcLoc
  19
  20 import GhcTools
  21 import HsTools
  22
  23 -- | Evaluate a core Type representing type level int from the tfp
  24 -- library to a real int.
  25 eval_tfp_int :: Type.Type -> Int
  26 eval_tfp_int ty =
  27   unsafeRunGhc $ do
  28     -- Automatically import modules for any fully qualified identifiers
  29     setDynFlag DynFlags.Opt_ImplicitImportQualified
  30     --setDynFlag DynFlags.Opt_D_dump_if_trace
  31
  32     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  33     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  34     let undef = hsTypedUndef $ coreToHsType ty
  35     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  36     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  37     let expr = HsExpr.ExprWithTySig app int_ty
  38     let foo_name = mkRdrName "Types.Data.Num" "foo"
  39     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  40     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  41     let letexpr = HsExpr.HsLet
  42           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  43           (SrcLoc.noLoc expr)
  44
  45     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  46     core <- toCore modules expr
  47     execCore core
  48
  49 -- | Get the width of a SizedWord type
  50 sized_word_len :: Type.Type -> Int
  51 sized_word_len ty =
  52   eval_tfp_int len
  53   where
  54     (tycon, args) = Type.splitTyConApp ty
  55     [len] = args
  56
  57 -- | Evaluate a core Type representing type level int from the TypeLevel
  58 -- library to a real int.
  59 -- eval_type_level_int :: Type.Type -> Int
  60 -- eval_type_level_int ty =
  61 --   unsafeRunGhc $ do
  62 --     -- Automatically import modules for any fully qualified identifiers
  63 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
  64 --
  65 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
  66 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
  67 --     let undef = hsTypedUndef $ coreToHsType ty
  68 --     let app = HsExpr.HsApp (to_int) (undef)
  69 --
  70 --     core <- toCore [] app
  71 --     execCore core
  72
  73 -- | Get the length of a FSVec type
  74 tfvec_len :: Type.Type -> Int
  75 tfvec_len ty =
  76   eval_tfp_int len
  77   where
  78     (tycon, args) = Type.splitTyConApp ty
  79     [len, el_ty] = args