Add buildinfo-reference-generator

Note all Described instances are implemented. This is just a start.

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

@@ -3,16 +3,30 @@
 module Test.QuickCheck.Instances.Cabal () where
 
 import Control.Applicative (liftA2)
+import Data.Char (isAlphaNum, isDigit)
+import Data.List (intercalate)
 import Test.QuickCheck
 
 import Distribution.SPDX
 import Distribution.Version
+import Distribution.Types.PackageName
 import Distribution.Types.VersionRange.Internal
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (pure, (<$>), (<*>))
 #endif
 
+-------------------------------------------------------------------------------
+-- PackageName
+-------------------------------------------------------------------------------
+
+instance Arbitrary PackageName where
+    arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent
+      where
+        nameComponent = shortListOf1 5 (elements packageChars)
+                        `suchThat` (not . all isDigit)
+        packageChars  = filter isAlphaNum ['\0'..'\127']
+
 -------------------------------------------------------------------------------
 -- Version
 -------------------------------------------------------------------------------
@@ -150,3 +164,11 @@ instance Arbitrary LicenseExpression where
     shrink (EOr a b)  = a : b : map (uncurry EOr) (shrink (a, b))
     shrink _          = []
 
+-------------------------------------------------------------------------------
+-- Helpers
+-------------------------------------------------------------------------------
+
+shortListOf1 :: Int -> Gen a -> Gen [a]
+shortListOf1 bound gen = sized $ \n -> do
+    k <- choose (1, 1 `max` ((n `div` 2) `min` bound))
+    vectorOf k gen

Cabal/Cabal.cabal

@@ -303,6 +303,9 @@ library
     -- already depends on `fail` and `semigroups` transitively
     build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20
 
+  if !impl(ghc >= 7.10)
+    build-depends: void >= 0.7.3 && < 0.8
+
   if !impl(ghc >= 7.8)
     -- semigroups depends on tagged.
     build-depends:  tagged >=0.8.6 && <0.9
@@ -481,6 +484,8 @@ library
     Distribution.Types.VersionInterval
     Distribution.Types.GivenComponent
     Distribution.Types.PackageVersionConstraint
+    Distribution.Utils.CharSet
+    Distribution.Utils.Regex
     Distribution.Utils.Generic
     Distribution.Utils.NubList
     Distribution.Utils.ShortText
@@ -504,6 +509,7 @@ library
     Distribution.Compat.CharParsing
     Distribution.FieldGrammar
     Distribution.FieldGrammar.Class
+    Distribution.FieldGrammar.Described
     Distribution.FieldGrammar.FieldDescrs
     Distribution.FieldGrammar.Parsec
     Distribution.FieldGrammar.Pretty
@@ -614,13 +620,15 @@ test-suite unit-tests
     UnitTests.Distribution.Compat.CreatePipe
     UnitTests.Distribution.Compat.Graph
     UnitTests.Distribution.Compat.Time
+    UnitTests.Distribution.Described
     UnitTests.Distribution.Simple.Glob
     UnitTests.Distribution.Simple.Program.GHC
     UnitTests.Distribution.Simple.Program.Internal
     UnitTests.Distribution.Simple.Utils
     UnitTests.Distribution.SPDX
     UnitTests.Distribution.System
     UnitTests.Distribution.Types.GenericPackageDescription
+    UnitTests.Distribution.Utils.CharSet
     UnitTests.Distribution.Utils.Generic
     UnitTests.Distribution.Utils.NubList
     UnitTests.Distribution.Utils.ShortText
@@ -644,6 +652,7 @@ test-suite unit-tests
     directory,
     filepath,
     integer-logarithms >= 1.0.2 && <1.1,
+    rere >=0.1 && <0.2,
     tasty >= 1.2.3 && < 1.3,
     tasty-hunit,
     tasty-quickcheck,
@@ -657,6 +666,14 @@ test-suite unit-tests
   ghc-options: -Wall
   default-language: Haskell2010
 
+  if !impl(ghc >= 7.10)
+    build-depends: void
+
+  -- Cabal-quickcheck
+  hs-source-dirs: Cabal-quickcheck/src
+  other-modules:
+    Test.QuickCheck.Instances.Cabal
+
 test-suite parser-tests
   type: exitcode-stdio-1.0
   hs-source-dirs: tests
@@ -677,7 +694,7 @@ test-suite parser-tests
   default-language: Haskell2010
 
   if !impl(ghc >= 8.0)
-    build-depends:  semigroups
+    build-depends: semigroups
 
   if impl(ghc >= 7.8)
     build-depends:

Cabal/Distribution/Compat/Prelude.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Trustworthy #-}
 
 #ifdef MIN_VERSION_base
 #define MINVER_base_411 MIN_VERSION_base(4,11,0)
