Skip to content

Commit b4a6090

Browse files
phadejphadej
authored
Merge pull request #6798 from phadej/dependency-non-empty-set
Add NonEmptySet and use it in Dependency
2 parents 9c148f7 + 9b3686f commit b4a6090

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

58 files changed

+731
-776
lines changed

‎Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,9 @@ library
1515
, Cabal ^>=3.3.0.0
1616
, QuickCheck ^>=2.13.2
1717

18+
if !impl(ghc >= 8.0)
19+
build-depends: semigroups
20+
1821
exposed-modules:
1922
Test.QuickCheck.GenericArbitrary
2023
Test.QuickCheck.Instances.Cabal

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

+17
Original file line numberDiff line numberDiff line change
@@ -6,10 +6,12 @@ module Test.QuickCheck.Instances.Cabal () where
66
import Control.Applicative (liftA2)
77
import Data.Char (isAlphaNum, isDigit)
88
import Data.List (intercalate)
9+
import Data.List.NonEmpty (NonEmpty (..))
910
import Distribution.Utils.Generic (lowercase)
1011
import Test.QuickCheck
1112

1213
import Distribution.CabalSpecVersion
14+
import Distribution.Compat.NonEmptySet (NonEmptySet)
1315
import Distribution.Compiler
1416
import Distribution.FieldGrammar.Newtypes
1517
import Distribution.ModuleName
@@ -33,6 +35,8 @@ import Distribution.Version
3335

3436
import Test.QuickCheck.GenericArbitrary
3537

38+
import qualified Distribution.Compat.NonEmptySet as NES
39+
3640
#if !MIN_VERSION_base(4,8,0)
3741
import Control.Applicative (pure, (<$>), (<*>))
3842
#endif
@@ -351,6 +355,19 @@ instance Arbitrary CompilerId where
351355
arbitrary = genericArbitrary
352356
shrink = genericShrink
353357

358+
-------------------------------------------------------------------------------
359+
-- NonEmptySet
360+
-------------------------------------------------------------------------------
361+
362+
instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where
363+
arbitrary = mk <$> arbitrary <*> arbitrary where
364+
mk x xs = NES.fromNonEmpty (x :| xs)
365+
366+
shrink nes = case NES.toNonEmpty nes of
367+
x :| xs -> map mk (shrink (x, xs))
368+
where
369+
mk (x,xs) = NES.fromNonEmpty (x :| xs)
370+
354371
-------------------------------------------------------------------------------
355372
-- Helpers
356373
-------------------------------------------------------------------------------

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -374,7 +374,7 @@ instance Described Dependency where
374374
[ reChar '{'
375375
, RESpaces
376376
-- no leading or trailing comma
377-
, REMunch reSpacedComma reUnqualComponent
377+
, REMunch1 reSpacedComma reUnqualComponent
378378
, RESpaces
379379
, reChar '}'
380380
]

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

+11-2
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ import Distribution.CabalSpecVersion (CabalSpecVersion)
2020
import Distribution.Compiler (CompilerFlavor, CompilerId, PerCompilerFlavor)
2121
import Distribution.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo)
2222
import Distribution.ModuleName (ModuleName)
23-
import Distribution.Package (Dependency, PackageIdentifier, PackageName)
23+
import Distribution.Package (PackageIdentifier, PackageName)
2424
import Distribution.PackageDescription
2525
import Distribution.Simple.Compiler (DebugInfoLevel, OptimisationLevel, ProfDetailLevel)
2626
import Distribution.Simple.Flag (Flag)
@@ -31,6 +31,7 @@ import Distribution.System
3131
import Distribution.Types.AbiHash (AbiHash)
3232
import Distribution.Types.ComponentId (ComponentId)
3333
import Distribution.Types.CondTree
34+
import Distribution.Types.Dependency (Dependency (..), mainLibSet)
3435
import Distribution.Types.ExecutableScope
3536
import Distribution.Types.ExeDependency
3637
import Distribution.Types.ForeignLib
@@ -52,6 +53,8 @@ import Distribution.Utils.ShortText (ShortText, fromShortText)
5253
import Distribution.Verbosity
5354
import Distribution.Verbosity.Internal
5455

