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 TcType
14 import qualified HsExpr
15 import qualified HsTypes
16 import qualified HsBinds
17 import qualified RdrName
19 import qualified OccName
20 import qualified TysWiredIn
22 import qualified DynFlags
23 import qualified SrcLoc
24 import qualified CoreSyn
26 import qualified VarSet
27 import qualified Unique
28 import qualified CoreUtils
29 import qualified CoreFVs
36 -- | Evaluate a core Type representing type level int from the tfp
37 -- library to a real int.
38 eval_tfp_int :: Type.Type -> Int
41 -- Automatically import modules for any fully qualified identifiers
42 setDynFlag DynFlags.Opt_ImplicitImportQualified
43 --setDynFlag DynFlags.Opt_D_dump_if_trace
45 let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
46 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
47 let undef = hsTypedUndef $ coreToHsType ty
48 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
49 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
50 let expr = HsExpr.ExprWithTySig app int_ty
51 let foo_name = mkRdrName "Types.Data.Num" "foo"
52 let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
53 let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
54 let letexpr = HsExpr.HsLet
55 (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
58 let modules = map GHC.mkModuleName ["Types.Data.Num"]
59 core <- toCore modules expr
62 -- | Get the width of a SizedWord type
63 sized_word_len :: Type.Type -> Int
67 (tycon, args) = Type.splitTyConApp ty
70 -- | Get the upperbound of a RangedWord type
71 ranged_word_bound :: Type.Type -> Int
72 ranged_word_bound ty =
75 (tycon, args) = Type.splitTyConApp ty
78 -- | Evaluate a core Type representing type level int from the TypeLevel
79 -- library to a real int.
80 -- eval_type_level_int :: Type.Type -> Int
81 -- eval_type_level_int ty =
83 -- -- Automatically import modules for any fully qualified identifiers
84 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
86 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
87 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
88 -- let undef = hsTypedUndef $ coreToHsType ty
89 -- let app = HsExpr.HsApp (to_int) (undef)
91 -- core <- toCore [] app
94 -- | Get the length of a FSVec type
95 tfvec_len :: Type.Type -> Int
99 args = case Type.splitTyConApp_maybe ty of
100 Just (tycon, args) -> args
101 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
104 -- | Get the element type of a TFVec type
105 tfvec_elem :: Type.Type -> Type.Type
106 tfvec_elem ty = el_ty
108 args = case Type.splitTyConApp_maybe ty of
109 Just (tycon, args) -> args
110 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
113 -- Is this a wild binder?
114 is_wild :: CoreSyn.CoreBndr -> Bool
115 -- wild binders have a particular unique, that we copied from MkCore.lhs to
116 -- here. However, this comparison didn't work, so we'll just check the
117 -- occstring for now... TODO
118 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
119 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
121 -- Is the given core expression a lambda abstraction?
122 is_lam :: CoreSyn.CoreExpr -> Bool
123 is_lam (CoreSyn.Lam _ _) = True
126 -- Is the given core expression of a function type?
127 is_fun :: CoreSyn.CoreExpr -> Bool
128 -- Treat Type arguments differently, because exprType is not defined for them.
129 is_fun (CoreSyn.Type _) = False
130 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
132 -- Is the given core expression polymorphic (i.e., does it accept type
134 is_poly :: CoreSyn.CoreExpr -> Bool
135 -- Treat Type arguments differently, because exprType is not defined for them.
136 is_poly (CoreSyn.Type _) = False
137 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
139 -- Is the given core expression a variable reference?
140 is_var :: CoreSyn.CoreExpr -> Bool
141 is_var (CoreSyn.Var _) = True
144 -- Can the given core expression be applied to something? This is true for
145 -- applying to a value as well as a type.
146 is_applicable :: CoreSyn.CoreExpr -> Bool
147 is_applicable expr = is_fun expr || is_poly expr
149 -- Is the given core expression a variable or an application?
150 is_simple :: CoreSyn.CoreExpr -> Bool
151 is_simple (CoreSyn.App _ _) = True
152 is_simple (CoreSyn.Var _) = True
153 is_simple (CoreSyn.Cast expr _) = is_simple expr
156 -- Does the given CoreExpr have any free type vars?
157 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
158 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
160 -- Does the given CoreExpr have any free local vars?
161 has_free_vars :: CoreSyn.CoreExpr -> Bool
162 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
164 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
165 -- simple Var CoreExprs, not complexer ones.
166 exprToVar :: CoreSyn.CoreExpr -> Var.Id
167 exprToVar (CoreSyn.Var id) = id
168 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
170 -- Removes all the type and dictionary arguments from the given argument list,
171 -- leaving only the normal value arguments. The type given is the type of the
172 -- expression applied to this argument list.
173 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
174 get_val_args ty args = drop n args
176 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
177 -- The first (length tyvars) arguments should be types, the next
178 -- (length predtypes) arguments should be dictionaries. We drop this many
179 -- arguments, to get at the value arguments.
180 n = length tyvars + length predtypes