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.
10 import qualified HsExpr
11 import qualified HsTypes
12 import qualified HsBinds
13 import qualified RdrName
15 import qualified OccName
16 import qualified TysWiredIn
18 import qualified DynFlags
19 import qualified SrcLoc
20 import qualified CoreSyn
22 import qualified Unique
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
32 -- Automatically import modules for any fully qualified identifiers
33 setDynFlag DynFlags.Opt_ImplicitImportQualified
34 --setDynFlag DynFlags.Opt_D_dump_if_trace
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) [])
49 let modules = map GHC.mkModuleName ["Types.Data.Num"]
50 core <- toCore modules expr
53 -- | Get the width of a SizedWord type
54 sized_word_len :: Type.Type -> Int
58 (tycon, args) = Type.splitTyConApp ty
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 =
66 -- Automatically import modules for any fully qualified identifiers
67 setDynFlag DynFlags.Opt_ImplicitImportQualified
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)
77 -- | Get the length of a FSVec type
78 fsvec_len :: Type.Type -> Int
80 eval_type_level_int len
82 (tycon, args) = Type.splitTyConApp ty
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