56+
import qualified Distribution.Compat.NonEmptySet as NES
57+
5558
-------------------------------------------------------------------------------
5659
-- instances
5760
-------------------------------------------------------------------------------
@@ -61,9 +64,16 @@ instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExp
6164
instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExpr (CondBranch a b c)
6265
instance (ToExpr a) => ToExpr (NubList a)
6366
instance (ToExpr a) => ToExpr (Flag a)
67+
instance ToExpr a => ToExpr (NES.NonEmptySet a) where
68+
toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs]
6469

6570
instance ToExpr a => ToExpr (PerCompilerFlavor a)
6671

72+
instance ToExpr Dependency where
73+
toExpr d@(Dependency pn vr cs)
74+
| cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []]
75+
| otherwise = genericToExpr d
76+
6777
instance ToExpr AbiDependency
6878
instance ToExpr AbiHash
6979
instance ToExpr Arch
@@ -78,7 +88,6 @@ instance ToExpr CompilerId
7888
instance ToExpr ComponentId
7989
instance ToExpr DebugInfoLevel
8090
instance ToExpr DefUnitId
81-
instance ToExpr Dependency
8291
instance ToExpr ExeDependency
8392
instance ToExpr Executable
8493
instance ToExpr ExecutableScope

‎Cabal/Cabal.cabal

+4
Original file line numberDiff line numberDiff line change
@@ -352,6 +352,7 @@ library
352352
Distribution.Compat.Graph
353353
Distribution.Compat.Internal.TempFile
354354
Distribution.Compat.Newtype
355+
Distribution.Compat.NonEmptySet
355356
Distribution.Compat.ResponseFile
356357
Distribution.Compat.Prelude.Internal
357358
Distribution.Compat.Process
@@ -693,6 +694,9 @@ test-suite unit-tests
693694
if !impl(ghc >= 7.10)
694695
build-depends: void
695696

697+
if !impl(ghc >= 8.0)
698+
build-depends: semigroups
699+
696700
test-suite parser-tests
697701
type: exitcode-stdio-1.0
698702
hs-source-dirs: tests

‎Cabal/Distribution/Backpack/ConfiguredComponent.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ import Distribution.Utils.Generic
4545

4646
import Control.Monad
4747
import qualified Data.Set as Set
48+
import qualified Distribution.Compat.NonEmptySet as NonEmptySet
4849
import qualified Data.Map as Map
4950
import Distribution.Pretty
5051
import Text.PrettyPrint
@@ -179,7 +180,7 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
179180
text "package" <+> pretty pn
180181
Just p -> return p
181182
-- Return all library components
182-
forM (Set.toList sublibs) $ \lib ->
183+
forM (NonEmptySet.toList sublibs) $ \lib ->
183184
let comp = CLibName lib in
184185
case Map.lookup (CLibName $ LSubLibName $
185186
packageNameToUnqualComponentName name) pkg

‎Cabal/Distribution/Compat/NonEmptySet.hs

