diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index d095040a87c..f79fbc34288 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -414,10 +414,28 @@ instance Described ForeignLibType where describe _ = REUnion ["native-shared","native-static"] instance Described IncludeRenaming where - describe _ = mr <> REOpt (RESpaces <> "requires" <> RESpaces1 <> mr) + -- Unfortunately, we can't directly use ModuleRenaming, as + -- there is some ambiguity in the grammar that we can't express + -- compositionally with regular expressions + describe _ = REUnion + [ reEps + , "requires" <> RESpaces1 <> mr + , nonempty_mr <> REOpt (RESpaces1 <> "requires" <> RESpaces1 <> mr) + ] where mr = describe (Proxy :: Proxy ModuleRenaming) + nonempty_mr = REUnion + [ "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn) + , "qualified" <> RESpaces1 <> mn + , bp (REMunch reSpacedComma entry) + ] + where + bp r = "(" <> RESpaces <> r <> RESpaces <> ")" + mn = RENamed "module-name" $ describe (Proxy :: Proxy ModuleName) + + entry = mn <> REOpt (RESpaces1 <> "as" <> RESpaces1 <> mn) + instance Described Language where describe _ = REUnion ["Haskell98", "Haskell2010"] @@ -448,6 +466,7 @@ instance Described ModuleRenaming where describe _ = REUnion [ reEps , "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn) + , "qualified" <> RESpaces1 <> mn , bp (REMunch reSpacedComma entry) ] where diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index fd984b1a78a..bd69d147fab 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -24,7 +24,7 @@ tests = testGroup "Distribution.Utils.Structured" , testCase "SPDX.License" $ structureHash (Proxy :: Proxy License) @?= md5FromInteger 0xd3d4a09f517f9f75bc3d16370d5a853a -- The difference is in encoding of newtypes #if MIN_VERSION_base(4,7,0) - , testCase "GenericPackageDescription" $ structureHash (Proxy :: Proxy GenericPackageDescription) @?= md5FromInteger 0x1e02ad776ad91e10d644d1ead8927205 - , testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= md5FromInteger 0x06bf760ed08809b56b165f72d485b9c5 + , testCase "GenericPackageDescription" $ structureHash (Proxy :: Proxy GenericPackageDescription) @?= md5FromInteger 0xf3a898a586312623fe123876e53f346c + , testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= md5FromInteger 0xeff1b7556bd8b832eae5bd8d8a33019c #endif ] diff --git a/Cabal/src/Distribution/Backpack/UnifyM.hs b/Cabal/src/Distribution/Backpack/UnifyM.hs index 6256e82f4fb..758ba96f240 100644 --- a/Cabal/src/Distribution/Backpack/UnifyM.hs +++ b/Cabal/src/Distribution/Backpack/UnifyM.hs @@ -487,6 +487,13 @@ convertInclude ci@(ComponentInclude { req_rename_list <- case req_rns of DefaultRenaming -> return [] + QualifiedRenaming _ -> do + -- TODO: support this for requires (req_rename_list + -- is a bad representation for this, alas, need + -- a bigger refactor here) + addErr $ text "Unsupported syntax" <+> + quotes (text "requires qualified (...)") + return [] HidingRenaming _ -> do -- Not valid here for requires! addErr $ text "Unsupported syntax" <+> @@ -561,6 +568,12 @@ convertInclude ci@(ComponentInclude { (pre_prov_scope, prov_rns') <- case prov_rns of DefaultRenaming -> return (Map.toList provs, prov_rns) + QualifiedRenaming prefix -> + let prov_scope0 = [ (prefix `joinModuleName` k,v) | (k,v) <- Map.toList provs ] + prov_rns0 = [ (k, prefix `joinModuleName` k) | (k,_) <- Map.toList provs ] + -- GHC doesn't understand qualification, so return + -- the expanded version + in return (prov_scope0, ModuleRenaming prov_rns0) HidingRenaming hides -> let hides_set = Set.fromList hides in let r = [ (k,v) diff --git a/Cabal/src/Distribution/ModuleName.hs b/Cabal/src/Distribution/ModuleName.hs index f23050f296a..611337dedbc 100644 --- a/Cabal/src/Distribution/ModuleName.hs +++ b/Cabal/src/Distribution/ModuleName.hs @@ -18,6 +18,7 @@ module Distribution.ModuleName ( fromString, fromComponents, components, + joinModuleName, toFilePath, main, -- * Internal @@ -44,6 +45,12 @@ newtype ModuleName = ModuleName ShortText unModuleName :: ModuleName -> String unModuleName (ModuleName s) = fromShortText s +-- Guaranteed to be valid by invariants on the initial module +-- names (in particular, empty module name is not valid) +joinModuleName :: ModuleName -> ModuleName -> ModuleName +joinModuleName a b = + ModuleName (toShortText (unModuleName a ++ "." ++ unModuleName b)) + instance Binary ModuleName instance Structured ModuleName diff --git a/Cabal/src/Distribution/Types/ModuleRenaming.hs b/Cabal/src/Distribution/Types/ModuleRenaming.hs index 581d45b9938..59fef1f1d41 100644 --- a/Cabal/src/Distribution/Types/ModuleRenaming.hs +++ b/Cabal/src/Distribution/Types/ModuleRenaming.hs @@ -41,6 +41,11 @@ data ModuleRenaming -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all -- exported modules into scope except the hidden ones. | HidingRenaming [ModuleName] + -- | Qualified renaming, @(qualified P)@, brining all + -- exported modules into scope with P prefix. So if M + -- was provided by the package, it is now in scope as + -- P.M + | QualifiedRenaming ModuleName deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) -- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' @@ -54,6 +59,8 @@ interpModuleRenaming (ModuleRenaming rns) = interpModuleRenaming (HidingRenaming hs) = let s = Set.fromList hs in \k -> if k `Set.member` s then Nothing else Just k +interpModuleRenaming (QualifiedRenaming prefix) = + \k -> Just (prefix `joinModuleName` k) -- | The default renaming, if something is specified in @build-depends@ -- only. @@ -79,6 +86,8 @@ instance Pretty ModuleRenaming where pretty DefaultRenaming = mempty pretty (HidingRenaming hides) = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) + pretty (QualifiedRenaming prefix) + = text "qualified" <+> pretty prefix pretty (ModuleRenaming rns) = parens . hsep $ punctuate comma (map dispEntry rns) where dispEntry (orig, new) @@ -109,7 +118,7 @@ moduleRenamingParsec -> m ModuleRenaming moduleRenamingParsec bp mn = -- NB: try not necessary as the first token is obvious - P.choice [ parseRename, parseHiding, return DefaultRenaming ] + P.choice [ parseRename, parseHiding, parseQualified, return DefaultRenaming ] where cma = P.char ',' >> P.spaces parseRename = do @@ -121,6 +130,11 @@ moduleRenamingParsec bp mn = P.spaces -- space isn't strictly required as next is an open paren hides <- bp (P.sepBy mn cma) return (HidingRenaming hides) + parseQualified = do + _ <- P.string "qualified" + P.skipSpaces1 -- no parenthesis after, space required + prefix <- mn + return (QualifiedRenaming prefix) parseList = P.sepBy parseEntry cma parseEntry = do diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/A.hs b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/A.hs new file mode 100644 index 00000000000..2bafce338a2 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/A.hs @@ -0,0 +1,2 @@ +module A where +import Prefix.Quxbaz diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/QualifiedIncludes.cabal b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/QualifiedIncludes.cabal new file mode 100644 index 00000000000..87cc3cf4796 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/QualifiedIncludes.cabal @@ -0,0 +1,19 @@ +name: QualifiedIncludes +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: 2.0 + +library impl + build-depends: base + exposed-modules: Foobar, Quxbaz + hs-source-dirs: impl + default-language: Haskell2010 + +library good + build-depends: base, impl + mixins: impl qualified Prefix + exposed-modules: A + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Foobar.hs b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Foobar.hs new file mode 100644 index 00000000000..eab54be4485 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Foobar.hs @@ -0,0 +1 @@ +module Foobar where diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Quxbaz.hs b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Quxbaz.hs new file mode 100644 index 00000000000..b47992788d2 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Quxbaz.hs @@ -0,0 +1 @@ +module Quxbaz where diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.cabal.out b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.cabal.out new file mode 100644 index 00000000000..5e322768ff1 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.cabal.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring QualifiedIncludes-0.1.0.0... +# Setup build +Preprocessing library 'impl' for QualifiedIncludes-0.1.0.0.. +Building library 'impl' for QualifiedIncludes-0.1.0.0.. +Preprocessing library 'good' for QualifiedIncludes-0.1.0.0.. +Building library 'good' for QualifiedIncludes-0.1.0.0.. diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.out b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.out new file mode 100644 index 00000000000..5e322768ff1 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring QualifiedIncludes-0.1.0.0... +# Setup build +Preprocessing library 'impl' for QualifiedIncludes-0.1.0.0.. +Building library 'impl' for QualifiedIncludes-0.1.0.0.. +Preprocessing library 'good' for QualifiedIncludes-0.1.0.0.. +Building library 'good' for QualifiedIncludes-0.1.0.0.. diff --git a/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.test.hs new file mode 100644 index 00000000000..0e94748ee42 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnlessGhcVersion ">= 8.1" + setup "configure" [] + setup "build" [] + return ()