From 5bf9c473b84fbc4441b27f6c8e2cf4b2906a10f3 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@haskell.org>
Date: Thu, 7 Aug 2008 18:39:45 +0000
Subject: [PATCH] Rearrange the BuildReport code
---
.../Anonymous.hs} | 152 +++------
.../Client/BuildReports/Storage.hs | 114 +++++++
cabal-install/Distribution/Client/Install.hs | 12 +-
cabal-install/Distribution/Client/Logging.hs | 292 ------------------
4 files changed, 164 insertions(+), 406 deletions(-)
rename cabal-install/Distribution/Client/{Reporting.hs => BuildReports/Anonymous.hs} (64%)
create mode 100644 cabal-install/Distribution/Client/BuildReports/Storage.hs
delete mode 100644 cabal-install/Distribution/Client/Logging.hs
diff --git a/cabal-install/Distribution/Client/Reporting.hs b/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
similarity index 64%
rename from cabal-install/Distribution/Client/Reporting.hs
rename to cabal-install/Distribution/Client/BuildReports/Anonymous.hs
index 605b5b7372..7b27a0a22e 100644
--- a/cabal-install/Distribution/Client/Reporting.hs
+++ b/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
@@ -8,38 +8,29 @@
-- Stability : experimental
-- Portability : portable
--
--- Report data structure
+-- Anonymous build report data structure, printing and parsing
--
-----------------------------------------------------------------------------
-module Distribution.Client.Reporting (
+module Distribution.Client.BuildReports.Anonymous (
BuildReport(..),
InstallOutcome(..),
Outcome(..),
-- * Constructing and writing reports
- buildReport,
- writeBuildReports,
+ new,
-- * parsing and pretty printing
- parseBuildReport,
- parseBuildReports,
- showBuildReport,
-
- -- * 'InstallPlan' variants
- planPackageBuildReport,
- installPlanBuildReports,
- writeInstallPlanBuildReports
+ parse,
+ parseList,
+ show,
+ showList,
) where
import Distribution.Client.Types
- ( ConfiguredPackage(..), AvailablePackage(..), BuildResult
- , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
+ ( ConfiguredPackage(..), BuildResult )
import qualified Distribution.Client.Types as BR
( BuildResult, BuildFailure(..), BuildSuccess(..)
, DocsResult(..), TestsResult(..) )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan
- ( InstallPlan, PlanPackage )
import Distribution.Client.ParseUtils
( parseFields )
import qualified Paths_cabal_install (version)
@@ -54,25 +45,24 @@ import Distribution.System
( OS, Arch )
import Distribution.Compiler
( CompilerId )
-import Distribution.Text
+import qualified Distribution.Text as Text
( Text(disp, parse) )
import Distribution.ParseUtils
- ( FieldDescr(..), ParseResult(..), simpleField, listField, ppFields )
+ ( FieldDescr(..), ParseResult(..)
+ , simpleField, listField, ppFields, locatedErrorMsg )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, pfail, munch1, char, option, skipSpaces )
-import Text.PrettyPrint.HughesPJ as Disp
- ( Doc, render, char, text, (<+>), (<>) )
-import Distribution.Simple.Utils
- ( comparing, equating )
+import qualified Text.PrettyPrint.HughesPJ as Disp
+ ( Doc, render, char, text )
+import Text.PrettyPrint.HughesPJ
+ ( (<+>), (<>) )
import Data.List
- ( unfoldr, groupBy, sortBy )
-import Data.Maybe
- ( catMaybes )
+ ( unfoldr )
import Data.Char as Char
( isAlpha, isAlphaNum )
-import System.FilePath
- ( (</>) )
+
+import Prelude hiding (show)
data BuildReport
= BuildReport {
@@ -123,35 +113,10 @@ data InstallOutcome
data Outcome = NotTried | Failed | Ok
-writeBuildReports :: [(BuildReport, Repo)] -> IO ()
-writeBuildReports reports = sequence_
- [ appendFile file (concatMap format reports')
- | (repo, reports') <- separate reports
- , let file = repoLocalDir repo </> "build-reports.log" ]
- --TODO: make this concurrency safe, either lock the report file or make sure
- -- the writes for each report are atomic (under 4k and flush at boundaries)
-
- where
- format r = '\n' : showBuildReport r ++ "\n"
- separate :: [(BuildReport, Repo)]
- -> [(Repo, [BuildReport])]
- separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
- . map concat
- . groupBy (equating (repoName . head))
- . sortBy (comparing (repoName . head))
- . groupBy (equating repoName)
- . onlyRemote
- repoName (_,_,rrepo) = remoteRepoName rrepo
-
- onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
- onlyRemote rs =
- [ (report, repo, remoteRepo)
- | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
-
-buildReport :: OS -> Arch -> CompilerId -- -> Version
- -> ConfiguredPackage -> BR.BuildResult
- -> BuildReport
-buildReport os' arch' comp (ConfiguredPackage pkg flags deps) result =
+new :: OS -> Arch -> CompilerId -- -> Version
+ -> ConfiguredPackage -> BR.BuildResult
+ -> BuildReport
+new os' arch' comp (ConfiguredPackage pkg flags deps) result =
BuildReport {
package = packageId pkg,
os = os',
@@ -212,12 +177,14 @@ initialBuildReport = BuildReport {
-- -----------------------------------------------------------------------------
-- Parsing
-parseBuildReport :: String -> ParseResult BuildReport
-parseBuildReport = parseFields fieldDescrs initialBuildReport
+parse :: String -> Either String BuildReport
+parse s = case parseFields fieldDescrs initialBuildReport s of
+ ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror
+ ParseOk _ report -> Right report
-parseBuildReports :: String -> [BuildReport]
-parseBuildReports str =
- [ report | ParseOk [] report <- map parseBuildReport (split str) ]
+parseList :: String -> [BuildReport]
+parseList str =
+ [ report | Right report <- map parse (split str) ]
where
split :: String -> [String]
@@ -229,33 +196,33 @@ parseBuildReports str =
-- -----------------------------------------------------------------------------
-- Pretty-printing
-showBuildReport :: BuildReport -> String
-showBuildReport br = Disp.render (ppFields br fieldDescrs)
+show :: BuildReport -> String
+show br = Disp.render (ppFields br fieldDescrs)
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
fieldDescrs :: [FieldDescr BuildReport]
fieldDescrs =
- [ simpleField "package" disp parse
+ [ simpleField "package" Text.disp Text.parse
package (\v r -> r { package = v })
- , simpleField "os" disp parse
+ , simpleField "os" Text.disp Text.parse
os (\v r -> r { os = v })
- , simpleField "arch" disp parse
+ , simpleField "arch" Text.disp Text.parse
arch (\v r -> r { arch = v })
- , simpleField "compiler" disp parse
+ , simpleField "compiler" Text.disp Text.parse
compiler (\v r -> r { compiler = v })
- , simpleField "client" disp parse
+ , simpleField "client" Text.disp Text.parse
client (\v r -> r { client = v })
, listField "flags" dispFlag parseFlag
flagAssignment (\v r -> r { flagAssignment = v })
- , listField "dependencies" disp parse
+ , listField "dependencies" Text.disp Text.parse
dependencies (\v r -> r { dependencies = v })
- , simpleField "install-outcome" disp parse
+ , simpleField "install-outcome" Text.disp Text.parse
installOutcome (\v r -> r { installOutcome = v })
- , simpleField "docs-outcome" disp parse
+ , simpleField "docs-outcome" Text.disp Text.parse
docsOutcome (\v r -> r { docsOutcome = v })
- , simpleField "tests-outcome" disp parse
+ , simpleField "tests-outcome" Text.disp Text.parse
testsOutcome (\v r -> r { testsOutcome = v })
]
@@ -269,8 +236,8 @@ parseFlag = do
name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
return (FlagName name, value)
-instance Text InstallOutcome where
- disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> disp pkgid
+instance Text.Text InstallOutcome where
+ disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
disp DownloadFailed = Disp.text "DownloadFailed"
disp UnpackFailed = Disp.text "UnpackFailed"
disp SetupFailed = Disp.text "SetupFailed"
@@ -283,7 +250,7 @@ instance Text InstallOutcome where
name <- Parse.munch1 Char.isAlphaNum
case name of
"DependencyFailed" -> do Parse.skipSpaces
- pkgid <- parse
+ pkgid <- Text.parse
return (DependencyFailed pkgid)
"DownloadFailed" -> return DownloadFailed
"UnpackFailed" -> return UnpackFailed
@@ -294,7 +261,7 @@ instance Text InstallOutcome where
"InstallOk" -> return InstallOk
_ -> Parse.pfail
-instance Text Outcome where
+instance Text.Text Outcome where
disp NotTried = Disp.text "NotTried"
disp Failed = Disp.text "Failed"
disp Ok = Disp.text "Ok"
@@ -305,34 +272,3 @@ instance Text Outcome where
"Failed" -> return Failed
"Ok" -> return Ok
_ -> Parse.pfail
-
--- ------------------------------------------------------------
--- * InstallPlan support
--- ------------------------------------------------------------
-
-writeInstallPlanBuildReports :: InstallPlan -> IO ()
-writeInstallPlanBuildReports = writeBuildReports . installPlanBuildReports
-
-installPlanBuildReports :: InstallPlan -> [(BuildReport, Repo)]
-installPlanBuildReports plan = catMaybes
- . map (planPackageBuildReport os' arch' comp)
- . InstallPlan.toList
- $ plan
- where os' = InstallPlan.planOS plan
- arch' = InstallPlan.planArch plan
- comp = InstallPlan.planCompiler plan
-
-planPackageBuildReport :: OS -> Arch -> CompilerId
- -> InstallPlan.PlanPackage
- -> Maybe (BuildReport, Repo)
-planPackageBuildReport os' arch' comp planPackage = case planPackage of
-
- InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
- packageSource = RepoTarballPackage repo }) _ _) result
- -> Just $ (buildReport os' arch' comp pkg (Right result), repo)
-
- InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
- packageSource = RepoTarballPackage repo }) _ _) result
- -> Just $ (buildReport os' arch' comp pkg (Left result), repo)
-
- _ -> Nothing
diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
new file mode 100644
index 0000000000..c42f15f668
--- /dev/null
+++ b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -0,0 +1,114 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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.Storage (
+
+ -- * Storing and retrieving build reports
+ storeAnonymous,
+ storeLocal,
+-- retrieve,
+
+ -- * 'InstallPlan' support
+ fromInstallPlan,
+ ) where
+
+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
+import Distribution.Client.BuildReports.Anonymous (BuildReport)
+
+import Distribution.Client.Types
+ ( ConfiguredPackage(..), AvailablePackage(..)
+ , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.InstallPlan
+ ( InstallPlan, PlanPackage )
+import Distribution.Client.Config
+ ( defaultCabalDir )
+
+import Distribution.System
+ ( OS, Arch )
+import Distribution.Compiler
+ ( CompilerId )
+import Distribution.Simple.Utils
+ ( comparing, equating )
+
+import Data.List
+ ( groupBy, sortBy )
+import Data.Maybe
+ ( catMaybes )
+import System.FilePath
+ ( (</>) )
+
+storeAnonymous :: [(BuildReport, Repo)] -> IO ()
+storeAnonymous reports = sequence_
+ [ appendFile file (concatMap format reports')
+ | (repo, reports') <- separate reports
+ , let file = repoLocalDir repo </> "build-reports.log" ]
+ --TODO: make this concurrency safe, either lock the report file or make sure
+ -- the writes for each report are atomic (under 4k and flush at boundaries)
+
+ where
+ format r = '\n' : BuildReport.show r ++ "\n"
+ separate :: [(BuildReport, Repo)]
+ -> [(Repo, [BuildReport])]
+ separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
+ . map concat
+ . groupBy (equating (repoName . head))
+ . sortBy (comparing (repoName . head))
+ . groupBy (equating repoName)
+ . onlyRemote
+ repoName (_,_,rrepo) = remoteRepoName rrepo
+
+ onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
+ onlyRemote rs =
+ [ (report, repo, remoteRepo)
+ | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
+
+storeLocal :: [(BuildReport, Repo)] -> IO ()
+storeLocal reports = do
+ cabalDir <- defaultCabalDir
+ let file = cabalDir </> "build.log"
+ appendFile file (concatMap (format . fst) reports)
+ --TODO: make this concurrency safe, either lock the report file or make sure
+ -- the writes for each report are atomic (under 4k and flush at boundaries)
+
+ where
+ format r = '\n' : BuildReport.show r ++ "\n"
+
+
+-- ------------------------------------------------------------
+-- * InstallPlan support
+-- ------------------------------------------------------------
+
+fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
+fromInstallPlan plan = catMaybes
+ . map (fromPlanPackage os' arch' comp)
+ . InstallPlan.toList
+ $ plan
+ where os' = InstallPlan.planOS plan
+ arch' = InstallPlan.planArch plan
+ comp = InstallPlan.planCompiler plan
+
+fromPlanPackage :: OS -> Arch -> CompilerId
+ -> InstallPlan.PlanPackage
+ -> Maybe (BuildReport, Repo)
+fromPlanPackage os' arch' comp planPackage = case planPackage of
+
+ InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
+ packageSource = RepoTarballPackage repo }) _ _) result
+ -> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo)
+
+ InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
+ packageSource = RepoTarballPackage repo }) _ _) result
+ -> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo)
+
+ _ -> Nothing
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 9502e6825b..2449fbf23b 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -48,10 +48,8 @@ import Distribution.Client.Types as Available
, DocsResult(..), TestsResult(..) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
-import Distribution.Client.Reporting
- ( writeInstallPlanBuildReports )
-import Distribution.Client.Logging
- ( writeInstallPlanBuildLog )
+import qualified Distribution.Client.BuildReports.Storage as BuildReports
+ ( storeAnonymous, storeLocal, fromInstallPlan )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
import Paths_cabal_install (getBinDir)
@@ -158,8 +156,10 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
installUnpackedPackage verbosity (setupScriptOptions installed)
miscOptions configFlags' installFlags
pkg mpath useLogFile
- writeInstallPlanBuildReports installPlan'
- writeInstallPlanBuildLog installPlan'
+
+ let buildReports = BuildReports.fromInstallPlan installPlan'
+ BuildReports.storeAnonymous buildReports
+ BuildReports.storeLocal buildReports
symlinkBinaries verbosity configFlags installFlags installPlan'
printBuildFailures installPlan'
diff --git a/cabal-install/Distribution/Client/Logging.hs b/cabal-install/Distribution/Client/Logging.hs
deleted file mode 100644
index 22f5b952d0..0000000000
--- a/cabal-install/Distribution/Client/Logging.hs
+++ /dev/null
@@ -1,292 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Logging
--- Copyright : (c) David Waern 2008
--- License : BSD-like
---
--- Maintainer : david.waern@gmail.com
--- Stability : experimental
--- Portability : portable
---
--- Build log data structure
---
------------------------------------------------------------------------------
-module Distribution.Client.Logging (
- BuildLogEntry(..),
- InstallOutcome(..),
- Outcome(..),
-
- -- * Constructing and writing reports
- buildLogEntry,
- writeBuildLog,
-
- -- * parsing and pretty printing
- parseBuildLogEntry,
- parseBuildLog,
- showBuildLogEntry,
-
- -- * 'InstallPlan' variants
- planPackageBuildLogEntry,
- installPlanBuildLog,
- writeInstallPlanBuildLog
- ) where
-
-import Distribution.Client.Reporting
- ( InstallOutcome(..), Outcome(..) )
-import Distribution.Client.Types
- ( ConfiguredPackage(..), BuildResult )
-import Distribution.Client.Config
- ( defaultCabalDir )
-import qualified Distribution.Client.Types as BR
- ( BuildFailure(..), BuildSuccess(..)
- , DocsResult(..), TestsResult(..) )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan
- ( InstallPlan, PlanPackage )
-import Distribution.Client.ParseUtils
- ( parseFields )
-import qualified Paths_cabal_install (version)
-
-import Distribution.Package
- ( PackageIdentifier(PackageIdentifier), Package(packageId) )
-import Distribution.PackageDescription
- ( FlagName(..), FlagAssignment )
---import Distribution.Version
--- ( Version )
-import Distribution.System
- ( OS, Arch )
-import Distribution.Compiler
- ( CompilerId )
-import Distribution.Text
- ( Text(disp, parse) )
-import Distribution.ParseUtils
- ( FieldDescr(..), ParseResult(..), simpleField, listField, ppFields )
-import qualified Distribution.Compat.ReadP as Parse
- ( ReadP, {-pfail,-} munch1, char, option )
-import Text.PrettyPrint.HughesPJ as Disp
- ( Doc, render, char, text, (<>) )
-
-import Data.List
- ( unfoldr )
-import Data.Maybe
- ( catMaybes )
-import Data.Char as Char
- ( isAlphaNum )
-import System.FilePath
- ( (</>) )
---import Network.URI
--- ( URI, uriToString, parseAbsoluteURI )
-
-type BuildLog = [BuildLogEntry]
-
-data BuildLogEntry
- = BuildLogEntry {
- -- | The package this build report is about
- package :: PackageIdentifier,
-
- -- Which hackage server this package is from or local
--- server :: Maybe URI,
-
- -- | 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
- }
-
-writeBuildLog :: BuildLog -> IO ()
-writeBuildLog reports = do
- cabalDir <- defaultCabalDir
- let file = cabalDir </> "build.log"
- appendFile file (concatMap format reports)
- --TODO: make this concurrency safe, either lock the report file or make sure
- -- the writes for each report are atomic (under 4k and flush at boundaries)
-
- where
- format r = '\n' : showBuildLogEntry r ++ "\n"
-
-buildLogEntry :: OS -> Arch -> CompilerId -- -> Version
- -> ConfiguredPackage -> BuildResult
- -> BuildLogEntry
-buildLogEntry os' arch' comp (ConfiguredPackage pkg flags deps) result =
- BuildLogEntry {
- package = packageId pkg,
--- server = Nothing,
- os = os',
- arch = arch',
- compiler = comp,
- client = cabalInstallID,
- flagAssignment = flags,
- dependencies = deps,
- installOutcome = convertInstallOutcome,
--- cabalVersion = undefined
- docsOutcome = convertDocsOutcome,
- testsOutcome = convertTestsOutcome
- }
- where
- cabalInstallID =
- PackageIdentifier "cabal-install" Paths_cabal_install.version
-
- convertInstallOutcome = case result of
- Left (BR.DependentFailed p) -> DependencyFailed p
- Left (BR.UnpackFailed _) -> UnpackFailed
- Left (BR.ConfigureFailed _) -> ConfigureFailed
- Left (BR.BuildFailed _) -> BuildFailed
- Left (BR.InstallFailed _) -> InstallFailed
- Right (BR.BuildOk _ _) -> InstallOk
- convertDocsOutcome = case result of
- Left _ -> NotTried
- Right (BR.BuildOk BR.DocsNotTried _) -> NotTried
- Right (BR.BuildOk BR.DocsFailed _) -> Failed
- Right (BR.BuildOk BR.DocsOk _) -> Ok
- convertTestsOutcome = case result of
- Left _ -> NotTried
- Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried
- Right (BR.BuildOk _ BR.TestsFailed) -> Failed
- Right (BR.BuildOk _ BR.TestsOk) -> Ok
-
--- ------------------------------------------------------------
--- * External format
--- ------------------------------------------------------------
-
-initialBuildLogEntry :: BuildLogEntry
-initialBuildLogEntry = BuildLogEntry {
- package = requiredField "package",
--- server = Nothing,
- os = requiredField "os",
- arch = requiredField "arch",
- compiler = requiredField "compiler",
- client = requiredField "client",
- flagAssignment = [],
- dependencies = [],
- installOutcome = requiredField "install-outcome",
--- cabalVersion = Nothing,
--- tools = [],
- docsOutcome = NotTried,
- testsOutcome = NotTried
- }
- where
- requiredField fname = error ("required field: " ++ fname)
-
--- -----------------------------------------------------------------------------
--- Parsing
-
-parseBuildLogEntry :: String -> ParseResult BuildLogEntry
-parseBuildLogEntry = parseFields fieldDescrs initialBuildLogEntry
-
-parseBuildLog :: String -> [BuildLogEntry]
-parseBuildLog str =
- [ report | ParseOk [] report <- map parseBuildLogEntry (split str) ]
-
- where
- split :: String -> [String]
- split = filter (not . null) . unfoldr chunk . lines
- chunk [] = Nothing
- chunk ls = case break null ls of
- (r, rs) -> Just (unlines r, dropWhile null rs)
-
--- -----------------------------------------------------------------------------
--- Pretty-printing
-
-showBuildLogEntry :: BuildLogEntry -> String
-showBuildLogEntry e = Disp.render (ppFields e fieldDescrs)
-
--- -----------------------------------------------------------------------------
--- Description of the fields, for parsing/printing
-
-fieldDescrs :: [FieldDescr BuildLogEntry]
-fieldDescrs =
- [ simpleField "package" disp parse
- package (\v r -> r { package = v })
--- , simpleField "server" disp parse
--- server (\v r -> r { server = v })
- , simpleField "os" disp parse
- os (\v r -> r { os = v })
- , simpleField "arch" disp parse
- arch (\v r -> r { arch = v })
- , simpleField "compiler" disp parse
- compiler (\v r -> r { compiler = v })
- , simpleField "client" disp parse
- client (\v r -> r { client = v })
- , listField "flags" dispFlag parseFlag
- flagAssignment (\v r -> r { flagAssignment = v })
- , listField "dependencies" disp parse
- dependencies (\v r -> r { dependencies = v })
- , simpleField "install-outcome" disp parse
- installOutcome (\v r -> r { installOutcome = v })
- , simpleField "docs-outcome" disp parse
- docsOutcome (\v r -> r { docsOutcome = v })
- , simpleField "tests-outcome" disp parse
- testsOutcome (\v r -> r { testsOutcome = v })
- ]
-
-dispFlag :: (FlagName, Bool) -> Disp.Doc
-dispFlag (FlagName name, True) = Disp.text name
-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name
-
-parseFlag :: Parse.ReadP r (FlagName, Bool)
-parseFlag = do
- value <- Parse.option True (Parse.char '-' >> return False)
- name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
- return (FlagName name, value)
-
-{-
-instance Text URI where
- disp uri = Disp.text (uriToString id uri [])
- parse = do
- str <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")
- maybe Parse.pfail return (parseAbsoluteURI str)
--}
--- ------------------------------------------------------------
--- * InstallPlan support
--- ------------------------------------------------------------
-
-writeInstallPlanBuildLog :: InstallPlan -> IO ()
-writeInstallPlanBuildLog = writeBuildLog . installPlanBuildLog
-
-installPlanBuildLog :: InstallPlan -> BuildLog
-installPlanBuildLog plan = catMaybes
- . map (planPackageBuildLogEntry os' arch' comp)
- . InstallPlan.toList
- $ plan
- where os' = InstallPlan.planOS plan
- arch' = InstallPlan.planArch plan
- comp = InstallPlan.planCompiler plan
-
-planPackageBuildLogEntry :: OS -> Arch -> CompilerId
- -> InstallPlan.PlanPackage
- -> Maybe BuildLogEntry
-planPackageBuildLogEntry os' arch' comp planPackage = case planPackage of
-
- InstallPlan.Installed pkg result
- -> Just $ buildLogEntry os' arch' comp pkg (Right result)
-
- InstallPlan.Failed pkg result
- -> Just $ buildLogEntry os' arch' comp pkg (Left result)
-
- _ -> Nothing
--
GitLab