From 1867a7bb8c59ea514b4f47f5434842543933ec9a Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 5 Aug 2008 13:35:44 +0000 Subject: [PATCH] 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 --- compiler/hsSyn/HsImpExp.lhs | 10 ++++++--- compiler/iface/LoadIface.lhs | 11 ++++++--- compiler/main/DynFlags.hs | 4 +++- compiler/main/Finder.lhs | 45 ++++++++++++++++++++----------------- compiler/main/GHC.hs | 2 +- compiler/main/HeaderInfo.hs | 14 ++++++++---- compiler/main/HscStats.lhs | 2 +- compiler/main/Packages.lhs | 27 +++++++++++++--------- compiler/parser/Parser.y.pp | 8 +++++-- compiler/rename/RnEnv.lhs | 2 +- compiler/rename/RnNames.lhs | 19 +++++++++++----- docs/users_guide/flags.xml | 6 +++++ docs/users_guide/glasgow_exts.xml | 23 +++++++++++++++++++ 13 files changed, 122 insertions(+), 51 deletions(-) diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 4e58dd7..099537f 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 66cdf78..d7089f1 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 73e58c9..cf17155 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 63beae4..bbea77d 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 2ecd2f0..e1210bd 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 d0e30e0..eea6b52 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 e717bfe..3bcaac4 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 3e2c3ef..ace175d 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 67b2dca..b51edf2 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 63db61c..a4c4afd 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 9a95a85..e629dac 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} diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index ef57f13..32eb565 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -959,6 +959,12 @@ dynamic + + + Enable package-qualified imports. + dynamic + + diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 63c5dbd..1484815 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1568,6 +1568,29 @@ necessary to enable them. + + Package-qualified imports + + With the flag, GHC allows + import declarations to be qualified by the package name that the + module is intended to be imported from. For example: + + +import "network" Network.Socket + + + would import the module Network.Socket from + the package network (any version). This may + be used to disambiguate an import when the same module is + available from multiple packages, or is present in both the + current package being built and an external package. + + Note: you probably don't need to use this feature, it was + added mainly so that we can build backwards-compatible versions of + packages when APIs change. It can lead to fragile dependencies in + the common case: modules occasionally move from one package to + another, rendering any package-qualified imports broken. + -- 1.7.10.4