{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Reporting
-- Copyright   :  (c) David Waern 2008
-- License     :  BSD-like
--
-- Maintainer  :  david.waern@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Anonymous build report data structure, printing and parsing
--
-----------------------------------------------------------------------------
module Distribution.Client.BuildReports.Anonymous (
    BuildReport(..),
    InstallOutcome(..),
    Outcome(..),

    -- * Constructing and writing reports
    newBuildReport,

    -- * parsing and pretty printing
    parseBuildReport,
    parseBuildReportList,
    showBuildReport,
    cabalInstallID
--    showList,
  ) 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


-------------------------------------------------------------------------------
-- New
-------------------------------------------------------------------------------

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 :: PackageIdentifier
-> OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> InstallOutcome
-> Outcome
-> Outcome
-> BuildReport
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,
--    cabalVersion          = undefined
    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

-------------------------------------------------------------------------------
-- FieldGrammar
-------------------------------------------------------------------------------

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 :: g BuildReport BuildReport
fieldDescrs = PackageIdentifier
-> OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> InstallOutcome
-> Outcome
-> Outcome
-> BuildReport
BuildReport
    (PackageIdentifier
 -> OS
 -> Arch
 -> CompilerId
 -> PackageIdentifier
 -> FlagAssignment
 -> [PackageIdentifier]
 -> InstallOutcome
 -> Outcome
 -> Outcome
 -> BuildReport)
-> g BuildReport PackageIdentifier
-> g BuildReport
     (OS
      -> Arch
      -> CompilerId
      -> PackageIdentifier
      -> FlagAssignment
      -> [PackageIdentifier]
      -> InstallOutcome
      -> Outcome
      -> Outcome
      -> BuildReport)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName
-> ALens' BuildReport PackageIdentifier
-> g BuildReport PackageIdentifier
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"package"                           ALens' BuildReport PackageIdentifier
Lens' BuildReport PackageIdentifier
L.package
    g BuildReport
  (OS
   -> Arch
   -> CompilerId
   -> PackageIdentifier
   -> FlagAssignment
   -> [PackageIdentifier]
   -> InstallOutcome
   -> Outcome
   -> Outcome
   -> BuildReport)
-> g BuildReport OS
-> g BuildReport
     (Arch
      -> CompilerId
      -> PackageIdentifier
      -> FlagAssignment
      -> [PackageIdentifier]
      -> InstallOutcome
      -> Outcome
      -> Outcome
      -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName -> ALens' BuildReport OS -> g BuildReport OS
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"os"                                ALens' BuildReport OS
Lens' BuildReport OS
L.os
    g BuildReport
  (Arch
   -> CompilerId
   -> PackageIdentifier
   -> FlagAssignment
   -> [PackageIdentifier]
   -> InstallOutcome
   -> Outcome
   -> Outcome
   -> BuildReport)
-> g BuildReport Arch
-> g BuildReport
     (CompilerId
      -> PackageIdentifier
      -> FlagAssignment
      -> [PackageIdentifier]
      -> InstallOutcome
      -> Outcome
      -> Outcome
      -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName -> ALens' BuildReport Arch -> g BuildReport Arch
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"arch"                              ALens' BuildReport Arch
Lens' BuildReport Arch
L.arch
    g BuildReport
  (CompilerId
   -> PackageIdentifier
   -> FlagAssignment
   -> [PackageIdentifier]
   -> InstallOutcome
   -> Outcome
   -> Outcome
   -> BuildReport)
-> g BuildReport CompilerId
-> g BuildReport
     (PackageIdentifier
      -> FlagAssignment
      -> [PackageIdentifier]
      -> InstallOutcome
      -> Outcome
      -> Outcome
      -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ALens' BuildReport CompilerId -> g BuildReport CompilerId
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"compiler"                          ALens' BuildReport CompilerId
Lens' BuildReport CompilerId
L.compiler
    g BuildReport
  (PackageIdentifier
   -> FlagAssignment
   -> [PackageIdentifier]
   -> InstallOutcome
   -> Outcome
   -> Outcome
   -> BuildReport)
-> g BuildReport PackageIdentifier
-> g BuildReport
     (FlagAssignment
      -> [PackageIdentifier]
      -> InstallOutcome
      -> Outcome
      -> Outcome
      -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ALens' BuildReport PackageIdentifier
-> g BuildReport PackageIdentifier
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"client"                            ALens' BuildReport PackageIdentifier
Lens' BuildReport PackageIdentifier
L.client
    g BuildReport
  (FlagAssignment
   -> [PackageIdentifier]
   -> InstallOutcome
   -> Outcome
   -> Outcome
   -> BuildReport)
-> g BuildReport FlagAssignment
-> g BuildReport
     ([PackageIdentifier]
      -> InstallOutcome -> Outcome -> Outcome -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ALens' BuildReport FlagAssignment
-> g BuildReport FlagAssignment
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a), Monoid a) =>
FieldName -> ALens' s a -> g s a
monoidalField     FieldName
"flags"                             ALens' BuildReport FlagAssignment
Lens' BuildReport FlagAssignment
L.flagAssignment
    g BuildReport
  ([PackageIdentifier]
   -> InstallOutcome -> Outcome -> Outcome -> BuildReport)
-> g BuildReport [PackageIdentifier]
-> g BuildReport
     (InstallOutcome -> Outcome -> Outcome -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ([PackageIdentifier]
    -> List VCat (Identity PackageIdentifier) PackageIdentifier)
-> ALens' BuildReport [PackageIdentifier]
-> g BuildReport [PackageIdentifier]
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"       (VCat
-> [PackageIdentifier]
-> List VCat (Identity PackageIdentifier) PackageIdentifier
forall sep a. sep -> [a] -> List sep (Identity a) a
alaList VCat
VCat) ALens' BuildReport [PackageIdentifier]
Lens' BuildReport [PackageIdentifier]
L.dependencies
    g BuildReport (InstallOutcome -> Outcome -> Outcome -> BuildReport)
-> g BuildReport InstallOutcome
-> g BuildReport (Outcome -> Outcome -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ALens' BuildReport InstallOutcome
-> g BuildReport InstallOutcome
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"install-outcome"                   ALens' BuildReport InstallOutcome
Lens' BuildReport InstallOutcome
L.installOutcome
    g BuildReport (Outcome -> Outcome -> BuildReport)
-> g BuildReport Outcome -> g BuildReport (Outcome -> BuildReport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName -> ALens' BuildReport Outcome -> g BuildReport Outcome
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"docs-outcome"                      ALens' BuildReport Outcome
Lens' BuildReport Outcome
L.docsOutcome
    g BuildReport (Outcome -> BuildReport)
-> g BuildReport Outcome -> g BuildReport BuildReport
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName -> ALens' BuildReport Outcome -> g BuildReport Outcome
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s a -> g s a
uniqueField       FieldName
"tests-outcome"                     ALens' BuildReport Outcome
Lens' BuildReport Outcome
L.testsOutcome

-- -----------------------------------------------------------------------------
-- Parsing

parseBuildReport :: BS.ByteString -> Either String BuildReport
parseBuildReport :: FieldName -> Either String BuildReport
parseBuildReport FieldName
s = case ([PWarning], Either (Maybe Version, NonEmpty PError) BuildReport)
-> Either (Maybe Version, NonEmpty PError) BuildReport
forall a b. (a, b) -> b
snd (([PWarning], Either (Maybe Version, NonEmpty PError) BuildReport)
 -> Either (Maybe Version, NonEmpty PError) BuildReport)
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) BuildReport)
-> Either (Maybe Version, NonEmpty PError) BuildReport
forall a b. (a -> b) -> a -> b
$ ParseResult BuildReport
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) BuildReport)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ParseResult BuildReport
 -> ([PWarning],
     Either (Maybe Version, NonEmpty PError) BuildReport))
-> ParseResult BuildReport
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) BuildReport)
forall a b. (a -> b) -> a -> b
$ FieldName -> ParseResult BuildReport
parseFields FieldName
s of
  Left (Maybe Version
_, NonEmpty PError
perrors) -> String -> Either String BuildReport
forall a b. a -> Either a b
Left (String -> Either String BuildReport)
-> String -> Either String BuildReport
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
err | PError Position
_ String
err <- NonEmpty PError -> [PError]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
perrors ]
  Right BuildReport
