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 Name
  15 import qualified OccName
  16 import qualified TysWiredIn
  17 import qualified Bag
  18 import qualified DynFlags
  19 import qualified SrcLoc
  20 import qualified CoreSyn
  21 import qualified Var
  22 import qualified Unique
  23
  24 import GhcTools
  25 import HsTools
  26
  27 -- | Evaluate a core Type representing type level int from the tfp
  28 -- library to a real int.
  29 eval_tfp_int :: Type.Type -> Int
  30 eval_tfp_int ty =
  31   unsafeRunGhc $ do
  32     -- Automatically import modules for any fully qualified identifiers
  33     setDynFlag DynFlags.Opt_ImplicitImportQualified
  34     --setDynFlag DynFlags.Opt_D_dump_if_trace
  35
  36     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  37     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  38     let undef = hsTypedUndef $ coreToHsType ty
  39     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  40     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  41     let expr = HsExpr.ExprWithTySig app int_ty
  42     let foo_name = mkRdrName "Types.Data.Num" "foo"
  43     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  44     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  45     let letexpr = HsExpr.HsLet
  46           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  47           (SrcLoc.noLoc expr)
  48
  49     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  50     core <- toCore modules expr
  51     execCore core
  52
  53 -- | Get the width of a SizedWord type
  54 sized_word_len :: Type.Type -> Int
  55 sized_word_len ty =
  56   eval_tfp_int len
  57   where
  58     (tycon, args) = Type.splitTyConApp ty
  59     [len] = args
  60
  61 -- | Evaluate a core Type representing type level int from the TypeLevel
  62 -- library to a real int.
  63 eval_type_level_int :: Type.Type -> Int
  64 eval_type_level_int ty =
  65   unsafeRunGhc $ do
  66     -- Automatically import modules for any fully qualified identifiers
  67     setDynFlag DynFlags.Opt_ImplicitImportQualified
  68
  69     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
  70     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
  71     let undef = hsTypedUndef $ coreToHsType ty
  72     let app = HsExpr.HsApp (to_int) (undef)
  73
  74     core <- toCore [] app
  75     execCore core
  76
  77 -- | Get the length of a FSVec type
  78 fsvec_len :: Type.Type -> Int
  79 fsvec_len ty =
  80   eval_type_level_int len
  81   where
  82     (tycon, args) = Type.splitTyConApp ty
  83     [len, el_ty] = args
  84
  85 -- Is this a wild binder?
  86 is_wild :: CoreSyn.CoreBndr -> Bool
  87 -- wild binders have a particular unique, that we copied from MkCore.lhs to
  88 -- here. However, this comparison didn't work, so we'll just check the
  89 -- occstring for now... TODO
  90 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
  91 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr