Generalise Package Support

This patch pushes through one fundamental change: a module is now
identified by the pair of its package and module name, whereas
previously it was identified by its module name alone.  This means
that now a program can contain multiple modules with the same name, as
long as they belong to different packages.

This is a language change - the Haskell report says nothing about
packages, but it is now necessary to understand packages in order to
understand GHC's module system.  For example, a type T from module M
in package P is different from a type T from module M in package Q.
Previously this wasn't an issue because there could only be a single
module M in the program.

The "module restriction" on combining packages has therefore been
lifted, and a program can contain multiple versions of the same
package.

Note that none of the proposed syntax changes have yet been
implemented, but the architecture is geared towards supporting import
declarations qualified by package name, and that is probably the next
step.

It is now necessary to specify the package name when compiling a
package, using the -package-name flag (which has been un-deprecated).
Fortunately Cabal still uses -package-name.

Certain packages are "wired in".  Currently the wired-in packages are:
base, haskell98, template-haskell and rts, and are always referred to
by these versionless names.  Other packages are referred to with full
package IDs (eg. "network-1.0").  This is because the compiler needs
to refer to entities in the wired-in packages, and we didn't want to
bake the version of these packages into the comiler.  It's conceivable
that someone might want to upgrade the base package independently of
GHC.

Internal changes:

  - There are two module-related types:

        ModuleName      just a FastString, the name of a module
        Module          a pair of a PackageId and ModuleName

    A mapping from ModuleName can be a UniqFM, but a mapping from Module
    must be a FiniteMap (we provide it as ModuleEnv).

  - The "HomeModules" type that was passed around the compiler is now
    gone, replaced in most cases by the current package name which is
    contained in DynFlags.  We can tell whether a Module comes from the
    current package by comparing its package name against the current
    package.

  - While I was here, I changed PrintUnqual to be a little more useful:
    it now returns the ModuleName that the identifier should be qualified
    with according to the current scope, rather than its original
    module.  Also, PrintUnqual tells whether to qualify module names with
    package names (currently unused).

Docs to follow.

3 files changed, 117 insertions, 84 deletions

diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
index 875f1d6331..d294178e5d 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -19,19 +19,21 @@ import ByteCodeItbls	( ItblEnv, ItblPtr )
 import ByteCodeAsm	( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
 import ObjLink		( lookupSymbol )
 
-import Name		( Name,  nameModule, nameOccName, isExternalName )
+import Name		( Name,  nameModule, nameOccName )
+#ifdef DEBUG
+import Name             ( isExternalName )
+#endif
 import NameEnv
 import OccName		( occNameFS )
 import PrimOp		( PrimOp, primOpOcc )
-import Module		( moduleFS )
+import Module
+import PackageConfig    ( mainPackageId, packageIdFS )
 import FastString	( FastString(..), unpackFS, zEncodeFS )
-import Outputable
 import Panic            ( GhcException(..) )
 
 -- Standard libraries
 import GHC.Word		( Word(..) )
 
-import Data.Array.IArray ( listArray )
 import Data.Array.Base
 import GHC.Arr		( STArray(..) )
 
@@ -256,8 +258,17 @@ linkFail who what
 -- HACKS!!!  ToDo: cleaner
 nameToCLabel :: Name -> String{-suffix-} -> String
 nameToCLabel n suffix
-   = unpackFS (zEncodeFS (moduleFS (nameModule n)))
-     ++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix
+   = if pkgid /= mainPackageId
+        then package_part ++ '_': qual_name
+        else qual_name
+  where
+        pkgid = modulePackageId mod
+        mod = nameModule n
+        package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
+        module_part  = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
+        occ_part     = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
+        qual_name = module_part ++ '_':occ_part ++ '_':suffix
+
 
 primopToCLabel :: PrimOp -> String{-suffix-} -> String
 primopToCLabel primop suffix
diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 55384bc63e..8a20fb1b99 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -31,9 +31,9 @@ import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 
 -- The GHC interface
 import qualified GHC
-import GHC		( Session, verbosity, dopt, DynFlag(..), Target(..),
+import GHC		( Session, dopt, DynFlag(..), Target(..),
 			  TargetId(..), DynFlags(..),
-			  pprModule, Type, Module, SuccessFlag(..),
+			  pprModule, Type, Module, ModuleName, SuccessFlag(..),
 			  TyThing(..), Name, LoadHowMuch(..), Phase,
 			  GhcException(..), showGhcException,
 			  CheckedModule(..), SrcLoc )
@@ -45,7 +45,6 @@ import PprTyThing
 import Outputable
 
 -- for createtags (should these come via GHC?)
-import Module		( moduleString )
 import Name		( nameSrcLoc, nameModule, nameOccName )
 import OccName		( pprOccName )
 import SrcLoc		( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
@@ -95,7 +94,6 @@ import System.IO.Error as IO
 import Data.Char
 import Control.Monad as Monad
 import Foreign.StablePtr	( newStablePtr )
-import Text.Printf
 
 import GHC.Exts		( unsafeCoerce# )
 import GHC.IOBase	( IOErrorType(InvalidArgument) )
@@ -242,13 +240,15 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b
 		  	      ic_type_env     = new_type_env }
          writeIORef ref (hsc_env { hsc_IC = new_ic })
          is_tty <- hIsTerminalDevice stdin
+         prel_mod <- GHC.findModule session prel_name Nothing
          withExtendedLinkEnv (zip names hValues) $
            startGHCi (interactiveLoop is_tty True)
                      GHCiState{ progname = "<interactive>",
                                 args = [],
                                 prompt = location++"> ",
                                 session = session,
-                                options = [] }
+                                options = [],
+                                prelude =  prel_mod }
          writeIORef ref hsc_env
          putStrLn $ "Returning to normal execution..."
          return b
@@ -284,7 +284,8 @@ interactiveUI session srcs maybe_expr = do
    hSetBuffering stdin NoBuffering
 
 	-- initial context is just the Prelude
-   GHC.setContext session [] [prelude_mod]
+   prel_mod <- GHC.findModule session prel_name Nothing
+   GHC.setContext session [] [prel_mod]
 
 #ifdef USE_READLINE
    Readline.initialize
@@ -305,7 +306,8 @@ interactiveUI session srcs maybe_expr = do
 		   args = [],
                    prompt = "%s> ",
 		   session = session,
-		   options = [] }
+		   options = [],
+                   prelude = prel_mod }
 
 #ifdef USE_READLINE
    Readline.resetTerminal Nothing
@@ -313,6 +315,8 @@ interactiveUI session srcs maybe_expr = do
 
    return ()
 
+prel_name = GHC.mkModuleName "Prelude"
+
 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 runGHCi paths maybe_expr = do
   let read_dot_files = not opt_IgnoreDotGhci
@@ -807,7 +811,7 @@ loadModule' files = do
 
 checkModule :: String -> GHCi ()
 checkModule m = do
-  let modl = GHC.mkModule m
+  let modl = GHC.mkModuleName m
   session <- getSession
   result <- io (GHC.checkModule session modl)
   case result of
@@ -816,7 +820,7 @@ checkModule m = do
 	case checkedModuleInfo r of
 	   Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
 		let
