Revert "Revert "Support for multiple signature files in scope.""
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Tue, 21 Jul 2015 03:16:40 +0000 (20:16 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Tue, 21 Jul 2015 03:54:05 +0000 (20:54 -0700)
This reverts commit bac927b9770ff769128b66d13a3e72bf5a9bc514.

As it turns out, we need these commits for separate compilation
and accurate dependency tracking.  So back in they go!

40 files changed:
compiler/deSugar/DsMonad.hs
compiler/ghci/Linker.hs
compiler/iface/LoadIface.hs
compiler/iface/MkIface.hs
compiler/main/DriverMkDepend.hs
compiler/main/DynamicLoading.hs
compiler/main/Finder.hs
compiler/main/GHC.hs
compiler/main/GhcMake.hs
compiler/main/HscTypes.hs
compiler/main/Packages.hs
docs/users_guide/separate_compilation.xml
ghc/Main.hs
testsuite/.gitignore
testsuite/tests/cabal/sigcabal02/Main.hs [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/Makefile [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/Setup.hs [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/ShouldFail.hs [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/all.T [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/p/LICENSE [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/p/Map.hsig [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/p/P.hs [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/p/Set.hsig [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/p/p.cabal [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/q/LICENSE [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/q/Map.hsig [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/q/Q.hs [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/q/q.cabal [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/sigcabal02.stderr [new file with mode: 0644]
testsuite/tests/cabal/sigcabal02/sigcabal02.stdout [new file with mode: 0644]
testsuite/tests/driver/recomp014/Makefile [new file with mode: 0644]
testsuite/tests/driver/recomp014/all.T [new file with mode: 0644]
testsuite/tests/driver/recomp014/recomp014.stdout [new file with mode: 0644]
testsuite/tests/driver/sigof01/Makefile
testsuite/tests/driver/sigof01/all.T
testsuite/tests/driver/sigof01/sigof01i.script [new file with mode: 0644]
testsuite/tests/driver/sigof01/sigof01i.stdout [new file with mode: 0644]
testsuite/tests/driver/sigof01/sigof01i2.script [new file with mode: 0644]
testsuite/tests/driver/sigof01/sigof01i2.stdout [new file with mode: 0644]
testsuite/tests/package/package09e.stderr

index 61beca2..ad6a6b1 100644 (file)
@@ -184,7 +184,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
                  else do {
                ; result <- liftIO $ findImportedModule hsc_env modname Nothing
                ; case result of
-                   Found _ mod -> loadModule err mod
+                   FoundModule h -> loadModule err (fr_mod h)
                    _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
                } }
 
index 8c2a07c..3e8423c 100644 (file)
@@ -562,23 +562,29 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
 
         -- 3.  For each dependent module, find its linkable
         --     This will either be in the HPT or (in the case of one-shot
-        --     compilation) we may need to use maybe_getFileLinkable
+        --     compilation) we may need to use maybe_getFileLinkable.
+        --     If the module is actually a signature, there won't be a
+        --     linkable (thus catMaybes)
       ; let { osuf = objectSuf dflags }
-      ; lnks_needed <- mapM (get_linkable osuf) mods_needed
+      ; lnks_needed <- fmap Maybes.catMaybes
+                     $ mapM (get_linkable osuf) mods_needed
 
       ; return (lnks_needed, pkgs_needed) }
   where
     dflags = hsc_dflags hsc_env
     this_pkg = thisPackage dflags
 
-        -- The ModIface contains the transitive closure of the module dependencies
-        -- within the current package, *except* for boot modules: if we encounter
-        -- a boot module, we have to find its real interface and discover the
-        -- dependencies of that.  Hence we need to traverse the dependency
-        -- tree recursively.  See bug #936, testcase ghci/prog007.
-    follow_deps :: [Module]             -- modules to follow
-                -> UniqSet ModuleName         -- accum. module dependencies
-                -> UniqSet PackageKey          -- accum. package dependencies
+    -- | Given a list of modules @mods@, recursively discover all external
+    -- package and local module (according to @this_pkg@) dependencies.
+    --
+    -- The 'ModIface' contains the transitive closure of the module dependencies
+    -- within the current package, *except* for boot modules: if we encounter
+    -- a boot module, we have to find its real interface and discover the
+    -- dependencies of that.  Hence we need to traverse the dependency
+    -- tree recursively.  See bug #936, testcase ghci/prog007.
+    follow_deps :: [Module]                     -- modules to follow
+                -> UniqSet ModuleName           -- accum. module dependencies
+                -> UniqSet PackageKey           -- accum. package dependencies
                 -> IO ([ModuleName], [PackageKey]) -- result
     follow_deps []     acc_mods acc_pkgs
         = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
@@ -601,6 +607,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
                     where is_boot (m,True)  = Left m
                           is_boot (m,False) = Right m
 
+            -- Boot module dependencies which must be processed recursively
             boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
             acc_mods'  = addListToUniqSet acc_mods (moduleName mod : mod_deps)
             acc_pkgs'  = addListToUniqSet acc_pkgs $ map fst pkg_deps
@@ -631,30 +638,37 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
 
     get_linkable osuf mod_name      -- A home-package module
         | Just mod_info <- lookupUFM hpt mod_name
-        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
+        = adjust_linkable (hm_iface mod_info)
+            (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
         | otherwise
         = do    -- It's not in the HPT because we are in one shot mode,
                 -- so use the Finder to get a ModLocation...
+                -- ezyang: I don't actually know how to trigger this codepath,
+                -- seeing as this is GHCi logic. Template Haskell, maybe?
              mb_stuff <- findHomeModule hsc_env mod_name
              case mb_stuff of
-                  Found loc mod -> found loc mod
+                  FoundExact loc mod -> found loc mod
                   _ -> no_obj mod_name
         where
             found loc mod = do {
                 -- ...and then find the linkable for it
                mb_lnk <- findObjectLinkableMaybe mod loc ;
+               iface <- initIfaceCheck hsc_env $
+                            loadUserInterface False (text "getLinkDeps2") mod ;
                case mb_lnk of {
                   Nothing  -> no_obj mod ;
-                  Just lnk -> adjust_linkable lnk
+                  Just lnk -> adjust_linkable iface lnk
               }}
 
-            adjust_linkable lnk
+            adjust_linkable iface lnk
+                -- Signatures have no linkables! Don't return one.
+                | Just _ <- mi_sig_of iface = return Nothing
                 | Just new_osuf <- replace_osuf = do
                         new_uls <- mapM (adjust_ul new_osuf)
                                         (linkableUnlinked lnk)
-                        return lnk{ linkableUnlinked=new_uls }
+                        return (Just lnk{ linkableUnlinked=new_uls })
                 | otherwise =
-                        return lnk
+                        return (Just lnk)
 
             adjust_ul new_osuf (DotO file) = do
                 MASSERT(osuf `isSuffixOf` file)
index bdfba7c..5250c4f 100644 (file)
@@ -297,12 +297,17 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
   -- interface; it will call the Finder again, but the ModLocation will be
   -- cached from the first search.
   = do { hsc_env <- getTopEnv
-       -- ToDo: findImportedModule should return a list of interfaces
        ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
        ; case res of
-           Found _ mod -> fmap (fmap (:[]))
-                        . initIfaceTcRn
-                        $ loadInterface doc mod (ImportByUser want_boot)
+           FoundModule (FoundHs { fr_mod = mod })
+            -> fmap (fmap (:[]))
+             . initIfaceTcRn
+             $ loadInterface doc mod (ImportByUser want_boot)
+           FoundSigs mods _backing
+            -> initIfaceTcRn $ do
+               ms <- forM mods $ \(FoundHs { fr_mod = mod }) ->
+                          loadInterface doc mod (ImportByUser want_boot)
+               return (sequence ms)
            err         -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) }
 
 -- | Load interface directly for a fully qualified 'Module'.  (This is a fairly
@@ -742,7 +747,7 @@ findAndReadIface doc_str mod hi_boot_file
                hsc_env <- getTopEnv
                mb_found <- liftIO (findExactModule hsc_env mod)
                case mb_found of
-                   Found loc mod -> do
+                   FoundExact loc mod -> do
 
                        -- Found file, so read it
                        let file_path = addBootSuffix_maybe hi_boot_file
@@ -759,7 +764,8 @@ findAndReadIface doc_str mod hi_boot_file
                        traceIf (ptext (sLit "...not found"))
                        dflags <- getDynFlags
                        return (Failed (cannotFindInterface dflags
-                                           (moduleName mod) err))
+                                           (moduleName mod)
+                                           (convFindExactResult err)))
     where read_file file_path = do
               traceIf (ptext (sLit "readIFace") <+> text file_path)
               read_result <- readIface mod file_path
index 9700313..a493da9 100644 (file)
@@ -1334,9 +1334,20 @@ checkDependencies hsc_env summary iface
      find_res <- liftIO $ findImportedModule hsc_env mod (fmap snd pkg)
      let reason = moduleNameString mod ++ " changed"
      case find_res of
-        Found _ mod
+        FoundModule h -> check_mod reason (fr_mod h)
+        FoundSigs hs _backing -> check_mods reason (map fr_mod hs)
+        _otherwise  -> return (RecompBecause reason)
+
+   check_mods _ [] = return UpToDate
+   check_mods reason (m:ms) = do
+        r <- check_mod reason m
+        case r of
+            UpToDate -> check_mods reason ms
+            _otherwise -> return r
+
+   check_mod reason mod
           | pkg == this_pkg
-           -> if moduleName mod `notElem` map fst prev_dep_mods
+            = if moduleName mod `notElem` map fst prev_dep_mods
                  then do traceHiDiffs $
                            text "imported module " <> quotes (ppr mod) <>
                            text " not among previous dependencies"
@@ -1344,7 +1355,7 @@ checkDependencies hsc_env summary iface
                  else
                          return UpToDate
           | otherwise
-           -> if pkg `notElem` (map fst prev_dep_pkgs)
+            = if pkg `notElem` (map fst prev_dep_pkgs)
                  then do traceHiDiffs $
                            text "imported module " <> quotes (ppr mod) <>
                            text " is from package " <> quotes (ppr pkg) <>
@@ -1353,7 +1364,6 @@ checkDependencies hsc_env summary iface
                  else
                          return UpToDate
            where pkg = modulePackageKey mod
-        _otherwise  -> return (RecompBecause reason)
 
 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
               -> IfG RecompileRequired
index 310007d..c51feeb 100644 (file)
@@ -248,7 +248,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
                 -- we've done it once during downsweep
           r <- findImportedModule hsc_env imp pkg
         ; case r of
-            Found loc _
+            FoundModule (FoundHs { fr_loc = loc })
                 -- Home package: just depend on the .hi or hi-boot file
                 | isJust (ml_hs_file loc) || include_pkg_deps
                 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
@@ -257,6 +257,9 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
                 | otherwise
                 -> return Nothing
 
+            -- TODO: FoundSignature.  For now, we assume home package
+            -- "signature" dependencies look like FoundModule.
+
             fail ->
                 let dflags = hsc_dflags hsc_env
                 in throwOneError $ mkPlainErrMsg dflags srcloc $
index 0d72bec..3b62717 100644 (file)
@@ -203,7 +203,15 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
     -- First find the package the module resides in by searching exposed packages and home modules
     found_module <- findImportedModule hsc_env mod_name Nothing
     case found_module of
-        Found _ mod -> do
+        FoundModule h -> check_mod (fr_mod h)
+        FoundSigs hs _backing  -> check_mods (map fr_mod hs) -- (not tested)
+        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+  where
+    dflags = hsc_dflags hsc_env
+    meth = "lookupRdrNameInModule"
+    doc = ptext (sLit $ "contains a name used in an invocation of " ++ meth)
+
+    check_mod mod = do
             -- Find the exports of the module
             (_, mb_iface) <- initTcInteractive hsc_env $
                              initIfaceTcRn $
@@ -221,10 +229,13 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
                         _     -> panic "lookupRdrNameInModule"
 
                 Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
-        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
-  where
-    dflags = hsc_dflags hsc_env
-    doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")
+
+    check_mods [] = return Nothing
+    check_mods (m:ms) = do
+        r <- check_mod m
+        case r of
+            Nothing -> check_mods ms
+            Just _ -> return r
 
 wrongTyThingError :: Name -> TyThing -> SDoc
 wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
index 00ba038..d8aef57 100644 (file)
@@ -9,6 +9,7 @@
 module Finder (
     flushFinderCaches,
     FindResult(..),
+    convFindExactResult, -- move to HscTypes?
     findImportedModule,
     findExactModule,
     findHomeModule,
@@ -45,8 +46,7 @@ import System.Directory
 import System.FilePath
 import Control.Monad
 import Data.Time
-import Data.List        ( foldl' )
-
+import Data.List        ( foldl', partition )
 
 type FileExt = String   -- Filename extension
 type BaseName = String  -- Basename of file
@@ -75,7 +75,7 @@ flushFinderCaches hsc_env =
         is_ext mod _ | modulePackageKey mod /= this_pkg = True
                      | otherwise = False
 
-addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO ()
+addToFinderCache :: IORef FinderCache -> Module -> FindExactResult -> IO ()
 addToFinderCache ref key val =
   atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ())
 
@@ -83,7 +83,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
 removeFromFinderCache ref key =
   atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
 
-lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult)
+lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindExactResult)
 lookupFinderCache ref key = do
    c <- readIORef ref
    return $! lookupModuleEnv c key
@@ -104,7 +104,7 @@ findImportedModule hsc_env mod_name mb_pkg =
         Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
                  | otherwise           -> pkg_import
   where
-    home_import   = findHomeModule hsc_env mod_name
+    home_import   = convFindExactResult `fmap` findHomeModule hsc_env mod_name
 
     pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg
 
@@ -118,7 +118,7 @@ findImportedModule hsc_env mod_name mb_pkg =
 -- reading the interface for a module mentioned by another interface,
 -- for example (a "system import").
 
-findExactModule :: HscEnv -> Module -> IO FindResult
+findExactModule :: HscEnv -> Module -> IO FindExactResult
 findExactModule hsc_env mod =
     let dflags = hsc_dflags hsc_env
     in if modulePackageKey mod == thisPackage dflags
@@ -152,17 +152,45 @@ orIfNotFound this or_this = do
 -- been done.  Otherwise, do the lookup (with the IO action) and save
 -- the result in the finder cache and the module location cache (if it
 -- was successful.)
-homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
+homeSearchCache :: HscEnv
+                -> ModuleName
+                -> IO FindExactResult
+                -> IO FindExactResult
 homeSearchCache hsc_env mod_name do_this = do
   let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
   modLocationCache hsc_env mod do_this
 
+-- | Converts a 'FindExactResult' into a 'FindResult' in the obvious way.
+convFindExactResult :: FindExactResult -> FindResult
+convFindExactResult (FoundExact loc m) = FoundModule (FoundHs loc m)
+convFindExactResult (NoPackageExact pk) = NoPackage pk
+convFindExactResult NotFoundExact { fer_paths = paths, fer_pkg = pkg } =
+    NotFound {
+        fr_paths = paths, fr_pkg = pkg,
+        fr_pkgs_hidden = [], fr_mods_hidden = [], fr_suggestions = []
+    }
+
+foundExact :: FindExactResult -> Bool
+foundExact FoundExact{} = True
+foundExact _ = False
+
 findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
                          -> IO FindResult
 findExposedPackageModule hsc_env mod_name mb_pkg
   = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of
-     LookupFound m pkg_conf ->
-       findPackageModule_ hsc_env m pkg_conf
+     LookupFound (m, _) -> do
+       fmap convFindExactResult (findPackageModule hsc_env m)
+     LookupFoundSigs ms backing -> do
+       locs <- mapM (findPackageModule hsc_env . fst) ms
+       let (ok, missing) = partition foundExact locs
+       case missing of
+        -- At the moment, we return the errors one at a time.  It might be
+        -- better if we collected them up and reported them all, but
+        -- FindResult doesn't have enough information to support this.
+        -- In any case, this REALLY shouldn't happen (it means there are
+        -- broken packages in the database.)
+        (m:_) -> return (convFindExactResult m)
+        _ -> return (FoundSigs [FoundHs l m | FoundExact l m <- ok] backing)
      LookupMultiple rs ->
        return (FoundMultiple rs)
      LookupHidden pkg_hiddens mod_hiddens ->
@@ -176,7 +204,7 @@ findExposedPackageModule hsc_env mod_name mb_pkg
                        , fr_mods_hidden = []
                        , fr_suggestions = suggest })
 
-modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
+modLocationCache :: HscEnv -> Module -> IO FindExactResult -> IO FindExactResult
 modLocationCache hsc_env mod do_this = do
   m <- lookupFinderCache (hsc_FC hsc_env) mod
   case m of
@@ -189,7 +217,7 @@ modLocationCache hsc_env mod do_this = do
 addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
 addHomeModuleToFinder hsc_env mod_name loc = do
   let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
-  addToFinderCache (hsc_FC hsc_env) mod (Found loc mod)
+  addToFinderCache (hsc_FC hsc_env) mod (FoundExact loc mod)
   return mod
 
 uncacheModule :: HscEnv -> ModuleName -> IO ()
@@ -216,7 +244,7 @@ uncacheModule hsc_env mod = do
 --
 --  4. Some special-case code in GHCi (ToDo: Figure out why that needs to
 --  call this.)
-findHomeModule :: HscEnv -> ModuleName -> IO FindResult
+findHomeModule :: HscEnv -> ModuleName -> IO FindExactResult
 findHomeModule hsc_env mod_name =
    homeSearchCache hsc_env mod_name $
    let
@@ -247,19 +275,19 @@ findHomeModule hsc_env mod_name =
   -- This is important only when compiling the base package (where GHC.Prim
   -- is a home module).
   if mod == gHC_PRIM
-        then return (Found (error "GHC.Prim ModLocation") mod)
+        then return (FoundExact (error "GHC.Prim ModLocation") mod)
         else searchPathExts home_path mod exts
 
 
 -- | Search for a module in external packages only.
-findPackageModule :: HscEnv -> Module -> IO FindResult
+findPackageModule :: HscEnv -> Module -> IO FindExactResult
 findPackageModule hsc_env mod = do
   let
         dflags = hsc_dflags hsc_env
         pkg_id = modulePackageKey mod
   --
   case lookupPackage dflags pkg_id of
-     Nothing -> return (NoPackage pkg_id)
+     Nothing -> return (NoPackageExact pkg_id)
      Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
 
 -- | Look up the interface file associated with module @mod@.  This function
@@ -269,14 +297,14 @@ findPackageModule hsc_env mod = do
 -- the 'PackageConfig' must be consistent with the package key in the 'Module'.
 -- The redundancy is to avoid an extra lookup in the package state
 -- for the appropriate config.
-findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult
+findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindExactResult
 findPackageModule_ hsc_env mod pkg_conf =
   ASSERT( modulePackageKey mod == packageConfigId pkg_conf )
   modLocationCache hsc_env mod $
 
   -- special case for GHC.Prim; we won't find it in the filesystem.
   if mod == gHC_PRIM
-        then return (Found (error "GHC.Prim ModLocation") mod)
+        then return (FoundExact (error "GHC.Prim ModLocation") mod)
         else
 
   let
@@ -299,7 +327,7 @@ findPackageModule_ hsc_env mod pkg_conf =
           -- don't bother looking for it.
           let basename = moduleNameSlashes (moduleName mod)
           loc <- mk_hi_loc one basename
-          return (Found loc mod)
+          return (FoundExact loc mod)
     _otherwise ->
           searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
 
@@ -314,7 +342,7 @@ searchPathExts
         FilePath -> BaseName -> IO ModLocation  -- action
        )
      ]
-  -> IO FindResult
+  -> IO FindExactResult
 
 searchPathExts paths mod exts
    = do result <- search to_search
@@ -340,15 +368,13 @@ searchPathExts paths mod exts
                       file = base <.> ext
                 ]
 
-    search [] = return (NotFound { fr_paths = map fst to_search
-                                 , fr_pkg   = Just (modulePackageKey mod)
-                                 , fr_mods_hidden = [], fr_pkgs_hidden = []
-                                 , fr_suggestions = [] })
+    search [] = return (NotFoundExact {fer_paths = map fst to_search
+                                      ,fer_pkg   = Just (modulePackageKey mod)})
 
     search ((file, mk_result) : rest) = do
       b <- doesFileExist file
       if b
-        then do { loc <- mk_result; return (Found loc mod) }
+        then do { loc <- mk_result; return (FoundExact loc mod) }
         else search rest
 
 mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
@@ -571,7 +597,8 @@ cantFindErr cannot_find _ dflags mod_name find_result
                    vcat (map mod_hidden mod_hiddens) $$
                    tried_these files
 
-            _ -> panic "cantFindErr"
+            _ -> pprPanic "cantFindErr"
+                   (ptext cannot_find <+> quotes (ppr mod_name))
 
     build_tag = buildTag dflags
 
index 1a7d4ef..d9380e1 100644 (file)
@@ -1378,6 +1378,20 @@ showRichTokenStream ts = go startLoc ts ""
 -- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the
 -- filesystem and package database to find the corresponding 'Module', 
 -- using the algorithm that is used for an @import@ declaration.
+--
+-- However, there is a twist for local modules, see #2682.
+--
+-- The full algorithm:
+-- IF it's a package qualified import for a REMOTE package (not @this_pkg@ or
+-- this), do a normal lookup.
+-- OTHERWISE see if it is ALREADY loaded, and use it if it is.
+-- OTHERWISE do a normal lookup, but reject the result if the found result
+-- is from the LOCAL package (@this_pkg@).
+--
+-- For signatures, we return the BACKING implementation to keep the API
+-- consistent with what we had before. (ToDo: create a new GHC API which
+-- can deal with signatures.)
+--
 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
   let 
@@ -1388,17 +1402,23 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
     Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
       res <- findImportedModule hsc_env mod_name maybe_pkg
       case res of
-        Found _ m -> return m
+        FoundModule h -> return (fr_mod h)
+        FoundSigs _ backing -> return backing
         err       -> throwOneError $ noModError dflags noSrcSpan mod_name err
     _otherwise -> do
       home <- lookupLoadedHomeModule mod_name
       case home of
+        -- TODO: This COULD be a signature
         Just m  -> return m
         Nothing -> liftIO $ do
            res <- findImportedModule hsc_env mod_name maybe_pkg
            case res of
-             Found loc m | modulePackageKey m /= this_pkg -> return m
-                         | otherwise -> modNotLoadedError dflags m loc
+             FoundModule (FoundHs { fr_mod = m, fr_loc = loc })
+                | modulePackageKey m /= this_pkg -> return m
+                | otherwise -> modNotLoadedError dflags m loc
+             FoundSigs (FoundHs { fr_loc = loc, fr_mod = m }:_) backing
+                | modulePackageKey m /= this_pkg -> return backing
+                | otherwise -> modNotLoadedError dflags m loc
              err -> throwOneError $ noModError dflags noSrcSpan mod_name err
 
 modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
@@ -1419,11 +1439,13 @@ lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
 lookupModule mod_name Nothing = withSession $ \hsc_env -> do
   home <- lookupLoadedHomeModule mod_name
   case home of
+    -- TODO: This COULD be a signature
     Just m  -> return m
     Nothing -> liftIO $ do
       res <- findExposedPackageModule hsc_env mod_name Nothing
       case res of
-        Found _ m -> return m
+        FoundModule (FoundHs { fr_mod = m }) -> return m
+        FoundSigs _ backing -> return backing
         err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
 
 lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
index 2d1d9eb..89cab9e 100644 (file)
@@ -1815,7 +1815,10 @@ findSummaryBySourceFile summaries file
         [] -> Nothing
         (x:_) -> Just x
 
--- Summarise a module, and pick up source and timestamp.
+-- | Summarise a module, and pick up source and timestamp.
+-- Returns @Nothing@ if the module is excluded via @excl_mods@ or is an
+-- external package module (which we don't compile), otherwise returns the
+-- new module summary (or an error saying why we couldn't summarise it).
 summariseModule
           :: HscEnv
           -> NodeMap ModSummary -- Map of old summaries
@@ -1877,7 +1880,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
         uncacheModule hsc_env wanted_mod
         found <- findImportedModule hsc_env wanted_mod Nothing
         case found of
-             Found location mod
+             -- TODO: When we add -alias support, we can validly find
+             -- multiple signatures in the home package; need to make this
+             -- logic more flexible in that case.
+             FoundModule (FoundHs { fr_loc = location, fr_mod = mod })
                 | isJust (ml_hs_file location) ->
                         -- Home package
                          just_found location mod
@@ -1886,6 +1892,15 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                         ASSERT(modulePackageKey mod /= thisPackage dflags)
                         return Nothing
 
+             FoundSigs hs _backing
+                | Just (FoundHs { fr_loc = location, fr_mod = mod })
+                  <- find (isJust . ml_hs_file . fr_loc) hs ->
+                        just_found location mod
+                | otherwise ->
+                        ASSERT(all (\h -> modulePackageKey (fr_mod h)
+                                            /= thisPackage dflags) hs)
+                        return Nothing
+
              err -> return $ Just $ Left $ noModError dflags loc wanted_mod err
                         -- Not found
 
index b7707f8..0dd6341 100644 (file)
@@ -10,7 +10,7 @@
 module HscTypes (
         -- * compilation state
         HscEnv(..), hscEPS,
-        FinderCache, FindResult(..),
+        FinderCache, FindResult(..), FoundHs(..), FindExactResult(..),
         Target(..), TargetId(..), pprTarget, pprTargetId,
         ModuleGraph, emptyMG,
         HscStatus(..),
@@ -674,15 +674,30 @@ prepareAnnotations hsc_env mb_guts = do
 -- modules along the search path. On @:load@, we flush the entire
 -- contents of this cache.
 --
--- Although the @FinderCache@ range is 'FindResult' for convenience,
--- in fact it will only ever contain 'Found' or 'NotFound' entries.
---
-type FinderCache = ModuleEnv FindResult
+type FinderCache = ModuleEnv FindExactResult
+
+-- | The result of search for an exact 'Module'.
+data FindExactResult
+    = FoundExact ModLocation Module
+        -- ^ The module/signature was found
+    | NoPackageExact PackageKey
+    | NotFoundExact
+        { fer_paths     :: [FilePath]
+        , fer_pkg       :: Maybe PackageKey
+        }
+
+-- | A found module or signature; e.g. anything with an interface file
+data FoundHs = FoundHs { fr_loc :: ModLocation
+                       , fr_mod :: Module
+                       -- , fr_origin :: ModuleOrigin
+                       }
 
 -- | The result of searching for an imported module.
 data FindResult
-  = Found ModLocation Module
+  = FoundModule FoundHs
         -- ^ The module was found
+  | FoundSigs [FoundHs] Module
+        -- ^ Signatures were found, with some backing implementation
   | NoPackage PackageKey
         -- ^ The requested package was not found
   | FoundMultiple [(Module, ModuleOrigin)]
@@ -2069,6 +2084,15 @@ type IsBootInterface = Bool
 -- Invariant: the dependencies of a module @M@ never includes @M@.
 --
 -- Invariant: none of the lists contain duplicates.
+--
+-- NB: While this contains information about all modules and packages below
+-- this one in the the import *hierarchy*, this may not accurately reflect
+-- the full runtime dependencies of the module.  This is because this module may
+-- have imported a boot module, in which case we'll only have recorded the
+-- dependencies from the hs-boot file, not the actual hs file. (This is
+-- unavoidable: usually, the actual hs file will have been compiled *after*
+-- we wrote this interface file.)  See #936, and also @getLinkDeps@ in
+-- @compiler/ghci/Linker.hs@ for code which cares about this distinction.
 data Dependencies
   = Deps { dep_mods   :: [(ModuleName, IsBootInterface)]
                         -- ^ All home-package modules transitively below this one
index 0be5e3f..16ee352 100644 (file)
@@ -132,9 +132,10 @@ import qualified Data.Set as Set
 -- in a different DLL, by setting the DLL flag.
 
 -- | Given a module name, there may be multiple ways it came into scope,
--- possibly simultaneously.  This data type tracks all the possible ways
--- it could have come into scope.  Warning: don't use the record functions,
--- they're partial!
+-- possibly simultaneously.  For a given particular implementation (e.g.
+-- original module, or even a signature module), this data type tracks all the
+-- possible ways it could have come into scope.  Warning: don't use the record
+-- functions, they're partial!
 data ModuleOrigin =
     -- | Module is hidden, and thus never will be available for import.
     -- (But maybe the user didn't realize), so we'll still keep track
@@ -158,7 +159,7 @@ data ModuleOrigin =
       }
 
 instance Outputable ModuleOrigin where
-    ppr ModHidden = text "hidden module"
+    ppr ModHidden = text "hidden module" -- NB: cannot be signature
     ppr (ModOrigin e res rhs f) = sep (punctuate comma (
         (case e of
             Nothing -> []
@@ -175,17 +176,18 @@ instance Outputable ModuleOrigin where
         (if f then [text "package flag"] else [])
         ))
 
--- | Smart constructor for a module which is in @exposed-modules@.  Takes
--- as an argument whether or not the defining package is exposed.
-fromExposedModules :: Bool -> ModuleOrigin
-fromExposedModules e = ModOrigin (Just e) [] [] False
+-- | Smart constructor for a module which is in @exposed-modules@ or
+-- @exposed-signatures@.  Takes as an argument whether or not the defining
+-- package is exposed.
+fromExposed :: Bool -> ModuleOrigin
+fromExposed e = ModOrigin (Just e) [] [] False
 
--- | Smart constructor for a module which is in @reexported-modules@.  Takes
--- as an argument whether or not the reexporting package is expsed, and
--- also its 'PackageConfig'.
-fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
-fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
-fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
+-- | Smart constructor for a module which is in @reexported-modules@
+-- or @reexported-signatures@.  Takes as an argument whether or not the
+-- reexporting package is expsed, and also its 'PackageConfig'.
+fromReexported :: Bool -> PackageConfig -> ModuleOrigin
+fromReexported True pkg = ModOrigin Nothing [pkg] [] False
+fromReexported False pkg = ModOrigin Nothing [] [pkg] False
 
 -- | Smart constructor for a module which was bound by a package flag.
 fromFlag :: ModuleOrigin
@@ -227,11 +229,40 @@ type PackageConfigMap = PackageKeyMap PackageConfig
 type VisibilityMap =
     PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)
 
--- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
--- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
--- (since this is the slow path, we'll just look it up again).
-type ModuleToPkgConfAll =
-    Map ModuleName (Map Module ModuleOrigin)
+-- | Alias for 'Module' indicating we expect the interface in question to
+-- be for a signature.
+type Signature = Module
+
+-- | Alias for 'ModuleOrigin' indicating we expect it to describe a signature.
+type SignatureOrigin = ModuleOrigin
+
+-- | This is the main lookup structure we use to handle imports, which map
+-- from 'ModuleName' to 'ModuleDb', which describes all possible implementations
+-- which are available under a module name.
+type ModuleNameDb = Map ModuleName ModuleDb
+
+-- | This is an auxiliary structure per module name, and it's a map of
+-- backing implementations to more information about them.  This is a map
+-- so it's easy to tell if we're bringing in an implementation for a name
+-- which is already in scope (and thus non-conflicting.)
+type ModuleDb = Map Module ModuleDesc
+
+-- | Per backing implementation, there may be multiple signatures available
+-- exporting subsets of its interface; we need to track all of them.
+type SignatureDb = Map Signature SignatureOrigin
+
+-- | Combined module description for a module: includes 'ModuleOrigin'
+-- describing the backing implementation, as well as 'SignatureDb' for any
+-- signatures of the module in question.
+data ModuleDesc = MD ModuleOrigin SignatureDb
+
+instance Outputable ModuleDesc where
+    ppr (MD o m) = ppr o <+> parens (ppr m)
+
+instance Monoid ModuleDesc where
+    mempty = MD mempty Map.empty
+    mappend (MD o m) (MD o' m') = MD (o `mappend` o')
+                                     (Map.unionWith mappend m m')
 
 data PackageState = PackageState {
   -- | A mapping of 'PackageKey' to 'PackageConfig'.  This list is adjusted
@@ -249,7 +280,7 @@ data PackageState = PackageState {
   -- | This is a full map from 'ModuleName' to all modules which may possibly
   -- be providing it.  These providers may be hidden (but we'll still want
   -- to report them in error messages), or it may be an ambiguous import.
-  moduleToPkgConfAll    :: ModuleToPkgConfAll,
+  moduleNameDb         :: ModuleNameDb,
 
   -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
   -- internally deals in package keys but the database may refer to installed
@@ -261,7 +292,7 @@ emptyPackageState :: PackageState
 emptyPackageState = PackageState {
     pkgIdMap = emptyUFM,
     preloadPackages = [],
-    moduleToPkgConfAll = Map.empty,
+    moduleNameDb = Map.empty,
     installedPackageIdMap = Map.empty
     }
 
@@ -1025,7 +1056,7 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do
   let pstate = PackageState{
     preloadPackages     = dep_preload,
     pkgIdMap            = pkg_db,
-    moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
+    moduleNameDb  = mkModuleNameDb dflags pkg_db ipid_map vis_map,
     installedPackageIdMap = ipid_map
     }
   return (pstate, new_dep_preload, this_package)
@@ -1034,62 +1065,70 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do
 -- -----------------------------------------------------------------------------
 -- | Makes the mapping from module to package info
 
-mkModuleToPkgConfAll
+mkModuleNameDb
   :: DynFlags
   -> PackageConfigMap
   -> InstalledPackageIdMap
   -> VisibilityMap
-  -> ModuleToPkgConfAll
-mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
+  -> ModuleNameDb
+mkModuleNameDb dflags pkg_db ipid_map vis_map =
     foldl' extend_modmap emptyMap (eltsUFM pkg_db)
  where
   emptyMap = Map.empty
-  sing pk m = Map.singleton (mkModule pk m)
+  sing pk m = Map.singleton (mkModule pk m)
   addListTo = foldl' merge
   merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
-  setOrigins m os = fmap (const os) m
   extend_modmap modmap pkg = addListTo modmap theBindings
    where
-    theBindings :: [(ModuleName, Map Module ModuleOrigin)]
+    theBindings :: [(ModuleName, ModuleDb)]
     theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
                               = newBindings b rns
                 | otherwise   = newBindings False []
 
     newBindings :: Bool
                 -> [(ModuleName, ModuleName)]
-                -> [(ModuleName, Map Module ModuleOrigin)]
+                -> [(ModuleName, ModuleDb)]
     newBindings e rns  = es e ++ hiddens ++ map rnBinding rns
 
     rnBinding :: (ModuleName, ModuleName)
-              -> (ModuleName, Map Module ModuleOrigin)
-    rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
+              -> (ModuleName, ModuleDb)
+    rnBinding (orig, new) = (new, fmap applyFlag origEntry)
      where origEntry = case lookupUFM esmap orig of
             Just r -> r
             Nothing -> throwGhcException (CmdLineError (showSDoc dflags
                         (text "package flag: could not find module name" <+>
                             ppr orig <+> text "in package" <+> ppr pk)))
 
-    es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
+    applyFlag (MD _ sigs) = MD fromFlag (fmap (const fromFlag) sigs)
+
+    es :: Bool -> [(ModuleName, ModuleDb)]
     es e = do
-     -- TODO: signature support
-     ExposedModule m exposedReexport _exposedSignature <- exposed_mods
-     let (pk', m', pkg', origin') =
+     ExposedModule m exposedReexport exposedSignature <- exposed_mods
+     let (pk', m', origin') =
           case exposedReexport of
-           Nothing -> (pk, m, pkg, fromExposedModules e)
+           Nothing -> (pk, m, fromExposed e)
            Just (OriginalModule ipid' m') ->
-            let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
-                pkg' = pkg_lookup pk'
-            in (pk', m', pkg', fromReexportedModules e pkg')
-     return (m, sing pk' m' pkg' origin')
+            let (pk', pkg') = ipid_lookup ipid'
+            in (pk', m', fromReexported e pkg')
+     return $ case exposedSignature of
+        Nothing -> (m, sing pk' m' (MD origin' Map.empty))
+        Just (OriginalModule ipid'' m'') ->
+            let (pk'', _) = ipid_lookup ipid''
+            in (m, sing pk'' m'' (MD mempty (sing pk' m' origin')))
 
-    esmap :: UniqFM (Map Module ModuleOrigin)
+
+    esmap :: UniqFM ModuleDb
     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
                                  -- be overwritten
 
-    hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
+    hiddens :: [(ModuleName, ModuleDb)]
+    hiddens = [(m, sing pk m (MD ModHidden Map.empty)) | m <- hidden_mods]
 
     pk = packageConfigId pkg
-    pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
+    pkg_lookup = expectJust "mkModuleNameDb" . lookupPackage' pkg_db
+    ipid_lookup ipid =
+        let pk = expectJust "mkModuleNameDb" (Map.lookup ipid ipid_map)
+        in (pk, pkg_lookup pk)
 
     exposed_mods = exposedModules pkg
     hidden_mods = hiddenModules pkg
@@ -1199,16 +1238,20 @@ lookupModuleInAllPackages :: DynFlags
                           -> [(Module, PackageConfig)]
 lookupModuleInAllPackages dflags m
   = case lookupModuleWithSuggestions dflags m Nothing of
-      LookupFound a b -> [(a,b)]
-      LookupMultiple rs -> map f rs
-        where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
-                                                         (modulePackageKey m)))
+      LookupFound (m,_) -> [(m,get_pkg m)]
+      LookupMultiple rs -> map (\(m,_) -> (m,get_pkg m)) rs
       _ -> []
+      where get_pkg = expectJust "lookupModule" . lookupPackage dflags
+                                                . modulePackageKey
 
 -- | The result of performing a lookup
 data LookupResult =
     -- | Found the module uniquely, nothing else to do
-    LookupFound Module PackageConfig
+    LookupFound (Module, ModuleOrigin)
+    -- | We found (possibly multiple) signatures with a unique backing
+    -- implementation: they should be "merged" together.  For good measure,
+    -- the backing implementation is recorded too.
+  | LookupFoundSigs [(Module, ModuleOrigin)] Module
     -- | Multiple modules with the same name in scope
   | LookupMultiple [(Module, ModuleOrigin)]
     -- | No modules found, but there were some hidden ones with
@@ -1218,6 +1261,39 @@ data LookupResult =
     -- | Nothing found, here are some suggested different names
   | LookupNotFound [ModuleSuggestion] -- suggestions
 
+instance Monoid LookupResult where
+    mempty = LookupNotFound []
+
+    LookupNotFound s1   `mappend` LookupNotFound s2
+        = LookupNotFound (s1 ++ s2)
+    LookupNotFound{}    `mappend` l                 = l
+    l                   `mappend` LookupNotFound{}  = l
+
+    LookupHidden x1 y1  `mappend` LookupHidden x2 y2
+        = LookupHidden (x1 ++ x2) (y1 ++ y2)
+    LookupHidden{}      `mappend` l                 = l
+    l                   `mappend` LookupHidden{}    = l
+
+    LookupFound m1      `mappend` LookupFound m2
+        = ASSERT(fst m1 /= fst m2)             LookupMultiple [m1, m2]
+    LookupFound m       `mappend` LookupMultiple ms
+        = ASSERT(not (any ((==fst m).fst) ms)) LookupMultiple (m:ms)
+    LookupFound m       `mappend` LookupFoundSigs ms check
+        | fst m == check    = LookupFound m
+        | otherwise         = LookupMultiple (m:ms)
+    l1 `mappend` l2@LookupFound{}
+        = l2 `mappend` l1
+
+    LookupMultiple ms1  `mappend` LookupFoundSigs ms2 _
+        = LookupMultiple (ms1 ++ ms2)
+    LookupMultiple ms1  `mappend` LookupMultiple ms2
+        = LookupMultiple (ms1 ++ ms2)
+    l1  `mappend` l2@LookupMultiple{}
+        = l2 `mappend` l1
+
+    LookupFoundSigs ms1 m1 `mappend` LookupFoundSigs ms2 m2
+        = ASSERT(m1 /= m2)                     LookupMultiple (ms1 ++ ms2)
+
 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
                       | SuggestHidden ModuleName Module ModuleOrigin
 
@@ -1226,23 +1302,28 @@ lookupModuleWithSuggestions :: DynFlags
                             -> Maybe FastString
                             -> LookupResult
 lookupModuleWithSuggestions dflags m mb_pn
-  = case Map.lookup m (moduleToPkgConfAll pkg_state) of
+  = case Map.lookup m (moduleNameDb pkg_state) of
         Nothing -> LookupNotFound suggestions
-        Just xs ->
-          case foldl' classify ([],[],[]) (Map.toList xs) of
-            ([], [], []) -> LookupNotFound suggestions
-            (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)
-            (_, _, exposed@(_:_))        -> LookupMultiple exposed
-            (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
+        Just xs -> mconcat (LookupNotFound suggestions
+                           :map classify (Map.toList xs))
   where
-    classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
+    classify (m, MD origin0 sigs0) =
       let origin = filterOrigin mb_pn (mod_pkg m) origin0
-          x = (m, origin)
+          r = (m, origin)
       in case origin of
-          ModHidden                  -> (hidden_pkg,   x:hidden_mod, exposed)
-          _ | originEmpty origin     -> (hidden_pkg,   hidden_mod,   exposed)
-            | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)
-            | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)
+          ModHidden                -> LookupHidden [] [r]
+          _ | originVisible origin -> LookupFound r
+            | otherwise ->
+                let sigs = do (back_m, back_origin0) <- Map.toList sigs0
+                              let back_origin = filterOrigin mb_pn
+                                                             (mod_pkg back_m)
+                                                             back_origin0
+                              guard (originVisible back_origin)
+                              return (back_m, back_origin)
+                in case sigs of
+                    [] | originEmpty origin -> LookupNotFound []
+                       | otherwise          -> LookupHidden [r] []
+                    _ -> LookupFoundSigs sigs m
 
     pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
     pkg_state = pkgState dflags
@@ -1277,17 +1358,18 @@ lookupModuleWithSuggestions dflags m mb_pn
     all_mods :: [(String, ModuleSuggestion)]     -- All modules
     all_mods = sortBy (comparing fst) $
         [ (moduleNameString m, suggestion)
-        | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
+        | (m, e) <- Map.toList (moduleNameDb (pkgState dflags))
         , suggestion <- map (getSuggestion m) (Map.toList e)
         ]
-    getSuggestion name (mod, origin) =
+    -- For now, don't suggest implemented signatures
+    getSuggestion name (mod, MD origin _) =
         (if originVisible origin then SuggestVisible else SuggestHidden)
             name mod origin
 
 listVisibleModuleNames :: DynFlags -> [ModuleName]
 listVisibleModuleNames dflags =
-    map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
-  where visible (_, ms) = any originVisible (Map.elems ms)
+    map fst (filter visible (Map.toList (moduleNameDb (pkgState dflags))))
+  where visible (_, ms) = any (\(MD o _) -> originVisible o) (Map.elems ms)
 
 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
 -- 'PackageConfig's
@@ -1426,7 +1508,7 @@ pprPackagesSimple = pprPackagesWith pprIPI
 -- | Show the mapping of modules to where they come from.
 pprModuleMap :: DynFlags -> SDoc
 pprModuleMap dflags =
-  vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
+  vcat (map pprLine (Map.toList (moduleNameDb (pkgState dflags))))
     where
       pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
       pprEntry m (m',o)
index bbf9e64..7209f5e 100644 (file)
@@ -970,6 +970,11 @@ ghc -c A.hs
       written in a subset of Haskell essentially identical to that of
       <literal>hs-boot</literal> files.</para>
 
+      <para>Signatures can be installed like ordinary module files,
+      and when multiple signatures are brought into scope under the same
+      module name, they are merged together if their backing implementations
+      are the same.</para>
+
       <para>There is one important gotcha with the current implementation:
       currently, instances from backing implementations will "leak" code that
       uses signatures, and explicit instance declarations in signatures are
index fa266a2..201ee5d 100644 (file)
@@ -834,11 +834,12 @@ abiHash strs = do
          let modname = mkModuleName str
          r <- findImportedModule hsc_env modname Nothing
          case r of
-           Found _ m -> return m
+           FoundModule h -> return [fr_mod h]
+           FoundSigs hs _ -> return (map fr_mod hs)
            _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
                           cannotFindInterface dflags modname r
 
-  mods <- mapM find_it strs
+  mods <- fmap concat (mapM find_it strs)
 
   let get_iface modl = loadUserInterface False (text "abiHash") modl
   ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
index d4ef22b..6ebb05a 100644 (file)
@@ -118,6 +118,12 @@ mk/ghcconfig*_bin_ghc-*.exe.mk
 /tests/cabal/sigcabal01/p_lazy
 /tests/cabal/sigcabal01/p_strict
 /tests/cabal/sigcabal01/containers
+/tests/cabal/sigcabal02/Main
+/tests/cabal/sigcabal02/p_ipid
+/tests/cabal/sigcabal02/q_ipid
+/tests/cabal/sigcabal02/containers
+/tests/cabal/sigcabal02/tmp*
+/tests/cabal/sigcabal02/inst*
 /tests/cabal/local01.package.conf/
 /tests/cabal/local03.package.conf/
 /tests/cabal/local04.package.conf/
diff --git a/testsuite/tests/cabal/sigcabal02/Main.hs b/testsuite/tests/cabal/sigcabal02/Main.hs
new file mode 100644 (file)
index 0000000..52def3d
--- /dev/null
@@ -0,0 +1,7 @@
+import Map
+import P
+import Q
+
+main = do
+    x <- foo
+    print (mymember 5 x)
diff --git a/testsuite/tests/cabal/sigcabal02/Makefile b/testsuite/tests/cabal/sigcabal02/Makefile
new file mode 100644 (file)
index 0000000..152aaea
--- /dev/null
@@ -0,0 +1,34 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP=../Setup -v0
+
+# This test is for two Cabal packages exposing the same signature
+
+sigcabal02:
+       $(MAKE) clean
+       '$(GHC_PKG)' field containers id | sed 's/^.*: *//' > containers
+       '$(GHC_PKG)' init tmp.d
+       '$(TEST_HC)' -v0 --make Setup
+       cd p && $(SETUP) clean
+       cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-p' --instantiate-with="Map=Data.Map.Lazy@`cat ../containers`" --instantiate-with="Set=Data.Set@`cat ../containers`" --ghc-pkg-options="--enable-multi-instance"
+       cd p && $(SETUP) build
+       cd p && $(SETUP) copy
+       cd p && $(SETUP) register --print-ipid > ../p_ipid
+       cd q && $(SETUP) clean
+       cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-p' --instantiate-with="Map=Data.Map.Lazy@`cat ../containers`" --ghc-pkg-options="--enable-multi-instance"
+       cd q && $(SETUP) build
+       cd q && $(SETUP) copy
+       cd q && $(SETUP) register --print-ipid > ../q_ipid
+       '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package-id "`cat p_ipid`" -package-id "`cat q_ipid`" --make Main.hs
+       ./Main
+       ! '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package-id "`cat p_ipid`" -package-id "`cat q_ipid`" --make ShouldFail.hs
+ifneq "$(CLEANUP)" ""
+       $(MAKE) clean
+endif
+
+clean :
+       '$(GHC_PKG)' unregister --force p >/dev/null 2>&1 || true
+       '$(GHC_PKG)' unregister --force q >/dev/null 2>&1 || true
+       $(RM) -r tmp.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
diff --git a/testsuite/tests/cabal/sigcabal02/Setup.hs b/testsuite/tests/cabal/sigcabal02/Setup.hs
new file mode 100644 (file)
index 0000000..9a994af
--- /dev/null
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/testsuite/tests/cabal/sigcabal02/ShouldFail.hs b/testsuite/tests/cabal/sigcabal02/ShouldFail.hs
new file mode 100644 (file)
index 0000000..98ec49e
--- /dev/null
@@ -0,0 +1 @@
+import Set
diff --git a/testsuite/tests/cabal/sigcabal02/all.T b/testsuite/tests/cabal/sigcabal02/all.T
new file mode 100644 (file)
index 0000000..11eb059
--- /dev/null
@@ -0,0 +1,9 @@
+if default_testopts.cleanup != '':
+   cleanup = 'CLEANUP=1'
+else:
+   cleanup = ''
+
+test('sigcabal02',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory sigcabal02 ' + cleanup])
diff --git a/testsuite/tests/cabal/sigcabal02/p/LICENSE b/testsuite/tests/cabal/sigcabal02/p/LICENSE
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/testsuite/tests/cabal/sigcabal02/p/Map.hsig b/testsuite/tests/cabal/sigcabal02/p/Map.hsig
new file mode 100644 (file)
index 0000000..359cf64
--- /dev/null
@@ -0,0 +1,18 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Map where
+
+import Set
+
+type role Map nominal representational
+data Map k a
+
+instance (Show k, Show a) => Show (Map k a)
+
+size :: Map k a -> Int
+lookup :: Ord k => k -> Map k a -> Maybe a
+empty :: Map k a
+insert :: Ord k => k -> a -> Map k a -> Map k a
+delete :: Ord k => k -> Map k a -> Map k a
+
+keysSet :: Map k a -> Set k
+fromSet :: (k -> a) -> Set k -> Map k a
diff --git a/testsuite/tests/cabal/sigcabal02/p/P.hs b/testsuite/tests/cabal/sigcabal02/p/P.hs
new file mode 100644 (file)
index 0000000..dec6b41
--- /dev/null
@@ -0,0 +1,12 @@
+module P where
+
+import qualified Map
+import qualified Set
+
+foo = do
+    let x = Map.insert 0 "foo"
+          . Map.insert (6 :: Int) "foo"
+          $ Map.empty
+    print (Map.lookup 1 x)
+    print (Set.size (Map.keysSet x))
+    return x
diff --git a/testsuite/tests/cabal/sigcabal02/p/Set.hsig b/testsuite/tests/cabal/sigcabal02/p/Set.hsig
new file mode 100644 (file)
index 0000000..1713133
--- /dev/null
@@ -0,0 +1,13 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Set where
+
+type role Set nominal
+data Set a
+
+instance Show a => Show (Set a)
+
+size :: Set a -> Int
+member :: Ord a => a -> Set a -> Bool
+empty :: Set a
+insert :: Ord a => a -> Set a -> Set a
+delete :: Ord a => a -> Set a -> Set a
diff --git a/testsuite/tests/cabal/sigcabal02/p/p.cabal b/testsuite/tests/cabal/sigcabal02/p/p.cabal
new file mode 100644 (file)
index 0000000..bb3b2a4
--- /dev/null
@@ -0,0 +1,14 @@
+name:                p
+version:             1.0
+license-file:        LICENSE
+author:              Edward Z. Yang
+maintainer:          ezyang@cs.stanford.edu
+build-type:          Simple
+cabal-version:       >=1.20
+
+library
+  exposed-modules:     P
+  exposed-signatures:  Map
+  required-signatures: Set
+  build-depends:       base
+  default-language:    Haskell2010
diff --git a/testsuite/tests/cabal/sigcabal02/q/LICENSE b/testsuite/tests/cabal/sigcabal02/q/LICENSE
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/testsuite/tests/cabal/sigcabal02/q/Map.hsig b/testsuite/tests/cabal/sigcabal02/q/Map.hsig
new file mode 100644 (file)
index 0000000..40fd0bc
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Map where
+
+type role Map nominal representational
+data Map k a
+
+member :: Ord k => k -> Map k a -> Bool
diff --git a/testsuite/tests/cabal/sigcabal02/q/Q.hs b/testsuite/tests/cabal/sigcabal02/q/Q.hs
new file mode 100644 (file)
index 0000000..ba55fb9
--- /dev/null
@@ -0,0 +1,7 @@
+module Q where
+
+import qualified Map
+import Map(Map)
+
+mymember :: Int -> Map Int a -> Bool
+mymember k m = Map.member k m || Map.member (k + 1) m
diff --git a/testsuite/tests/cabal/sigcabal02/q/q.cabal b/testsuite/tests/cabal/sigcabal02/q/q.cabal
new file mode 100644 (file)
index 0000000..2f99c44
--- /dev/null
@@ -0,0 +1,13 @@
+name:                q
+version:             1.0
+license-file:        LICENSE
+author:              Edward Z. Yang
+maintainer:          ezyang@cs.stanford.edu
+build-type:          Simple
+cabal-version:       >=1.20
+
+library
+  exposed-modules:     Q
+  exposed-signatures:  Map
+  build-depends:       base
+  default-language:    Haskell2010
diff --git a/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr b/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr
new file mode 100644 (file)
index 0000000..7c1f092
--- /dev/null
@@ -0,0 +1,4 @@
+
+ShouldFail.hs:1:8:
+    Could not find module ‘Set’
+    Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout b/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout
new file mode 100644 (file)
index 0000000..48cb59e
--- /dev/null
@@ -0,0 +1,5 @@
+[1 of 1] Compiling Main             ( Main.hs, Main.o )
+Linking Main ...
+Nothing
+2
+True
diff --git a/testsuite/tests/driver/recomp014/Makefile b/testsuite/tests/driver/recomp014/Makefile
new file mode 100644 (file)
index 0000000..e788110
--- /dev/null
@@ -0,0 +1,31 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# -fforce-recomp makes lots of driver tests trivially pass, so we
+# filter it out from $(TEST_HC_OPTS).
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+# Recompilation tests
+
+clean:
+       rm -f *.o *.hi
+
+recomp014: clean
+       echo 'module A where a = False' > A.hs
+       echo 'module A1 where a = False' > A1.hs
+       echo 'module B where a :: Bool' > B.hsig
+       echo 'first run'
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A1.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of "B is main:A"
+       echo 'import B; main = print a' > C.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs
+       echo 'second run'
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of "B is main:A1"
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A1.o C.o -o recomp014
+       ./recomp014
+
+.PHONY: clean recomp014
diff --git a/testsuite/tests/driver/recomp014/all.T b/testsuite/tests/driver/recomp014/all.T
new file mode 100644 (file)
index 0000000..affccd2
--- /dev/null
@@ -0,0 +1,4 @@
+test('recomp014',
+     [ clean_cmd('$MAKE -s clean') ],
+     run_command,
+     ['$MAKE -s --no-print-directory recomp014'])
diff --git a/testsuite/tests/driver/recomp014/recomp014.stdout b/testsuite/tests/driver/recomp014/recomp014.stdout
new file mode 100644 (file)
index 0000000..7d54071
--- /dev/null
@@ -0,0 +1,4 @@
+first run
+compilation IS NOT required
+second run
+False
index 84dfc33..629d4b6 100644 (file)
@@ -21,3 +21,9 @@ sigof01m:
        mkdir tmp_sigof01m
        '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -outputdir tmp_sigof01m --make Main.hs -sig-of "B is main:A" -o tmp_sigof01m/Main
        tmp_sigof01m/Main
+
+sigof01i:
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) --interactive -v0 -ignore-dot-ghci Main.hs -sig-of "B is main:A" < sigof01i.script
+
+sigof01i2:
+       '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) --interactive -v0 -ignore-dot-ghci -sig-of "B is main:A" < sigof01i2.script
index d0cdc3c..50418b9 100644 (file)
@@ -7,3 +7,13 @@ test('sigof01m',
      [ clean_cmd('rm -rf tmp_sigof01m') ],
      run_command,
      ['$MAKE -s --no-print-directory sigof01m'])
+
+test('sigof01i',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory sigof01i'])
+
+test('sigof01i2',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory sigof01i2'])
diff --git a/testsuite/tests/driver/sigof01/sigof01i.script b/testsuite/tests/driver/sigof01/sigof01i.script
new file mode 100644 (file)
index 0000000..ba2906d
--- /dev/null
@@ -0,0 +1 @@
+main
diff --git a/testsuite/tests/driver/sigof01/sigof01i.stdout b/testsuite/tests/driver/sigof01/sigof01i.stdout
new file mode 100644 (file)
index 0000000..bb614cd
--- /dev/null
@@ -0,0 +1,3 @@
+False
+T
+True
diff --git a/testsuite/tests/driver/sigof01/sigof01i2.script b/testsuite/tests/driver/sigof01/sigof01i2.script
new file mode 100644 (file)
index 0000000..3a91e37
--- /dev/null
@@ -0,0 +1,3 @@
+:load B
+:browse B
+:issafe
diff --git a/testsuite/tests/driver/sigof01/sigof01i2.stdout b/testsuite/tests/driver/sigof01/sigof01i2.stdout
new file mode 100644 (file)
index 0000000..ac15dcf
--- /dev/null
@@ -0,0 +1,8 @@
+class Foo a where
+  foo :: a -> a
+data T = A.T
+mkT :: T
+x :: Bool
+Trust type is (Module: Safe, Package: trusted)
+Package Trust: Off
+B is trusted!
index 9cd00a2..70c6f22 100644 (file)
@@ -1,5 +1,5 @@
 
 package09e.hs:2:1:
     Ambiguous interface for ‘M’:
-      it is bound as Data.Set by a package flag
       it is bound as Data.Map by a package flag
+      it is bound as Data.Set by a package flag