checkpoint

Cabal-syntax/Cabal-syntax.cabal

@@ -132,6 +132,7 @@ library
     Distribution.Types.Condition
     Distribution.Types.ConfVar
     Distribution.Types.Dependency
+    Distribution.Types.Dependency.Lens
     Distribution.Types.DependencyMap
     Distribution.Types.ExeDependency
     Distribution.Types.Executable

Cabal-syntax/src/Distribution/FieldGrammar/Class.hs

@@ -133,6 +133,20 @@ class
     -- ^ lens into the field
     -> g s a
 
+  -- | Like monoidalFieldAla but the field-name can have a parsed suffix
+  monoidalFieldPrefixAla
+    :: (c b, c d, Monoid a)
+    => FieldName
+    -- ^ field name prefix
+    -- b = parsing rest of prefix field
+    -- d = parsing contents of field
+    -> (a -> [(b, d)])
+    -> ([(b, d)] -> a)
+    -- ^ 'pack'
+    -> ALens' s a
+    -- ^ lens into the field
+    -> g s a
+
   -- | Parser matching all fields with a name starting with a prefix.
   prefixedFields
     :: FieldName

Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 
 -- | This module provides a 'FieldGrammarParser', one way to parse
 -- @.cabal@ -like files.
@@ -73,6 +75,7 @@ import Distribution.Utils.String (trim)
 import Prelude ()
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -87,6 +90,9 @@ import Distribution.Fields.ParseResult
 import Distribution.Parsec
 import Distribution.Parsec.FieldLineStream
 import Distribution.Parsec.Position (positionCol, positionRow)
+import Distribution.Compat.Lens
+import Distribution.Compat.CharParsing (CharParsing(..), spaces)
+import Distribution.Types.Dependency (PrivateAlias(..))
 
 -------------------------------------------------------------------------------
 -- Auxiliary types
@@ -265,6 +271,45 @@ instance FieldGrammar Parsec ParsecFieldGrammar where
 
       parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
 
+  monoidalFieldPrefixAla :: (Parsec b, Parsec d, Monoid a)
+                         => FieldName
+                         -> (a -> [(b, d)])
+                         -> ([(b, d)] -> a)
+                         -> ALens' s a
+                         -> ParsecFieldGrammar s a
+  monoidalFieldPrefixAla fnPfx _unpack _pack _extract =  ParsecFG mempty (Set.singleton fnPfx) parser
+
+        where
+      parser :: CabalSpecVersion -> Fields Position -> ParseResult _
+      parser v values = process v $ filter match $ Map.toList values
+
+      process v xs = case xs of
+                    [] -> pure mempty
+                    xs -> foldMap _pack <$> traverse (parseStanza v) xs
+
+      parseStanza v (header, fls) = do
+        traceShowM (header, fls)
+        let mn = BS.drop (BS.length fnPfx + 1) header
+--        let name'' = PrivateAlias (fromString (map toUpper (BS8.unpack mn)))
+        name'' <- runFieldParser' [] parsec v (fieldLineStreamFromBS mn)
+        dls <-  traverse (parseOne v) fls
+        return  $ [(name'', d) | d <- dls]
+
+
+      parseOne v (MkNamelessField pos fls) = do
+        runFieldParser pos parsec v fls
+
+      match (fn, _) = fnPfx `BS.isPrefixOf` fn
+
+{-
+      convert (fn, fields) =
+        [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls))
+        | MkNamelessField pos fls <- fields
+        ]
+      -- hack: recover the order of prefixed fields
+      reorder = map snd . sortBy (comparing fst)
+      -}
+
   prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs))
     where
       parser :: Fields Position -> [(String, String)]

Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs

@@ -86,6 +86,16 @@ instance FieldGrammar Pretty PrettyFieldGrammar where
     where
       pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s)))
 
