Resolve #6281: Add foo:bar syntax to mixins

Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs

@@ -176,8 +176,8 @@ instance Arbitrary Bound where
 -------------------------------------------------------------------------------
 
 instance Arbitrary Mixin where
-    arbitrary = genericArbitrary
-    shrink    = genericShrink
+    arbitrary = normaliseMixin <$> genericArbitrary
+    shrink    = fmap normaliseMixin . genericShrink
 
 instance Arbitrary IncludeRenaming where
     arbitrary = genericArbitrary

Cabal/Cabal-described/src/Distribution/Described.hs

@@ -431,7 +431,9 @@ instance Described LibVersionInfo where
         reDigits = reChars ['0'..'9']
 
 instance Described Mixin where
-    describe _ = RENamed "package-name" (describe (Proxy :: Proxy PackageName)) <>
+    describe _ =
+        RENamed "package-name" (describe (Proxy :: Proxy PackageName)) <>
+        REOpt (reChar ':' <> RENamed "library-name" (describe (Proxy :: Proxy UnqualComponentName))) <>
         REOpt (RESpaces1 <> describe (Proxy :: Proxy IncludeRenaming))
 
 instance Described ModuleName where

Cabal/Cabal.cabal

@@ -156,6 +156,9 @@ extra-source-files:
   tests/ParserTests/regressions/ghc-option-j.check
   tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal
   tests/ParserTests/regressions/haddock-api-2.18.1-check.check
+  tests/ParserTests/regressions/hasktorch.cabal
+  tests/ParserTests/regressions/hasktorch.expr
+  tests/ParserTests/regressions/hasktorch.format
   tests/ParserTests/regressions/hidden-main-lib.cabal
   tests/ParserTests/regressions/hidden-main-lib.expr
   tests/ParserTests/regressions/hidden-main-lib.format

Cabal/Distribution/Backpack/ConfiguredComponent.hs

@@ -32,7 +32,6 @@ import Distribution.Types.PackageName
 import Distribution.Types.Mixin
 import Distribution.Types.ComponentName
 import Distribution.Types.LibraryName
-import Distribution.Types.UnqualComponentName
 import Distribution.Types.ComponentInclude
 import Distribution.Package
 import Distribution.PackageDescription
@@ -48,7 +47,8 @@ import qualified Data.Set as Set
 import qualified Distribution.Compat.NonEmptySet as NonEmptySet
 import qualified Data.Map as Map
 import Distribution.Pretty
-import Text.PrettyPrint
+import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$))
+import qualified Text.PrettyPrint as PP
 
 -- | A configured component, we know exactly what its 'ComponentId' is,
 -- and the 'ComponentId's of the things it depends on.
@@ -112,13 +112,12 @@ mkConfiguredComponent
 mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do
     -- Resolve each @mixins@ into the actual dependency
     -- from @lib_deps@.
-    explicit_includes <- forM (mixins bi) $ \(Mixin name rns) -> do
-        let keys = fixFakePkgName pkg_descr name
-        aid <- case Map.lookup keys deps_map of
+    explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do
+        aid <- case Map.lookup (pn, CLibName ln) deps_map of
                 Nothing ->
                     dieProgress $
-                    text "Mix-in refers to non-existent package" <+>
-                    quotes (pretty name) $$
+                    text "Mix-in refers to non-existent library" <+>
+                    quotes (pretty pn <<>> prettyLN ln) $$
                     text "(did you forget to add the package to build-depends?)"
                 Just r  -> return r
         return ComponentInclude {
@@ -150,9 +149,17 @@ mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do
             cc_includes = explicit_includes ++ implicit_includes
         }
   where
+    bi :: BuildInfo
     bi = componentBuildInfo component
+
+    prettyLN :: LibraryName -> Doc
+    prettyLN LMainLibName    = PP.empty
+    prettyLN (LSubLibName n) = PP.colon <<>> pretty n
+
+    deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId)
     deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep)
                             | dep <- lib_deps ]
+
     is_public = componentName component == CLibName LMainLibName
 
 type ConfiguredComponentMap =
@@ -179,10 +186,7 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
                     -- Return all library components
                     forM (NonEmptySet.toList sublibs) $ \lib ->
                         let comp = CLibName lib in
