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.
9 import System.IO.Unsafe
14 import qualified TcType
15 import qualified HsExpr
16 import qualified HsTypes
17 import qualified HsBinds
18 import qualified HscTypes
19 import qualified RdrName
21 import qualified OccName
22 import qualified TysWiredIn
24 import qualified DynFlags
25 import qualified SrcLoc
26 import qualified CoreSyn
28 import qualified VarSet
29 import qualified Unique
30 import qualified CoreUtils
31 import qualified CoreFVs
32 import qualified Literal
39 -- | Evaluate a core Type representing type level int from the tfp
40 -- library to a real int.
41 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
45 -- Automatically import modules for any fully qualified identifiers
46 setDynFlag DynFlags.Opt_ImplicitImportQualified
48 let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
49 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
50 let undef = hsTypedUndef $ coreToHsType ty
51 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
52 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
53 let expr = HsExpr.ExprWithTySig app int_ty
54 let foo_name = mkRdrName "Types.Data.Num" "foo"
55 let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
56 let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
57 let letexpr = HsExpr.HsLet
58 (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
63 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
64 normalise_tfp_int env ty =
66 nty <- normaliseType env ty
69 -- | Get the width of a SizedWord type
70 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
71 -- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
73 sized_word_len_ty :: Type.Type -> Type.Type
74 sized_word_len_ty ty = len
76 args = case Type.splitTyConApp_maybe ty of
77 Just (tycon, args) -> args
78 Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
81 -- | Get the width of a SizedInt type
82 -- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
83 -- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
85 sized_int_len_ty :: Type.Type -> Type.Type
86 sized_int_len_ty ty = len
88 args = case Type.splitTyConApp_maybe ty of
89 Just (tycon, args) -> args
90 Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
93 -- | Get the upperbound of a RangedWord type
94 -- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
95 -- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
97 ranged_word_bound_ty :: Type.Type -> Type.Type
98 ranged_word_bound_ty ty = len
100 args = case Type.splitTyConApp_maybe ty of
101 Just (tycon, args) -> args
102 Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
105 -- | Evaluate a core Type representing type level int from the TypeLevel
106 -- library to a real int.
107 -- eval_type_level_int :: Type.Type -> Int
108 -- eval_type_level_int ty =
110 -- -- Automatically import modules for any fully qualified identifiers
111 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
113 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
114 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
115 -- let undef = hsTypedUndef $ coreToHsType ty
116 -- let app = HsExpr.HsApp (to_int) (undef)
118 -- core <- toCore [] app
121 -- | Get the length of a FSVec type
122 -- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
123 -- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
125 tfvec_len_ty :: Type.Type -> Type.Type
126 tfvec_len_ty ty = len
128 args = case Type.splitTyConApp_maybe ty of
129 Just (tycon, args) -> args
130 Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
133 -- | Get the element type of a TFVec type
134 tfvec_elem :: Type.Type -> Type.Type
135 tfvec_elem ty = el_ty
137 args = case Type.splitTyConApp_maybe ty of
138 Just (tycon, args) -> args
139 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
142 -- Is this a wild binder?
143 is_wild :: CoreSyn.CoreBndr -> Bool
144 -- wild binders have a particular unique, that we copied from MkCore.lhs to
145 -- here. However, this comparison didn't work, so we'll just check the
146 -- occstring for now... TODO
147 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
148 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
150 -- Is the given core expression a lambda abstraction?
151 is_lam :: CoreSyn.CoreExpr -> Bool
152 is_lam (CoreSyn.Lam _ _) = True
155 -- Is the given core expression of a function type?
156 is_fun :: CoreSyn.CoreExpr -> Bool
157 -- Treat Type arguments differently, because exprType is not defined for them.
158 is_fun (CoreSyn.Type _) = False
159 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
161 -- Is the given core expression polymorphic (i.e., does it accept type
163 is_poly :: CoreSyn.CoreExpr -> Bool
164 -- Treat Type arguments differently, because exprType is not defined for them.
165 is_poly (CoreSyn.Type _) = False
166 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
168 -- Is the given core expression a variable reference?
169 is_var :: CoreSyn.CoreExpr -> Bool
170 is_var (CoreSyn.Var _) = True
173 is_lit :: CoreSyn.CoreExpr -> Bool
174 is_lit (CoreSyn.Lit _) = True
177 -- Can the given core expression be applied to something? This is true for
178 -- applying to a value as well as a type.
179 is_applicable :: CoreSyn.CoreExpr -> Bool
180 is_applicable expr = is_fun expr || is_poly expr
182 -- Is the given core expression a variable or an application?
183 is_simple :: CoreSyn.CoreExpr -> Bool
184 is_simple (CoreSyn.App _ _) = True
185 is_simple (CoreSyn.Var _) = True
186 is_simple (CoreSyn.Cast expr _) = is_simple expr
189 -- Does the given CoreExpr have any free type vars?
190 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
191 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
193 -- Does the given CoreExpr have any free local vars?
194 has_free_vars :: CoreSyn.CoreExpr -> Bool
195 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
197 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
198 -- simple Var CoreExprs, not complexer ones.
199 exprToVar :: CoreSyn.CoreExpr -> Var.Id
200 exprToVar (CoreSyn.Var id) = id
201 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
203 -- Turns a Lit CoreExpr into the Literal inside it.
204 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
205 exprToLit (CoreSyn.Lit lit) = lit
206 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
208 -- Removes all the type and dictionary arguments from the given argument list,
209 -- leaving only the normal value arguments. The type given is the type of the
210 -- expression applied to this argument list.
211 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
212 get_val_args ty args = drop n args
214 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
215 -- The first (length tyvars) arguments should be types, the next
216 -- (length predtypes) arguments should be dictionaries. We drop this many
217 -- arguments, to get at the value arguments.
218 n = length tyvars + length predtypes
220 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
221 getLiterals app@(CoreSyn.App _ _) = literals
223 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
224 literals = filter (is_lit) args