Merge pull request #6798 from phadej/dependency-non-empty-set

Add NonEmptySet and use it in Dependency

Author: phadej

Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal

@@ -15,6 +15,9 @@ library
     , Cabal       ^>=3.3.0.0
     , QuickCheck  ^>=2.13.2
 
+  if !impl(ghc >= 8.0)
+    build-depends: semigroups
+
   exposed-modules:
     Test.QuickCheck.GenericArbitrary
     Test.QuickCheck.Instances.Cabal

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

@@ -6,10 +6,12 @@ module Test.QuickCheck.Instances.Cabal () where
 import Control.Applicative        (liftA2)
 import Data.Char                  (isAlphaNum, isDigit)
 import Data.List                  (intercalate)
+import Data.List.NonEmpty         (NonEmpty (..))
 import Distribution.Utils.Generic (lowercase)
 import Test.QuickCheck
 
 import Distribution.CabalSpecVersion
+import Distribution.Compat.NonEmptySet             (NonEmptySet)
 import Distribution.Compiler
 import Distribution.FieldGrammar.Newtypes
 import Distribution.ModuleName
@@ -33,6 +35,8 @@ import Distribution.Version
 
 import Test.QuickCheck.GenericArbitrary
 
+import qualified Distribution.Compat.NonEmptySet as NES
+
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (pure, (<$>), (<*>))
 #endif
@@ -351,6 +355,19 @@ instance Arbitrary CompilerId where
     arbitrary = genericArbitrary
     shrink    = genericShrink
 
+-------------------------------------------------------------------------------
+-- NonEmptySet
+-------------------------------------------------------------------------------
+
+instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where
+    arbitrary = mk <$> arbitrary <*> arbitrary where
+        mk x xs = NES.fromNonEmpty (x :| xs)
+
+    shrink nes = case NES.toNonEmpty nes of
+        x :| xs -> map mk (shrink (x, xs))
+      where
+        mk (x,xs) = NES.fromNonEmpty (x :| xs)
+
 -------------------------------------------------------------------------------
 -- Helpers
 -------------------------------------------------------------------------------

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

@@ -374,7 +374,7 @@ instance Described Dependency where
                     [ reChar '{'
                     , RESpaces
                     -- no leading or trailing comma
-                    , REMunch reSpacedComma reUnqualComponent
+                    , REMunch1 reSpacedComma reUnqualComponent
                     , RESpaces
                     , reChar '}'
                     ]

Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs

@@ -20,7 +20,7 @@ import Distribution.CabalSpecVersion               (CabalSpecVersion)
 import Distribution.Compiler                       (CompilerFlavor, CompilerId, PerCompilerFlavor)
 import Distribution.InstalledPackageInfo           (AbiDependency, ExposedModule, InstalledPackageInfo)
 import Distribution.ModuleName                     (ModuleName)
-import Distribution.Package                        (Dependency, PackageIdentifier, PackageName)
+import Distribution.Package                        (PackageIdentifier, PackageName)
 import Distribution.PackageDescription
 import Distribution.Simple.Compiler                (DebugInfoLevel, OptimisationLevel, ProfDetailLevel)
 import Distribution.Simple.Flag                    (Flag)
@@ -31,6 +31,7 @@ import Distribution.System
 import Distribution.Types.AbiHash                  (AbiHash)
 import Distribution.Types.ComponentId              (ComponentId)
 import Distribution.Types.CondTree
+import Distribution.Types.Dependency               (Dependency (..), mainLibSet)
 import Distribution.Types.ExecutableScope
 import Distribution.Types.ExeDependency
 import Distribution.Types.ForeignLib
@@ -52,6 +53,8 @@ import Distribution.Utils.ShortText                (ShortText, fromShortText)
 import Distribution.Verbosity
 import Distribution.Verbosity.Internal
 
+import qualified Distribution.Compat.NonEmptySet as NES
+
 -------------------------------------------------------------------------------
 -- instances
 -------------------------------------------------------------------------------
@@ -61,9 +64,16 @@ instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExp
 instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExpr (CondBranch a b c)
 instance (ToExpr a) => ToExpr (NubList a)
 instance (ToExpr a) => ToExpr (Flag a)
+instance ToExpr a => ToExpr (NES.NonEmptySet a) where
+    toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs]
 
 instance ToExpr a => ToExpr (PerCompilerFlavor a)
 
+instance ToExpr Dependency where
+    toExpr d@(Dependency pn vr cs)
+        | cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []]
+        | otherwise        = genericToExpr d
+
 instance ToExpr AbiDependency
 instance ToExpr AbiHash
 instance ToExpr Arch
@@ -78,7 +88,6 @@ instance ToExpr CompilerId
 instance ToExpr ComponentId
 instance ToExpr DebugInfoLevel
 instance ToExpr DefUnitId
-instance ToExpr Dependency
 instance ToExpr ExeDependency
 instance ToExpr Executable
 instance ToExpr ExecutableScope