-                        case Map.lookup (CLibName $ LSubLibName $
-                                         packageNameToUnqualComponentName name) pkg
-                         <|> Map.lookup comp pkg
-                        of
+                        case Map.lookup comp pkg of
                             Nothing ->
                                 dieProgress $
                                     text "Dependency on unbuildable" <+>
@@ -302,19 +306,3 @@ newPackageDepsBehaviourMinVersion = CabalSpecV1_8
 newPackageDepsBehaviour :: PackageDescription -> Bool
 newPackageDepsBehaviour pkg =
    specVersion pkg >= newPackageDepsBehaviourMinVersion
-
--- | 'build-depends:' stanzas are currently ambiguous as the external packages
--- and internal libraries are specified the same. For now, we assume internal
--- libraries shadow, and this function disambiguates accordingly, but soon the
--- underlying ambiguity will be addressed.
--- Multiple public libraries (cabal 3.0) added an unambiguous way of specifying
--- sublibraries, but we still have to support the old syntax for bc reasons.
-fixFakePkgName :: PackageDescription -> PackageName -> (PackageName, ComponentName)
-fixFakePkgName pkg_descr pn =
-  if subLibName `elem` internalLibraries
-  then (packageName pkg_descr, CLibName (LSubLibName subLibName))
-  else (pn,                    CLibName LMainLibName            )
-  where
-    subLibName        = packageNameToUnqualComponentName pn
-    internalLibraries = mapMaybe (libraryNameString . libName)
-                        (allLibraries pkg_descr)

Cabal/Distribution/PackageDescription/Parsec.hs

@@ -47,7 +47,7 @@ import Distribution.Fields.LexerMonad                (LexWarning, toPWarnings)
 import Distribution.Fields.Parser
 import Distribution.Fields.ParseResult
 import Distribution.PackageDescription
-import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildDependsN)
+import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos)
 import Distribution.PackageDescription.FieldGrammar
 import Distribution.PackageDescription.Quirks        (patchQuirks)
 import Distribution.Parsec                           (parsec, simpleParsecBS)
@@ -56,6 +56,7 @@ import Distribution.Parsec.Position                  (Position (..), zeroPos)
 import Distribution.Parsec.Warning                   (PWarnType (..))
 import Distribution.Pretty                           (prettyShow)
 import Distribution.Simple.Utils                     (fromUTF8BS, toUTF8BS)
+import Distribution.Types.Mixin                      (Mixin (..), mkMixin)
 import Distribution.Utils.Generic                    (breakMaybe, unfoldrM, validateUTF8)
 import Distribution.Verbosity                        (Verbosity)
 import Distribution.Version                          (Version, mkVersion, versionNumbers)
@@ -71,6 +72,7 @@ import qualified Distribution.Types.Executable.Lens                as L
 import qualified Distribution.Types.ForeignLib.Lens                as L
 import qualified Distribution.Types.GenericPackageDescription.Lens as L
 import qualified Distribution.Types.PackageDescription.Lens        as L
+import qualified Distribution.Types.SetupBuildInfo.Lens            as L
 import qualified Text.Parsec                                       as P
 
 -- ---------------------------------------------------------------
@@ -727,14 +729,25 @@ checkForUndefinedFlags gpd = do
 -- i.e. what you write is what you get;
 -- For pre-3.4 we post-process the file.
 --
+-- Similarly, we process mixins.
+-- See https://github.com/haskell/cabal/issues/6281
+--
 
 postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription
 postProcessInternalDeps specVer gpd
     | specVer >= CabalSpecV3_4 = gpd
-    | otherwise                = transformAllBuildDependsN (concatMap f) gpd
+    | otherwise                = transformAllBuildInfos transformBI transformSBI gpd
   where
-    f :: Dependency -> [Dependency]
-    f (Dependency pn vr ln)
+    transformBI :: BuildInfo -> BuildInfo
+    transformBI
+        = over L.targetBuildDepends (concatMap transformD)
+        . over L.mixins (map transformM)
+
+    transformSBI :: SetupBuildInfo -> SetupBuildInfo
+    transformSBI = over L.setupDepends (concatMap transformD)
+
+    transformD :: Dependency -> [Dependency]
+    transformD (Dependency pn vr ln)
         | uqn `Set.member` internalLibs
         , LMainLibName `NES.member` ln
         = case NES.delete LMainLibName ln of