@@ -48,6 +49,7 @@ module Distribution.Compat.Prelude (
     Set,
     Identity (..),
     Proxy (..),
+    Void,
 
     -- * Data.Maybe
     catMaybes, mapMaybe,
@@ -92,6 +94,9 @@ module Distribution.Compat.Prelude (
     chr, ord,
     toLower, toUpper,
 
+    -- * Data.Void
+    absurd, vacuous,
+
     -- * Data.Word & Data.Int
     Word,
     Word8, Word16, Word32, Word64,
@@ -160,6 +165,7 @@ import Data.Maybe
 import Data.String                   (IsString (..))
 import Data.Int
 import Data.Word
+import Data.Void                     (Void, absurd, vacuous)
 import Text.Read                     (readMaybe)
 
 import qualified Text.PrettyPrint as Disp

Cabal/Distribution/FieldGrammar/Class.hs

@@ -11,11 +11,10 @@ import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.CabalSpecVersion (CabalSpecVersion)
-import Distribution.Compat.Newtype   (Newtype)
+import Distribution.CabalSpecVersion       (CabalSpecVersion)
+import Distribution.Compat.Newtype         (Newtype)
+import Distribution.FieldGrammar.Described (Described)
 import Distribution.Fields.Field
-import Distribution.Parsec           (Parsec)
-import Distribution.Pretty           (Pretty)
 import Distribution.Utils.ShortText
 
 -- | 'FieldGrammar' is parametrised by
@@ -33,7 +32,7 @@ class FieldGrammar g where
 
     -- | Field which should be defined, exactly once.
     uniqueFieldAla
-        :: (Parsec b, Pretty b, Newtype a b)
+        :: (Described b, Newtype a b)
         => FieldName   -- ^ field name
         -> (a -> b)    -- ^ 'Newtype' pack
         -> ALens' s a  -- ^ lens into the field
@@ -48,15 +47,15 @@ class FieldGrammar g where
 
     -- | Optional field.
     optionalFieldAla
-        :: (Parsec b, Pretty b, Newtype a b)
+        :: (Described b, Newtype a b)
         => FieldName          -- ^ field name
         -> (a -> b)           -- ^ 'pack'
         -> ALens' s (Maybe a) -- ^ lens into the field
         -> g s (Maybe a)
 
     -- | Optional field with default value.
     optionalFieldDefAla
-        :: (Parsec b, Pretty b, Newtype a b, Eq a)
+        :: (Described b, Newtype a b, Eq a)
         => FieldName   -- ^ field name
         -> (a -> b)    -- ^ 'Newtype' pack
         -> ALens' s a  -- ^ @'Lens'' s a@: lens into the field
@@ -94,7 +93,7 @@ class FieldGrammar g where
     -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
     --
     monoidalFieldAla
-        :: (Parsec b, Pretty b, Monoid a, Newtype a b)
+        :: (Described b, Monoid a, Newtype a b)
         => FieldName   -- ^ field name
         -> (a -> b)    -- ^ 'pack'
         -> ALens' s a  -- ^ lens into the field
@@ -135,23 +134,23 @@ class FieldGrammar g where
 
 -- | Field which can be defined at most once.
 uniqueField
-    :: (FieldGrammar g, Parsec a, Pretty a)
+    :: (FieldGrammar g, Described a)
     => FieldName   -- ^ field name
     -> ALens' s a  -- ^ lens into the field
     -> g s a
 uniqueField fn = uniqueFieldAla fn Identity
 
 -- | Field which can be defined at most once.
 optionalField
-    :: (FieldGrammar g, Parsec a, Pretty a)
+    :: (FieldGrammar g, Described a)
     => FieldName          -- ^ field name
     -> ALens' s (Maybe a) -- ^ lens into the field
     -> g s (Maybe a)
 optionalField fn = optionalFieldAla fn Identity
 
 -- | Optional field with default value.
 optionalFieldDef
-    :: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a)
+    :: (FieldGrammar g, Functor (g s), Described a, Eq a)
     => FieldName   -- ^ field name
     -> ALens' s a  -- ^ @'Lens'' s a@: lens into the field
     -> a           -- ^ default value
@@ -160,7 +159,7 @@ optionalFieldDef fn = optionalFieldDefAla fn Identity
 
 -- | Field which can be define multiple times, and the results are @mappend@ed.
 monoidalField
-    :: (FieldGrammar g, Parsec a, Pretty a, Monoid a)
+    :: (FieldGrammar g, Described a, Monoid a)
     => FieldName   -- ^ field name
     -> ALens' s a  -- ^ lens into the field
     -> g s a

Cabal/Distribution/FieldGrammar/Described.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE DeriveFoldable      #-}
+{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Distribution.FieldGrammar.Described (
+    Described (..),
+    describeDoc,
+    -- * Regular expressions
+    Regex (..),
+    reEps,
+    reChar,
+    reChars,
+    reMunchCS,
+    reMunch1CS,
+    -- * Variables
+    reVar0,
+    reVar1,
+    -- * Special expressions
+    reDot,
+    reComma,
+    reSpacedComma,
+    reHsString,
+    reUnqualComponent,
+    -- * Lists
+    reSpacedList,
+    reCommaList,
+    reOptCommaList,
+    -- * Character Sets
+    csChar,
+    csAlphaNum,
+    csNotSpace,
+    csNotSpaceOrComma,
+    ) where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Distribution.Parsec (Parsec)
+import Distribution.Pretty (Pretty)
+
+import Distribution.Utils.Regex
+
+import qualified Distribution.Utils.CharSet as CS
+import qualified Text.PrettyPrint           as PP
+
+-- | Class describing the pretty/parsec format of a.
+class (Pretty a, Parsec a) => Described a where
+    -- | A pretty document of "regex" describing the field format
+    describe :: proxy a -> Regex void
+
+-- | Pretty-print description.
+--
+-- >>> describeDoc ([] :: [Bool])
+-- \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\}
+--
+describeDoc :: Described a => proxy a -> PP.Doc
+describeDoc p = regexDoc (describe p)
+
+instance Described Bool where
+    describe _ = REUnion ["True", "False"]
+
+instance Described a => Described (Identity a) where
+    describe _ = describe ([] :: [a])
+
+-------------------------------------------------------------------------------
+-- Lists
+------------------------------------------------------------------------------
+
+reSpacedList :: Regex a -> Regex a
+reSpacedList = REMunch RESpaces1
+
+reCommaList :: Regex a -> Regex a
+reCommaList = RECommaList
+
+reOptCommaList :: Regex a -> Regex a
+reOptCommaList = REOptCommaList
+
+-------------------------------------------------------------------------------
+-- Specific grammars
+-------------------------------------------------------------------------------
+
+reHsString :: Regex a
+reHsString = RENamed "hs-string" impl  where
+    impl = reChar '"' <> REMunch reEps (REUnion [strChar, escChar]) <> reChar '"'
+    strChar = RECharSet $ CS.difference CS.universe (CS.fromList "\"\\")
+
+    escChar = REUnion
+        [ "\\&"
+        , "\\\\"
+        , REUnion ["\\n", RENamed "escapes" "\\n"] -- TODO
+        , "\\" <> RECharSet "0123456789"
+        , "\\o" <> RECharSet "01234567"
+        , "\\x" <> RECharSet "0123456789abcdefABCDEF"
+        , REUnion ["\\^@", RENamed "control" "\\^@"] -- TODO
+        , REUnion ["\\NUL", RENamed "ascii" "\\NUL"] -- TODO
+        ]
+
+reUnqualComponent :: Regex a
+reUnqualComponent = RENamed "unqual-name" $
+    REMunch1 (reChar '-') component
+  where
+    component
+        = REMunch reEps (RECharSet csAlphaNum)
+        -- currently the parser accepts "csAlphaNum `difference` "0123456789"
+        -- which is larger set than CS.alpha
+        --
+        -- Hackage rejects non ANSI names, so it's not so relevant.
+        <> RECharSet CS.alpha
+        <> REMunch reEps (RECharSet csAlphaNum)
+
+reDot :: Regex a
+reDot = reChar '.'
+
+reComma :: Regex a
+reComma = reChar ','
+
+reSpacedComma :: Regex a
+reSpacedComma = RESpaces <> reComma <> RESpaces
+
+-------------------------------------------------------------------------------
+-- Character sets
+-------------------------------------------------------------------------------
+
+csChar :: Char -> CS.CharSet
+csChar = CS.singleton
+
+csAlphaNum :: CS.CharSet
+csAlphaNum = CS.alphanum
+
+csNotSpace :: CS.CharSet
+csNotSpace = CS.difference CS.universe $ CS.singleton ' '
+
+csNotSpaceOrComma :: CS.CharSet
+csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ','

Cabal/Distribution/ModuleName.hs

@@ -26,10 +26,11 @@ module Distribution.ModuleName (
 import Distribution.Compat.Prelude
 import Prelude ()
 
+import Distribution.FieldGrammar.Described
 import Distribution.Parsec
 import Distribution.Pretty
-import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText)
-import System.FilePath              (pathSeparator)
+import Distribution.Utils.ShortText        (ShortText, fromShortText, toShortText)
+import System.FilePath                     (pathSeparator)
 
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint                as Disp
@@ -57,6 +58,9 @@ instance Parsec ModuleName where
             cs <- P.munch validModuleChar
             return (c:cs)
 
+instance Described ModuleName where
+    describe _ = RETodo
+
 validModuleChar :: Char -> Bool
 validModuleChar c = isAlphaNum c || c == '_' || c == '\''