[commit: ghc] master: Add support for module reification (#1480) (69fa2e5)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/69fa2e558d56178d33950df815c3233606b0d44e/ghc

>---------------------------------------------------------------

commit 69fa2e558d56178d33950df815c3233606b0d44e
Author: Austin Seipp <austin at well-typed.com>
Date:   Fri Nov 1 22:15:53 2013 -0500

    Add support for module reification (#1480)
    
    Authored-by: Gergely Risko <gergely at risko.hu>
    Signed-off-by: Austin Seipp <austin at well-typed.com>


>---------------------------------------------------------------

69fa2e558d56178d33950df815c3233606b0d44e
 compiler/iface/LoadIface.lhs    |   12 +++++++++++-
 compiler/typecheck/TcSplice.lhs |   30 +++++++++++++++++++++++++++++-
 2 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index ab522db..08e7466 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -10,7 +10,7 @@ Loading interface files
 module LoadIface (
         -- RnM/TcM functions
         loadModuleInterface, loadModuleInterfaces, 
-        loadSrcInterface, loadInterfaceForName, 
+        loadSrcInterface, loadInterfaceForName, loadInterfaceForModule,
 
         -- IfM functions
         loadInterface, loadWiredInHomeIface, 
@@ -126,6 +126,16 @@ loadInterfaceForName doc name
   ; ASSERT2( isExternalName name, ppr name ) 
     initIfaceTcRn $ loadSysInterface doc (nameModule name)
   }
+
+-- | Loads the interface for a given Module.
+loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
+loadInterfaceForModule doc m
+  = do
+    -- Should not be called with this module
+    when debugIsOn $ do
+      this_mod <- getModule
+      MASSERT2( this_mod /= m, ppr m <+> parens doc )
+    initIfaceTcRn $ loadSysInterface doc m
 \end{code}
 
 
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 458fc07..5a55d25 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -55,6 +55,7 @@ import Var
 import Module
 import Annotations
 import TcRnMonad
+import LoadIface
 import Class
 import Inst
 import TyCon
@@ -1050,6 +1051,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
   qReifyInstances   = reifyInstances
   qReifyRoles       = reifyRoles
   qReifyAnnotations = reifyAnnotations
+  qReifyModule      = reifyModule
 
         -- For qRecover, discard error messages if
         -- the recovery action is chosen.  Otherwise
@@ -1654,7 +1656,7 @@ reifyStrict (HsUnpack {})                 = TH.Unpacked
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
-lookupThAnnLookup (TH.AnnLookupModule pn mn)
+lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
   = return $ ModuleTarget $
     mkModule (stringToPackageId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
 
@@ -1668,6 +1670,32 @@ reifyAnnotations th_nm
        ; return (envAnns ++ epsAnns) }
 
 ------------------------------
+modToTHMod :: Module -> TH.Module
+modToTHMod m = TH.Module (TH.PkgName $ packageIdString  $ modulePackageId m)
+                         (TH.ModName $ moduleNameString $ moduleName m)
+
+reifyModule :: TH.Module -> TcM TH.ModuleInfo
+reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
+  this_mod <- getModule
+  let reifMod = mkModule (stringToPackageId pkgString) (mkModuleName mString)
+  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
+    where
+      reifyThisModule = do
+        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
+        return $ TH.ModuleInfo usages
+
+      reifyFromIface reifMod = do
+        iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
+        let usages = [modToTHMod m | usage <- mi_usages iface,
+                                     Just m <- [usageToModule (modulePackageId reifMod) usage] ]
+        return $ TH.ModuleInfo usages
+
+      usageToModule :: PackageId -> Usage -> Maybe Module
+      usageToModule _ (UsageFile {}) = Nothing
+      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
+      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
+
+------------------------------
 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys