No longer any need to explicitly load module interface in 'toCore'

[matthijs/master-project/cλash.git] / HsTools.hs

diff --git a/HsTools.hs b/HsTools.hs
index ae5582a002f1c2f2d8d3685d5cfafe1216d369c1..d132ce874033020c12071996e3c112ec92477ce7 100644 (file)
--- a/HsTools.hs
+++ b/HsTools.hs
@@ -3,7 +3,7 @@ module HsTools where
 
 -- Standard modules
 import qualified Unsafe.Coerce
 
 -- Standard modules
 import qualified Unsafe.Coerce

-
+import qualified Maybe

 
 -- GHC API
 import qualified GHC
 
 -- GHC API
 import qualified GHC


@@ -14,6 +14,7 @@ import qualified FastString
 import qualified StringBuffer
 import qualified MonadUtils
 import Outputable ( showSDoc, ppr )
 import qualified StringBuffer
 import qualified MonadUtils
 import Outputable ( showSDoc, ppr )

+import qualified Outputable

 -- Lexer & Parser, i.e. up to HsExpr
 import qualified Lexer
 import qualified Parser
 -- Lexer & Parser, i.e. up to HsExpr
 import qualified Lexer
 import qualified Parser


@@ -24,19 +25,26 @@ import qualified HsExpr
 import qualified HsTypes
 import qualified HsBinds
 import qualified TcRnMonad
 import qualified HsTypes
 import qualified HsBinds
 import qualified TcRnMonad

+import qualified TcRnTypes

 import qualified RnExpr
 import qualified RnEnv
 import qualified TcExpr
 import qualified TcEnv
 import qualified TcSimplify
 import qualified RnExpr
 import qualified RnEnv
 import qualified TcExpr
 import qualified TcEnv
 import qualified TcSimplify

+import qualified TcTyFuns

 import qualified Desugar
 import qualified Desugar

+import qualified InstEnv
+import qualified FamInstEnv

 import qualified PrelNames
 import qualified Module
 import qualified OccName
 import qualified RdrName
 import qualified Name
 import qualified PrelNames
 import qualified Module
 import qualified OccName
 import qualified RdrName
 import qualified Name

+import qualified TysWiredIn

 import qualified SrcLoc
 import qualified SrcLoc

+import qualified LoadIface

 import qualified BasicTypes
 import qualified BasicTypes

+import qualified Bag

 -- Core representation and handling
 import qualified CoreSyn
 import qualified Id
 -- Core representation and handling
 import qualified CoreSyn
 import qualified Id


@@ -59,7 +67,9 @@ import CoreShow
 --    (==) = Prelude.(==) Int $dInt 
 --  in 
 --    \x = (==) x 1
 --    (==) = Prelude.(==) Int $dInt 
 --  in 
 --    \x = (==) x 1

-toCore :: HsSyn.HsExpr RdrName.RdrName -> GHC.Ghc CoreSyn.CoreExpr
+toCore ::
+  HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
+  -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.

 toCore expr = do
   env <- GHC.getSession
   let icontext = HscTypes.hsc_IC env
 toCore expr = do
   env <- GHC.getSession
   let icontext = HscTypes.hsc_IC env


@@ -111,17 +121,33 @@ mkId rdr_name = do
         TcEnv.tcLookupId name 
   return id
 
         TcEnv.tcLookupId name 
   return id
 

+normaliseType ::
+  HscTypes.HscEnv
+  -> Type.Type
+  -> IO Type.Type
+normaliseType env ty = do
+   (err, nty) <- MonadUtils.liftIO $
+     -- Initialize the typechecker monad
+     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+       -- Normalize the type
+       (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
+       return nty
+   let normalized_ty = Maybe.fromJust nty
+   return normalized_ty
+

 -- | Translate a core Type to an HsType. Far from complete so far.
 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
 --  Translate TyConApps
 -- | Translate a core Type to an HsType. Far from complete so far.
 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
 --  Translate TyConApps

-coreToHsType (Type.splitTyConApp_maybe -> Just (tycon, tys)) =
-  foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
-  where
-    tycon_name = TyCon.tyConName tycon
-    mod_name = Module.moduleName $ Name.nameModule tycon_name
-    occ_name = Name.nameOccName tycon_name
-    tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
-    tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
+coreToHsType ty = case Type.splitTyConApp_maybe ty of
+  Just (tycon, tys) ->
+    foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
+    where
+      tycon_name = TyCon.tyConName tycon
+      mod_name = Module.moduleName $ Name.nameModule tycon_name
+      occ_name = Name.nameOccName tycon_name
+      tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
+      tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
+  Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"

 
 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
 --   should already know the result type for sure, since the result value is
 
 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
 --   should already know the result type for sure, since the result value is


@@ -141,22 +167,6 @@ execCore expr = do
         let res = Unsafe.Coerce.unsafeCoerce hval :: Int
         return $ Unsafe.Coerce.unsafeCoerce hval
 
         let res = Unsafe.Coerce.unsafeCoerce hval :: Int
         return $ Unsafe.Coerce.unsafeCoerce hval
 

--- | 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 
-

 -- These functions build (parts of) a LHSExpr RdrName.
 
 -- | A reference to the Prelude.undefined function.
 -- These functions build (parts of) a LHSExpr RdrName.
 
 -- | A reference to the Prelude.undefined function.


@@ -185,3 +195,30 @@ hscParseThing parser dflags str = do
     let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
     return thing
 
     let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
     return thing
 

+-- | This function imports the module with the given name, for the renamer /
+-- typechecker to use. It also imports any "orphans" and "family instances"
+-- from modules included by this module, but not the actual modules
+-- themselves. I'm not 100% sure how this works, but it seems that any
+-- functions defined in included modules are available just by loading the
+-- original module, and by doing this orphan stuff, any (type family or class)
+-- instances are available as well.
+--
+-- Most of the code is based on tcRnImports and rnImportDecl, but those
+-- functions do a lot more (which I hope we won't need...).
+importModule :: Module.ModuleName -> TcRnTypes.RnM ()
+importModule mod = do
+  let reason = Outputable.text "Hardcoded import" -- Used for trace output
+  let pkg = Nothing
+  -- Load the interface.
+  iface <- LoadIface.loadSrcInterface reason mod False pkg
+  -- Load orphan an familiy instance dependencies as well. I think these
+  -- dependencies are needed for the type checker to know all instances. Any
+  -- other instances (on other packages) are only useful to the
+  -- linker, so we can probably safely ignore them here. Dependencies within
+  -- the same package are also listed in deps, but I'm not so sure what to do
+  -- with them.
+  let deps = HscTypes.mi_deps iface
+  let orphs = HscTypes.dep_orphs deps
+  let finsts = HscTypes.dep_finsts deps
+  LoadIface.loadOrphanModules orphs False
+  LoadIface.loadOrphanModules finsts True