Generalise Package Support

[ghc-hetmet.git] / compiler / basicTypes / Module.lhs

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index f9b00f1..720c51f 100644 (file)
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -11,36 +11,49 @@ the keys.
 \begin{code}
 module Module 
     (
 \begin{code}
 module Module 
     (

-      Module                   -- Abstract, instance of Eq, Ord, Outputable
-    , pprModule                        -- :: Module -> SDoc
-
-    , ModLocation(..)
-    , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn
-
-    , moduleString             -- :: Module -> String
-    , moduleFS                 -- :: Module -> FastString
-
-    , mkModule                 -- :: String -> Module
-    , mkModuleFS               -- :: FastString -> Module
- 
-    , ModuleEnv
-    , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
-    , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
-    , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
-    , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
-    , extendModuleEnv_C, filterModuleEnv
-
-    , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
-
+       -- * The ModuleName type
+       ModuleName,
+       pprModuleName,
+       moduleNameFS,
+       moduleNameString,
+       mkModuleName,
+       mkModuleNameFS,
+
+       -- * The Module type
+       Module,
+       modulePackageId, moduleName,
+       pprModule,
+       mkModule,
+
+       -- * The ModuleLocation type
+       ModLocation(..),
+       addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
+
+       -- * Module mappings
+       ModuleEnv,
+       elemModuleEnv, extendModuleEnv, extendModuleEnvList, 
+       extendModuleEnvList_C, plusModuleEnv_C,
+       delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
+       lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
+       moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv,
+       extendModuleEnv_C, filterModuleEnv,
+
+       -- * ModuleName mappings
+       ModuleNameEnv,
+
+       -- * Sets of modules
+       ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet,
+       elemModuleSet

     ) where
 
 #include "HsVersions.h"
 import Outputable
 import Unique          ( Uniquable(..) )
     ) where
 
 #include "HsVersions.h"
 import Outputable
 import Unique          ( Uniquable(..) )

+import FiniteMap

 import UniqFM
 import UniqFM

-import UniqSet
-import Binary
+import PackageConfig   ( PackageId, packageIdFS, mainPackageId )

 import FastString
 import FastString

+import Binary

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -105,49 +118,86 @@ addBootSuffixLocn locn
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-newtype Module = Module FastString
-       -- Haskell module names can include the quote character ',
-       -- so the module names have the z-encoding applied to them
-
-instance Binary Module where
-   put_ bh (Module m) = put_ bh m
-   get bh = do m <- get bh; return (Module m)
+-- | A ModuleName is a simple string, eg. @Data.List@.
+newtype ModuleName = ModuleName FastString

 
 

-instance Uniquable Module where
-  getUnique (Module nm) = getUnique nm
+instance Uniquable ModuleName where
+  getUnique (ModuleName nm) = getUnique nm

 
 

-instance Eq Module where
+instance Eq ModuleName where

   nm1 == nm2 = getUnique nm1 == getUnique nm2
 
 -- Warning: gives an ordering relation based on the uniques of the
 -- FastStrings which are the (encoded) module names.  This is _not_
 -- a lexicographical ordering.
   nm1 == nm2 = getUnique nm1 == getUnique nm2
 
 -- Warning: gives an ordering relation based on the uniques of the
 -- FastStrings which are the (encoded) module names.  This is _not_
 -- a lexicographical ordering.

-instance Ord Module where
+instance Ord ModuleName where

   nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
 
   nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
 

-instance Outputable Module where
-  ppr = pprModule
+instance Outputable ModuleName where
+  ppr = pprModuleName

 
 

-pprModule :: Module -> SDoc
-pprModule (Module nm) = 
+instance Binary ModuleName where
+  put_ bh (ModuleName fs) = put_ bh fs
+  get bh = do fs <- get bh; return (ModuleName fs)
+
+pprModuleName :: ModuleName -> SDoc
+pprModuleName (ModuleName nm) = 

     getPprStyle $ \ sty ->
     if codeStyle sty 
        then ftext (zEncodeFS nm)
        else ftext nm
 
     getPprStyle $ \ sty ->
     if codeStyle sty 
        then ftext (zEncodeFS nm)
        else ftext nm
 

-moduleFS :: Module -> FastString
-moduleFS (Module mod) = mod
+moduleNameFS :: ModuleName -> FastString
+moduleNameFS (ModuleName mod) = mod

 
 

-moduleString :: Module -> String
-moduleString (Module mod) = unpackFS mod
+moduleNameString :: ModuleName -> String
+moduleNameString (ModuleName mod) = unpackFS mod

 
 

--- used to be called mkSrcModule
-mkModule :: String -> Module
-mkModule s = Module (mkFastString s)
+mkModuleName :: String -> ModuleName
+mkModuleName s = ModuleName (mkFastString s)

 
 