@@ -744,7 +757,16 @@ postProcessInternalDeps specVer gpd
         uqn = packageNameToUnqualComponentName pn
         dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn))
 
-    f d = [d]
+    transformD d = [d]
+
+    transformM :: Mixin -> Mixin
+    transformM (Mixin pn LMainLibName incl)
+        | uqn `Set.member` internalLibs
+        = mkMixin thisPn (LSubLibName uqn) incl
+      where
+        uqn = packageNameToUnqualComponentName pn
+
+    transformM m = m
 
     thisPn :: PackageName
     thisPn = pkgName (package (packageDescription gpd))

Cabal/Distribution/PackageDescription/PrettyPrint.hs

@@ -33,17 +33,20 @@ import Prelude ()
 
 import Distribution.CabalSpecVersion
 import Distribution.Fields.Pretty
+import Distribution.Compat.Lens
 import Distribution.PackageDescription
 import Distribution.Pretty
-import Distribution.Simple.Utils
-
+import Distribution.Simple.Utils (writeFileAtomic, writeUTF8File)
+import Distribution.Types.Mixin                      (Mixin (..), mkMixin)
 import Distribution.FieldGrammar                     (PrettyFieldGrammar', prettyFieldGrammar)
-import Distribution.PackageDescription.Configuration (transformAllBuildDependsN)
+import Distribution.PackageDescription.Configuration (transformAllBuildInfos)
 import Distribution.PackageDescription.FieldGrammar
        (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar,
        packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar)
 
 import qualified Distribution.PackageDescription.FieldGrammar as FG
+import qualified Distribution.Types.BuildInfo.Lens                 as L
+import qualified Distribution.Types.SetupBuildInfo.Lens            as L
 
 import Text.PrettyPrint (Doc, char, hsep, parens, text)
 
@@ -228,10 +231,18 @@ pdToGpd pd = GenericPackageDescription
 preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription
 preProcessInternalDeps specVer gpd
     | specVer >= CabalSpecV3_4 = gpd
-    | otherwise                = transformAllBuildDependsN (concatMap f) gpd
+    | otherwise                = transformAllBuildInfos transformBI transformSBI gpd
   where
-    f :: Dependency -> [Dependency]
-    f (Dependency pn vr ln)
+    transformBI :: BuildInfo -> BuildInfo
+    transformBI
+        = over L.targetBuildDepends (concatMap transformD)
+        . over L.mixins (map transformM)
+
+    transformSBI :: SetupBuildInfo -> SetupBuildInfo
+    transformSBI = over L.setupDepends (concatMap transformD)
+
+    transformD :: Dependency -> [Dependency]
+    transformD (Dependency pn vr ln)
         | pn == thisPn
         = if LMainLibName `NES.member` ln
           then Dependency thisPn vr mainLibSet : sublibs
@@ -242,7 +253,13 @@ preProcessInternalDeps specVer gpd
             | LSubLibName uqn <- NES.toList ln
             ]
 
-    f d = [d]
+    transformD d = [d]
+
+    transformM :: Mixin -> Mixin
+    transformM (Mixin pn (LSubLibName uqn) inc)
+        | pn == thisPn
+        = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc
+    transformM m = m
 
     thisPn :: PackageName
     thisPn = pkgName (package (packageDescription gpd))