-		    (local,global) = partition ((== modl) . GHC.nameModule) scope
+		    (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 		in
 			(text "global names: " <+> ppr global) $$
 		        (text "local  names: " <+> ppr local)
@@ -832,22 +836,23 @@ reloadModule "" = do
 reloadModule m = do
   io (revertCAFs)		-- always revert CAFs on reload.
   session <- getSession
-  ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
+  ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
   afterLoad ok session
 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
   graph <- io (GHC.getModuleGraph session)
-  graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
+  graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
-  modulesLoadedMsg ok (map GHC.ms_mod graph')
+  modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 #if defined(GHCI) && defined(BREAKPOINT)
   io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
                     ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
 #endif
 
 setContextAfterLoad session [] = do
-  io (GHC.setContext session [] [prelude_mod])
+  prel_mod <- getPrelude
+  io (GHC.setContext session [] [prel_mod])
 setContextAfterLoad session ms = do
   -- load a target if one is available, otherwise load the topmost module.
   targets <- io (GHC.getTargets session)
@@ -864,7 +869,7 @@ setContextAfterLoad session ms = do
 	(m:_) -> Just m
 
    summary `matches` Target (TargetModule m) _
-	= GHC.ms_mod summary == m
+	= GHC.ms_mod_name summary == m
    summary `matches` Target (TargetFile f _) _ 
 	| Just f' <- GHC.ml_hs_file (GHC.ms_location summary)	= f == f'
    summary `matches` target
@@ -873,17 +878,19 @@ setContextAfterLoad session ms = do
    load_this summary | m <- GHC.ms_mod summary = do
 	b <- io (GHC.moduleIsInterpreted session m)
 	if b then io (GHC.setContext session [m] []) 
-       	     else io (GHC.setContext session []  [prelude_mod,m])
+       	     else do
+                   prel_mod <- getPrelude
+                   io (GHC.setContext session []  [prel_mod,m])
 
 
-modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
+modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 modulesLoadedMsg ok mods = do
   dflags <- getDynFlags
   when (verbosity dflags > 0) $ do
    let mod_commas 
 	| null mods = text "none."
 	| otherwise = hsep (
-	    punctuate comma (map pprModule mods)) <> text "."
+	    punctuate comma (map ppr mods)) <> text "."
    case ok of
     Failed ->
        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
@@ -950,8 +957,9 @@ createTagsFile session tagskind tagFile = do
         is_interpreted <- GHC.moduleIsInterpreted session m
         -- should we just skip these?
         when (not is_interpreted) $
-          throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
-
+          throwDyn (CmdLineError ("module '" 
+                                ++ GHC.moduleNameString (GHC.moduleName m)
+                                ++ "' is not interpreted"))
         mbModInfo <- GHC.getModuleInfo session m
         let unqual 
 	      | Just modinfo <- mbModInfo,
@@ -1039,8 +1047,7 @@ browseCmd m =
 
 browseModule m exports_only = do
   s <- getSession
-
-  let modl = GHC.mkModule m
+  modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
   when (not is_interpreted && not exports_only) $
 	throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
@@ -1048,7 +1055,8 @@ browseModule m exports_only = do
   -- Temporarily set the context to the module we're interested in,
   -- just so we can get an appropriate PrintUnqualified
   (as,bs) <- io (GHC.getContext s)
-  io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
+  prel_mod <- getPrelude
+  io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 		      else GHC.setContext s [modl] [])
   unqual <- io (GHC.getPrintUnqual s)
   io (GHC.setContext s as bs)
@@ -1089,47 +1097,53 @@ setContext str
     sensible ('*':m) = looksLikeModuleName m
     sensible m       = looksLikeModuleName m
 