+128
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,128 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveDataTypeable #-}
3+
module Distribution.Compat.NonEmptySet (
4+
NonEmptySet,
5+
-- * Construction
6+
singleton,
7+
-- * Conversions
8+
toNonEmpty,
9+
fromNonEmpty,
10+
toList,
11+
-- * Query
12+
member,
13+
-- * Map
14+
map,
15+
) where
16+
17+
import Prelude (Bool (..), Eq, Ord (..), Read, Show (..), String, error, return, showParen, showString, ($), (++), (.))
18+
19+
import Control.DeepSeq (NFData (..))
20+
import Data.Data (Data)
21+
import Data.List.NonEmpty (NonEmpty (..))
22+
import Data.Semigroup (Semigroup (..))
23+
import Data.Typeable (Typeable)
24+
25+
import qualified Data.Foldable as F
26+
import qualified Data.Set as Set
27+
28+
import Distribution.Compat.Binary (Binary (..))
29+
import Distribution.Utils.Structured
30+
31+
#if MIN_VERSION_binary(0,6,0)
32+
import Control.Applicative (empty)
33+
#else
34+
import Control.Monad (fail)
35+
#endif
36+
37+
newtype NonEmptySet a = NES (Set.Set a)
38+
deriving (Eq, Ord, Typeable, Data, Read)
39+
40+
-------------------------------------------------------------------------------
41+
-- Instances
42+
-------------------------------------------------------------------------------
43+
44+
instance Show a => Show (NonEmptySet a) where
45+
showsPrec d s = showParen (d > 10)
46+
$ showString "fromNonEmpty "
47+
. showsPrec 11 (toNonEmpty s)
48+
49+
instance Binary a => Binary (NonEmptySet a) where
50+
put (NES s) = put s
51+
get = do
52+
xs <- get
53+
if Set.null xs
54+
#if MIN_VERSION_binary(0,6,0)
55+
then empty
56+
#else
57+
then fail "NonEmptySet: empty"
58+
#endif
59+
else return (NES xs)
60+
61+
instance Structured a => Structured (NonEmptySet a) where
62+
structure = containerStructure
63+
64+
instance NFData a => NFData (NonEmptySet a) where
65+
rnf (NES x) = rnf x
66+
67+
-- | Note: there aren't @Monoid@ instance.
68+
instance Ord a => Semigroup (NonEmptySet a) where
69+
NES x <> NES y = NES (Set.union x y)
70+
71+
instance F.Foldable NonEmptySet where
72+
foldMap f (NES s) = F.foldMap f s
73+
foldr f z (NES s) = F.foldr f z s
74+
75+
#if MIN_VERSION_base(4,8,0)
76+
toList = toList
77+
null _ = False
78+
length (NES s) = F.length s
79+
#endif
80+
81+
-------------------------------------------------------------------------------
82+
-- Constructors
83+
-------------------------------------------------------------------------------
84+
85+
singleton :: a -> NonEmptySet a
86+
singleton = NES . Set.singleton
87+
88+
-------------------------------------------------------------------------------
89+
-- Conversions
90+
-------------------------------------------------------------------------------
91+
92+
fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a
93+
fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs))
94+
95+
toNonEmpty :: NonEmptySet a -> NonEmpty a
96+
toNonEmpty (NES s) = case Set.toList s of
97+
[] -> panic "toNonEmpty"
98+
x:xs -> x :| xs
99+
100+
toList :: NonEmptySet a -> [a]
101+
toList (NES s) = Set.toList s
102+
103+
-------------------------------------------------------------------------------
104+
-- Query
105+
-------------------------------------------------------------------------------
106+
107+
member :: Ord a => a -> NonEmptySet a -> Bool
108+
member x (NES xs) = Set.member x xs
109+
110+
-------------------------------------------------------------------------------
111+
-- Map
112+
-------------------------------------------------------------------------------
113+
114+
map
115+
:: ( Ord b
116+
#if !MIN_VERSION_containers(0,5,2)
117+
, Ord a
118+
#endif
119+
)
120+
=> (a -> b) -> NonEmptySet a -> NonEmptySet b
121+
map f (NES x) = NES (Set.map f x)
122+
123+
-------------------------------------------------------------------------------
124+
-- Internal
125+
-------------------------------------------------------------------------------
126+
127+
panic :: String -> a
128+
panic msg = error $ "NonEmptySet invariant violated: " ++ msg

‎Cabal/Distribution/Compat/Prelude.hs