Cabal/Cabal.cabal

@@ -352,6 +352,7 @@ library
     Distribution.Compat.Graph
     Distribution.Compat.Internal.TempFile
     Distribution.Compat.Newtype
+    Distribution.Compat.NonEmptySet
     Distribution.Compat.ResponseFile
     Distribution.Compat.Prelude.Internal
     Distribution.Compat.Process
@@ -693,6 +694,9 @@ test-suite unit-tests
   if !impl(ghc >= 7.10)
     build-depends: void
 
+  if !impl(ghc >= 8.0)
+    build-depends: semigroups
+
 test-suite parser-tests
   type: exitcode-stdio-1.0
   hs-source-dirs: tests

Cabal/Distribution/Backpack/ConfiguredComponent.hs

@@ -45,6 +45,7 @@ import Distribution.Utils.Generic
 
 import Control.Monad
 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
@@ -179,7 +180,7 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
                                 text "package" <+> pretty pn
                         Just p -> return p
                     -- Return all library components
-                    forM (Set.toList sublibs) $ \lib ->
+                    forM (NonEmptySet.toList sublibs) $ \lib ->
                         let comp = CLibName lib in
                         case Map.lookup (CLibName $ LSubLibName $
                                          packageNameToUnqualComponentName name) pkg

Cabal/Distribution/Compat/NonEmptySet.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Distribution.Compat.NonEmptySet (
+    NonEmptySet,
+    -- * Construction
+    singleton,
+    -- * Conversions
+    toNonEmpty,
+    fromNonEmpty,
+    toList,
+    -- * Query
+    member,
+    -- * Map
+    map,
+) where
+
+import Prelude (Bool (..), Eq, Ord (..), Read, Show (..), String, error, return, showParen, showString, ($), (++), (.))
+
+import Control.DeepSeq    (NFData (..))
+import Data.Data          (Data)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Semigroup     (Semigroup (..))
+import Data.Typeable      (Typeable)
+
+import qualified Data.Foldable as F
+import qualified Data.Set      as Set
+
+import Distribution.Compat.Binary (Binary (..))
+import Distribution.Utils.Structured
+
+#if MIN_VERSION_binary(0,6,0)
+import Control.Applicative (empty)
+#else
+import Control.Monad (fail)
+#endif
+
+newtype NonEmptySet a = NES (Set.Set a)
+  deriving (Eq, Ord, Typeable, Data, Read)
+
+-------------------------------------------------------------------------------
+-- Instances
+-------------------------------------------------------------------------------
+
+instance Show a => Show (NonEmptySet a) where
+    showsPrec d s = showParen (d > 10)
+        $ showString "fromNonEmpty "
+        . showsPrec 11 (toNonEmpty s)
+
+instance Binary a => Binary (NonEmptySet a) where
+    put (NES s) = put s
+    get = do
+        xs <- get
+        if Set.null xs
+#if MIN_VERSION_binary(0,6,0)
+        then empty
+#else
+        then fail "NonEmptySet: empty"
+#endif
+        else return (NES xs)
+
+instance Structured a => Structured (NonEmptySet a) where
+    structure = containerStructure
+
+instance NFData a => NFData (NonEmptySet a) where
+    rnf (NES x) = rnf x
+
+-- | Note: there aren't @Monoid@ instance.
+instance Ord a => Semigroup (NonEmptySet a) where
+    NES x <> NES y = NES (Set.union x y)
+
+instance F.Foldable NonEmptySet where
+    foldMap f (NES s) = F.foldMap f s
+    foldr f z (NES s) = F.foldr f z s
+
+#if MIN_VERSION_base(4,8,0)
+    toList         = toList
+    null _         = False
+    length (NES s) = F.length s
+#endif
+
+-------------------------------------------------------------------------------
+-- Constructors
+-------------------------------------------------------------------------------
+
+singleton :: a -> NonEmptySet a
+singleton = NES . Set.singleton
+
+-------------------------------------------------------------------------------
+-- Conversions
+-------------------------------------------------------------------------------
+
+fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a
+fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs))
+
+toNonEmpty :: NonEmptySet a -> NonEmpty a
+toNonEmpty (NES s) = case Set.toList s of
+    []   -> panic "toNonEmpty"
+    x:xs -> x :| xs
+
+toList :: NonEmptySet a -> [a]
+toList (NES s) = Set.toList s
+
+-------------------------------------------------------------------------------
+-- Query
+-------------------------------------------------------------------------------
+
+member :: Ord a => a -> NonEmptySet a -> Bool
+member x (NES xs) = Set.member x xs
+
+-------------------------------------------------------------------------------
+-- Map
+-------------------------------------------------------------------------------
+
+map
+    :: ( Ord b
+#if !MIN_VERSION_containers(0,5,2)
+       , Ord a
+#endif
+       )
+    => (a -> b) -> NonEmptySet a -> NonEmptySet b
+map f (NES x) = NES (Set.map f x)
+
+-------------------------------------------------------------------------------
+-- Internal
+-------------------------------------------------------------------------------
+
+panic :: String -> a
+panic msg = error $ "NonEmptySet invariant violated: " ++ msg

