Ticket #1480: reifmod-ghc.patch

File reifmod-ghc.patch, 3.6 KB (added by errge, 4 years ago)

patch, GHC part

  • compiler/iface/LoadIface.lhs

    diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
    index 0fc8e68..a453d57 100644
    a b Loading interface files 
    1010module LoadIface (
    1111        -- RnM/TcM functions
    1212        loadModuleInterface, loadModuleInterfaces,
    13         loadSrcInterface, loadInterfaceForName,
     13        loadSrcInterface, loadInterfaceForName, loadInterfaceForModule,
    1414
    1515        -- IfM functions
    1616        loadInterface, loadWiredInHomeIface,
    loadInterfaceForName doc name 
    126126  ; ASSERT2( isExternalName name, ppr name )
    127127    initIfaceTcRn $ loadSysInterface doc (nameModule name)
    128128  }
     129
     130-- | Loads the interface for a given Module.
     131loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
     132loadInterfaceForModule doc m
     133  = do
     134    -- Should not be called with this module
     135    when debugIsOn $ do
     136      this_mod <- getModule
     137      MASSERT2( this_mod /= m, ppr m <+> parens doc )
     138    initIfaceTcRn $ loadSysInterface doc m
    129139\end{code}
    130140
    131141
  • compiler/typecheck/TcSplice.lhs

    diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
    index 458fc07..5a55d25 100644
    a b import Var 
    5555import Module
    5656import Annotations
    5757import TcRnMonad
     58import LoadIface
    5859import Class
    5960import Inst
    6061import TyCon
    instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where 
    10501051  qReifyInstances   = reifyInstances
    10511052  qReifyRoles       = reifyRoles
    10521053  qReifyAnnotations = reifyAnnotations
     1054  qReifyModule      = reifyModule
    10531055
    10541056        -- For qRecover, discard error messages if
    10551057        -- the recovery action is chosen.  Otherwise
    reifyStrict (HsUnpack {}) = TH.Unpacked 
    16541656------------------------------
    16551657lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
    16561658lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
    1657 lookupThAnnLookup (TH.AnnLookupModule pn mn)
     1659lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
    16581660  = return $ ModuleTarget $
    16591661    mkModule (stringToPackageId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
    16601662
    reifyAnnotations th_nm 
    16681670       ; return (envAnns ++ epsAnns) }
    16691671
    16701672------------------------------
     1673modToTHMod :: Module -> TH.Module
     1674modToTHMod m = TH.Module (TH.PkgName $ packageIdString  $ modulePackageId m)
     1675                         (TH.ModName $ moduleNameString $ moduleName m)
     1676
     1677reifyModule :: TH.Module -> TcM TH.ModuleInfo
     1678reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
     1679  this_mod <- getModule
     1680  let reifMod = mkModule (stringToPackageId pkgString) (mkModuleName mString)
     1681  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
     1682    where
     1683      reifyThisModule = do
     1684        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
     1685        return $ TH.ModuleInfo usages
     1686
     1687      reifyFromIface reifMod = do
     1688        iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
     1689        let usages = [modToTHMod m | usage <- mi_usages iface,
     1690                                     Just m <- [usageToModule (modulePackageId reifMod) usage] ]
     1691        return $ TH.ModuleInfo usages
     1692
     1693      usageToModule :: PackageId -> Usage -> Maybe Module
     1694      usageToModule _ (UsageFile {}) = Nothing
     1695      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
     1696      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
     1697
     1698------------------------------
    16711699mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
    16721700mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
    16731701