--- used to be called mkSrcModuleFS
-mkModuleFS :: FastString -> Module
-mkModuleFS s = Module s
+mkModuleNameFS :: FastString -> ModuleName
+mkModuleNameFS s = ModuleName s
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{A fully qualified module}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- | A Module is a pair of a 'PackageId' and a 'ModuleName'.
+data Module = Module {
+   modulePackageId :: !PackageId,  -- pkg-1.0
+   moduleName      :: !ModuleName  -- A.B.C
+  }
+  deriving (Eq, Ord)
+
+instance Outputable Module where
+  ppr = pprModule
+
+instance Binary Module where
+  put_ bh (Module p n) = put_ bh p >> put_ bh n
+  get bh = do p <- get bh; n <- get bh; return (Module p n)
+
+mkModule :: PackageId -> ModuleName -> Module
+mkModule = Module
+
+pprModule :: Module -> SDoc
+pprModule mod@(Module p n)  = pprPackagePrefix p mod <> pprModuleName n
+
+pprPackagePrefix p mod = getPprStyle doc
+ where
+   doc sty
+       | codeStyle sty = 
+          if p == mainPackageId 
+                then empty -- never qualify the main package in code
+                else ftext (zEncodeFS (packageIdFS p)) <> char '_'
+       | Just pkg <- qualModule sty mod = ftext (packageIdFS pkg) <> char ':'
+                -- the PrintUnqualified tells us which modules have to
+                -- be qualified with package names
+       | otherwise = empty

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -157,7 +207,7 @@ mkModuleFS s = Module s
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-type ModuleEnv elt = UniqFM elt
+type ModuleEnv elt = FiniteMap Module elt

 
 emptyModuleEnv       :: ModuleEnv a
 mkModuleEnv          :: [(Module, a)] -> ModuleEnv a
 
 emptyModuleEnv       :: ModuleEnv a
 mkModuleEnv          :: [(Module, a)] -> ModuleEnv a

@@ -166,6 +216,7 @@ extendModuleEnv      :: ModuleEnv a -> Module -> a -> ModuleEnv a
 extendModuleEnv_C    :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
 plusModuleEnv        :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
 extendModuleEnvList  :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
 extendModuleEnv_C    :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
 plusModuleEnv        :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
 extendModuleEnvList  :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a

+extendModuleEnvList_C  :: (a->a->a) -> ModuleEnv a -> [(Module, a)] -> ModuleEnv a

                   
 delModuleEnvList     :: ModuleEnv a -> [Module] -> ModuleEnv a
 delModuleEnv         :: ModuleEnv a -> Module -> ModuleEnv a
                   
 delModuleEnvList     :: ModuleEnv a -> [Module] -> ModuleEnv a
 delModuleEnv         :: ModuleEnv a -> Module -> ModuleEnv a

@@ -180,37 +231,45 @@ elemModuleEnv        :: Module -> ModuleEnv a -> Bool
 foldModuleEnv        :: (a -> b -> b) -> b -> ModuleEnv a -> b
 filterModuleEnv      :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a
 
 foldModuleEnv        :: (a -> b -> b) -> b -> ModuleEnv a -> b
 filterModuleEnv      :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a
 

-filterModuleEnv            = filterUFM
-elemModuleEnv       = elemUFM
-extendModuleEnv     = addToUFM
-extendModuleEnv_C   = addToUFM_C
-extendModuleEnvList = addListToUFM
-plusModuleEnv_C     = plusUFM_C
-delModuleEnvList    = delListFromUFM
-delModuleEnv        = delFromUFM
-plusModuleEnv       = plusUFM
-lookupModuleEnv     = lookupUFM
-lookupWithDefaultModuleEnv = lookupWithDefaultUFM
-mapModuleEnv        = mapUFM
-mkModuleEnv         = listToUFM
-emptyModuleEnv      = emptyUFM
-moduleEnvElts       = eltsUFM
-unitModuleEnv       = unitUFM
-isEmptyModuleEnv    = isNullUFM
-foldModuleEnv       = foldUFM
+filterModuleEnv f   = filterFM (\_ v -> f v)
+elemModuleEnv       = elemFM
+extendModuleEnv     = addToFM
+extendModuleEnv_C   = addToFM_C
+extendModuleEnvList = addListToFM
+extendModuleEnvList_C = addListToFM_C
+plusModuleEnv_C     = plusFM_C
+delModuleEnvList    = delListFromFM
+delModuleEnv        = delFromFM
+plusModuleEnv       = plusFM
+lookupModuleEnv     = lookupFM
+lookupWithDefaultModuleEnv = lookupWithDefaultFM
+mapModuleEnv f      = mapFM (\_ v -> f v)
+mkModuleEnv         = listToFM
+emptyModuleEnv      = emptyFM
+moduleEnvElts       = eltsFM
+unitModuleEnv       = unitFM
+isEmptyModuleEnv    = isEmptyFM
+foldModuleEnv f     = foldFM (\_ v -> f v)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-type ModuleSet = UniqSet Module
+type ModuleSet = FiniteMap Module ()

 mkModuleSet    :: [Module] -> ModuleSet
 extendModuleSet :: ModuleSet -> Module -> ModuleSet
 emptyModuleSet  :: ModuleSet
 moduleSetElts   :: ModuleSet -> [Module]
 elemModuleSet   :: Module -> ModuleSet -> Bool
 
 mkModuleSet    :: [Module] -> ModuleSet
 extendModuleSet :: ModuleSet -> Module -> ModuleSet
 emptyModuleSet  :: ModuleSet
 moduleSetElts   :: ModuleSet -> [Module]
 elemModuleSet   :: Module -> ModuleSet -> Bool
 

-emptyModuleSet  = emptyUniqSet
-mkModuleSet     = mkUniqSet
-extendModuleSet = addOneToUniqSet
-moduleSetElts   = uniqSetToList
-elemModuleSet   = elementOfUniqSet
+emptyModuleSet    = emptyFM
+mkModuleSet ms    = listToFM [(m,()) | m <- ms ]
+extendModuleSet s m = addToFM s m ()
+moduleSetElts     = keysFM
+elemModuleSet     = elemFM
+\end{code}
+
+A ModuleName has a Unique, so we can build mappings of these using
+UniqFM.
+
+\begin{code}
+type ModuleNameEnv elt = UniqFM elt

 \end{code}
 \end{code}