-newContext mods = do
-  session <- getSession
-  (as,bs) <- separate session mods [] []
-  let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
-  io (GHC.setContext session as bs')
-
-separate :: Session -> [String] -> [Module] -> [Module]
-  -> GHCi ([Module],[Module])
+separate :: Session -> [String] -> [Module] -> [Module] 
+        -> GHCi ([Module],[Module])
 separate session []           as bs = return (as,bs)
-separate session (('*':m):ms) as bs = do
-   let modl = GHC.mkModule m
-   b <- io (GHC.moduleIsInterpreted session modl)
-   if b then separate session ms (modl:as) bs
-   	else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
-separate session (m:ms)       as bs = separate session ms as (GHC.mkModule m:bs)
-
-prelude_mod = GHC.mkModule "Prelude"
+separate session (('*':str):ms) as bs = do
+   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+   b <- io $ GHC.moduleIsInterpreted session m
+   if b then separate session ms (m:as) bs
+   	else throwDyn (CmdLineError ("module '"
+                        ++ GHC.moduleNameString (GHC.moduleName m)
+                        ++ "' is not interpreted"))
+separate session (str:ms) as bs = do
+  m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+  separate session ms as (m:bs)
+
+newContext :: [String] -> GHCi ()
+newContext strs = do
+  s <- getSession
+  (as,bs) <- separate s strs [] []
+  prel_mod <- getPrelude
+  let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
+  io $ GHC.setContext s as bs'
 
 
-addToContext mods = do
-  cms <- getSession
-  (as,bs) <- io (GHC.getContext cms)
+addToContext :: [String] -> GHCi ()
+addToContext strs = do
+  s <- getSession
+  (as,bs) <- io $ GHC.getContext s
 
-  (as',bs') <- separate cms mods [] []
+  (new_as,new_bs) <- separate s strs [] []
 
-  let as_to_add = as' \\ (as ++ bs)
-      bs_to_add = bs' \\ (as ++ bs)
+  let as_to_add = new_as \\ (as ++ bs)
+      bs_to_add = new_bs \\ (as ++ bs)
 
-  io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
+  io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
 
 
-removeFromContext mods = do
-  cms <- getSession
-  (as,bs) <- io (GHC.getContext cms)
+removeFromContext :: [String] -> GHCi ()
+removeFromContext strs = do
+  s <- getSession
+  (as,bs) <- io $ GHC.getContext s
 
-  (as_to_remove,bs_to_remove) <- separate cms mods [] []
+  (as_to_remove,bs_to_remove) <- separate s strs [] []
 
   let as' = as \\ (as_to_remove ++ bs_to_remove)
       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 
-  io (GHC.setContext cms as' bs')
+  io $ GHC.setContext s as' bs'
 
 ----------------------------------------------------------------------------
 -- Code for `:set'
@@ -1357,7 +1371,7 @@ completeModule w = do
 completeHomeModule w = do
   s <- restoreSession
   g <- GHC.getModuleGraph s
-  let home_mods = map GHC.ms_mod g
+  let home_mods = map GHC.ms_mod_name g
   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
 
 completeSetOptions w = do
@@ -1393,9 +1407,9 @@ getCommonPrefix (s:ss) = foldl common s ss
 	   | c == d = c : common cs ds
 	   | otherwise = ""
 
-allExposedModules :: DynFlags -> [Module]
+allExposedModules :: DynFlags -> [ModuleName]
 allExposedModules dflags 
- = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
  where
   pkg_db = pkgIdMap (pkgState dflags)
 #else
@@ -1418,7 +1432,8 @@ data GHCiState = GHCiState
 	args	       :: [String],
         prompt         :: String,
 	session        :: GHC.Session,
-	options        :: [GHCiOption]
+	options        :: [GHCiOption],
+        prelude        :: Module
      }
 
 data GHCiOption 
@@ -1445,6 +1460,7 @@ setGHCiState s = GHCi $ \r -> writeIORef r s
 
 -- for convenience...
 getSession = getGHCiState >>= return . session
+getPrelude = getGHCiState >>= return . prelude
 
 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
 no_saved_sess = error "no saved_ses"
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index cec1047be8..26f40ebbe4 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -30,16 +30,19 @@ import ByteCodeAsm	( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
 
 import Packages
 import DriverPhases	( isObjectFilename, isDynLibFilename )
-import Finder		( findModule, findObjectLinkableMaybe, FindResult(..) )
+import Finder		( findHomeModule, findObjectLinkableMaybe,
+                          FindResult(..) )
 import HscTypes
 import Name		( Name, nameModule, isExternalName, isWiredInName )
 import NameEnv
 import NameSet		( nameSetToList )
+import UniqFM           ( lookupUFM )
 import Module
 import ListSetOps	( minusList )
 import DynFlags		( DynFlags(..), getOpts )
 import BasicTypes	( SuccessFlag(..), succeeded, failed )
 import Outputable
+import PackageConfig    ( rtsPackageId )
 import Panic            ( GhcException(..) )
 import Util             ( zipLazy, global, joinFileExt, joinFileName, suffixOf,
 			  replaceFilenameSuffix )
@@ -58,7 +61,10 @@ import System.IO	( putStr, putStrLn, hPutStrLn, stderr, fixIO )
 import System.Directory	( doesFileExist )
 
 import Control.Exception ( block, throwDyn, bracket )
-import Maybe		( isJust, fromJust )
+import Maybe		( fromJust )
+#ifdef DEBUG
+import Maybe            ( isJust )
+#endif
 
 #if __GLASGOW_HASKELL__ >= 503
 import GHC.IOBase	( IO(..) )
@@ -122,9 +128,7 @@ emptyPLS dflags = PersistentLinkerState {
   --
   -- The linker's symbol table is populated with RTS symbols using an
   -- explicit list.  See rts/Linker.c for details.
-  where init_pkgs
-	  | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id]
-	  | otherwise = []
+  where init_pkgs = [rtsPackageId]
 \end{code}
 
 \begin{code}
@@ -363,7 +367,6 @@ linkExpr hsc_env span root_ul_bco
    }}
    where
      hpt    = hsc_HPT hsc_env
-     dflags = hsc_dflags hsc_env
      free_names = nameSetToList (bcoFreeNames root_ul_bco)
 
      needed_mods :: [Module]
@@ -413,7 +416,8 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
 	    mods_needed = nub (concat mods_s) `minusList` linked_mods     ;
 	    pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ;
 
-	    linked_mods = map linkableModule (objs_loaded pls ++ bcos_loaded pls)
+	    linked_mods = map (moduleName.linkableModule) 
+                                (objs_loaded pls ++ bcos_loaded pls)
 	} ;
 	
 	-- 3.  For each dependent module, find its linkable
@@ -423,19 +427,22 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
 
 	return (lnks_needed, pkgs_needed) }
   where
-    get_deps :: Module -> ([Module],[PackageId])
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+    get_deps :: Module -> ([ModuleName],[PackageId])
 	-- Get the things needed for the specified module
 	-- This is rather similar to the code in RnNames.importsFromImportDecl
     get_deps mod
-	| ExtPackage p <- mi_package iface
-	= ([], p : dep_pkgs deps)
+        | pkg /= this_pkg
+        = ([], pkg : dep_pkgs deps)
 	| otherwise
-	= (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps)
+	= (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps)
 	where
-	  iface = get_iface mod
-	  deps  = mi_deps iface
+          pkg   = modulePackageId mod
+	  deps  = mi_deps (get_iface mod)
 
-    get_iface mod = case lookupIface hpt pit mod of
+    get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
 			    Just iface -> iface
 			    Nothing    -> pprPanic "getLinkDeps" (no_iface mod)
     no_iface mod = ptext SLIT("No iface for") <+> ppr mod
@@ -451,23 +458,22 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
 	-- This one is a build-system bug
 
     get_linkable maybe_normal_osuf mod_name	-- A home-package module
-	| Just mod_info <- lookupModuleEnv hpt mod_name 
+	| Just mod_info <- lookupUFM hpt mod_name 
 	= ASSERT(isJust (hm_linkable mod_info))
 	  adjust_linkable (fromJust (hm_linkable mod_info))
 	| otherwise	
-	=	-- It's not in the HPT because we are in one shot mode, 
+	= do	-- It's not in the HPT because we are in one shot mode, 
 		-- so use the Finder to get a ModLocation...
-	  do { mb_stuff <- findModule hsc_env mod_name False ;
-	       case mb_stuff of {
-		  Found loc _ -> found loc mod_name ;
+	     mb_stuff <- findHomeModule hsc_env mod_name
+	     case mb_stuff of
+		  Found loc mod -> found loc mod
 		  _ -> no_obj mod_name
-	     }}
-	where
-	    found loc mod_name = do {
+
+    found loc mod = do {
 		-- ...and then find the linkable for it
-	       mb_lnk <- findObjectLinkableMaybe mod_name loc ;
+	       mb_lnk <- findObjectLinkableMaybe mod loc ;
 	       case mb_lnk of {
-		  Nothing -> no_obj mod_name ;
+		  Nothing -> no_obj mod ;
 		  Just lnk -> adjust_linkable lnk
 	      }}