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
35 -- | Evaluate a core Type representing type level int from the tfp
36 -- library to a real int.
37 eval_tfp_int :: Type.Type -> Int
40 -- Automatically import modules for any fully qualified identifiers
41 setDynFlag DynFlags.Opt_ImplicitImportQualified
42 --setDynFlag DynFlags.Opt_D_dump_if_trace
44 let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
45 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
46 let undef = hsTypedUndef $ coreToHsType ty
47 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
48 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
49 let expr = HsExpr.ExprWithTySig app int_ty
50 let foo_name = mkRdrName "Types.Data.Num" "foo"
51 let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
52 let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
53 let letexpr = HsExpr.HsLet
54 (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
57 let modules = map GHC.mkModuleName ["Types.Data.Num"]
58 core <- toCore modules expr
61 -- | Get the width of a SizedWord type
62 sized_word_len :: Type.Type -> Int
66 (tycon, args) = Type.splitTyConApp ty
69 -- | Get the upperbound of a RangedWord type
70 ranged_word_bound :: Type.Type -> Int
71 ranged_word_bound ty =
74 (tycon, args) = Type.splitTyConApp ty
77 -- | Evaluate a core Type representing type level int from the TypeLevel
78 -- library to a real int.
79 -- eval_type_level_int :: Type.Type -> Int
80 -- eval_type_level_int ty =
82 -- -- Automatically import modules for any fully qualified identifiers
83 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
85 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
86 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
87 -- let undef = hsTypedUndef $ coreToHsType ty
88 -- let app = HsExpr.HsApp (to_int) (undef)
90 -- core <- toCore [] app
93 -- | Get the length of a FSVec type
94 tfvec_len :: Type.Type -> Int
98 args = case Type.splitTyConApp_maybe ty of
99 Just (tycon, args) -> args
100 Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
103 -- | Get the element type of a TFVec type
104 tfvec_elem :: Type.Type -> Type.Type
105 tfvec_elem ty = el_ty
107 args = case Type.splitTyConApp_maybe ty of
108 Just (tycon, args) -> args
109 Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
112 -- Is this a wild binder?
113 is_wild :: CoreSyn.CoreBndr -> Bool
114 -- wild binders have a particular unique, that we copied from MkCore.lhs to
115 -- here. However, this comparison didn't work, so we'll just check the
116 -- occstring for now... TODO
117 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
118 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
120 -- Is the given core expression a lambda abstraction?
121 is_lam :: CoreSyn.CoreExpr -> Bool
122 is_lam (CoreSyn.Lam _ _) = True
125 -- Is the given core expression of a function type?
126 is_fun :: CoreSyn.CoreExpr -> Bool
127 -- Treat Type arguments differently, because exprType is not defined for them.
128 is_fun (CoreSyn.Type _) = False
129 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
131 -- Is the given core expression polymorphic (i.e., does it accept type
133 is_poly :: CoreSyn.CoreExpr -> Bool
134 -- Treat Type arguments differently, because exprType is not defined for them.
135 is_poly (CoreSyn.Type _) = False
136 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
138 -- Is the given core expression a variable reference?
139 is_var :: CoreSyn.CoreExpr -> Bool
140 is_var (CoreSyn.Var _) = True
143 -- Can the given core expression be applied to something? This is true for
144 -- applying to a value as well as a type.
145 is_applicable :: CoreSyn.CoreExpr -> Bool
146 is_applicable expr = is_fun expr || is_poly expr
148 -- Does the given CoreExpr have any free type vars?
149 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
150 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
152 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
153 -- simple Var CoreExprs, not complexer ones.
154 exprToVar :: CoreSyn.CoreExpr -> Var.Id
155 exprToVar (CoreSyn.Var id) = id