X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FModule.lhs;h=4b59757c6a286c560a621611a80518859d2ffed7;hb=70b6c54b3c140d96b69287f8f400f88a0b7e9c18;hp=0e81b9d10ea857b77cc5c17c6a7f21b28f166e4d;hpb=0171936c9092666692c69a7f93fa75af976330cb;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 0e81b9d..4b59757 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -41,8 +41,8 @@ module Module ( Module, -- Abstract, instance of Eq, Ord, Outputable - , PackageName -- = FastString; instance of Outputable, Uniquable - , preludePackage -- :: PackageName + , ModLocation(..), + , showModMsg , ModuleName , pprModuleName -- :: ModuleName -> SDoc @@ -56,10 +56,8 @@ module Module , moduleString -- :: Module -> EncodedString , moduleUserString -- :: Module -> UserString - , mkVanillaModule -- :: ModuleName -> Module - , isVanillaModule -- :: Module -> Bool - , mkPrelModule -- :: UserString -> Module - , mkModule -- :: ModuleName -> PackageName -> Module + , mkBasePkgModule -- :: UserString -> Module + , mkThPkgModule -- :: UserString -> Module , mkHomeModule -- :: ModuleName -> Module , isHomeModule -- :: Module -> Bool , mkPackageModule -- :: ModuleName -> Module @@ -70,15 +68,13 @@ module Module , pprModule, - -- Where to find a .hi file - , WhereFrom(..) - , ModuleEnv, , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv - , lookupModuleEnvByName, extendModuleEnv_C + , extendModuleEnv_C + , lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet @@ -87,12 +83,15 @@ module Module #include "HsVersions.h" import OccName import Outputable +import Packages ( PackageName, basePackage, thPackage ) import CmdLineOpts ( opt_InPackage ) import FastString ( FastString ) import Unique ( Uniquable(..) ) +import Maybes ( expectJust ) import UniqFM import UniqSet import Binary +import FastString \end{code} @@ -118,29 +117,13 @@ renamer href here.) \begin{code} data Module = Module ModuleName !PackageInfo -instance Binary Module where - put_ bh (Module m p) = put_ bh m - get bh = do m <- get bh; return (Module m DunnoYet) - data PackageInfo = ThisPackage -- A module from the same package -- as the one being compiled | AnotherPackage -- A module from a different package - | DunnoYet -- This is used when we don't yet know - -- Main case: we've come across Foo.x in an interface file - -- but we havn't yet opened Foo.hi. We need a Name for Foo.x - -- Later on (in RnEnv.newTopBinder) we'll update the cache - -- to have the right PackageName - -type PackageName = FastString -- No encoding at all - -preludePackage :: PackageName -preludePackage = FSLIT("std") - packageInfoPackage :: PackageInfo -> PackageName packageInfoPackage ThisPackage = opt_InPackage -packageInfoPackage DunnoYet = FSLIT("") packageInfoPackage AnotherPackage = FSLIT("") instance Outputable PackageInfo where @@ -151,28 +134,52 @@ instance Outputable PackageInfo where %************************************************************************ %* * -\subsection{Where from} +\subsection{Module locations} %* * %************************************************************************ -The @WhereFrom@ type controls where the renamer looks for an interface file - \begin{code} -data WhereFrom = ImportByUser -- Ordinary user import: look for M.hi - | ImportByUserSource -- User {- SOURCE -}: look for M.hi-boot - | ImportBySystem -- Non user import. Look for M.hi if M is in - -- the module this module depends on, or is a system-ish module; - -- M.hi-boot otherwise - | ImportByCmdLine -- The user typed a qualified name at - -- the GHCi prompt, try to demand-load - -- the interface. - -instance Outputable WhereFrom where - ppr ImportByUser = empty - ppr ImportByUserSource = ptext SLIT("{- SOURCE -}") - ppr ImportBySystem = ptext SLIT("{- SYSTEM IMPORT -}") +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + + ml_hspp_file :: Maybe FilePath, -- Path of preprocessed source + + ml_hi_file :: FilePath, -- Where the .hi file is, whether or not it exists + -- Always of form foo.hi, even if there is an hi-boot + -- file (we add the -boot suffix later) + + ml_obj_file :: FilePath -- Where the .o file is, whether or not it exists + -- (might not exist either because the module + -- hasn't been compiled yet, or because + -- it is part of a package with a .a file) + } + deriving Show + +instance Outputable ModLocation where + ppr = text . show + +-- Rather a gruesome function to have in Module + +showModMsg :: Bool -> Module -> ModLocation -> String +showModMsg use_object mod location = + mod_str ++ replicate (max 0 (16 - length mod_str)) ' ' + ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", " + ++ (if use_object + then ml_obj_file location + else "interpreted") + ++ " )" + where mod_str = moduleUserString mod \end{code} +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. + %************************************************************************ %* * @@ -212,14 +219,14 @@ moduleNameFS :: ModuleName -> EncodedFS moduleNameFS (ModuleName mod) = mod moduleNameString :: ModuleName -> EncodedString -moduleNameString (ModuleName mod) = _UNPK_ mod +moduleNameString (ModuleName mod) = unpackFS mod moduleNameUserString :: ModuleName -> UserString -moduleNameUserString (ModuleName mod) = decode (_UNPK_ mod) +moduleNameUserString (ModuleName mod) = decode (unpackFS mod) -- used to be called mkSrcModule mkModuleName :: UserString -> ModuleName -mkModuleName s = ModuleName (_PK_ (encode s)) +mkModuleName s = ModuleName (mkFastString (encode s)) -- used to be called mkSrcModuleFS mkModuleNameFS :: UserFS -> ModuleName @@ -254,21 +261,30 @@ pprModule :: Module -> SDoc pprModule (Module mod p) = getPprStyle $ \ sty -> if debugStyle sty then -- Print the package too - ppr p <> dot <> pprModuleName mod + -- Don't use '.' because it gets confused + -- with module names + brackets (ppr p) <> pprModuleName mod else pprModuleName mod \end{code} \begin{code} -mkModule :: ModuleName -- Name of the module - -> PackageName - -> Module -mkModule mod_nm pack_name +mkBasePkgModule :: ModuleName -> Module +mkBasePkgModule mod_nm = Module mod_nm pack_info where - pack_info | pack_name == opt_InPackage = ThisPackage - | otherwise = AnotherPackage + pack_info + | opt_InPackage == basePackage = ThisPackage + | otherwise = AnotherPackage + +mkThPkgModule :: ModuleName -> Module +mkThPkgModule mod_nm + = Module mod_nm pack_info + where + pack_info + | opt_InPackage == thPackage = ThisPackage + | otherwise = AnotherPackage mkHomeModule :: ModuleName -> Module mkHomeModule mod_nm = Module mod_nm ThisPackage @@ -280,21 +296,8 @@ isHomeModule _ = False mkPackageModule :: ModuleName -> Module mkPackageModule mod_nm = Module mod_nm AnotherPackage --- Used temporarily when we first come across Foo.x in an interface --- file, but before we've opened Foo.hi. --- (Until we've opened Foo.hi we don't know what the Package is.) -mkVanillaModule :: ModuleName -> Module -mkVanillaModule name = Module name DunnoYet - -isVanillaModule :: Module -> Bool -isVanillaModule (Module nm DunnoYet) = True -isVanillaModule _ = False - -mkPrelModule :: ModuleName -> Module -mkPrelModule name = mkModule name preludePackage - moduleString :: Module -> EncodedString -moduleString (Module (ModuleName fs) _) = _UNPK_ fs +moduleString (Module (ModuleName fs) _) = unpackFS fs moduleName :: Module -> ModuleName moduleName (Module mod pkg_info) = mod @@ -317,6 +320,9 @@ printModulePrefix _ = True \begin{code} type ModuleEnv elt = UniqFM elt +-- A ModuleName and Module have the same Unique, +-- so both will work as keys. +-- The 'ByName' variants work on ModuleNames emptyModuleEnv :: ModuleEnv a mkModuleEnv :: [(Module, a)] -> ModuleEnv a @@ -334,13 +340,18 @@ moduleEnvElts :: ModuleEnv a -> [a] isEmptyModuleEnv :: ModuleEnv a -> Bool lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnvByName:: ModuleEnv a -> ModuleName -> Maybe a lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a elemModuleEnv :: Module -> ModuleEnv a -> Bool foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +-- The ByName variants +lookupModuleEnvByName :: ModuleEnv a -> ModuleName -> Maybe a +unitModuleEnvByName :: ModuleName -> a -> ModuleEnv a +extendModuleEnvByName :: ModuleEnv a -> ModuleName -> a -> ModuleEnv a + elemModuleEnv = elemUFM extendModuleEnv = addToUFM +extendModuleEnvByName = addToUFM extendModuleEnv_C = addToUFM_C extendModuleEnvList = addListToUFM plusModuleEnv_C = plusUFM_C @@ -355,6 +366,7 @@ mkModuleEnv = listToUFM emptyModuleEnv = emptyUFM moduleEnvElts = eltsUFM unitModuleEnv = unitUFM +unitModuleEnvByName = unitUFM isEmptyModuleEnv = isNullUFM foldModuleEnv = foldUFM \end{code}