Cabal/Distribution/Compat/Prelude.hs

@@ -47,6 +47,7 @@ module Distribution.Compat.Prelude (
     -- * Some types
     Map,
     Set,
+    NonEmptySet,
     Identity (..),
     Proxy (..),
     Void,
@@ -171,6 +172,7 @@ import Text.Read                     (readMaybe)
 import qualified Text.PrettyPrint as Disp
 
 import Distribution.Utils.Structured (Structured)
+import Distribution.Compat.NonEmptySet (NonEmptySet)
 
 -- | New name for 'Text.PrettyPrint.<>'
 (<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc

Cabal/Distribution/PackageDescription/Check.hs

@@ -594,7 +594,7 @@ checkFields pkg =
              , name `elem` map prettyShow knownLanguages ]
 
     testedWithImpossibleRanges =
-      [ Dependency (mkPackageName (prettyShow compiler)) vr Set.empty
+      [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet
       | (compiler, vr) <- testedWith pkg
       , isNoVersion vr ]
 

Cabal/Distribution/PackageDescription/Configuration.hs

@@ -64,9 +64,7 @@ import Distribution.Types.CondTree
 import Distribution.Types.Condition
 import Distribution.Types.DependencyMap
 
-import qualified Data.Map.Strict as Map.Strict
 import qualified Data.Map.Lazy   as Map
-import qualified Data.Set as Set
 import Data.Tree ( Tree(Node) )
 
 ------------------------------------------------------------------------------
@@ -188,7 +186,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
     either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
   where
     extraConstrs = toDepMap
-      [ Dependency pn ver mempty
+      [ Dependency pn ver mainLibSet
       | PackageVersionConstraint pn ver <- constrs
       ]
 
@@ -232,11 +230,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
     mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
     mp m@(Right _) _           = m
     mp _           m@(Right _) = m
-    mp (Left xs)   (Left ys)   =
-        let union = Map.foldrWithKey (Map.Strict.insertWith combine)
-                    (unDepMapUnion xs) (unDepMapUnion ys)
-            combine x y = (\(vr, cs) -> (simplifyVersionRange vr,cs)) $ unionVersionRanges' x y
-        in union `seq` Left (DepMapUnion union)
+    mp (Left xs)   (Left ys)   = Left (xs <> ys)
 
     -- `mzero'
     mz :: Either DepMapUnion a
@@ -312,21 +306,24 @@ extractConditions f gpkg =
     ]
 
 
--- | A map of dependencies that combines version ranges using 'unionVersionRanges'.
-newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, Set LibraryName) }
+-- | A map of package constraints that combines version ranges using 'unionVersionRanges'.
+newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) }
 
--- An union of versions should correspond to an intersection of the components.
--- The intersection may not be necessary.
-unionVersionRanges' :: (VersionRange, Set LibraryName)
-                    -> (VersionRange, Set LibraryName)
-                    -> (VersionRange, Set LibraryName)
-unionVersionRanges' (vra, csa) (vrb, csb) =
-  (unionVersionRanges vra vrb, Set.intersection csa csb)
+instance Semigroup DepMapUnion where
+    DepMapUnion x <> DepMapUnion y = DepMapUnion $
+        Map.unionWith unionVersionRanges' x y
+
+unionVersionRanges'
+    :: (VersionRange, NonEmptySet LibraryName)
+    -> (VersionRange, NonEmptySet LibraryName)
+    -> (VersionRange, NonEmptySet LibraryName)
+unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
 
 toDepMapUnion :: [Dependency] -> DepMapUnion
 toDepMapUnion ds =
   DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ]
 
+
 fromDepMapUnion :: DepMapUnion -> [Dependency]
 fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ]
 

Cabal/Distribution/Parsec.hs

@@ -39,6 +39,7 @@ module Distribution.Parsec (
     parsecQuoted,
     parsecMaybeQuoted,
     parsecCommaList,
+    parsecCommaNonEmpty,
     parsecLeadingCommaList,
     parsecLeadingCommaNonEmpty,
     parsecOptCommaList,
@@ -293,6 +294,9 @@ parsecStandard f = do
 parsecCommaList :: CabalParsing m => m a -> m [a]
 parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")
 
+parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a)
+parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")
+
 -- | Like 'parsecCommaList' but accept leading or trailing comma.
 --
 -- @

Cabal/Distribution/Simple/Build.hs

@@ -549,7 +549,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
     testLibDep = Dependency
         pkgName'
         (thisVersion $ pkgVersion $ package pkg_descr)
-        (Set.singleton LMainLibName)
+        mainLibSet
     exe = Executable {
             exeName    = mkUnqualComponentName $ stubName test,
             modulePath = stubFilePath test,