-- Core and Haskell (it uses HsTools for this), but only the functions that
-- know about various libraries and know which functions to call.
module CoreTools where
-
+
+--Standard modules
+import qualified Maybe
+
-- GHC API
-import qualified DynFlags
+import qualified GHC
import qualified Type
import qualified HsExpr
import qualified HsTypes
-import qualified RdrName
import qualified HsBinds
+import qualified RdrName
+import qualified Name
import qualified OccName
-import qualified HsBinds
+import qualified TysWiredIn
+import qualified Bag
+import qualified DynFlags
import qualified SrcLoc
+import qualified CoreSyn
+import qualified Var
+import qualified VarSet
+import qualified Unique
+import qualified CoreUtils
+import qualified CoreFVs
-import qualified HsTools
+import GhcTools
+import HsTools
-- | Evaluate a core Type representing type level int from the tfp
-- library to a real int.
(HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
(SrcLoc.noLoc expr)
- core <- toCore expr
+ let modules = map GHC.mkModuleName ["Types.Data.Num"]
+ core <- toCore modules expr
execCore core
--- | Get the length of a SizedWord type
+-- | Get the width of a SizedWord type
sized_word_len :: Type.Type -> Int
sized_word_len ty =
eval_tfp_int len
(tycon, args) = Type.splitTyConApp ty
[len] = args
+-- | Evaluate a core Type representing type level int from the TypeLevel
+-- library to a real int.
+-- eval_type_level_int :: Type.Type -> Int
+-- eval_type_level_int ty =
+-- unsafeRunGhc $ do
+-- -- Automatically import modules for any fully qualified identifiers
+-- setDynFlag DynFlags.Opt_ImplicitImportQualified
+--
+-- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
+-- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
+-- let undef = hsTypedUndef $ coreToHsType ty
+-- let app = HsExpr.HsApp (to_int) (undef)
+--
+-- core <- toCore [] app
+-- execCore core
+
+-- | Get the length of a FSVec type
+tfvec_len :: Type.Type -> Int
+tfvec_len ty =
+ eval_tfp_int len
+ where
+ (tycon, args) = Type.splitTyConApp ty
+ [len, el_ty] = args
+
+-- Is this a wild binder?
+is_wild :: CoreSyn.CoreBndr -> Bool
+-- wild binders have a particular unique, that we copied from MkCore.lhs to
+-- here. However, this comparison didn't work, so we'll just check the
+-- occstring for now... TODO
+--(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
+is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
+
+-- Is the given core expression a lambda abstraction?
+is_lam :: CoreSyn.CoreExpr -> Bool
+is_lam (CoreSyn.Lam _ _) = True
+is_lam _ = False
+
+-- Is the given core expression of a function type?
+is_fun :: CoreSyn.CoreExpr -> Bool
+-- Treat Type arguments differently, because exprType is not defined for them.
+is_fun (CoreSyn.Type _) = False
+is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
+
+-- Is the given core expression polymorphic (i.e., does it accept type
+-- arguments?).
+is_poly :: CoreSyn.CoreExpr -> Bool
+-- Treat Type arguments differently, because exprType is not defined for them.
+is_poly (CoreSyn.Type _) = False
+is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
+
+-- Is the given core expression a variable reference?
+is_var :: CoreSyn.CoreExpr -> Bool
+is_var (CoreSyn.Var _) = True
+is_var _ = False
+
+-- Does the given CoreExpr have any free type vars?
+has_free_tyvars :: CoreSyn.CoreExpr -> Bool
+has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)