Commit 1a7d1b77 authored by Simon Marlow's avatar Simon Marlow

refactoring only: use the parameterised InstalledPackageInfo

This required moving PackageId from PackageConfig to Module
parent e9325082
module Module where
data Module
data ModuleName
data PackageId
moduleName :: Module -> ModuleName
modulePackageId :: Module -> PackageConfig.PackageId
modulePackageId :: Module -> PackageId
packageIdString :: PackageId -> GHC.Base.String
......@@ -9,13 +9,6 @@ These are Uniquable, hence we can build FiniteMaps with Modules as
the keys.
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Module
(
-- * The ModuleName type
......@@ -26,6 +19,21 @@ module Module
mkModuleName,
mkModuleNameFS,
-- * The PackageId type
PackageId,
fsToPackageId,
packageIdFS,
stringToPackageId,
packageIdString,
-- * Wired-in PackageIds
basePackageId,
rtsPackageId,
haskell98PackageId,
thPackageId,
ndpPackageId,
mainPackageId,
-- * The Module type
Module,
modulePackageId, moduleName,
......@@ -55,10 +63,10 @@ module Module
#include "HsVersions.h"
import Outputable
import qualified Pretty
import Unique
import FiniteMap
import UniqFM
import PackageConfig
import FastString
import Binary
\end{code}
......@@ -188,12 +196,16 @@ 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)
instance Uniquable PackageId where
getUnique pid = getUnique (packageIdFS pid)
mkModule :: PackageId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n
pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
......@@ -207,6 +219,70 @@ pprPackagePrefix p mod = getPprStyle doc
| otherwise = empty
\end{code}
%************************************************************************
%* *
\subsection{PackageId}
%* *
%************************************************************************
\begin{code}
newtype PackageId = PId FastString deriving( Eq, Ord ) -- includes the version
-- here to avoid module loops with PackageConfig
instance Outputable PackageId where
ppr pid = text (packageIdString pid)
instance Binary PackageId where
put_ bh pid = put_ bh (packageIdFS pid)
get bh = do { fs <- get bh; return (fsToPackageId fs) }
fsToPackageId :: FastString -> PackageId
fsToPackageId = PId
packageIdFS :: PackageId -> FastString
packageIdFS (PId fs) = fs
stringToPackageId :: String -> PackageId
stringToPackageId = fsToPackageId . mkFastString
packageIdString :: PackageId -> String
packageIdString = unpackFS . packageIdFS
-- -----------------------------------------------------------------------------
-- Package Ids that are wired in
-- Certain packages are "known" to the compiler, in that we know about certain
-- entities that reside in these packages, and the compiler needs to
-- declare static Modules and Names that refer to these packages. Hence
-- the wired-in packages can't include version numbers, since we don't want
-- to bake the version numbers of these packages into GHC.
--
-- So here's the plan. Wired-in packages are still versioned as
-- normal in the packages database, and you can still have multiple
-- versions of them installed. However, for each invocation of GHC,
-- only a single instance of each wired-in package will be recognised
-- (the desired one is selected via -package/-hide-package), and GHC
-- will use the unversioned PackageId below when referring to it,
-- including in .hi files and object file symbols. Unselected
-- versions of wired-in packages will be ignored, as will any other
-- package that depends directly or indirectly on it (much as if you
-- had used -ignore-package).
basePackageId, rtsPackageId, haskell98PackageId,
thPackageId, ndpPackageId, mainPackageId :: PackageId
basePackageId = fsToPackageId FSLIT("base")
rtsPackageId = fsToPackageId FSLIT("rts")
haskell98PackageId = fsToPackageId FSLIT("haskell98")
thPackageId = fsToPackageId FSLIT("template-haskell")
ndpPackageId = fsToPackageId FSLIT("ndp")
-- This is the package Id for the program. It is the default package
-- Id if you don't specify a package name. We don't add this prefix
-- to symbol name, since there can be only one main package per program.
mainPackageId = fsToPackageId FSLIT("main")
\end{code}
%************************************************************************
%* *
\subsection{@ModuleEnv@s}
......
\begin{code}
module Module where
import PackageConfig (PackageId)
data Module
data ModuleName
data PackageId
moduleName :: Module -> ModuleName
modulePackageId :: Module -> PackageId
packageIdString :: PackageId -> String
\end{code}
......@@ -58,7 +58,6 @@ module Unique (
#include "HsVersions.h"
import BasicTypes
import PackageConfig
import FastString
import Outputable
......@@ -155,9 +154,6 @@ x `hasKey` k = getUnique x == k
instance Uniquable FastString where
getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs))
instance Uniquable PackageId where
getUnique pid = getUnique (packageIdFS pid)
instance Uniquable Int where
getUnique i = mkUniqueGrimily i
\end{code}
......
......@@ -55,6 +55,7 @@ import SrcLoc
import VarSet
import VarEnv
import Name
import Module
#if mingw32_TARGET_OS
import Packages
#endif
......@@ -70,7 +71,6 @@ import TyCon
import TysWiredIn
import CostCentre
import BasicTypes
import PackageConfig
import Unique
import Outputable
import DynFlags
......
......@@ -1448,7 +1448,7 @@ getCommonPrefix (s:ss) = foldl common s ss
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules dflags
= map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
= concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
where
pkg_db = pkgIdMap (pkgState dflags)
#else
......
......@@ -30,7 +30,6 @@ import Finder ( mkStubPaths )
import PprC ( writeCs )
import CmmLint ( cmmLint )
import Packages
import PackageConfig ( rtsPackageId )
import Util
import FastString ( unpackFS )
import Cmm ( RawCmm )
......@@ -40,7 +39,7 @@ import DynFlags
import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
import Pretty ( Mode(..), printDoc )
import Module ( Module, ModLocation(..), moduleName )
import Module
import List ( nub )
import Maybes ( firstJust )
......
......@@ -61,7 +61,7 @@ module DynFlags (
#include "HsVersions.h"
import Module ( Module, mkModuleName, mkModule, ModLocation )
import Module
import PackageConfig
import PrelNames ( mAIN )
#ifdef i386_TARGET_ARCH
......@@ -381,7 +381,7 @@ data DynFlags = DynFlags {
-- Package state
-- NB. do not modify this field, it is calculated by
-- Packages.initPackages and Packages.updatePackages.
pkgDatabase :: Maybe (UniqFM InstalledPackageInfo),
pkgDatabase :: Maybe (UniqFM PackageConfig),
pkgState :: PackageState,
-- hsc dynamic flags
......
......@@ -4,13 +4,6 @@
\section[Finder]{Module Finder}
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Finder (
flushFinderCaches,
FindResult(..),
......@@ -530,7 +523,7 @@ findObjectLinkableMaybe mod locn
findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable
findObjectLinkable mod obj_fn obj_time = do
let stub_fn = case splitFilename3 obj_fn of
(dir, base, ext) -> dir ++ "/" ++ base ++ "_stub.o"
(dir, base, _ext) -> dir ++ "/" ++ base ++ "_stub.o"
stub_exist <- doesFileExist stub_fn
if stub_exist
then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
......
......@@ -244,7 +244,6 @@ import Module
import UniqFM
import UniqSet
import Unique
import PackageConfig
import FiniteMap
import Panic
import Digraph
......
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
--
-- (c) The University of Glasgow, 2004
--
module PackageConfig (
-- * PackageId
PackageId,
mkPackageId, stringToPackageId, packageIdString, packageConfigId,
packageIdFS, fsToPackageId, unpackPackageId,
mkPackageId, packageConfigId, unpackPackageId,
-- * The PackageConfig type: information about a package
PackageConfig,
InstalledPackageInfo(..), showPackageId,
InstalledPackageInfo_(..), showPackageId,
Version(..),
PackageIdentifier(..),
defaultPackageConfig,
-- * Wired-in PackageIds
basePackageId,
rtsPackageId,
haskell98PackageId,
thPackageId,
ndpPackageId,
mainPackageId
) where
#include "HsVersions.h"
import Module
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
import FastString
import Distribution.Compat.ReadP ( readP_to_S )
-- warning suppression
_unused :: FS.FastString
_unused = FSLIT("")
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we
-- might need to extend it with some GHC-specific stuff, but for now it's fine.
type PackageConfig = InstalledPackageInfo
type PackageConfig = InstalledPackageInfo_ ModuleName
defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo
-- -----------------------------------------------------------------------------
......@@ -60,22 +48,6 @@ defaultPackageConfig = emptyInstalledPackageInfo
--
-- A PackageId is a string of the form <pkg>-<version>.
newtype PackageId = PId FastString deriving( Eq, Ord ) -- includes the version
-- easier not to use a newtype here, because we need instances of
-- Binary & Outputable, and we're too early to define them
fsToPackageId :: FastString -> PackageId
fsToPackageId = PId
packageIdFS :: PackageId -> FastString
packageIdFS (PId fs) = fs
stringToPackageId :: String -> PackageId
stringToPackageId = fsToPackageId . mkFastString
packageIdString :: PackageId -> String
packageIdString = unpackFS . packageIdFS
mkPackageId :: PackageIdentifier -> PackageId
mkPackageId = stringToPackageId . showPackageId
......@@ -88,35 +60,3 @@ unpackPackageId p
[] -> Nothing
(pid:_) -> Just pid
where str = packageIdString p
-- -----------------------------------------------------------------------------
-- Package Ids that are wired in
-- Certain packages are "known" to the compiler, in that we know about certain
-- entities that reside in these packages, and the compiler needs to
-- declare static Modules and Names that refer to these packages. Hence
-- the wired-in packages can't include version numbers, since we don't want
-- to bake the version numbers of these packages into GHC.
--
-- So here's the plan. Wired-in packages are still versioned as
-- normal in the packages database, and you can still have multiple
-- versions of them installed. However, for each invocation of GHC,
-- only a single instance of each wired-in package will be recognised
-- (the desired one is selected via -package/-hide-package), and GHC
-- will use the unversioned PackageId below when referring to it,
-- including in .hi files and object file symbols. Unselected
-- versions of wired-in packages will be ignored, as will any other
-- package that depends directly or indirectly on it (much as if you
-- had used -ignore-package).
basePackageId = fsToPackageId FSLIT("base")
rtsPackageId = fsToPackageId FSLIT("rts")
haskell98PackageId = fsToPackageId FSLIT("haskell98")
thPackageId = fsToPackageId FSLIT("template-haskell")
ndpPackageId = fsToPackageId FSLIT("ndp")
-- This is the package Id for the program. It is the default package
-- Id if you don't specify a package name. We don't add this prefix
-- to symbol name, since there can be only one main package per program.
mainPackageId = fsToPackageId FSLIT("main")
......@@ -557,12 +557,12 @@ mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
extend_modmap pkgid modmap =
addListToUFM_C (++) modmap
[(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
([(m, [(pkg, True)]) | m <- exposed_mods] ++
[(m, [(pkg, False)]) | m <- hidden_mods])
where
pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
exposed_mods = map mkModuleName (exposedModules pkg)
hidden_mods = map mkModuleName (hiddenModules pkg)
all_mods = exposed_mods ++ hidden_mods
exposed_mods = exposedModules pkg
hidden_mods = hiddenModules pkg
pprPkg :: PackageConfig -> SDoc
pprPkg p = text (showPackageId (package p))
......@@ -704,5 +704,10 @@ dumpPackages :: DynFlags -> IO ()
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
putMsg dflags $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
vcat (map (text.showInstalledPackageInfo.to_ipi) (eltsUFM pkg_map))
where
to_ipi pkgconf@InstalledPackageInfo_{ exposedModules = e,
hiddenModules = h } =
pkgconf{ exposedModules = map moduleNameString e,
hiddenModules = map moduleNameString h }
\end{code}
......@@ -12,6 +12,7 @@ module ParsePkgConf( loadPackageConfig ) where
import PackageConfig
import Lexer
import Module
import DynFlags
import FastString
import StringBuffer
......@@ -82,27 +83,27 @@ field :: { PackageConfig -> PackageConfig }
-- another case of license
| VARID '=' strlist
{\p -> case unpackFS $1 of
"exposedModules" -> p{exposedModules = $3}
"hiddenModules" -> p{hiddenModules = $3}
"importDirs" -> p{importDirs = $3}
"libraryDirs" -> p{libraryDirs = $3}
"hsLibraries" -> p{hsLibraries = $3}
"extraLibraries" -> p{extraLibraries = $3}
"extraGHCiLibraries"-> p{extraGHCiLibraries= $3}
"includeDirs" -> p{includeDirs = $3}
"includes" -> p{includes = $3}
"hugsOptions" -> p{hugsOptions = $3}
"ccOptions" -> p{ccOptions = $3}
"ldOptions" -> p{ldOptions = $3}
"frameworkDirs" -> p{frameworkDirs = $3}
"frameworks" -> p{frameworks = $3}
"haddockInterfaces" -> p{haddockInterfaces = $3}
"haddockHTMLs" -> p{haddockHTMLs = $3}
"depends" -> p{depends = []}
-- empty list only, non-empty handled below
other -> p
}
{\p -> case unpackFS $1 of
"exposedModules" -> p{exposedModules = map mkModuleNameFS $3}
"hiddenModules" -> p{hiddenModules = map mkModuleNameFS $3}
"importDirs" -> p{importDirs = map unpackFS $3}
"libraryDirs" -> p{libraryDirs = map unpackFS $3}
"hsLibraries" -> p{hsLibraries = map unpackFS $3}
"extraLibraries" -> p{extraLibraries = map unpackFS $3}
"extraGHCiLibraries"-> p{extraGHCiLibraries= map unpackFS $3}
"includeDirs" -> p{includeDirs = map unpackFS $3}
"includes" -> p{includes = map unpackFS $3}
"hugsOptions" -> p{hugsOptions = map unpackFS $3}
"ccOptions" -> p{ccOptions = map unpackFS $3}
"ldOptions" -> p{ldOptions = map unpackFS $3}
"frameworkDirs" -> p{frameworkDirs = map unpackFS $3}
"frameworks" -> p{frameworks = map unpackFS $3}
"haddockInterfaces" -> p{haddockInterfaces = map unpackFS $3}
"haddockHTMLs" -> p{haddockHTMLs = map unpackFS $3}
"depends" -> p{depends = []}
-- empty list only, non-empty handled below
other -> p
}
| VARID '=' pkgidlist
{% case unpackFS $1 of
......@@ -117,7 +118,8 @@ pkgid :: { PackageIdentifier }
version :: { Version }
: CONID '{' VARID '=' intlist ',' VARID '=' strlist '}'
{ Version{ versionBranch=$5, versionTags=$9 } }
{ Version{ versionBranch=$5,
versionTags=map unpackFS $9 } }
pkgidlist :: { [PackageIdentifier] }
: '[' pkgids ']' { $2 }
......@@ -135,13 +137,13 @@ ints :: { [Int] }
: INT { [ fromIntegral $1 ] }
| INT ',' ints { fromIntegral $1 : $3 }
strlist :: { [String] }
strlist :: { [FastString] }
: '[' ']' { [] }
| '[' strs ']' { $2 }
strs :: { [String] }
: STRING { [ unpackFS $1 ] }
| STRING ',' strs { unpackFS $1 : $3 }
strs :: { [FastString] }
: STRING { [ $1 ] }
| STRING ',' strs { $1 : $3 }
{
happyError :: P a
......
......@@ -47,11 +47,10 @@ import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon,
newTyConRep, tyConSelIds, isAlgTyCon,
isEnumerationTyCon, isOpenTyCon )
import Class ( classSelIds )
import Module ( Module )
import Module
import HscTypes
import Maybes ( orElse, mapCatMaybes )
import ErrUtils ( showPass, dumpIfSet_core )
import PackageConfig ( PackageId )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import Outputable
import FastTypes hiding ( fastOr )
......
......@@ -20,7 +20,6 @@ import Type ( Kind,
)
import Name( Name, nameOccName, nameModule, mkExternalName )
import Module
import PackageConfig ( mainPackageId, stringToPackageId )
import ParserCoreUtils
import LexCore
import Literal
......
......@@ -56,8 +56,7 @@ module PrelNames (
#include "HsVersions.h"
import PackageConfig
import Module ( Module, ModuleName, mkModule, mkModuleNameFS )
import Module
import OccName ( dataName, tcName, clsName, varName, mkOccNameFS,
mkVarOccFS )
import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual )
......
......@@ -36,12 +36,11 @@ module SCCfinal ( stgMassageForProfiling ) where
import StgSyn
import PackageConfig ( PackageId )
import StaticFlags ( opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
import Id
import Name
import Module ( Module )
import Module
import UniqSupply ( splitUniqSupply, UniqSupply )
#ifdef PROF_DO_BOXING
import UniqSupply ( uniqFromSupply )
......
......@@ -36,7 +36,7 @@ import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
import StaticFlags ( opt_RuntimeTypes )
import PackageConfig ( PackageId )
import Module
import Outputable
infixr 9 `thenLne`
......
......@@ -59,7 +59,6 @@ import Var ( isId )
import Id ( Id, idName, idType, idCafInfo )
import IdInfo ( mayHaveCafRefs )
import Packages ( isDllName )
import PackageConfig ( PackageId )
import Literal ( Literal, literalType )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
......@@ -74,7 +73,7 @@ import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Unique ( Unique )
import Bitmap
import StaticFlags ( opt_SccProfilingOn )
import Module ( Module, pprModule )
import Module
\end{code}
%************************************************************************
......
......@@ -66,7 +66,6 @@ import Unique
import Panic
import UniqFM
import FastMutInt
import PackageConfig
import Foreign
import Data.Array.IO
......@@ -667,10 +666,6 @@ getFS bh = do
--
go 0
instance Binary PackageId where
put_ bh pid = put_ bh (packageIdFS pid)
get bh = do { fs <- get bh; return (fsToPackageId fs) }
instance Binary FastString where
put_ bh f@(FastString id l _ fp _) =
case getUserData bh of {
......
......@@ -51,12 +51,10 @@ module Outputable (
#include "HsVersions.h"
import {-# SOURCE #-} Module( Module,
ModuleName, moduleName )
import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
import PackageConfig ( PackageId, packageIdString )
import FastString
import FastTypes
import GHC.Ptr
......@@ -477,9 +475,6 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
instance Outputable FastString where
ppr fs = ftext fs -- Prints an unadorned string,
-- no double quotes or anything
instance Outputable PackageId where
ppr pid = text (packageIdString pid)
\end{code}
......
......@@ -30,8 +30,7 @@ import TypeRep ( funTyCon )
import Type ( Type )
import TysPrim
import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
import Module ( Module, mkModule, mkModuleNameFS )
import PackageConfig ( ndpPackageId )
import Module
import BasicTypes ( Boxity(..) )
import FastString
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment