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