+  monoidalFieldPrefixAla fnPfx _pack _unpack l = PrettyFG pp
+    where
+      pp v s =
+        let d = _pack (aview l s)
+        in concatMap (doOne v) d
+
+      doOne v (h, l) =
+        let pfxString = PP.render (prettyVersioned v h)
+        in ppField (fnPfx <> fromString " " <> toUTF8BS pfxString) (prettyVersioned v l)
+
   prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l)
     where
       pp xs =

Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs

@@ -62,6 +62,7 @@ import Distribution.Version
 
 import qualified Data.Map.Lazy as Map
 import Data.Tree (Tree (Node))
+import qualified Distribution.Types.Dependency.Lens as L
 
 ------------------------------------------------------------------------------
 
@@ -323,30 +324,32 @@ extractConditions f gpkg =
     ]
 
 -- | A map of package constraints that combines version ranges using 'unionVersionRanges'.
-newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName, IsPrivate)}
+newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map (PackageName, IsPrivate) (VersionRange, NonEmptySet LibraryName)}
 
 instance Semigroup DepMapUnion where
   DepMapUnion x <> DepMapUnion y =
     DepMapUnion $
       Map.unionWith unionVersionRanges' x y
 
 unionVersionRanges'
-  :: (VersionRange, NonEmptySet LibraryName, IsPrivate)
-  -> (VersionRange, NonEmptySet LibraryName, IsPrivate)
-  -> (VersionRange, NonEmptySet LibraryName, IsPrivate)
-unionVersionRanges' (vr, cs, p) (vr', cs', p') = (unionVersionRanges vr vr', cs <> cs', p <> p')
+  :: (VersionRange, NonEmptySet LibraryName)
+  -> (VersionRange, NonEmptySet LibraryName)
+  -> (VersionRange, NonEmptySet LibraryName)
+unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
 
 toDepMapUnion :: Dependencies -> DepMapUnion
 toDepMapUnion ds =
   DepMapUnion $ Map.fromListWith unionVersionRanges'
-    ([(p, (vr, cs, Public)) | Dependency p vr cs <- publicDependencies ds]
-    ++ [(p, (vr, cs, Private)) | Dependency p vr cs <- privateDependencies ds])
+    ([((p, Public), (vr, cs)) | Dependency p vr cs <- publicDependencies ds]
+    ++ [((p, Private (private_alias d, pns)), (vr, cs)) | d <- privateDependencies ds, let pns = map depPkgName (private_depends d), Dependency p vr cs <- private_depends d])
 
 fromDepMapUnion :: DepMapUnion -> Dependencies
 fromDepMapUnion m =
   Dependencies
-    [Dependency p vr cs | (p, (vr, cs, Public)) <- Map.toList (unDepMapUnion m)]
-    [Dependency p vr cs | (p, (vr, cs, Private)) <- Map.toList (unDepMapUnion m)]
+    [Dependency p vr cs | ((p, Public), (vr, cs)) <- Map.toList (unDepMapUnion m)]
+    [PrivateDependency alias deps | (alias, deps) <- Map.toList priv_deps]
+    where
+      priv_deps = Map.fromListWith (++) [(sn, [Dependency p vr cs]) | ((p, Private (sn, _)), (vr, cs)) <- Map.toList (unDepMapUnion m)]
 
 freeVars :: CondTree ConfVar c a -> [FlagName]
 freeVars t = [f | PackageFlag f <- freeVars' t]
@@ -458,7 +461,7 @@ finalizePD
   :: FlagAssignment
   -- ^ Explicitly specified flag assignments
   -> ComponentRequestedSpec
-  -> (Dependency -> Bool)
+  -> (Maybe PrivateAlias -> Dependency -> Bool)
   -- ^ Is a given dependency satisfiable from the set of
   -- available packages?  If this is unknown then use
   -- True.
@@ -531,8 +534,8 @@ finalizePD
           | otherwise -> [b, not b]
       -- flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
       check ds =
-        let missingDeps = Dependencies (filter (not . satisfyDep) (publicDependencies ds))
-                                       (filter (not . satisfyDep) (privateDependencies ds))
+        let missingDeps = Dependencies (filter (not . satisfyDep Nothing) (publicDependencies ds))
+                                       (mapMaybe (\(PrivateDependency priv ds) -> case filter (not . satisfyDep (Just priv)) ds of { [] -> Nothing; ds' -> Just (PrivateDependency priv ds') })  (privateDependencies ds))
          in if null (publicDependencies missingDeps) && null (privateDependencies missingDeps)
               then DepOk
               else MissingDeps missingDeps
@@ -658,7 +661,7 @@ transformAllBuildDepends
   -> GenericPackageDescription
   -> GenericPackageDescription
 transformAllBuildDepends f =
-  over (L.traverseBuildInfos . L.targetPrivateBuildDepends . traverse) f
+  over (L.traverseBuildInfos . L.targetPrivateBuildDepends . traverse . L.private_depends . traverse) f
     . over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f
     . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
     -- cannot be point-free as normal because of higher rank

Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs

@@ -174,6 +174,7 @@ libraryFieldGrammar
      , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
      , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
      , c (List CommaVCat (Identity Dependency) Dependency)
+     , c (List CommaVCat (Identity PrivateDependency) PrivateDependency)
      , c (List CommaVCat (Identity Mixin) Mixin)
      , c (List CommaVCat (Identity ModuleReexport) ModuleReexport)
      , c (List FSep (MQuoted Extension) Extension)
@@ -223,6 +224,7 @@ foreignLibFieldGrammar
      , c (List CommaFSep (Identity ExeDependency) ExeDependency)
      , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
      , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+     , c (List CommaVCat (Identity PrivateDependency) PrivateDependency)
      , c (List CommaVCat (Identity Dependency) Dependency)
      , c (List CommaVCat (Identity Mixin) Mixin)
      , c (List FSep (Identity ForeignLibOption) ForeignLibOption)
@@ -263,6 +265,7 @@ executableFieldGrammar
      , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
      , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
      , c (List CommaVCat (Identity Dependency) Dependency)
+     , c (List CommaVCat (Identity PrivateDependency) PrivateDependency)
      , c (List CommaVCat (Identity Mixin) Mixin)
      , c (List FSep (MQuoted Extension) Extension)
      , c (List FSep (MQuoted Language) Language)
@@ -335,6 +338,7 @@ testSuiteFieldGrammar
      , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
      , c (List CommaFSep Token String)
      , c (List CommaVCat (Identity Dependency) Dependency)
+     , c (List CommaVCat (Identity PrivateDependency) PrivateDependency)
      , c (List CommaVCat (Identity Mixin) Mixin)
      , c (List FSep (MQuoted Extension) Extension)
      , c (List FSep (MQuoted Language) Language)
@@ -346,6 +350,7 @@ testSuiteFieldGrammar
      , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
      , c (List VCat Token String)
      , c (MQuoted Language)
+     , c PrivateAlias
      )
   => g TestSuiteStanza TestSuiteStanza
 testSuiteFieldGrammar =
