Closure property in the solver for private dependencies and finish pr…

…ivate dependencies

Romes edits on top of MPs edits: implements the closure property and
fixes the remaining bits of private dependencies such that the whole
testsuite passes

my edits

Remove that [PackageName] attempt

My example

Get tests compiling

Fix qualified constraints

Readd support for --show-solver-log flag testsuite

Add several tests

WIP readd qualifyDeps privat ewrong

just fail to make it work ... W

RM Fix all the testsuite

Corrently inheritQ for deps of packages in the private scope that are
also in the private scope should not introduce top level but rather
qualilfied goals...

Ammendmmends to patch

Drop allDependencies /easy

Add cabal-hooks-demo PackageTest

Closure-property-test PackageTest

Drop 'tail' usage from InstallPlan

More cleanups

First pass of clean up, including naive impls for missing commands

Add backpack + private deps test

Tests for nested private scopes

uhh... borked

Fix first bug

Fix second nested priv deps test

Fix PackageInconsistency error checks, testsuite privdeps passing

changes to tests

Fix more PackageTests for PrivateDeps

Formatting

Satisfy build and lint

Accept parser tests

X

Y

Described PrivateDependency

Z

W

A

B

Describe user constraint private qual

Normal verbose

Revert "Normal verbose"

This reverts commit 7ea5838.

Reapply "Normal verbose"

This reverts commit 0114342.

Not so pretty Thing to make tests pass

Revert "Not so pretty Thing to make tests pass"

This reverts commit 71e521a.

Fix test stanzas ignored thing

X

fix first part of the problem for test

Fix part 2

FORMAT

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

@@ -3,13 +3,13 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Test.QuickCheck.Instances.Cabal () where
 
-import Control.Applicative        (liftA2)
 import Data.Bits                  (shiftR)
 import Data.Char                  (isAlphaNum, isDigit, toLower)
 import Data.List                  (intercalate, (\\))
 import Data.List.NonEmpty         (NonEmpty (..))
 import Distribution.Utils.Generic (lowercase)
 import Test.QuickCheck
+import Control.Applicative (liftA2)
 
 #if MIN_VERSION_base(4,8,0)
 import Data.Bits (countLeadingZeros, finiteBitSize, shiftL)
@@ -206,6 +206,23 @@ instance Arbitrary Dependency where
         | (pn', vr', lb') <- shrink (pn, vr, lb)
         ]
 
+-------------------------------------------------------------------------------
+-- Private Dependency
+-------------------------------------------------------------------------------
+
+instance Arbitrary PrivateAlias where
+  arbitrary = PrivateAlias <$> arbitrary
+  shrink (PrivateAlias al) = PrivateAlias <$> shrink al
+instance Arbitrary PrivateDependency where
+    arbitrary = PrivateDependency
+        <$> arbitrary
+        <*> arbitrary
+
+    shrink (PrivateDependency al dps) =
+        [ PrivateDependency al' dps'
+        | (al', dps') <- shrink (al, dps)
+        ]
+
 -------------------------------------------------------------------------------
 -- PackageVersionConstraint
 -------------------------------------------------------------------------------

Cabal-described/src/Distribution/Described.hs

@@ -76,7 +76,7 @@ import Distribution.Types.AbiDependency            (AbiDependency)
 import Distribution.Types.AbiHash                  (AbiHash)
 import Distribution.Types.BenchmarkType            (BenchmarkType)
 import Distribution.Types.BuildType                (BuildType)
-import Distribution.Types.Dependency               (Dependency)
+import Distribution.Types.Dependency               (Dependency, PrivateAlias(..), PrivateDependency)
 import Distribution.Types.ExecutableScope          (ExecutableScope)
 import Distribution.Types.ExeDependency            (ExeDependency)
 import Distribution.Types.ExposedModule            (ExposedModule)
@@ -370,7 +370,7 @@ instance Described CompilerId where
         <> describe (Proxy :: Proxy Version)
 
 instance Described Dependency where
-    describe _ = REAppend
+  describe _ = REAppend
         [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName))
         , REOpt $
                reChar ':'
@@ -391,6 +391,19 @@ instance Described Dependency where
       where
         vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
 
+instance Described PrivateDependency where
+    describe _ = REAppend
+        [ RENamed "alias" (describe (Proxy :: Proxy PrivateAlias))
+        , RESpaces1
+        , "with"
+        , RESpaces1
+        , reChar '('
+        , RESpaces
+        , REMunch reSpacedComma (describe (Proxy :: Proxy Dependency))
+        , RESpaces
+        , reChar ')'
+        ]
+
 instance Described ExecutableScope where
     describe _ = REUnion ["public","private"]
 