+2
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ module Distribution.Compat.Prelude (
4747
-- * Some types
4848
Map,
4949
Set,
50+
NonEmptySet,
5051
Identity (..),
5152
Proxy (..),
5253
Void,
@@ -171,6 +172,7 @@ import Text.Read (readMaybe)
171172
import qualified Text.PrettyPrint as Disp
172173

173174
import Distribution.Utils.Structured (Structured)
175+
import Distribution.Compat.NonEmptySet (NonEmptySet)
174176

175177
-- | New name for 'Text.PrettyPrint.<>'
176178
(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc

‎Cabal/Distribution/PackageDescription/Check.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -594,7 +594,7 @@ checkFields pkg =
594594
, name `elem` map prettyShow knownLanguages ]
595595

596596
testedWithImpossibleRanges =
597-
[ Dependency (mkPackageName (prettyShow compiler)) vr Set.empty
597+
[ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet
598598
| (compiler, vr) <- testedWith pkg
599599
, isNoVersion vr ]
600600

‎Cabal/Distribution/PackageDescription/Configuration.hs

+14-17
Original file line numberDiff line numberDiff line change
@@ -64,9 +64,7 @@ import Distribution.Types.CondTree
6464
import Distribution.Types.Condition
6565
import Distribution.Types.DependencyMap
6666

67-
import qualified Data.Map.Strict as Map.Strict
6867
import qualified Data.Map.Lazy as Map
69-
import qualified Data.Set as Set
7068
import Data.Tree ( Tree(Node) )
7169

7270
------------------------------------------------------------------------------
@@ -188,7 +186,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
188186
either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
189187
where
190188
extraConstrs = toDepMap
191-
[ Dependency pn ver mempty
189+
[ Dependency pn ver mainLibSet
192190
| PackageVersionConstraint pn ver <- constrs
193191
]
194192

@@ -232,11 +230,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
232230
mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
233231
mp m@(Right _) _ = m
234232
mp _ m@(Right _) = m
235-
mp (Left xs) (Left ys) =
236-
let union = Map.foldrWithKey (Map.Strict.insertWith combine)
237-
(unDepMapUnion xs) (unDepMapUnion ys)
238-
combine x y = (\(vr, cs) -> (simplifyVersionRange vr,cs)) $ unionVersionRanges' x y
239-
in union `seq` Left (DepMapUnion union)
233+
mp (Left xs) (Left ys) = Left (xs <> ys)
240234

241235
-- `mzero'
242236
mz :: Either DepMapUnion a
@@ -312,21 +306,24 @@ extractConditions f gpkg =
312306
]
313307

314308

315-
-- | A map of dependencies that combines version ranges using 'unionVersionRanges'.
316-
newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, Set LibraryName) }
309+
-- | A map of package constraints that combines version ranges using 'unionVersionRanges'.
310+
newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) }
317311

318-
-- An union of versions should correspond to an intersection of the components.
319-
-- The intersection may not be necessary.
320-
unionVersionRanges' :: (VersionRange, Set LibraryName)
321-
-> (VersionRange, Set LibraryName)
322-
-> (VersionRange, Set LibraryName)
323-
unionVersionRanges' (vra, csa) (vrb, csb) =
324-
(unionVersionRanges vra vrb, Set.intersection csa csb)
312+
instance Semigroup DepMapUnion where
313+
DepMapUnion x <> DepMapUnion y = DepMapUnion $
314+
Map.unionWith unionVersionRanges' x y
315+
316+
unionVersionRanges'
317+
:: (VersionRange, NonEmptySet LibraryName)
318+
-> (VersionRange, NonEmptySet LibraryName)
319+
-> (VersionRange, NonEmptySet LibraryName)
320+
unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
325321

326322
toDepMapUnion :: [Dependency] -> DepMapUnion
327323
toDepMapUnion ds =
328324
DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ]
329325

326+
330327
fromDepMapUnion :: DepMapUnion -> [Dependency]
331328
fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ]
332329

‎Cabal/Distribution/Parsec.hs

+4
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ module Distribution.Parsec (
3939
parsecQuoted,
4040
parsecMaybeQuoted,
4141
parsecCommaList,
42+
parsecCommaNonEmpty,
4243
parsecLeadingCommaList,
4344
parsecLeadingCommaNonEmpty,
4445
parsecOptCommaList,
@@ -293,6 +294,9 @@ parsecStandard f = do
293294
parsecCommaList :: CabalParsing m => m a -> m [a]
294295
parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")
295296

297+
parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a)
298+
parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")
299+
296300
-- | Like 'parsecCommaList' but accept leading or trailing comma.
297301
--
298302
-- @

‎Cabal/Distribution/Simple/Build.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -549,7 +549,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
549549
testLibDep = Dependency
550550
pkgName'
551551
(thisVersion $ pkgVersion $ package pkg_descr)
552-
(Set.singleton LMainLibName)
552+
mainLibSet
553553
exe = Executable {
554554
exeName = mkUnqualComponentName $ stubName test,
555555
modulePath = stubFilePath test,

0 commit comments

Comments
 (0)