@@ -478,6 +483,7 @@ benchmarkFieldGrammar
      , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
      , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
      , c (List CommaVCat (Identity Dependency) Dependency)
+     , c (List CommaVCat (Identity PrivateDependency) PrivateDependency)
      , c (List CommaVCat (Identity Mixin) Mixin)
      , c (List FSep (MQuoted Extension) Extension)
      , c (List FSep (MQuoted Language) Language)
@@ -576,6 +582,7 @@ buildInfoFieldGrammar
      , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
      , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
      , c (List CommaVCat (Identity Dependency) Dependency)
+     , c (List CommaVCat (Identity PrivateDependency) PrivateDependency)
      , c (List CommaVCat (Identity Mixin) Mixin)
      , c (List FSep (MQuoted Extension) Extension)
      , c (List FSep (MQuoted Language) Language)
@@ -670,7 +677,7 @@ buildInfoFieldGrammar =
     <*> pure mempty -- static-options ???
     <*> prefixedFields "x-" L.customFieldsBI
     <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends
-    <*> monoidalFieldAla "private-build-depends" formatDependencyList L.targetPrivateBuildDepends
+    <*> monoidalFieldAla "private-build-depends" formatPrivateDependencyList L.targetPrivateBuildDepends --(map (\(PrivateDependency a ds) -> (a, formatDependencyList ds))) (map (\(alias, ds) -> PrivateDependency alias (unpack' formatDependencyList ds))) L.targetPrivateBuildDepends
     <*> monoidalFieldAla "mixins" formatMixinList L.mixins
       ^^^ availableSince CabalSpecV2_0 []
 {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-}
@@ -795,6 +802,9 @@ setupBInfoFieldGrammar def =
 formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency
 formatDependencyList = alaList CommaVCat
 
+formatPrivateDependencyList :: [PrivateDependency] -> List CommaVCat (Identity PrivateDependency) PrivateDependency
+formatPrivateDependencyList = alaList CommaVCat
+
 formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin
 formatMixinList = alaList CommaVCat
 

Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs

@@ -71,6 +71,7 @@ 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
+import qualified Distribution.Types.Dependency.Lens as L
 
 ------------------------------------------------------------------------------
 
@@ -812,7 +813,7 @@ postProcessInternalDeps specVer gpd
   where
     transformBI :: BuildInfo -> BuildInfo
     transformBI =
-      over L.targetPrivateBuildDepends (concatMap transformD)
+      over (L.targetPrivateBuildDepends . traverse . L.private_depends) (concatMap transformD)
         . over L.targetBuildDepends (concatMap transformD)
         . over L.mixins (map transformM)
 

Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs

@@ -61,6 +61,7 @@ import Text.PrettyPrint (Doc, char, hsep, parens, text)
 
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 import qualified Distribution.Compat.NonEmptySet as NES
+import qualified Distribution.Types.Dependency.Lens as L
 
 -- | Writes a .cabal file from a generic package description
 writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
@@ -263,7 +264,7 @@ preProcessInternalDeps specVer gpd
   where
     transformBI :: BuildInfo -> BuildInfo
     transformBI =
-      over L.targetPrivateBuildDepends (concatMap transformD)
+      over (L.targetPrivateBuildDepends . traverse . L.private_depends) (concatMap transformD)
         . over L.targetBuildDepends (concatMap transformD)
         . over L.mixins (map transformM)
 
@@ -274,7 +275,7 @@ preProcessInternalDeps specVer gpd
     transformD (Dependency pn vr ln)
       | pn == thisPn =
           if LMainLibName `NES.member` ln
-            then Dependency thisPn vr mainLibSet : sublibs
+            then Dependency thisPn vr mainLibSet: sublibs
             else sublibs
       where
         sublibs =

Cabal-syntax/src/Distribution/Types/BuildInfo.hs

@@ -137,7 +137,7 @@ data BuildInfo = BuildInfo
   --  simple assoc-list.
   , targetBuildDepends :: [Dependency]
   -- ^ Dependencies specific to a library or executable target
-  , targetPrivateBuildDepends :: [Dependency]
+  , targetPrivateBuildDepends :: [PrivateDependency]
   , mixins :: [Mixin]
   }
   deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)

Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs

@@ -11,7 +11,7 @@ import Prelude ()
 import Distribution.Compiler (PerCompilerFlavor)
 import Distribution.ModuleName (ModuleName)
 import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.Dependency (Dependency)
+import Distribution.Types.Dependency (Dependency, PrivateDependency)
 import Distribution.Types.ExeDependency (ExeDependency)
 import Distribution.Types.LegacyExeDependency (LegacyExeDependency)
 import Distribution.Types.Mixin (Mixin)
@@ -205,7 +205,7 @@ class HasBuildInfo a where
   targetBuildDepends = buildInfo . targetBuildDepends
   {-# INLINE targetBuildDepends #-}
 
-  targetPrivateBuildDepends :: Lens' a [Dependency]
+  targetPrivateBuildDepends :: Lens' a [PrivateDependency]
   targetPrivateBuildDepends = buildInfo . targetPrivateBuildDepends
   {-# INLINE targetPrivateBuildDepends #-}