@@ -446,6 +459,9 @@ instance Described ModuleName where
     describe _ = REMunch1 (reChar '.') component where
         component = RECharSet csUpper <> REMunch reEps (REUnion [RECharSet csAlphaNum, RECharSet (fromString "_'")])
 
+instance Described PrivateAlias where
+  describe _ = describe (Proxy :: Proxy ModuleName)
+
 instance Described ModuleReexport where
     describe _ = RETodo
 
@@ -591,4 +607,4 @@ instance Described CompatLicenseFile where
     describe _ = describe ([] :: [Token])
 
 instance Described CompatFilePath where
-    describe _ = describe ([] :: [Token]) 
+    describe _ = describe ([] :: [Token]) 

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

@@ -133,20 +133,6 @@ 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

@@ -1,9 +1,9 @@
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | This module provides a 'FieldGrammarParser', one way to parse
 -- @.cabal@ -like files.
@@ -75,7 +75,6 @@ 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
@@ -90,9 +89,6 @@ 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
@@ -271,45 +267,6 @@ 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,16 +86,6 @@ 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/ModuleName.hs

@@ -99,12 +99,6 @@ validModuleComponent (c : cs) = isUpper c && all validModuleChar cs
 instance IsString ModuleName where
   fromString = ModuleName . toShortText
 
--- | Construct a 'ModuleName' from valid module components, i.e. parts
--- separated by dots.
-fromComponents :: [String] -> ModuleName
-fromComponents comps = fromString (intercalate "." comps)
-{-# DEPRECATED fromComponents "Exists for cabal-install only" #-}
-
 -- | The module name @Main@.
 main :: ModuleName
 main = ModuleName (fromString "Main")
@@ -119,6 +113,13 @@ components mn = split (unModuleName mn)
       (chunk, []) -> chunk : []
       (chunk, _ : rest) -> chunk : split rest
 
+-- | Construct a 'ModuleName' from valid module components, i.e. parts
+-- separated by dots.
+--
+-- Inverse of 'components', i.e. @fromComponents (components x) = x@
+fromComponents :: [String] -> ModuleName
+fromComponents comps = fromString (intercalate "." comps)
+
 -- | Convert a module name to a file path, but without any file extension.
 -- For example:
 --

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

@@ -339,17 +339,20 @@ unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
 
 toDepMapUnion :: Dependencies -> DepMapUnion
 toDepMapUnion ds =
-  DepMapUnion $ Map.fromListWith unionVersionRanges'
-    ([((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])
+  DepMapUnion $
+    Map.fromListWith
+      unionVersionRanges'
+      ( [((p, Public), (vr, cs)) | Dependency p vr cs <- publicDependencies ds]
+          ++ [((p, Private (private_alias d)), (vr, cs)) | d <- privateDependencies ds, Dependency p vr cs <- private_depends d]
+      )
 
 fromDepMapUnion :: DepMapUnion -> Dependencies
 fromDepMapUnion m =
   Dependencies
     [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)]
+  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]
@@ -534,8 +537,10 @@ finalizePD
           | otherwise -> [b, not b]
       -- flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
       check 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))
+        let missingDeps =
+              Dependencies
+                (filter (not . satisfyDep Nothing) (publicDependencies ds))
+                (mapMaybe (\(PrivateDependency priv pds) -> case filter (not . satisfyDep (Just priv)) pds of [] -> Nothing; pds' -> Just (PrivateDependency priv pds')) (privateDependencies ds))
          in if null (publicDependencies missingDeps) && null (privateDependencies missingDeps)
               then DepOk
               else MissingDeps missingDeps

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

@@ -677,7 +677,7 @@ buildInfoFieldGrammar =
     <*> pure mempty -- static-options ???
     <*> prefixedFields "x-" L.customFieldsBI
     <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends
-    <*> 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 "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 #-}

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

@@ -1,9 +1,9 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE BangPatterns #-}
 
 -----------------------------------------------------------------------------
 
@@ -65,13 +65,13 @@ import qualified Data.Set as Set
 import qualified Distribution.Compat.Newtype as Newtype
 import qualified Distribution.Compat.NonEmptySet as NES
 import qualified Distribution.Types.BuildInfo.Lens as L
+import qualified Distribution.Types.Dependency.Lens as L
 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
-import qualified Distribution.Types.Dependency.Lens as L
 
 ------------------------------------------------------------------------------
 

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

@@ -275,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/ComponentName.hs

@@ -8,8 +8,7 @@ module Distribution.Types.ComponentName
   , componentNameRaw
   , componentNameStanza
   , componentNameString
-
-  , NotLibComponentName(..)
+  , NotLibComponentName (..)
   ) where
 
 import Distribution.Compat.Prelude