Cabal/Distribution/Types/GenericPackageDescription.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Distribution.Types.GenericPackageDescription (
     GenericPackageDescription(..),
@@ -74,14 +75,31 @@ emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescripti
 -- Traversal Instances
 
 instance L.HasBuildInfos GenericPackageDescription where
-  traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
-    GenericPackageDescription
-        <$> L.traverseBuildInfos f p
-        <*> pure v
-        <*> pure a1
-        <*> (traverse . traverse . L.buildInfo) f x1
-        <*> (traverse . L._2 . traverse . L.buildInfo) f x2
-        <*> (traverse . L._2 . traverse . L.buildInfo) f x3
-        <*> (traverse . L._2 . traverse . L.buildInfo) f x4
-        <*> (traverse . L._2 . traverse . L.buildInfo) f x5
-        <*> (traverse . L._2 . traverse . L.buildInfo) f x6
+    traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
+        GenericPackageDescription
+            <$> L.traverseBuildInfos f p
+            <*> pure v
+            <*> pure a1
+            <*> (traverse . traverseCondTreeBuildInfo) f x1
+            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2
+            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3
+            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4
+            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5
+            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6
+      where
+
+-- We use this traversal to keep [Dependency] field in CondTree up to date.
+traverseCondTreeBuildInfo
+    :: forall f comp v. (Applicative f, L.HasBuildInfo comp)
+    => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo
+traverseCondTreeBuildInfo g = node where
+    mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp
+    mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches
+
+    node (CondNode comp _ branches) = mkCondNode
+        <$> L.buildInfo g comp
+        <*> traverse branch branches
+
+    branch (CondBranch v x y) = CondBranch v
+        <$> node x
+        <*> traverse node y

Cabal/Distribution/Types/Mixin.hs

@@ -3,19 +3,32 @@
 
 module Distribution.Types.Mixin (
     Mixin(..),
+    mkMixin,
+    normaliseMixin,
 ) where
 
 import Distribution.Compat.Prelude
 import Prelude ()
 
+import Distribution.CabalSpecVersion
 import Distribution.Parsec
 import Distribution.Pretty
 import Distribution.Types.IncludeRenaming
+import Distribution.Types.LibraryName
 import Distribution.Types.PackageName
+import Distribution.Types.UnqualComponentName
 
 import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint                as PP
 
+-- |
+--
+-- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not
+-- the same as 'mixinPackageName'. In other words,
+-- the same invariant as 'Dependency' has.
+--
 data Mixin = Mixin { mixinPackageName :: PackageName
+                   , mixinLibraryName :: LibraryName
                    , mixinIncludeRenaming :: IncludeRenaming }
     deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
 
@@ -25,11 +38,54 @@ instance Structured Mixin
 instance NFData Mixin where rnf = genericRnf
 
 instance Pretty Mixin where
-    pretty (Mixin pkg_name incl) = pretty pkg_name <+> pretty incl
+    pretty (Mixin pn LMainLibName incl)     = pretty pn <+> pretty incl
+    pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl
 
+-- |
+--
+-- >>>  simpleParsec "mylib" :: Maybe Mixin
+-- Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})
+--
+-- >>>  simpleParsec "thatlib:sublib" :: Maybe Mixin
+-- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LSubLibName (UnqualComponentName "sublib"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})
+--
+-- >>>  simpleParsec "thatlib:thatlib" :: Maybe Mixin
+-- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})
+--
+-- Sublibrary syntax is accepted since @cabal-version: 3.4@.
+--
+-- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin]
+-- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})]
+--
 instance Parsec Mixin where
     parsec = do
-        mod_name <- parsec
+        pn <- parsec
+        ln <- P.option LMainLibName $ do
+            _ <- P.char ':'
+            versionGuardMultilibs
+            parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)"
+            LSubLibName <$> parsec
         P.spaces
         incl <- parsec
-        return (Mixin mod_name incl)
+        return (mkMixin pn ln incl)
+      where
+
+versionGuardMultilibs :: CabalParsing m => m ()
+versionGuardMultilibs = do
+  csv <- askCabalSpecVersion
+  when (csv < CabalSpecV3_4) $ fail $ unwords
+    [ "Sublibrary mixin syntax used."
+    , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'."
+    ]
+
+-- | Smart constructor of 'Mixin', enforces invariant.
+mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin
+mkMixin pn (LSubLibName uqn) incl
+    | packageNameToUnqualComponentName pn == uqn
+    = Mixin pn LMainLibName incl
+mkMixin pn ln incl
+    = Mixin pn ln incl
+
+-- | Restore invariant
+normaliseMixin :: Mixin -> Mixin
+normaliseMixin (Mixin pn ln incl) = mkMixin pn ln incl