never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Distribution.Client.Reporting
6 -- Copyright : (c) David Waern 2008
7 -- License : BSD-like
8 --
9 -- Maintainer : david.waern@gmail.com
10 -- Stability : experimental
11 -- Portability : portable
12 --
13 -- Anonymous build report data structure, printing and parsing
14 --
15 -----------------------------------------------------------------------------
16 module Distribution.Client.BuildReports.Anonymous (
17 BuildReport(..),
18 InstallOutcome(..),
19 Outcome(..),
20
21 -- * Constructing and writing reports
22 newBuildReport,
23
24 -- * parsing and pretty printing
25 parseBuildReport,
26 parseBuildReportList,
27 showBuildReport,
28 -- showList,
29 ) where
30
31 import Distribution.Client.Compat.Prelude
32 import Prelude ()
33
34 import Distribution.CabalSpecVersion
35 import Distribution.Client.BuildReports.Types
36 import Distribution.Client.Utils (cabalInstallVersion)
37 import Distribution.Compiler (CompilerId (..))
38 import Distribution.FieldGrammar
39 import Distribution.Fields (readFields, showFields)
40 import Distribution.Fields.ParseResult (ParseResult, parseFatalFailure, runParseResult)
41 import Distribution.Package (PackageIdentifier (..), mkPackageName)
42 import Distribution.PackageDescription (FlagAssignment)
43 import Distribution.Parsec (PError (..), zeroPos)
44 import Distribution.System (Arch, OS)
45
46 import qualified Distribution.Client.BuildReports.Lens as L
47 import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))
48
49 import qualified Data.ByteString as BS
50 import qualified Data.ByteString.Char8 as BS8
51
52
53 -------------------------------------------------------------------------------
54 -- New
55 -------------------------------------------------------------------------------
56
57 newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
58 -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport
59 newBuildReport os' arch' comp pkgid flags deps result =
60 BuildReport {
61 package = pkgid,
62 os = os',
63 arch = arch',
64 compiler = comp,
65 client = cabalInstallID,
66 flagAssignment = flags,
67 dependencies = deps,
68 installOutcome = convertInstallOutcome,
69 -- cabalVersion = undefined
70 docsOutcome = convertDocsOutcome,
71 testsOutcome = convertTestsOutcome
72 }
73 where
74 convertInstallOutcome = case result of
75 Left BR.PlanningFailed -> PlanningFailed
76 Left (BR.DependentFailed p) -> DependencyFailed p
77 Left (BR.DownloadFailed _) -> DownloadFailed
78 Left (BR.UnpackFailed _) -> UnpackFailed
79 Left (BR.ConfigureFailed _) -> ConfigureFailed
80 Left (BR.BuildFailed _) -> BuildFailed
81 Left (BR.TestsFailed _) -> TestsFailed
82 Left (BR.InstallFailed _) -> InstallFailed
83 Right (BR.BuildResult _ _ _) -> InstallOk
84 convertDocsOutcome = case result of
85 Left _ -> NotTried
86 Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried
87 Right (BR.BuildResult BR.DocsFailed _ _) -> Failed
88 Right (BR.BuildResult BR.DocsOk _ _) -> Ok
89 convertTestsOutcome = case result of
90 Left (BR.TestsFailed _) -> Failed
91 Left _ -> NotTried
92 Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried
93 Right (BR.BuildResult _ BR.TestsOk _) -> Ok
94
95 cabalInstallID :: PackageIdentifier
96 cabalInstallID =
97 PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion
98
99 -------------------------------------------------------------------------------
100 -- FieldGrammar
101 -------------------------------------------------------------------------------
102
103 fieldDescrs
104 :: ( Applicative (g BuildReport), FieldGrammar c g
105 , c (Identity Arch)
106 , c (Identity CompilerId)
107 , c (Identity FlagAssignment)
108 , c (Identity InstallOutcome)
109 , c (Identity OS)
110 , c (Identity Outcome)
111 , c (Identity PackageIdentifier)
112 , c (List VCat (Identity PackageIdentifier) PackageIdentifier)
113 )
114 => g BuildReport BuildReport
115 fieldDescrs = BuildReport
116 <$> uniqueField "package" L.package
117 <*> uniqueField "os" L.os
118 <*> uniqueField "arch" L.arch
119 <*> uniqueField "compiler" L.compiler
120 <*> uniqueField "client" L.client
121 <*> monoidalField "flags" L.flagAssignment
122 <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
123 <*> uniqueField "install-outcome" L.installOutcome
124 <*> uniqueField "docs-outcome" L.docsOutcome
125 <*> uniqueField "tests-outcome" L.testsOutcome
126
127 -- -----------------------------------------------------------------------------
128 -- Parsing
129
130 parseBuildReport :: BS.ByteString -> Either String BuildReport
131 parseBuildReport s = case snd $ runParseResult $ parseFields s of
132 Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ]
133 Right report -> Right report
134
135 parseFields :: BS.ByteString -> ParseResult BuildReport
136 parseFields input = do
137 fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input
138 case partitionFields fields of
139 (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs
140 _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport"
141
142 parseBuildReportList :: BS.ByteString -> [BuildReport]
143 parseBuildReportList str =
144 [ report | Right report <- map parseBuildReport (split str) ]
145
146 where
147 split :: BS.ByteString -> [BS.ByteString]
148 split = filter (not . BS.null) . unfoldr chunk . BS8.lines
149 chunk [] = Nothing
150 chunk ls = case break BS.null ls of
151 (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)
152
153 -- -----------------------------------------------------------------------------
154 -- Pretty-printing
155
156 showBuildReport :: BuildReport -> String
157 showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs