Add Described to IndexState (incl. tests).

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

@@ -9,8 +9,14 @@ import Test.QuickCheck
 
 import Distribution.SPDX
 import Distribution.Version
+import Distribution.Types.Dependency
+import Distribution.Types.UnqualComponentName
+import Distribution.Simple.Flag (Flag (..))
+import Distribution.Types.LibraryName
 import Distribution.Types.PackageName
 import Distribution.Types.VersionRange.Internal
+import Distribution.System
+import Distribution.Verbosity
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (pure, (<$>), (<*>))
@@ -64,7 +70,6 @@ instance Arbitrary VersionRange where
         , (1, fmap orEarlierVersion' arbitrary)
         , (1, fmap withinVersion arbitrary)
         , (1, fmap majorBoundVersion arbitrary)
-        , (2, fmap VersionRangeParens arbitrary)
         ] ++ if n == 0 then [] else
         [ (2, liftA2 unionVersionRanges     verRangeExp2 verRangeExp2)
         , (2, liftA2 intersectVersionRanges verRangeExp2 verRangeExp2)
@@ -85,7 +90,6 @@ instance Arbitrary VersionRange where
   shrink (OrEarlierVersion v)         = EarlierVersion v : map OrEarlierVersion (shrink v)
   shrink (WildcardVersion v)          = map WildcardVersion ( shrink v)
   shrink (MajorBoundVersion v)        = map MajorBoundVersion (shrink v)
-  shrink (VersionRangeParens vr)      = vr : map VersionRangeParens (shrink vr)
   shrink (UnionVersionRanges a b)     = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
   shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))
 
@@ -122,6 +126,71 @@ instance Arbitrary VersionIntervals where
 instance Arbitrary Bound where
   arbitrary = elements [ExclusiveBound, InclusiveBound]
 
+-------------------------------------------------------------------------------
+-- Dependency
+-------------------------------------------------------------------------------
+
+instance Arbitrary Dependency where
+    arbitrary = mkDependency
+        <$> arbitrary
+        <*> arbitrary
+        <*> (arbitrary `suchThat` const True) -- should be (not . null)
+
+    shrink (Dependency pn vr lb) =
+        [ mkDependency pn' vr' lb'
+        | (pn', vr', lb') <- shrink (pn, vr, lb)
+        ]
+
+-------------------------------------------------------------------------------
+-- System
+-------------------------------------------------------------------------------
+
+instance Arbitrary OS where
+    arbitrary = elements knownOSs
+
+instance Arbitrary Arch where
+    arbitrary = elements knownArches
+
+instance Arbitrary Platform where
+    arbitrary = Platform <$> arbitrary <*> arbitrary
+
+-------------------------------------------------------------------------------
+-- Various names
+-------------------------------------------------------------------------------
+
+instance Arbitrary UnqualComponentName where
+    -- same rules as package names
+    arbitrary = packageNameToUnqualComponentName <$> arbitrary
+
+instance Arbitrary LibraryName where
+    arbitrary = oneof
+        [ LSubLibName <$> arbitrary
+        , pure LMainLibName
+        ]
+
+    shrink (LSubLibName _) = [LMainLibName]
+    shrink _               = []
+
+instance Arbitrary a => Arbitrary (Flag a) where
+    arbitrary = arbitrary1
+
+    shrink NoFlag   = []
+    shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ]
+
+instance Arbitrary1 Flag where
+    liftArbitrary genA = sized $ \sz ->
+        if sz <= 0
+        then pure NoFlag
+        else frequency [ (1, pure NoFlag)
+                       , (3, Flag <$> genA) ]
+
+-------------------------------------------------------------------------------
+-- Verbosity
+-------------------------------------------------------------------------------
+
+instance Arbitrary Verbosity where
+    arbitrary = elements [minBound..maxBound]
+
 -------------------------------------------------------------------------------
 -- SPDX
 -------------------------------------------------------------------------------

