Add -XPackageImports, new syntax for package-qualified imports

Now you can say
  
  import "network" Network.Socket

and get Network.Socket from package "network", even if there are
multiple Network.Socket modules in scope from different packages
and/or the current package.

This is not really intended for general use, it's mainly so that we
can build backwards-compatible versions of packages, where we need to
be able to do

module GHC.Base (module New.GHC.Base) where
import "base" GHC.Base as New.GHC.Base

11 files changed, 93 insertions, 51 deletions

diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index 4e58dd71f0..099537f9d0 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -35,6 +35,7 @@ type LImportDecl name = Located (ImportDecl name)
 
 data ImportDecl name
   = ImportDecl	  (Located ModuleName)		-- module name
+                  (Maybe FastString)            -- package qualifier
 		  Bool				-- True <=> {-# SOURCE #-} import
 		  Bool				-- True => qualified
 		  (Maybe ModuleName)		-- as Module
@@ -43,11 +44,14 @@ data ImportDecl name
 
 \begin{code}
 instance (Outputable name) => Outputable (ImportDecl name) where
-    ppr (ImportDecl mod from qual as spec)
+    ppr (ImportDecl mod pkg from qual as spec)
       = hang (hsep [ptext (sLit "import"), ppr_imp from, 
-                    pp_qual qual, ppr mod, pp_as as])
+                    pp_qual qual, pp_pkg pkg, ppr mod, pp_as as])
 	     4 (pp_spec spec)
       where
+        pp_pkg Nothing  = empty
+        pp_pkg (Just p) = doubleQuotes (ftext p)
+
 	pp_qual False   = empty
 	pp_qual True	= ptext (sLit "qualified")
 
