Merge pull request #63 from michaelpj/mpj/shake-bench-aeson

Fixup shake-bench
jneira · Jan 10, 2022 · 15b241c · 15b241c
2 parents 61e8d7f + 478203c
commit 15b241c
Show file tree

Hide file tree

Showing 2 changed files with 20 additions and 13 deletions.
diff --git 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
@@ -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