Revert "Revert "Support for multiple signature files in scope.""

This reverts commit bac927b9770ff769128b66d13a3e72bf5a9bc514.

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

1 files changed, 148 insertions, 66 deletions

diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 0be5e3ffaf..16ee352243 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -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)