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) [])
61 let modules = map GHC.mkModuleName ["Types.Data.Num"]
62 core <- toCore modules expr
65 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
66 normalise_tfp_int env ty =
68 nty <- normaliseType env ty
71 -- | Get the width of a SizedWord type
72 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
73 -- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
75 sized_word_len_ty :: Type.Type -> Type.Type
76 sized_word_len_ty ty = len
78 args = case Type.splitTyConApp_maybe ty of
79 Just (tycon, args) -> args
80 Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
83 -- | Get the width of a SizedInt type
84 -- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
85 -- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
87 sized_int_len_ty :: Type.Type -> Type.Type
88 sized_int_len_ty ty = len
90 args = case Type.splitTyConApp_maybe ty of
91 Just (tycon, args) -> args
92 Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
95 -- | Get the upperbound of a RangedWord type
96 -- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
97 -- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
99 ranged_word_bound_ty :: Type.Type -> Type.Type
100 ranged_word_bound_ty ty = len
102 args = case Type.splitTyConApp_maybe ty of
103 Just (tycon, args) -> args
104 Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
107 -- | Evaluate a core Type representing type level int from the TypeLevel
108 -- library to a real int.
109 -- eval_type_level_int :: Type.Type -> Int
110 -- eval_type_level_int ty =
112 -- -- Automatically import modules for any fully qualified identifiers
113 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
115 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
116 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
117 -- let undef = hsTypedUndef $ coreToHsType ty
118 -- let app = HsExpr.HsApp (to_int) (undef)
120 -- core <- toCore [] app
123 -- | Get the length of a FSVec type
124 -- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
125 -- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
127 tfvec_len_ty :: Type.Type -> Type.Type
128 tfvec_len_ty ty = len
130 args = case Type.splitTyConApp_maybe ty of
131 Just (tycon, args) -> args
132 Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
135 -- | Get the element type of a TFVec type
136 tfvec_elem :: Type.Type -> Type.Type
137 tfvec_elem ty = el_ty
139 args = case Type.splitTyConApp_maybe ty of
140 Just (tycon, args) -> args
141 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
144 -- Is this a wild binder?
145 is_wild :: CoreSyn.CoreBndr -> Bool
146 -- wild binders have a particular unique, that we copied from MkCore.lhs to
147 -- here. However, this comparison didn't work, so we'll just check the
148 -- occstring for now... TODO
149 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
150 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
152 -- Is the given core expression a lambda abstraction?
153 is_lam :: CoreSyn.CoreExpr -> Bool
154 is_lam (CoreSyn.Lam _ _) = True
157 -- Is the given core expression of a function type?
158 is_fun :: CoreSyn.CoreExpr -> Bool
159 -- Treat Type arguments differently, because exprType is not defined for them.
160 is_fun (CoreSyn.Type _) = False
161 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
163 -- Is the given core expression polymorphic (i.e., does it accept type
165 is_poly :: CoreSyn.CoreExpr -> Bool
166 -- Treat Type arguments differently, because exprType is not defined for them.
167 is_poly (CoreSyn.Type _) = False
168 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
170 -- Is the given core expression a variable reference?
171 is_var :: CoreSyn.CoreExpr -> Bool
172 is_var (CoreSyn.Var _) = True
175 is_lit :: CoreSyn.CoreExpr -> Bool
176 is_lit (CoreSyn.Lit _) = True
179 -- Can the given core expression be applied to something? This is true for
180 -- applying to a value as well as a type.
181 is_applicable :: CoreSyn.CoreExpr -> Bool
182 is_applicable expr = is_fun expr || is_poly expr
184 -- Is the given core expression a variable or an application?
185 is_simple :: CoreSyn.CoreExpr -> Bool
186 is_simple (CoreSyn.App _ _) = True
187 is_simple (CoreSyn.Var _) = True
188 is_simple (CoreSyn.Cast expr _) = is_simple expr
191 -- Does the given CoreExpr have any free type vars?
192 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
193 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
195 -- Does the given CoreExpr have any free local vars?
196 has_free_vars :: CoreSyn.CoreExpr -> Bool
197 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
199 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
200 -- simple Var CoreExprs, not complexer ones.
201 exprToVar :: CoreSyn.CoreExpr -> Var.Id
202 exprToVar (CoreSyn.Var id) = id
203 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
205 -- Turns a Lit CoreExpr into the Literal inside it.
206 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
207 exprToLit (CoreSyn.Lit lit) = lit
208 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
210 -- Removes all the type and dictionary arguments from the given argument list,
211 -- leaving only the normal value arguments. The type given is the type of the
212 -- expression applied to this argument list.
213 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
214 get_val_args ty args = drop n args
216 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
217 -- The first (length tyvars) arguments should be types, the next
218 -- (length predtypes) arguments should be dictionaries. We drop this many
219 -- arguments, to get at the value arguments.
220 n = length tyvars + length predtypes
222 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
223 getLiterals app@(CoreSyn.App _ _) = literals
225 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
226 literals = filter (is_lit) args