@@ -64,7 +68,7 @@ instance (Outputable name) => Outputable (ImportDecl name) where
 			= ptext (sLit "hiding") <+> parens (interpp'SP spec)
 
 ideclName :: ImportDecl name -> Located ModuleName
-ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm
+ideclName (ImportDecl mod_nm _ _ _ _ _) = mod_nm
 \end{code}
 
 %************************************************************************
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 66cdf7881a..d7089f173b 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -70,15 +70,20 @@ import Data.Maybe
 \begin{code}
 -- | Load the interface corresponding to an @import@ directive in 
 -- source code.  On a failure, fail in the monad with an error message.
-loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface
-loadSrcInterface doc mod want_boot  = do 	
+loadSrcInterface :: SDoc
+                 -> ModuleName
+                 -> IsBootInterface     -- {-# SOURCE #-} ?
+                 -> Maybe FastString    -- "package", if any
+                 -> RnM ModIface
+
+loadSrcInterface doc mod want_boot maybe_pkg  = do
   -- We must first find which Module this import refers to.  This involves
   -- calling the Finder, which as a side effect will search the filesystem
   -- and create a ModLocation.  If successful, loadIface will read the
   -- interface; it will call the Finder again, but the ModLocation will be
   -- cached from the first search.
   hsc_env <- getTopEnv
-  res <- liftIO $ findImportedModule hsc_env mod Nothing
+  res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
   case res of
     Found _ mod -> do
       mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 73e58c997f..cf17155472 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -241,6 +241,7 @@ data DynFlag
    | Opt_RankNTypes
    | Opt_ImpredicativeTypes
    | Opt_TypeOperators
+   | Opt_PackageImports
 
    | Opt_PrintExplicitForalls
 
@@ -1628,7 +1629,8 @@ xFlags = [
   ( "GeneralizedNewtypeDeriving",       Opt_GeneralizedNewtypeDeriving, const Supported ),
   ( "OverlappingInstances",             Opt_OverlappingInstances, const Supported ),
   ( "UndecidableInstances",             Opt_UndecidableInstances, const Supported ),
-  ( "IncoherentInstances",              Opt_IncoherentInstances, const Supported )
+  ( "IncoherentInstances",              Opt_IncoherentInstances, const Supported ),
+  ( "PackageImports",                   Opt_PackageImports, const Supported )
   ]
 
 impliedFlags :: [(DynFlag, [DynFlag])]
diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs
index 63beae4e6a..bbea77d44a 100644
--- a/compiler/main/Finder.lhs
+++ b/compiler/main/Finder.lhs
@@ -37,6 +37,7 @@ import FiniteMap
 import LazyUniqFM
 import Maybes		( expectJust )
 
+import Distribution.Package
 import Data.IORef	( IORef, writeIORef, readIORef, modifyIORef )
 import Data.List
 import System.Directory
@@ -113,27 +114,20 @@ lookupModLocationCache ref key = do
 -- packages to find the module, if a package is specified then only
 -- that package is searched for the module.
 
-findImportedModule :: HscEnv -> ModuleName -> Maybe PackageId -> IO FindResult
-findImportedModule hsc_env mod_name mb_pkgid =
-  case mb_pkgid of
-	Nothing		    	   -> unqual_import
-	Just pkg | pkg == this_pkg -> home_import
-	         | otherwise	   -> pkg_import pkg
+findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
+findImportedModule hsc_env mod_name mb_pkg =
+  case mb_pkg of
+	Nothing                        -> unqual_import
+	Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
+	         | otherwise           -> pkg_import
   where
-    dflags = hsc_dflags hsc_env
-    this_pkg = thisPackage dflags
+    home_import   = findHomeModule hsc_env mod_name
 
-    home_import     = findHomeModule hsc_env mod_name
+    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg
 
-    pkg_import pkg  = findPackageModule hsc_env (mkModule pkg mod_name)
-			-- ToDo: this isn't quite right, the module we want
-			-- might actually be in another package, but re-exposed
-			-- ToDo: should return NotFoundInPackage if
-			-- the module isn't exposed by the package.
-
-    unqual_import   = home_import 
+    unqual_import = home_import 
 			`orIfNotFound`
-		      findExposedPackageModule hsc_env mod_name
+		      findExposedPackageModule hsc_env mod_name Nothing
 
 -- | Locate a specific 'Module'.  The purpose of this function is to
 -- create a 'ModLocation' for a given 'Module', that is to find out
@@ -176,8 +170,9 @@ homeSearchCache hsc_env mod_name do_this = do
 	   _other        -> return ()
 	return result
 
-findExposedPackageModule :: HscEnv -> ModuleName -> IO FindResult
-findExposedPackageModule hsc_env mod_name
+findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
+                         -> IO FindResult
+findExposedPackageModule hsc_env mod_name mb_pkg
         -- not found in any package:
   | null found = return (NotFound [] Nothing)
         -- found in just one exposed package:
@@ -195,9 +190,19 @@ findExposedPackageModule hsc_env mod_name
   where
 	dflags = hsc_dflags hsc_env
         found = lookupModuleInAllPackages dflags mod_name
-        found_exposed = filter is_exposed found
+
+        found_exposed = [ (pkg_conf,exposed_mod) 
+                        | x@(pkg_conf,exposed_mod) <- found,
+                          is_exposed x,
+                          pkg_conf `matches` mb_pkg ]
+
         is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod
 
+        _pkg_conf `matches` Nothing  = True
+        pkg_conf  `matches` Just pkg =
+           case packageName pkg_conf of 
+              PackageName n -> pkg == mkFastString n
+
 
 modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
 modLocationCache hsc_env mod do_this = do
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 2ecd2f002e..e1210bd27f 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -2263,7 +2263,7 @@ getTokenStream :: Session -> Module -> IO [Located Token]
 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
 -- filesystem and package database to find the corresponding 'Module', 
 -- using the algorithm that is used for an @import@ declaration.
-findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
+findModule :: Session -> ModuleName -> Maybe FastString -> IO Module
 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
   let
         dflags = hsc_dflags hsc_env
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index d0e30e0617..eea6b52fc2 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -61,8 +61,9 @@ getImports dflags buf filename source_filename = do
 	      let
                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
 		mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
-	        (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
-		source_imps   = map getImpMod src_idecls	
+                imps' = filter isHomeImp (map unLoc imps)
+	        (src_idecls, ord_idecls) = partition isSourceIdecl imps'
+		source_imps   = map getImpMod src_idecls
 		ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc) 
 					(map getImpMod ord_idecls)
 		     -- GHC.Prim doesn't exist physically, so don't go looking for it.
@@ -72,11 +73,16 @@ getImports dflags buf filename source_filename = do
 parseError :: SrcSpan -> Message -> a
 parseError span err = throwErrMsg $ mkPlainErrMsg span err
 
+-- we aren't interested in package imports here, filter them out
+isHomeImp :: ImportDecl name -> Bool
+isHomeImp (ImportDecl _ (Just p) _ _ _ _) = p == fsLit "this"
+isHomeImp (ImportDecl _ Nothing  _ _ _ _) = True
+
 isSourceIdecl :: ImportDecl name -> Bool
-isSourceIdecl (ImportDecl _ s _ _ _) = s
+isSourceIdecl (ImportDecl _ _ s _ _ _) = s
 
 getImpMod :: ImportDecl name -> Located ModuleName
-getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
+getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
 
 --------------------------------------------------------------
 -- Get options
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index e717bfec64..3bcaac465a 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -119,7 +119,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _))
     sig_info (InlineSig _ _)    = (0,0,0,1)
     sig_info _                  = (0,0,0,0)
 
