Generating synonym instance representation tycons

[ghc-hetmet.git] / compiler / iface / LoadIface.lhs

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 9c89f18..571f96b 100644 (file)
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -51,6 +51,7 @@ import Outputable
 import BinIface
 import Panic
 
+import Control.Monad (when)
 import Data.List
 import Data.Maybe
 import Data.IORef
@@ -175,9 +176,9 @@ loadInterface doc_str mod from
                        -- The (src_imp == mi_boot iface) test checks that the already-loaded
                        -- interface isn't a boot iface.  This can conceivably happen,
                        -- if an earlier import had a before we got to real imports.   I think.
-           other -> do
+           other -> do {
 
-       { let { hi_boot_file = case from of
+          let { hi_boot_file = case from of
                                ImportByUser usr_boot -> usr_boot
                                ImportBySystem        -> sys_boot
 
@@ -310,7 +311,7 @@ loadDecl ignore_prags mod (_version, decl)
   = do         {       -- Populate the name cache with final versions of all 
                -- the names associated with the decl
          main_name      <- mk_new_bndr mod (ifName decl)
-        ; traceIf (text "Loading decl for " <> ppr main_name)
+--        ; traceIf (text "Loading decl for " <> ppr main_name)
        ; implicit_names <- mapM (mk_new_bndr mod) (ifaceDeclSubBndrs decl)
 
        -- Typecheck the thing, lazily
@@ -323,7 +324,27 @@ loadDecl ignore_prags mod (_version, decl)
        ; thing <- forkM doc $ do { bumpDeclStats main_name
                                  ; tcIfaceDecl ignore_prags decl }
 
-       -- Populate the type environment with the implicitTyThings too
+       -- Populate the type environment with the implicitTyThings too.
+       -- 
+       -- Note [Tricky iface loop]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~~
+       -- The delicate point here is that 'mini-env' should be
+       -- buildable from 'thing' without demanding any of the things 'forkM'd 
+       -- by tcIfaceDecl.  For example
+       --      class C a where { data T a; op :: T a -> Int }
+       -- We return the bindings
+       --      [("C", <cls>), ("T", lookup env "T"), ("op", lookup env "op")]
+       -- The call (lookup env "T") must return the tycon T without first demanding
+       -- op; because getting the latter will look up T, hence loop.
+       --
+       -- Of course, there is no reason in principle why (lookup env "T") should demand
+       -- anything do to with op, but take care: 
+       --      (a) implicitTyThings, and 
+       --      (b) getOccName of all the things returned by implicitThings, 
+       -- must not depend on any of the nested type-checks
+       -- 
+       -- All a bit too finely-balanced for my liking.
+
        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
              lookup n = case lookupOccEnv mini_env (getOccName n) of
                           Just thing -> thing
@@ -392,18 +413,25 @@ findAndReadIface doc_str mod hi_boot_file
 
        -- Look for the file
        ; hsc_env <- getTopEnv
-       ; mb_found <- ioToIOEnv (findHiFile hsc_env mod hi_boot_file)
+       ; mb_found <- ioToIOEnv (findExactModule hsc_env mod)
        ; case mb_found of {
-             Failed err -> do
+              
+             err | notFound err -> do
                { traceIf (ptext SLIT("...not found"))
                ; dflags <- getDOpts
                ; returnM (Failed (cannotFindInterface dflags 
                                        (moduleName mod) err)) } ;
-
-             Succeeded file_path -> do 
+             Found loc mod -> do 
 
        -- Found file, so read it
-       { traceIf (ptext SLIT("readIFace") <+> text file_path)
+       { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }
+
+        ; if thisPackage dflags == modulePackageId mod
+                && not (isOneShot (ghcMode dflags))
+            then returnM (Failed (homeModError mod loc))
+            else do {
+
+        ; traceIf (ptext SLIT("readIFace") <+> text file_path)
        ; read_result <- readIface mod file_path hi_boot_file
        ; case read_result of
            Failed err -> returnM (Failed (badIfaceFile file_path err))
@@ -413,18 +441,10 @@ findAndReadIface doc_str mod hi_boot_file
                | otherwise ->
                  returnM (Succeeded (iface, file_path))
                        -- Don't forget to fill in the package name...
-       }}}
-
-findHiFile :: HscEnv -> Module -> IsBootInterface
-          -> IO (MaybeErr FindResult FilePath)
-findHiFile hsc_env mod hi_boot_file
-  = do
-      maybe_found <- findExactModule hsc_env mod
-      case maybe_found of
-       Found loc mod -> return (Succeeded path)
-               where
-                  path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc)
-       err -> return (Failed err)
+       }}}}
+
+notFound (Found _ _) = False
+notFound _ = True
 \end{code}
 
 @readIface@ tries just the one file.
@@ -518,7 +538,7 @@ ifaceStats eps
         hsep [ int (n_rules_out stats), text "rule decls imported, out of",  
                int (n_rules_in stats), text "read"]
        ]
-\end{code}    
+\end{code}
 
 
 %************************************************************************
@@ -547,7 +567,7 @@ pprModIface iface
                <+> ppr (mi_mod_vers iface) <+> pp_sub_vers
                <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty)
                <+> (if mi_finsts iface then ptext SLIT("[family instance module]") else empty)
-               <+> int opt_HiVersion
+               <+> integer opt_HiVersion
                <+> ptext SLIT("where")
        , vcat (map pprExport (mi_exports iface))
        , pprDeps (mi_deps iface)
@@ -669,5 +689,12 @@ wrongIfaceModErr iface mod_name file_path
            ]
        ]
   where iface_file = doubleQuotes (text file_path)
+
+homeModError mod location
+  = ptext SLIT("attempting to use module ") <> quotes (ppr mod)
+    <> (case ml_hs_file location of
+           Just file -> space <> parens (text file)
+           Nothing   -> empty)
+    <+> ptext SLIT("which is not loaded")
 \end{code}