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
96 tfvec_len ty = eval_tfp_int (tfvec_len_ty ty)
98 tfvec_len_ty :: Type.Type -> Type.Type
101 args = case Type.splitTyConApp_maybe ty of
102 Just (tycon, args) -> args
103 Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
106 -- | Get the element type of a TFVec type
107 tfvec_elem :: Type.Type -> Type.Type
108 tfvec_elem ty = el_ty
110 args = case Type.splitTyConApp_maybe ty of
111 Just (tycon, args) -> args
112 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
115 -- Is this a wild binder?
116 is_wild :: CoreSyn.CoreBndr -> Bool
117 -- wild binders have a particular unique, that we copied from MkCore.lhs to
118 -- here. However, this comparison didn't work, so we'll just check the
119 -- occstring for now... TODO
120 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
121 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
123 -- Is the given core expression a lambda abstraction?
124 is_lam :: CoreSyn.CoreExpr -> Bool
125 is_lam (CoreSyn.Lam _ _) = True
128 -- Is the given core expression of a function type?
129 is_fun :: CoreSyn.CoreExpr -> Bool
130 -- Treat Type arguments differently, because exprType is not defined for them.
131 is_fun (CoreSyn.Type _) = False
132 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
134 -- Is the given core expression polymorphic (i.e., does it accept type
136 is_poly :: CoreSyn.CoreExpr -> Bool
137 -- Treat Type arguments differently, because exprType is not defined for them.
138 is_poly (CoreSyn.Type _) = False
139 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
141 -- Is the given core expression a variable reference?
142 is_var :: CoreSyn.CoreExpr -> Bool
143 is_var (CoreSyn.Var _) = True
146 -- Can the given core expression be applied to something? This is true for
147 -- applying to a value as well as a type.
148 is_applicable :: CoreSyn.CoreExpr -> Bool
149 is_applicable expr = is_fun expr || is_poly expr
151 -- Is the given core expression a variable or an application?
152 is_simple :: CoreSyn.CoreExpr -> Bool
153 is_simple (CoreSyn.App _ _) = True
154 is_simple (CoreSyn.Var _) = True
155 is_simple (CoreSyn.Cast expr _) = is_simple expr
158 -- Does the given CoreExpr have any free type vars?
159 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
160 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
162 -- Does the given CoreExpr have any free local vars?
163 has_free_vars :: CoreSyn.CoreExpr -> Bool
164 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
166 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
167 -- simple Var CoreExprs, not complexer ones.
168 exprToVar :: CoreSyn.CoreExpr -> Var.Id
169 exprToVar (CoreSyn.Var id) = id
170 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
172 -- Removes all the type and dictionary arguments from the given argument list,
173 -- leaving only the normal value arguments. The type given is the type of the
174 -- expression applied to this argument list.
175 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
176 get_val_args ty args = drop n args
178 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
179 -- The first (length tyvars) arguments should be types, the next
180 -- (length predtypes) arguments should be dictionaries. We drop this many
181 -- arguments, to get at the value arguments.
182 n = length tyvars + length predtypes