-    import_info (L _ (ImportDecl _ _ qual as spec))
+    import_info (L _ (ImportDecl _ _ _ qual as spec))
 	= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
     qual_info False  = 0
     qual_info True   = 1
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 3e2c3ef47d..ace175db99 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -413,11 +413,9 @@ findWiredInPackages dflags pkgs preload this_package = do
 			   -> IO (Maybe (PackageIdentifier, PackageId))
 	findWiredInPackage pkgs wired_pkg =
            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
-	   case filter exposed all_ps of
-		[] -> case all_ps of
-                        []   -> notfound
-                        many -> pick (head (sortByVersion many))
-		many  -> pick (head (sortByVersion many))
+	   case all_ps of
+		[]   -> notfound
+		many -> pick (head (sortByVersion many))
           where
                 suffixes = snd wired_pkg
                 notfound = do
@@ -444,9 +442,18 @@ findWiredInPackages dflags pkgs preload this_package = do
   let 
         wired_in_ids = catMaybes mb_wired_in_ids
 
-	deleteOtherWiredInPackages pkgs = filterOut bad pkgs
-	  where bad p = any (p `matches`) wired_in_pkgids
-                     && package p `notElem` map fst wired_in_ids
+        -- this is old: we used to assume that if there were
+        -- multiple versions of wired-in packages installed that
+        -- they were mutually exclusive.  Now we're assuming that
+        -- you have one "main" version of each wired-in package
+        -- (the latest version), and the others are backward-compat
+        -- wrappers that depend on this one.  e.g. base-4.0 is the
+        -- latest, base-3.0 is a compat wrapper depending on base-4.0.
+        {-
+ 	deleteOtherWiredInPackages pkgs = filterOut bad pkgs
+ 	  where bad p = any (p `matches`) wired_in_pkgids
+                      && package p `notElem` map fst wired_in_ids
+        -}
 
 	updateWiredInDependencies pkgs = map upd_pkg pkgs
 	  where upd_pkg p = p{ package = upd_pid (package p),
@@ -457,9 +464,9 @@ findWiredInPackages dflags pkgs preload this_package = do
 				((x, y):_) -> x{ pkgName = PackageName (packageIdString y),
                                                  pkgVersion = Version [] [] }
 
-        pkgs1 = deleteOtherWiredInPackages pkgs
+        -- pkgs1 = deleteOtherWiredInPackages pkgs
 
-        pkgs2 = updateWiredInDependencies pkgs1
+        pkgs2 = updateWiredInDependencies pkgs
 
         preload1 = map upd_pid preload
 
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 67b2dca269..b51edf2476 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -495,13 +495,17 @@ importdecls :: { [LImportDecl RdrName] }
 	| {- empty -}				{ [] }
 
 importdecl :: { LImportDecl RdrName }
-	: 'import' maybe_src optqualified modid maybeas maybeimpspec 
-		{ L (comb4 $1 $4 $5 $6) (ImportDecl $4 $2 $3 (unLoc $5) (unLoc $6)) }
+	: 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec 
+		{ L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) }
 
 maybe_src :: { IsBootInterface }
 	: '{-# SOURCE' '#-}'			{ True }
 	| {- empty -}				{ False }
 