Cabal/Distribution/Types/Dependency.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric      #-}
 module Distribution.Types.Dependency
   ( Dependency(..)
+  , mkDependency
   , depPkgName
   , depVerRange
   , depLibraries
@@ -33,6 +34,9 @@ import qualified Text.PrettyPrint as PP
 
 -- | Describes a dependency on a source package (API)
 --
+-- /Invariant:/ package name does not appear as 'LSubLibName' in
+-- set of library names.
+--
 data Dependency = Dependency
                     PackageName
                     VersionRange
@@ -51,35 +55,37 @@ depVerRange (Dependency _ vr _) = vr
 depLibraries :: Dependency -> Set LibraryName
 depLibraries (Dependency _ _ cs) = cs
 
+-- | Smart constructor of 'Dependency'.
+--
+-- If 'PackageName' is appears as 'LSubLibName' in a set of sublibraries,
+-- it is automatically converted to 'LMainLibName'.
+--
+-- @since 3.4.0.0
+--
+mkDependency :: PackageName -> VersionRange -> Set LibraryName -> Dependency
+mkDependency pn vr lb = Dependency pn vr (Set.map conv lb)
+  where
+    pn' = packageNameToUnqualComponentName pn
+
+    conv l@LMainLibName                 = l
+    conv l@(LSubLibName ln) | ln == pn' = LMainLibName
+                            | otherwise = l
+
 instance Binary Dependency
 instance Structured Dependency
 instance NFData Dependency where rnf = genericRnf
 
 instance Pretty Dependency where
-    pretty (Dependency name ver sublibs) = pretty name
-                                       <<>> optionalMonoid
-                                            (sublibs /= Set.singleton LMainLibName)
-                                            (PP.colon <<>> PP.braces prettySublibs)
-                                       <+> pretty ver
+    pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pretty ver
       where
-        optionalMonoid True x = x
-        optionalMonoid False _ = mempty
+        withSubLibs doc
+            | sublibs == mainLib = doc
+            | otherwise          = doc <<>> PP.colon <<>> PP.braces prettySublibs
+
         prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> Set.toList sublibs
-        prettySublib LMainLibName = PP.text $ unPackageName name
-        prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un
 
-versionGuardMultilibs :: (Monad m, CabalParsing m) => m a -> m a
-versionGuardMultilibs expr = do
-  csv <- askCabalSpecVersion
-  if csv < CabalSpecV3_0
-  then fail $ unwords
-    [ "Sublibrary dependency syntax used."
-    , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."
-    , "Alternatively, if you are depending on an internal library, you can write"
-    , "directly the library name as it were a package."
-    ]
-  else
-    expr
+        prettySublib LMainLibName     = PP.text $ unPackageName name
+        prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un
 
 -- |
 --
@@ -98,65 +104,87 @@ versionGuardMultilibs expr = do
 -- >>> simpleParsec "mylib:{ } ^>= 42" :: Maybe Dependency
 -- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromList []))
 --
--- Spaces around colon are not allowed:
+-- >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency])
+-- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LMainLibName]))
+-- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LMainLibName]))
+-- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LMainLibName,LSubLibName (UnqualComponentName "sublib")]))
 --
--- >>> simpleParsec "mylib: sub" :: Maybe Dependency
--- Nothing
+-- Spaces around colon are not allowed:
 --
--- >>> simpleParsec "mylib :sub" :: Maybe Dependency
--- Nothing
+-- >>> map simpleParsec ["mylib: sub", "mylib :sub", "mylib: {sub1,sub2}", "mylib :{sub1,sub2}"] :: [Maybe Dependency]
+-- [Nothing,Nothing,Nothing,Nothing]
 --
--- >>> simpleParsec "mylib: {sub1,sub2}" :: Maybe Dependency
--- Nothing
+-- Sublibrary syntax is accepted since @cabal-version: 3.0@
 --
--- >>> simpleParsec "mylib :{sub1,sub2}" :: Maybe Dependency
--- Nothing
+-- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency]
+-- [Nothing,Just (Dependency (PackageName "mylib") AnyVersion (fromList [LSubLibName (UnqualComponentName "sub")]))]
 --
 instance Parsec Dependency where
     parsec = do
         name <- parsec
 
-        libs <- option [LMainLibName]
-              $ (char ':' *>)
-              $ versionGuardMultilibs
-              $ pure <$> parseLib name <|> parseMultipleLibs name
+        libs <- option mainLib $ do
+          _ <- char ':'
+          versionGuardMultilibs
+          Set.singleton <$> parseLib <|> parseMultipleLibs
 
         spaces -- https://github.com/haskell/cabal/issues/5846
 
         ver  <- parsec <|> pure anyVersion
-        return $ Dependency name ver $ Set.fromList libs
-      where makeLib pn ln | unPackageName pn == ln = LMainLibName
-                          | otherwise = LSubLibName $ mkUnqualComponentName ln
-            parseLib pn = makeLib pn <$> parsecUnqualComponentName
-            parseMultipleLibs pn = between (char '{' *> spaces)
-                                           (spaces <* char '}')
-                                           $ parsecCommaList $ parseLib pn
+        return $ mkDependency name ver libs
+      where
+        parseLib          = LSubLibName <$> parsec
+        parseMultipleLibs = between
+            (char '{' *> spaces)
+            (spaces *> char '}')
+            (Set.fromList <$> parsecCommaList parseLib)
+
+versionGuardMultilibs :: CabalParsing m => m ()
+versionGuardMultilibs = do
+  csv <- askCabalSpecVersion
+  when (csv < CabalSpecV3_0) $ fail $ unwords
+    [ "Sublibrary dependency syntax used."
+    , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."
+    , "Alternatively, if you are depending on an internal library, you can write"
+    , "directly the library name as it were a package."
+    ]
+
+-- | Library set with main library.
+mainLib :: Set LibraryName
+mainLib = Set.singleton LMainLibName
 
 instance Described Dependency where
     describe _ = REAppend
         [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName))
         , REOpt $ 