report -> BuildReport -> Either String BuildReport
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 <- (ParseError -> ParseResult [Field Position])
-> ([Field Position] -> ParseResult [Field Position])
-> Either ParseError [Field Position]
-> ParseResult [Field Position]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Position -> String -> ParseResult [Field Position]
forall a. Position -> String -> ParseResult a
parseFatalFailure Position
zeroPos (String -> ParseResult [Field Position])
-> (ParseError -> String)
-> ParseError
-> ParseResult [Field Position]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) [Field Position] -> ParseResult [Field Position]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError [Field Position]
 -> ParseResult [Field Position])
-> Either ParseError [Field Position]
-> ParseResult [Field Position]
forall a b. (a -> b) -> a -> b
$ FieldName -> Either ParseError [Field Position]
readFields FieldName
input
  case [Field Position] -> (Fields Position, [[Section Position]])
forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
fields of
    (Fields Position
fields', []) -> CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar BuildReport BuildReport
-> ParseResult BuildReport
forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
CabalSpecV2_4 Fields Position
fields' ParsecFieldGrammar BuildReport BuildReport
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    -> Position -> String -> ParseResult BuildReport
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 <- (FieldName -> Either String BuildReport)
-> [FieldName] -> [Either String BuildReport]
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 = (FieldName -> Bool) -> [FieldName] -> [FieldName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FieldName -> Bool) -> FieldName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Bool
BS.null) ([FieldName] -> [FieldName])
-> (FieldName -> [FieldName]) -> FieldName -> [FieldName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FieldName] -> Maybe (FieldName, [FieldName]))
-> [FieldName] -> [FieldName]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [FieldName] -> Maybe (FieldName, [FieldName])
chunk ([FieldName] -> [FieldName])
-> (FieldName -> [FieldName]) -> FieldName -> [FieldName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> [FieldName]
BS8.lines
    chunk :: [FieldName] -> Maybe (FieldName, [FieldName])
chunk [] = Maybe (FieldName, [FieldName])
forall a. Maybe a
Nothing
    chunk [FieldName]
ls = case (FieldName -> Bool) -> [FieldName] -> ([FieldName], [FieldName])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break FieldName -> Bool
BS.null [FieldName]
ls of
                 ([FieldName]
r, [FieldName]
rs) -> (FieldName, [FieldName]) -> Maybe (FieldName, [FieldName])
forall a. a -> Maybe a
Just ([FieldName] -> FieldName
BS8.unlines [FieldName]
r, (FieldName -> Bool) -> [FieldName] -> [FieldName]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile FieldName -> Bool
BS.null [FieldName]
rs)

-- -----------------------------------------------------------------------------
-- Pretty-printing

showBuildReport :: BuildReport -> String
showBuildReport :: BuildReport -> String
showBuildReport = (() -> CommentPosition) -> [PrettyField ()] -> String
forall ann. (ann -> CommentPosition) -> [PrettyField ann] -> String
showFields (CommentPosition -> () -> CommentPosition
forall a b. a -> b -> a
const CommentPosition
NoComment) ([PrettyField ()] -> String)
-> (BuildReport -> [PrettyField ()]) -> BuildReport -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CabalSpecVersion
-> PrettyFieldGrammar BuildReport BuildReport
-> BuildReport
-> [PrettyField ()]
forall s a.
CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar CabalSpecVersion
CabalSpecV2_4 PrettyFieldGrammar BuildReport BuildReport
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