{-# 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 {
    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 :: 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

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

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)

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

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