Merge pull request #6783 from phadej/build-reports-parsec

Change BuildReports parse/pretty to use FieldGrammar framework

Author: phadej

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

@@ -1,4 +1,7 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP              #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs            #-}
+{-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Test.QuickCheck.Instances.Cabal () where
 
@@ -8,7 +11,10 @@ import Data.List                  (intercalate)
 import Distribution.Utils.Generic (lowercase)
 import Test.QuickCheck
 
+import GHC.Generics
+
 import Distribution.CabalSpecVersion
+import Distribution.Compiler
 import Distribution.ModuleName
 import Distribution.Parsec.Newtypes
 import Distribution.Simple.Flag                    (Flag (..))
@@ -311,6 +317,17 @@ instance Arbitrary LicenseExpression where
     shrink (EOr a b)  = a : b : map (uncurry EOr) (shrink (a, b))
     shrink _          = []
 
+-------------------------------------------------------------------------------
+-- Compiler
+-------------------------------------------------------------------------------
+
+instance Arbitrary CompilerFlavor where
+    arbitrary = elements knownCompilerFlavors
+
+instance Arbitrary CompilerId where
+    arbitrary = genericArbitrary
+    shrink    = genericShrink
+
 -------------------------------------------------------------------------------
 -- Helpers
 -------------------------------------------------------------------------------
@@ -319,3 +336,38 @@ 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
+
+-------------------------------------------------------------------------------
+-- Generic Arbitrary
+-------------------------------------------------------------------------------
+
+-- Generic arbitary for non-recursive types
+genericArbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a
+genericArbitrary = fmap to garbitrary
+
+class GArbitrary f where
+    garbitrary :: Gen (f ())
+
+class GArbitrarySum f where
+    garbitrarySum :: [Gen (f ())]
+
+class GArbitraryProd f where
+    garbitraryProd :: Gen (f ())
+
+instance (GArbitrarySum f, i ~ D) => GArbitrary (M1 i c f) where
+    garbitrary = fmap M1 (oneof garbitrarySum)
+
+instance (GArbitraryProd f, i ~ C) => GArbitrarySum (M1 i c f) where
+    garbitrarySum = [fmap M1 garbitraryProd]
+
+instance (GArbitrarySum f, GArbitrarySum g) => GArbitrarySum (f :+: g) where
+    garbitrarySum = map (fmap L1) garbitrarySum ++ map (fmap R1) garbitrarySum
+
+instance (GArbitraryProd f, i ~ S) => GArbitraryProd (M1 i c f) where
+    garbitraryProd = fmap M1 garbitraryProd
+
+instance (GArbitraryProd f, GArbitraryProd g) => GArbitraryProd (f :*: g) where
+    garbitraryProd = liftA2 (:*:) garbitraryProd garbitraryProd
+
+instance (Arbitrary a) => GArbitraryProd (K1 i a) where
+    garbitraryProd = fmap K1 arbitrary

Cabal/Distribution/Compiler.hs

@@ -59,6 +59,7 @@ import Distribution.Version (Version, mkVersion', nullVersion)
 import qualified System.Info (compilerName, compilerVersion)
 import Distribution.Parsec (Parsec (..))
 import Distribution.Pretty (Pretty (..), prettyShow)
+import Distribution.FieldGrammar.Described
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint as Disp
 
@@ -89,6 +90,12 @@ instance Parsec CompilerFlavor where
           cs <- P.munch1 isAlphaNum
           if all isDigit cs then fail "all digits compiler name" else return cs
 
+instance Described CompilerFlavor where
+    describe _ = REUnion
+        [ fromString (prettyShow c)
+        | c <- knownCompilerFlavors
+        ]
+
 classifyCompilerFlavor :: String -> CompilerFlavor
 classifyCompilerFlavor s =
   fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap
@@ -165,6 +172,12 @@ instance Parsec CompilerId where
     version <- (P.char '-' >> parsec) <|> return nullVersion
     return (CompilerId flavour version)
 
+instance Described CompilerId where
+  describe _ =
+    describe (Proxy :: Proxy CompilerFlavor)
+    <> fromString "-"
+    <> describe (Proxy :: Proxy Version)
+
 lowercase :: String -> String
 lowercase = map toLower
 

Cabal/tests/UnitTests/Distribution/Described.hs

@@ -11,21 +11,21 @@ import Test.QuickCheck       (Arbitrary (..), Gen, Property, choose, counterexam
 import Test.Tasty            (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
 
-import Distribution.FieldGrammar.Described
-       (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList)
+import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList)
 import Distribution.Parsec                 (eitherParsec)
 import Distribution.Pretty                 (prettyShow)
 
 import qualified Distribution.Utils.CharSet as CS
 
+import Distribution.Compiler                       (CompilerFlavor, CompilerId)
 import Distribution.ModuleName                     (ModuleName)
+import Distribution.System                         (Arch, OS)
 import Distribution.Types.Dependency               (Dependency)
-import Distribution.Types.Flag                     (FlagName, FlagAssignment)
+import Distribution.Types.Flag                     (FlagAssignment, FlagName)
 import Distribution.Types.PackageId                (PackageIdentifier)
 import Distribution.Types.PackageName              (PackageName)
 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
 import Distribution.Types.Version                  (Version)
-import Distribution.System (OS, Arch)
 import Distribution.Types.VersionRange             (VersionRange)
 
 import qualified RERE         as RE
@@ -47,6 +47,8 @@ tests = testGroup "Described"
     , testDescribed (Proxy :: Proxy ModuleName)
     , testDescribed (Proxy :: Proxy OS)
     , testDescribed (Proxy :: Proxy Arch)
+    , testDescribed (Proxy :: Proxy CompilerFlavor)
+    , testDescribed (Proxy :: Proxy CompilerId)
     ]
 
 -------------------------------------------------------------------------------