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
23 import qualified CoreUtils
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
33 -- Automatically import modules for any fully qualified identifiers
34 setDynFlag DynFlags.Opt_ImplicitImportQualified
35 --setDynFlag DynFlags.Opt_D_dump_if_trace
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) [])
50 let modules = map GHC.mkModuleName ["Types.Data.Num"]
51 core <- toCore modules expr
54 -- | Get the width of a SizedWord type
55 sized_word_len :: Type.Type -> Int
59 (tycon, args) = Type.splitTyConApp ty
62 -- | Get the upperbound of a RangedWord type
63 ranged_word_bound :: Type.Type -> Int
64 ranged_word_bound ty =
67 (tycon, args) = Type.splitTyConApp ty
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 =
75 -- -- Automatically import modules for any fully qualified identifiers
76 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
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)
83 -- core <- toCore [] app
86 -- | Get the length of a FSVec type
87 tfvec_len :: Type.Type -> Int
91 (tycon, args) = Type.splitTyConApp ty
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
102 -- Is the given core expression a lambda abstraction?
103 is_lam :: CoreSyn.CoreExpr -> Bool
104 is_lam (CoreSyn.Lam _ _) = True
107 -- Is the given core expression of a function type?
108 is_fun :: CoreSyn.CoreExpr -> Bool
109 is_fun = Type.isFunTy . CoreUtils.exprType