+maybe_pkg :: { Maybe FastString }
+        : STRING                                { Just (getSTRING $1) }
+        | {- empty -}                           { Nothing }
+
 optqualified :: { Bool }
       	: 'qualified'                           { True  }
       	| {- empty -}				{ False }
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 63db61ccb6..a4c4afd312 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -470,7 +470,7 @@ lookupQualifiedName rdr_name
   | Just (mod,occ) <- isQual_maybe rdr_name
    -- Note: we want to behave as we would for a source file import here,
    -- and respect hiddenness of modules/packages, hence loadSrcInterface.
-   = loadSrcInterface doc mod False	`thenM` \ iface ->
+   = loadSrcInterface doc mod False Nothing	`thenM` \ iface ->
 
    case  [ (mod,occ) | 
 	   (mod,avails) <- mi_exports iface,
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 9a95a85b78..e629dac7cf 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -63,7 +63,7 @@ rnImports imports
          implicit_prelude <- doptM Opt_ImplicitPrelude
          let prel_imports	= mkPrelImports this_mod implicit_prelude imports
              (source, ordinary) = partition is_source_import imports
-             is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot
+             is_source_import (L _ (ImportDecl _ _ is_boot _ _ _)) = is_boot
 
          ifOptM Opt_WarnImplicitPrelude (
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
@@ -99,13 +99,14 @@ mkPrelImports this_mod implicit_prelude import_decls
   | otherwise = [preludeImportDecl]
   where
       explicit_prelude_import
-       = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- import_decls, 
+       = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls, 
 	           unLoc mod == pRELUDE_NAME ]
 
       preludeImportDecl :: LImportDecl RdrName
       preludeImportDecl
         = L loc $
 	  ImportDecl (L loc pRELUDE_NAME)
+               Nothing {- no specific package -}
 	       False {- Not a boot interface -}
 	       False	{- Not qualified -}
 	       Nothing	{- No "as" -}
@@ -118,18 +119,22 @@ rnImportDecl  :: Module
 	      -> LImportDecl RdrName
 	      -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)
 
-rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot
+rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot
                                          qual_only as_mod imp_details))
   = 
     setSrcSpan loc $ do
 
+    when (isJust mb_pkg) $ do
+        pkg_imports <- doptM Opt_PackageImports
+        when (not pkg_imports) $ addErr packageImportErr
+
 	-- If there's an error in loadInterface, (e.g. interface
 	-- file not found) we get lots of spurious errors from 'filterImports'
     let
 	imp_mod_name = unLoc loc_imp_mod_name
 	doc = ppr imp_mod_name <+> ptext (sLit "is directly imported")
 
-    iface <- loadSrcInterface doc imp_mod_name want_boot
+    iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
 
 	-- Compiler sanity check: if the import didn't say
 	-- {-# SOURCE #-} we should not get a hi-boot file
@@ -239,7 +244,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot
 	  _    	      -> return ()
      )
 
-    let new_imp_decl = L loc (ImportDecl loc_imp_mod_name want_boot
+    let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot
                                          qual_only as_mod new_imp_details)
 
     return (new_imp_decl, gbl_env, imports, mi_hpc iface)
@@ -1443,4 +1448,8 @@ moduleWarn mod (DeprecatedTxt txt)
 implicitPreludeWarn :: SDoc
 implicitPreludeWarn
   = ptext (sLit "Module `Prelude' implicitly imported")
+
+packageImportErr :: SDoc
+packageImportErr
+  = ptext (sLit "Package-qualified imports are not enabled; use -XPackageImports")
 \end{code}