diff --git a/shake-bench/shake-bench.cabal b/shake-bench/shake-bench.cabal index 250bc302c6..948b10dace 100644 --- a/shake-bench/shake-bench.cabal +++ b/shake-bench/shake-bench.cabal @@ -27,6 +27,8 @@ library directory, extra >= 1.7.2, filepath, + lens, + lens-aeson, shake, text default-language: Haskell2010 diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index 29e36fe71d..024b32d3f6 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/shake-bench/src/Development/Benchmark/Rules.hs @@ -68,16 +68,19 @@ module Development.Benchmark.Rules import Control.Applicative import Control.Monad +import Control.Lens ((^.)) import Data.Aeson (FromJSON (..), ToJSON (..), - Value (..), (.!=), - (.:?)) + Value (..), object, (.!=), + (.:?), (.=)) +import Data.Aeson.Lens (_Object) import Data.Char (isDigit) import Data.List (find, isInfixOf, stripPrefix, transpose) import Data.List.Extra (lower) import Data.Maybe (fromMaybe) +import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T import Development.Shake @@ -88,7 +91,6 @@ import GHC.Exts (IsList (toList), import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import qualified Graphics.Rendering.Chart.Backend.Diagrams as E -import Graphics.Rendering.Chart.Easy ((.=)) import qualified Graphics.Rendering.Chart.Easy as E import System.Directory (createDirectoryIfMissing, findExecutable, @@ -498,21 +500,24 @@ data GitCommit = GitCommit instance FromJSON GitCommit where parseJSON (String s) = pure $ GitCommit s Nothing Nothing True - parseJSON (Object (toList -> [(name, String gitName)])) = - pure $ GitCommit gitName (Just name) Nothing True - parseJSON (Object (toList -> [(name, Object props)])) = - GitCommit - <$> props .:? "git" .!= name - <*> pure (Just name) - <*> props .:? "parent" - <*> props .:? "include" .!= True + parseJSON o@(Object _) = do + let keymap = o ^. _Object + case toList keymap of + [(name, String gitName)] -> pure $ GitCommit gitName (Just (fromString $ show name)) Nothing True + [(name, Object props)] -> + GitCommit + <$> props .:? "git" .!= name + <*> pure (Just (fromString $ show name)) + <*> props .:? "parent" + <*> props .:? "include" .!= True + _ -> empty parseJSON _ = empty instance ToJSON GitCommit where toJSON GitCommit {..} = case name of Nothing -> String gitName - Just n -> Object $ fromList [(n, String gitName)] + Just n -> object [fromString (T.unpack n) .= String gitName] humanName :: GitCommit -> Text humanName GitCommit {..} = fromMaybe gitName name @@ -607,7 +612,7 @@ plotDiagram :: Bool -> Diagram -> FilePath -> Action () plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do let extract = frameMetric traceMetric liftIO $ E.toFile E.def out $ do - E.layout_title .= title t + E.layout_title E..= title t E.setColors myColors forM_ runLogs $ \rl -> when (includeFailed || runSuccess rl) $ E.plot $ do