-               RESpaces
-            <> reChar ':'
-            <> RESpaces
+               reChar ':'
             <> REUnion
                 [ reUnqualComponent
                 , REAppend
                     [ reChar '{'
                     , RESpaces
-                    , RECommaList reUnqualComponent
+                    -- no leading or trailing comma
+                    , REMunch reSpacedComma reUnqualComponent
                     , RESpaces
                     , reChar '}'
                     ] 
                 ]
-        , REOpt $ RESpaces <> vr
+        -- TODO: RESpaces1 should be just RESpaces, but we are able
+        -- to generate non-parseable strings without mandatory space
+        --
+        -- https://github.com/haskell/cabal/issues/6589
+        --
+        , REOpt $ RESpaces1 <> vr
         ]
       where
         vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
 
 -- mempty should never be in a Dependency-as-dependency.
 -- This is only here until the Dependency-as-constraint problem is solved #5570.
 -- Same for below.
+--
+-- Note: parser allows for empty set!
+--
 thisPackageVersion :: PackageIdentifier -> Dependency
 thisPackageVersion (PackageIdentifier n v) =
   Dependency n (thisVersion v) Set.empty

Cabal/Distribution/Types/PackageName.hs

@@ -2,7 +2,9 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 module Distribution.Types.PackageName
-  ( PackageName, unPackageName, mkPackageName
+  ( PackageName
+  , unPackageName, mkPackageName
+  , unPackageNameST, mkPackageNameST
   ) where
 
 import Prelude ()
@@ -29,6 +31,10 @@ newtype PackageName = PackageName ShortText
 unPackageName :: PackageName -> String
 unPackageName (PackageName s) = fromShortText s
 
+-- | @since 3.4.0.0
+unPackageNameST :: PackageName -> ShortText
+unPackageNameST (PackageName s) = s
+
 -- | Construct a 'PackageName' from a 'String'
 --
 -- 'mkPackageName' is the inverse to 'unPackageName'
@@ -40,6 +46,15 @@ unPackageName (PackageName s) = fromShortText s
 mkPackageName :: String -> PackageName
 mkPackageName = PackageName . toShortText
 
+-- | Construct a 'PackageName' from a 'ShortText'
+--
+-- Note: No validations are performed to ensure that the resulting
+-- 'PackageName' is valid
+--
+-- @since 3.4.0.0
+mkPackageNameST :: ShortText -> PackageName
+mkPackageNameST = PackageName
+
 -- | 'mkPackageName'
 --
 -- @since 2.0.0.2

Cabal/Distribution/Types/UnqualComponentName.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Distribution.Types.UnqualComponentName
-  ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName
+  ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName
   , packageNameToUnqualComponentName, unqualComponentNameToPackageName
   ) where
 
@@ -32,6 +32,10 @@ newtype UnqualComponentName = UnqualComponentName ShortText
 unUnqualComponentName :: UnqualComponentName -> String
 unUnqualComponentName (UnqualComponentName s) = fromShortText s
 
+-- | @since 3.4.0.0
+unUnqualComponentNameST :: UnqualComponentName -> ShortText
+unUnqualComponentNameST (UnqualComponentName s) = s
+
 -- | Construct a 'UnqualComponentName' from a 'String'
 --
 -- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName'
@@ -78,7 +82,7 @@ instance NFData UnqualComponentName where
 --
 -- @since 2.0.0.2
 packageNameToUnqualComponentName :: PackageName -> UnqualComponentName
-packageNameToUnqualComponentName = mkUnqualComponentName . unPackageName
+packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST
 
 -- | Converts an unqualified component name to a package name
 --
@@ -90,4 +94,4 @@ packageNameToUnqualComponentName = mkUnqualComponentName . unPackageName
 --
 -- @since 2.0.0.2
 unqualComponentNameToPackageName :: UnqualComponentName -> PackageName
-unqualComponentNameToPackageName = mkPackageName . unUnqualComponentName
+unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST

Cabal/Distribution/Types/VersionRange.hs

@@ -71,7 +71,6 @@ foldVersionRange anyv this later earlier union intersect = fold
     alg (MajorBoundVersionF v)          = fold (majorBound v)
     alg (UnionVersionRangesF v1 v2)     = union v1 v2
     alg (IntersectVersionRangesF v1 v2) = intersect v1 v2
-    alg (VersionRangeParensF v)         = v
 
     wildcard v = intersectVersionRanges
                    (orLaterVersion v)
@@ -104,12 +103,11 @@ normaliseVersionRange = hyloVersionRange embed projectVersionRange
 
 -- |  Remove 'VersionRangeParens' constructors.
 --
+-- Since version 3.4 this function is 'id', there aren't 'VersionRangeParens' constructor in 'VersionRange' anymore.
+--
 -- @since 2.2
 stripParensVersionRange :: VersionRange -> VersionRange
-stripParensVersionRange = hyloVersionRange embed projectVersionRange
-  where
-    embed (VersionRangeParensF vr) = vr
-    embed vr = embedVersionRange vr
+stripParensVersionRange = id
 
 -- | Does this version fall within the given range?
 --