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.
13 import qualified HsExpr
14 import qualified HsTypes
15 import qualified HsBinds
16 import qualified RdrName
18 import qualified OccName
19 import qualified TysWiredIn
21 import qualified DynFlags
22 import qualified SrcLoc
23 import qualified CoreSyn
25 import qualified VarSet
26 import qualified Unique
27 import qualified CoreUtils
28 import qualified CoreFVs
33 -- | Evaluate a core Type representing type level int from the tfp
34 -- library to a real int.
35 eval_tfp_int :: Type.Type -> Int
38 -- Automatically import modules for any fully qualified identifiers
39 setDynFlag DynFlags.Opt_ImplicitImportQualified
40 --setDynFlag DynFlags.Opt_D_dump_if_trace
42 let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
43 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
44 let undef = hsTypedUndef $ coreToHsType ty
45 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
46 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
47 let expr = HsExpr.ExprWithTySig app int_ty
48 let foo_name = mkRdrName "Types.Data.Num" "foo"
49 let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
50 let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
51 let letexpr = HsExpr.HsLet
52 (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
55 let modules = map GHC.mkModuleName ["Types.Data.Num"]
56 core <- toCore modules expr
59 -- | Get the width of a SizedWord type
60 sized_word_len :: Type.Type -> Int
64 (tycon, args) = Type.splitTyConApp ty
67 -- | Get the upperbound of a RangedWord type
68 ranged_word_bound :: Type.Type -> Int
69 ranged_word_bound ty =
72 (tycon, args) = Type.splitTyConApp ty
75 -- | Evaluate a core Type representing type level int from the TypeLevel
76 -- library to a real int.
77 -- eval_type_level_int :: Type.Type -> Int
78 -- eval_type_level_int ty =
80 -- -- Automatically import modules for any fully qualified identifiers
81 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
83 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
84 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
85 -- let undef = hsTypedUndef $ coreToHsType ty
86 -- let app = HsExpr.HsApp (to_int) (undef)
88 -- core <- toCore [] app
91 -- | Get the length of a FSVec type
92 tfvec_len :: Type.Type -> Int
96 (tycon, args) = Type.splitTyConApp ty
99 -- | Get the element type of a TFVec type
100 tfvec_elem :: Type.Type -> Type.Type
101 tfvec_elem ty = el_ty
103 (tycon, args) = Type.splitTyConApp ty
106 -- Is this a wild binder?
107 is_wild :: CoreSyn.CoreBndr -> Bool
108 -- wild binders have a particular unique, that we copied from MkCore.lhs to
109 -- here. However, this comparison didn't work, so we'll just check the
110 -- occstring for now... TODO
111 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
112 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
114 -- Is the given core expression a lambda abstraction?
115 is_lam :: CoreSyn.CoreExpr -> Bool
116 is_lam (CoreSyn.Lam _ _) = True
119 -- Is the given core expression of a function type?
120 is_fun :: CoreSyn.CoreExpr -> Bool
121 -- Treat Type arguments differently, because exprType is not defined for them.
122 is_fun (CoreSyn.Type _) = False
123 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
125 -- Is the given core expression polymorphic (i.e., does it accept type
127 is_poly :: CoreSyn.CoreExpr -> Bool
128 -- Treat Type arguments differently, because exprType is not defined for them.
129 is_poly (CoreSyn.Type _) = False
130 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
132 -- Is the given core expression a variable reference?
133 is_var :: CoreSyn.CoreExpr -> Bool
134 is_var (CoreSyn.Var _) = True
137 -- Can the given core expression be applied to something? This is true for
138 -- applying to a value as well as a type.
139 is_applicable :: CoreSyn.CoreExpr -> Bool
140 is_applicable expr = is_fun expr || is_poly expr
142 -- Does the given CoreExpr have any free type vars?
143 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
144 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)