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
30 import qualified Literal
37 -- | Evaluate a core Type representing type level int from the tfp
38 -- library to a real int.
39 eval_tfp_int :: Type.Type -> Int
42 -- Automatically import modules for any fully qualified identifiers
43 setDynFlag DynFlags.Opt_ImplicitImportQualified
44 --setDynFlag DynFlags.Opt_D_dump_if_trace
46 let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
47 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
48 let undef = hsTypedUndef $ coreToHsType ty
49 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
50 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
51 let expr = HsExpr.ExprWithTySig app int_ty
52 let foo_name = mkRdrName "Types.Data.Num" "foo"
53 let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
54 let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
55 let letexpr = HsExpr.HsLet
56 (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
59 let modules = map GHC.mkModuleName ["Types.Data.Num"]
60 core <- toCore modules expr
63 -- | Get the width of a SizedWord type
64 sized_word_len :: Type.Type -> Int
65 sized_word_len ty = eval_tfp_int (sized_word_len_ty ty)
67 sized_word_len_ty :: Type.Type -> Type.Type
68 sized_word_len_ty ty = len
70 args = case Type.splitTyConApp_maybe ty of
71 Just (tycon, args) -> args
72 Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
75 -- | Get the width of a SizedInt type
76 sized_int_len :: Type.Type -> Int
77 sized_int_len ty = eval_tfp_int (sized_int_len_ty ty)
79 sized_int_len_ty :: Type.Type -> Type.Type
80 sized_int_len_ty ty = len
82 args = case Type.splitTyConApp_maybe ty of
83 Just (tycon, args) -> args
84 Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
87 -- | Get the upperbound of a RangedWord type
88 ranged_word_bound :: Type.Type -> Int
89 ranged_word_bound ty = eval_tfp_int (ranged_word_bound_ty ty)
91 ranged_word_bound_ty :: Type.Type -> Type.Type
92 ranged_word_bound_ty ty = len
94 args = case Type.splitTyConApp_maybe ty of
95 Just (tycon, args) -> args
96 Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
99 -- | Evaluate a core Type representing type level int from the TypeLevel
100 -- library to a real int.
101 -- eval_type_level_int :: Type.Type -> Int
102 -- eval_type_level_int ty =
104 -- -- Automatically import modules for any fully qualified identifiers
105 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
107 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
108 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
109 -- let undef = hsTypedUndef $ coreToHsType ty
110 -- let app = HsExpr.HsApp (to_int) (undef)
112 -- core <- toCore [] app
115 -- | Get the length of a FSVec type
116 tfvec_len :: Type.Type -> Int
117 tfvec_len ty = eval_tfp_int (tfvec_len_ty ty)
119 tfvec_len_ty :: Type.Type -> Type.Type
120 tfvec_len_ty ty = len
122 args = case Type.splitTyConApp_maybe ty of
123 Just (tycon, args) -> args
124 Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
127 -- | Get the element type of a TFVec type
128 tfvec_elem :: Type.Type -> Type.Type
129 tfvec_elem ty = el_ty
131 args = case Type.splitTyConApp_maybe ty of
132 Just (tycon, args) -> args
133 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
136 -- Is this a wild binder?
137 is_wild :: CoreSyn.CoreBndr -> Bool
138 -- wild binders have a particular unique, that we copied from MkCore.lhs to
139 -- here. However, this comparison didn't work, so we'll just check the
140 -- occstring for now... TODO
141 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
142 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
144 -- Is the given core expression a lambda abstraction?
145 is_lam :: CoreSyn.CoreExpr -> Bool
146 is_lam (CoreSyn.Lam _ _) = True
149 -- Is the given core expression of a function type?
150 is_fun :: CoreSyn.CoreExpr -> Bool
151 -- Treat Type arguments differently, because exprType is not defined for them.
152 is_fun (CoreSyn.Type _) = False
153 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
155 -- Is the given core expression polymorphic (i.e., does it accept type
157 is_poly :: CoreSyn.CoreExpr -> Bool
158 -- Treat Type arguments differently, because exprType is not defined for them.
159 is_poly (CoreSyn.Type _) = False
160 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
162 -- Is the given core expression a variable reference?
163 is_var :: CoreSyn.CoreExpr -> Bool
164 is_var (CoreSyn.Var _) = True
167 is_lit :: CoreSyn.CoreExpr -> Bool
168 is_lit (CoreSyn.Lit _) = True
171 -- Can the given core expression be applied to something? This is true for
172 -- applying to a value as well as a type.
173 is_applicable :: CoreSyn.CoreExpr -> Bool
174 is_applicable expr = is_fun expr || is_poly expr
176 -- Is the given core expression a variable or an application?
177 is_simple :: CoreSyn.CoreExpr -> Bool
178 is_simple (CoreSyn.App _ _) = True
179 is_simple (CoreSyn.Var _) = True
180 is_simple (CoreSyn.Cast expr _) = is_simple expr
183 -- Does the given CoreExpr have any free type vars?
184 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
185 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
187 -- Does the given CoreExpr have any free local vars?
188 has_free_vars :: CoreSyn.CoreExpr -> Bool
189 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
191 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
192 -- simple Var CoreExprs, not complexer ones.
193 exprToVar :: CoreSyn.CoreExpr -> Var.Id
194 exprToVar (CoreSyn.Var id) = id
195 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
197 -- Turns a Lit CoreExpr into the Literal inside it.
198 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
199 exprToLit (CoreSyn.Lit lit) = lit
200 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
202 -- Removes all the type and dictionary arguments from the given argument list,
203 -- leaving only the normal value arguments. The type given is the type of the
204 -- expression applied to this argument list.
205 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
206 get_val_args ty args = drop n args
208 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
209 -- The first (length tyvars) arguments should be types, the next
210 -- (length predtypes) arguments should be dictionaries. We drop this many
211 -- arguments, to get at the value arguments.
212 n = length tyvars + length predtypes
214 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
215 getLiterals app@(CoreSyn.App _ _) = literals
217 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
218 literals = filter (is_lit) args