Skip to content

GitLab

C
Cabal
Commit 288687e9 authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files
Options

Change BuildReports parse/pretty to use FieldGrammar framework

parent c753f62a
Hide whitespace changes
Inline Side-by-side
Showing with 459 additions and 277 deletions
Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs
View file @ 288687e9
{-# 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
View file @ 288687e9
......@@ -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
View file @ 288687e9
......@@ -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)
]
-------------------------------------------------------------------------------
......
cabal-install/Distribution/Client/BuildReports/Anonymous.hs
View file @ 288687e9
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Reporting
......@@ -17,110 +18,45 @@ module Distribution.Client.BuildReports.Anonymous (
Outcome(..),
-- * Constructing and writing reports
new,
newBuildReport,
-- * parsing and pretty printing
parse,
parseList,
show,
parseBuildReport,
parseBuildReportList,
showBuildReport,
-- showList,
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (show)
import qualified Distribution.Client.Types as BR
( BuildOutcome, BuildFailure(..), BuildResult(..)
, DocsResult(..), TestsResult(..) )
import Distribution.Client.Utils
( mergeBy, MergeResult(..), cabalInstallVersion )
import Distribution.CabalSpecVersion
import Distribution.Client.BuildReports.Types
import Distribution.Client.Utils (cabalInstallVersion)
import Distribution.Compiler (CompilerId (..))
import Distribution.FieldGrammar
import Distribution.Fields (readFields, showFields)
import Distribution.Fields.ParseResult (ParseResult, parseFatalFailure, runParseResult)
import Distribution.Package (PackageIdentifier (..), mkPackageName)
import Distribution.PackageDescription (FlagAssignment)
import Distribution.Parsec (PError (..), zeroPos)
import Distribution.Parsec.Newtypes
import Distribution.System (Arch, OS)
import Distribution.Package
( PackageIdentifier(..), mkPackageName )
import Distribution.PackageDescription
( FlagName, mkFlagName, unFlagName
, FlagAssignment, mkFlagAssignment, unFlagAssignment )
import Distribution.System
( OS, Arch )
import Distribution.Compiler
( CompilerId(..) )
import qualified Distribution.Deprecated.Text as Text
( Text(disp, parse) )
import Distribution.Deprecated.ParseUtils
( FieldDescr(..), ParseResult(..), Field(..)
, simpleField, listField, ppFields, readFields
, syntaxError, locatedErrorMsg, simpleFieldParsec )
import Distribution.Pretty (pretty)
import Distribution.Parsec (parsec)
import Distribution.Simple.Utils
( comparing )
import qualified Distribution.Client.BuildReports.Lens as L
import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))
import qualified Distribution.Deprecated.ReadP as Parse
( ReadP, pfail, munch1, skipSpaces )
import qualified Text.PrettyPrint as Disp
( Doc, render, char, text )
import Text.PrettyPrint
( (<+>) )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Char as Char
( isAlpha, isAlphaNum )
data BuildReport
= BuildReport {
-- | The package this build report is about
package :: PackageIdentifier,
-------------------------------------------------------------------------------
-- New
-------------------------------------------------------------------------------
-- | The OS and Arch the package was built on
os :: OS,
arch :: Arch,
-- | The Haskell compiler (and hopefully version) used
compiler :: CompilerId,
-- | The uploading client, ie cabal-install-x.y.z
client :: PackageIdentifier,
-- | Which configurations flags we used
flagAssignment :: FlagAssignment,
-- | Which dependent packages we were using exactly
dependencies :: [PackageIdentifier],
-- | Did installing work ok?
installOutcome :: InstallOutcome,
-- Which version of the Cabal library was used to compile the Setup.hs
-- cabalVersion :: Version,
-- Which build tools we were using (with versions)
-- tools :: [PackageIdentifier],
-- | Configure outcome, did configure work ok?
docsOutcome :: Outcome,
-- | Configure outcome, did configure work ok?
testsOutcome :: Outcome
}
data InstallOutcome
= PlanningFailed
| DependencyFailed PackageIdentifier
| DownloadFailed
| UnpackFailed
| SetupFailed
| ConfigureFailed
| BuildFailed
| TestsFailed
| InstallFailed
| InstallOk
deriving Eq
data Outcome = NotTried | Failed | Ok
deriving Eq
new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
-> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport
new os' arch' comp pkgid flags deps result =
newBuildReport os' arch' comp pkgid flags deps result =
BuildReport {
package = pkgid,
os = os',
......@@ -160,156 +96,52 @@ cabalInstallID :: PackageIdentifier
cabalInstallID =
PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion
-- ------------------------------------------------------------
-- * External format
-- ------------------------------------------------------------
-------------------------------------------------------------------------------
-- FieldGrammar
-------------------------------------------------------------------------------
initialBuildReport :: BuildReport
initialBuildReport = BuildReport {
package = requiredField "package",
os = requiredField "os",
arch = requiredField "arch",
compiler = requiredField "compiler",
client = requiredField "client",
flagAssignment = mempty,
dependencies = [],
installOutcome = requiredField "install-outcome",
-- cabalVersion = Nothing,
-- tools = [],
docsOutcome = NotTried,
testsOutcome = NotTried
}
where
requiredField fname = error ("required field: " ++ fname)
fieldDescrs :: (Applicative (g BuildReport), FieldGrammar g) => g BuildReport BuildReport
fieldDescrs = BuildReport
<$> uniqueField "package" L.package
<*> uniqueField "os" L.os
<*> uniqueField "arch" L.arch
<*> uniqueField "compiler" L.compiler
<*> uniqueField "client" L.client
<*> monoidalField "flags" L.flagAssignment
<*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
<*> uniqueField "install-outcome" L.installOutcome
<*> uniqueField "docs-outcome" L.docsOutcome
<*> uniqueField "tests-outcome" L.testsOutcome
-- -----------------------------------------------------------------------------
-- Parsing
parse :: String -> Either String BuildReport
parse s = case parseFields s of
ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror
ParseOk _ report -> Right report
parseBuildReport :: BS.ByteString -> Either String BuildReport
parseBuildReport s = case snd $ runParseResult $ parseFields s of
Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ]
Right report -> Right report
parseFields :: String -> ParseResult BuildReport
parseFields :: BS.ByteString -> ParseResult BuildReport
parseFields input = do
fields <- traverse extractField =<< readFields input
let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)
sortedFieldDescrs
(sortBy (comparing (\(_,name,_) -> name)) fields)
checkMerged initialBuildReport merged
where
extractField :: Field -> ParseResult (Int, String, String)
extractField (F line name value) = return (line, name, value)
extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"
extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"
fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input
case partitionFields fields of
(fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs
_otherwise -> parseFatalFailure zeroPos "found sections in BuildReport"
checkMerged report [] = return report
checkMerged report (merged:remaining) = case merged of
InBoth fieldDescr (line, _name, value) -> do
report' <- fieldSet fieldDescr line value report
checkMerged report' remaining
OnlyInRight (line, name, _) ->
syntaxError line ("Unrecognized field " ++ name)
OnlyInLeft fieldDescr ->
fail ("Missing field " ++ fieldName fieldDescr)
parseList :: String -> [BuildReport]
parseList str =
[ report | Right report <- map parse (split str) ]
parseBuildReportList :: BS.ByteString -> [BuildReport]
parseBuildReportList str =
[ report | Right report <- map parseBuildReport (split str) ]
where
split :: String -> [String]
split = filter (not . null) . unfoldr chunk . lines
split :: BS.ByteString -> [BS.ByteString]
split = filter (not . BS.null) . unfoldr chunk . BS8.lines
chunk [] = Nothing
chunk ls = case break null ls of
(r, rs) -> Just (unlines r, dropWhile null rs)
chunk ls = case break BS.null ls of
(r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)
-- -----------------------------------------------------------------------------
-- Pretty-printing
show :: BuildReport -> String
show = Disp.render . ppFields fieldDescrs
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
fieldDescrs :: [FieldDescr BuildReport]
fieldDescrs =
[ simpleField "package" Text.disp Text.parse
package (\v r -> r { package = v })
, simpleField "os" Text.disp Text.parse
os (\v r -> r { os = v })
, simpleFieldParsec "arch" pretty parsec
arch (\v r -> r { arch = v })
, simpleField "compiler" Text.disp Text.parse
compiler (\v r -> r { compiler = v })
, simpleField "client" Text.disp Text.parse
client (\v r -> r { client = v })
, listField "flags" dispFlag parseFlag
(unFlagAssignment . flagAssignment)
(\v r -> r { flagAssignment = mkFlagAssignment v })
, listField "dependencies" Text.disp Text.parse
dependencies (\v r -> r { dependencies = v })
, simpleField "install-outcome" Text.disp Text.parse
installOutcome (\v r -> r { installOutcome = v })
, simpleField "docs-outcome" Text.disp Text.parse
docsOutcome (\v r -> r { docsOutcome = v })
, simpleField "tests-outcome" Text.disp Text.parse
testsOutcome (\v r -> r { testsOutcome = v })
]
sortedFieldDescrs :: [FieldDescr BuildReport]
sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
dispFlag :: (FlagName, Bool) -> Disp.Doc
dispFlag (fname, True) = Disp.text (unFlagName fname)
dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname)
parseFlag :: Parse.ReadP r (FlagName, Bool)
parseFlag = do
name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
case name of
('-':flag) -> return (mkFlagName flag, False)
flag -> return (mkFlagName flag, True)
instance Text.Text InstallOutcome where
disp PlanningFailed = Disp.text "PlanningFailed"
disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
disp DownloadFailed = Disp.text "DownloadFailed"
disp UnpackFailed = Disp.text "UnpackFailed"
disp SetupFailed = Disp.text "SetupFailed"
disp ConfigureFailed = Disp.text "ConfigureFailed"
disp BuildFailed = Disp.text "BuildFailed"
disp TestsFailed = Disp.text "TestsFailed"
disp InstallFailed = Disp.text "InstallFailed"
disp InstallOk = Disp.text "InstallOk"
parse = do
name <- Parse.munch1 Char.isAlphaNum
case name of
"PlanningFailed" -> return PlanningFailed
"DependencyFailed" -> do Parse.skipSpaces
pkgid <- Text.parse
return (DependencyFailed pkgid)
"DownloadFailed" -> return DownloadFailed
"UnpackFailed" -> return UnpackFailed
"SetupFailed" -> return SetupFailed
"ConfigureFailed" -> return ConfigureFailed
"BuildFailed" -> return BuildFailed
"TestsFailed" -> return TestsFailed
"InstallFailed" -> return InstallFailed
"InstallOk" -> return InstallOk
_ -> Parse.pfail
instance Text.Text Outcome where
disp NotTried = Disp.text "NotTried"
disp Failed = Disp.text "Failed"
disp Ok = Disp.text "Ok"
parse = do
name <- Parse.munch1 Char.isAlpha
case name of
"NotTried" -> return NotTried
"Failed" -> return Failed
"Ok" -> return Ok
_ -> Parse.pfail
showBuildReport :: BuildReport -> String
showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs
cabal-install/Distribution/Client/BuildReports/Lens.hs 0 → 100644
View file @ 288687e9
module Distribution.Client.BuildReports.Lens (
BuildReport,
module Distribution.Client.BuildReports.Lens,
) where
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Lens
import Prelude ()
import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome)
import Distribution.Compiler (CompilerId)
import Distribution.System (Arch, OS)
import Distribution.Types.Flag (FlagAssignment)
import Distribution.Types.PackageId (PackageIdentifier)
import qualified Distribution.Client.BuildReports.Types as T
package :: Lens' BuildReport PackageIdentifier
package f s = fmap (\x -> s { T.package = x }) (f (T.package s))
os :: Lens' BuildReport OS
os f s = fmap (\x -> s { T.os = x }) (f (T.os s))
arch :: Lens' BuildReport Arch
arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s))
compiler :: Lens' BuildReport CompilerId
compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s))
client :: Lens' BuildReport PackageIdentifier
client f s = fmap (\x -> s { T.client = x }) (f (T.client s))
flagAssignment :: Lens' BuildReport FlagAssignment
flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s))
dependencies :: Lens' BuildReport [PackageIdentifier]
dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s))
installOutcome :: Lens' BuildReport InstallOutcome
installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s))
docsOutcome :: Lens' BuildReport Outcome
docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s))
testsOutcome :: Lens' BuildReport Outcome
testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s))
cabal-install/Distribution/Client/BuildReports/Storage.hs
View file @ 288687e9
-- TODO
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
......@@ -25,8 +24,8 @@ module Distribution.Client.BuildReports.Storage (
fromPlanningFailure,
) where
import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
import Distribution.Client.Types
import qualified Distribution.Client.InstallPlan as InstallPlan
......@@ -68,7 +67,7 @@ storeAnonymous reports = sequence_
-- the writes for each report are atomic (under 4k and flush at boundaries)
where
format r = '\n' : BuildReport.show r ++ "\n"
format r = '\n' : showBuildReport r ++ "\n"
separate :: [(BuildReport, Maybe Repo)]
-> [(Repo, [BuildReport])]
separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
......@@ -101,7 +100,7 @@ storeLocal cinfo templates reports platform = sequence_
, let output = concatMap format reports'
]
where
format r = '\n' : BuildReport.show r ++ "\n"
format r = '\n' : showBuildReport r ++ "\n"
reportFileName template report =
fromPathTemplate (substPathTemplate env template)
......@@ -141,7 +140,7 @@ fromPlanPackage :: Platform -> CompilerId
fromPlanPackage (Platform arch os) comp
(InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))
(Just buildResult) =
Just ( BuildReport.new os arch comp
Just ( newBuildReport os arch comp
(packageId srcPkg) flags
(map packageId (CD.nonSetupDeps deps))
buildResult
......@@ -157,5 +156,5 @@ fromPlanPackage _ _ _ _ = Nothing
fromPlanningFailure :: Platform -> CompilerId
-> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
fromPlanningFailure (Platform arch os) comp pkgids flags =
[ (BuildReport.new os arch comp pkgid flags [] (Left PlanningFailed), Nothing)
[ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing)
| pkgid <- pkgids ]
cabal-install/Distribution/Client/BuildReports/Types.hs
View file @ 288687e9
......@@ -13,18 +13,29 @@
-----------------------------------------------------------------------------
module Distribution.Client.BuildReports.Types (
ReportLevel(..),
) where
BuildReport (..),
InstallOutcome(..),
Outcome(..),
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
import qualified Text.PrettyPrint as Disp
import Distribution.Compiler (CompilerId (..))
import Distribution.FieldGrammar.Described
import Distribution.PackageDescription (FlagAssignment)
import Distribution.Parsec (Parsec (..))
import Distribution.Pretty (Pretty (..), prettyShow)
import Distribution.System (Arch, OS)
import Distribution.Types.PackageId (PackageIdentifier)
import Text.PrettyPrint ((<+>))
import Data.Char as Char
( isAlpha, toLower )
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)