{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Distribution.Client.BuildReports.Anonymous (
BuildReport(..),
InstallOutcome(..),
Outcome(..),
newBuildReport,
parseBuildReport,
parseBuildReportList,
showBuildReport,
cabalInstallID
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.CabalSpecVersion
import Distribution.Client.BuildReports.Types
import Distribution.Client.Version (cabalInstallVersion)
import Distribution.Compiler (CompilerId (..))
import Distribution.FieldGrammar
import Distribution.Fields
import Distribution.Package (PackageIdentifier (..), mkPackageName)
import Distribution.PackageDescription (FlagAssignment)
import Distribution.Parsec
import Distribution.System (Arch, OS)
import qualified Distribution.Client.BuildReports.Lens as L
import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
-> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport
newBuildReport :: OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> BuildOutcome
-> BuildReport
newBuildReport OS
os' Arch
arch' CompilerId
comp PackageIdentifier
pkgid FlagAssignment
flags [PackageIdentifier]
deps BuildOutcome
result =
BuildReport {
package :: PackageIdentifier
package = PackageIdentifier
pkgid,
os :: OS
os = OS
os',
arch :: Arch
arch = Arch
arch',
compiler :: CompilerId
compiler = CompilerId
comp,
client :: PackageIdentifier
client = PackageIdentifier
cabalInstallID,
flagAssignment :: FlagAssignment
flagAssignment = FlagAssignment
flags,
dependencies :: [PackageIdentifier]
dependencies = [PackageIdentifier]
deps,
installOutcome :: InstallOutcome
installOutcome = InstallOutcome
convertInstallOutcome,
docsOutcome :: Outcome
docsOutcome = Outcome
convertDocsOutcome,
testsOutcome :: Outcome
testsOutcome = Outcome
convertTestsOutcome
}
where
convertInstallOutcome :: InstallOutcome
convertInstallOutcome = case BuildOutcome
result of
Left BuildFailure
BR.PlanningFailed -> InstallOutcome
PlanningFailed
Left (BR.DependentFailed PackageIdentifier
p) -> PackageIdentifier -> InstallOutcome
DependencyFailed PackageIdentifier
p
Left (BR.DownloadFailed SomeException
_) -> InstallOutcome
DownloadFailed
Left (BR.UnpackFailed SomeException
_) -> InstallOutcome
UnpackFailed
Left (BR.ConfigureFailed SomeException
_) -> InstallOutcome
ConfigureFailed
Left (BR.BuildFailed SomeException
_) -> InstallOutcome
BuildFailed
Left (BR.TestsFailed SomeException
_) -> InstallOutcome
TestsFailed
Left (BR.InstallFailed SomeException
_) -> InstallOutcome
InstallFailed
Right (BR.BuildResult DocsResult
_ TestsResult
_ Maybe InstalledPackageInfo
_) -> InstallOutcome
InstallOk
convertDocsOutcome :: Outcome
convertDocsOutcome = case BuildOutcome
result of
Left BuildFailure
_ -> Outcome
NotTried
Right (BR.BuildResult DocsResult
BR.DocsNotTried TestsResult
_ Maybe InstalledPackageInfo
_) -> Outcome
NotTried
Right (BR.BuildResult DocsResult
BR.DocsFailed TestsResult
_ Maybe InstalledPackageInfo
_) -> Outcome
Failed
Right (BR.BuildResult DocsResult
BR.DocsOk TestsResult
_ Maybe InstalledPackageInfo
_) -> Outcome
Ok
convertTestsOutcome :: Outcome
convertTestsOutcome = case BuildOutcome
result of
Left (BR.TestsFailed SomeException
_) -> Outcome
Failed
Left BuildFailure
_ -> Outcome
NotTried
Right (BR.BuildResult DocsResult
_ TestsResult
BR.TestsNotTried Maybe InstalledPackageInfo
_) -> Outcome
NotTried
Right (BR.BuildResult DocsResult
_ TestsResult
BR.TestsOk Maybe InstalledPackageInfo
_) -> Outcome
Ok
cabalInstallID :: PackageIdentifier
cabalInstallID :: PackageIdentifier
cabalInstallID =
PackageName -> Version -> PackageIdentifier
PackageIdentifier (String -> PackageName
mkPackageName String
"cabal-install") Version
cabalInstallVersion
fieldDescrs
:: ( Applicative (g BuildReport), FieldGrammar c g
, c (Identity Arch)
, c (Identity CompilerId)
, c (Identity FlagAssignment)
, c (Identity InstallOutcome)
, c (Identity OS)
, c (Identity Outcome)
, c (Identity PackageIdentifier)
, c (List VCat (Identity PackageIdentifier) PackageIdentifier)
)
=> g BuildReport BuildReport
fieldDescrs :: forall (g :: * -> * -> *) (c :: * -> Constraint).
(Applicative (g BuildReport), FieldGrammar c g, c (Identity Arch),
c (Identity CompilerId), c (Identity FlagAssignment),
c (Identity InstallOutcome), c (Identity OS), c (Identity Outcome),
c (Identity PackageIdentifier),
c (List VCat (Identity PackageIdentifier) PackageIdentifier)) =>
g BuildReport BuildReport
fieldDescrs = PackageIdentifier
-> OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> InstallOutcome
-> Outcome
-> Outcome
-> BuildReport
BuildReport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"package" Lens' BuildReport PackageIdentifier
L.package
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"os" Lens' BuildReport OS
L.os
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"arch" Lens' BuildReport Arch
L.arch
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"compiler" Lens' BuildReport CompilerId
L.compiler
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"client" Lens' BuildReport PackageIdentifier
L.client
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a), Monoid a) =>
FieldName -> ALens' s a -> g s a
monoidalField FieldName
"flags" Lens' BuildReport FlagAssignment
L.flagAssignment
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Monoid a, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> g s a
monoidalFieldAla FieldName
"dependencies" (forall sep a. sep -> [a] -> List sep (Identity a) a
alaList VCat
VCat) Lens' BuildReport [PackageIdentifier]
L.dependencies
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"install-outcome" Lens' BuildReport InstallOutcome
L.installOutcome
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"docs-outcome" Lens' BuildReport Outcome
L.docsOutcome
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField FieldName
"tests-outcome" Lens' BuildReport Outcome
L.testsOutcome
parseBuildReport :: BS.ByteString -> Either String BuildReport
parseBuildReport :: FieldName -> Either String BuildReport
parseBuildReport FieldName
s = case forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult forall a b. (a -> b) -> a -> b
$ FieldName -> ParseResult BuildReport
parseFields FieldName
s of
Left (Maybe Version
_, NonEmpty PError
perrors) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
err | PError Position
_ String
err <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
perrors ]
Right BuildReport
report -> forall a b. b -> Either a b
Right BuildReport
report
parseFields :: BS.ByteString -> ParseResult BuildReport
parseFields :: FieldName -> ParseResult BuildReport
parseFields FieldName
input = do
[Field Position]
fields <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Position -> String -> ParseResult a
parseFatalFailure Position
zeroPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FieldName -> Either ParseError [Field Position]
readFields FieldName
input
case forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
fields of
(Fields Position
fields', []) -> forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
CabalSpecV2_4 Fields Position
fields' forall (g :: * -> * -> *) (c :: * -> Constraint).
(Applicative (g BuildReport), FieldGrammar c g, c (Identity Arch),
c (Identity CompilerId), c (Identity FlagAssignment),
c (Identity InstallOutcome), c (Identity OS), c (Identity Outcome),
c (Identity PackageIdentifier),
c (List VCat (Identity PackageIdentifier) PackageIdentifier)) =>
g BuildReport BuildReport
fieldDescrs
(Fields Position, [[Section Position]])
_otherwise -> forall a. Position -> String -> ParseResult a
parseFatalFailure Position
zeroPos String
"found sections in BuildReport"
parseBuildReportList :: BS.ByteString -> [BuildReport]
parseBuildReportList :: FieldName -> [BuildReport]
parseBuildReportList FieldName
str =
[ BuildReport
report | Right BuildReport
report <- forall a b. (a -> b) -> [a] -> [b]
map FieldName -> Either String BuildReport
parseBuildReport (FieldName -> [FieldName]
split FieldName
str) ]
where
split :: BS.ByteString -> [BS.ByteString]
split :: FieldName -> [FieldName]
split = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Bool
BS.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [FieldName] -> Maybe (FieldName, [FieldName])
chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> [FieldName]
BS8.lines
chunk :: [FieldName] -> Maybe (FieldName, [FieldName])
chunk [] = forall a. Maybe a
Nothing
chunk [FieldName]
ls = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break FieldName -> Bool
BS.null [FieldName]
ls of
([FieldName]
r, [FieldName]
rs) -> forall a. a -> Maybe a
Just ([FieldName] -> FieldName
BS8.unlines [FieldName]
r, forall a. (a -> Bool) -> [a] -> [a]
dropWhile FieldName -> Bool
BS.null [FieldName]
rs)
showBuildReport :: BuildReport -> String
showBuildReport :: BuildReport -> String
showBuildReport = forall ann. (ann -> CommentPosition) -> [PrettyField ann] -> String
showFields (forall a b. a -> b -> a
const CommentPosition
NoComment) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a.
CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar CabalSpecVersion
CabalSpecV2_4 forall (g :: * -> * -> *) (c :: * -> Constraint).
(Applicative (g BuildReport), FieldGrammar c g, c (Identity Arch),
c (Identity CompilerId), c (Identity FlagAssignment),
c (Identity InstallOutcome), c (Identity OS), c (Identity Outcome),
c (Identity PackageIdentifier),
c (List VCat (Identity PackageIdentifier) PackageIdentifier)) =>
g BuildReport BuildReport
fieldDescrs