Merge pull request #799 from explorable-viz/tweaks

Simplify `Monoid` instance for `BenchRow` to remove string literals

package.json

@@ -6,7 +6,6 @@
     "build-app": "yarn clean-app && spago build --purs-args '--strict --censor-codes=UserDefinedWarning' && purs-backend-es bundle-app --main App.Main --to dist/app/app.js",
     "clean-ex" : "rm -rf dist/ex && mkdir -p dist/ex && cp -r fluid dist/ex && cp web/index.html dist/ex && cp -r web/css dist/ex",
     "build-ex" : "yarn clean-ex && spago build --purs-args '--strict --censor-codes=UserDefinedWarning' && purs-backend-es bundle-app --main Example.Example --to dist/ex/app.js",
-    "example": "npx http-serve dist/ex -a 127.0.0.1",
     "serve-app": "yarn build-app && npx http-serve dist/app -a 127.0.0.1 -c-1",
     "clean-tests": "rm -rf dist/tests && mkdir -p dist/tests && cp web/tests.html dist/tests",
     "clean-bench": "rm -rf dist/benches && mkdir -p dist/benches && cp -r fluid dist/benches && cp web/index.html dist/benches && cp -r web/css dist/benches",

spago.dhall

@@ -11,25 +11,20 @@ You can edit this file as you like.
   , "bifunctors"
   , "console"
   , "control"
-  , "datetime"
   , "debug"
   , "effect"
   , "either"
   , "exceptions"
   , "exists"
   , "foldable-traversable"
   , "foreign-object"
-  , "heterogeneous"
   , "http-methods"
   , "identity"
   , "integers"
-  , "js-date"
-  , "lazy"
   , "lists"
   , "maybe"
   , "newtype"
   , "nonempty"
-  , "now"
   , "numbers"
   , "ordered-collections"
   , "parsing"

test/Benchmark.purs

@@ -1,29 +1,24 @@
-module Test.Benchmark
-   ( --bench_desugaring
-     main
-   ) where
-
-import Prelude hiding (add)
+module Test.Benchmark where
 
+import Prelude
 import Benchmark.Util (BenchAcc(..), BenchRow)
-import Control.Apply (lift2)
 import Data.Array (concat)
+import Data.Array.NonEmpty (fromArray)
 import Data.Traversable (sequence)
-import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Aff (Aff, launchAff_)
 import Effect.Class.Console (logShow)
 import Test.Many (many, bwdMany, withDatasetMany)
 import Test.Spec.Specs (misc_cases, bwd_cases, desugar_cases, graphics_cases)
-import Util (type (×), (×))
+import Util (type (×), definitely, (×))
 
 main :: Effect Unit
 main = launchAff_ do
    let
       iter = 1
       arr = concat ([ bench_misc, bench_desugaring, bench_bwd, bench_graphics ] <#> ((#) (iter × true)))
-   outs <- sequence $ map (\(str × row) -> lift2 Tuple (pure str) row) arr
-   logShow (BenchAcc outs)
+   outs <- sequence $ (\(str × row) -> (str × _) <$> row) <$> arr
+   logShow $ BenchAcc $ definitely "More than one benchmark" $ fromArray outs
 
 bench_desugaring :: (Int × Boolean) -> Array (String × Aff BenchRow)
 bench_desugaring = many desugar_cases

test/Benchmark/Util.purs

@@ -4,52 +4,53 @@ import Prelude
 
 import Control.Monad.Writer.Class (class MonadWriter, tell)
 import Data.Array (intersperse, fromFoldable) as A
+import Data.Array.NonEmpty (NonEmptyArray, head, toArray)
 import Data.Int (toNumber)
 import Data.List (fold)
-import Data.Map (Map, singleton, unionWith, fromFoldable, keys, values)
+import Data.Map (Map, singleton, unionWith, keys, values)
+import Data.Map (empty) as M
+import Data.Newtype (class Newtype, over2)
+import Data.Tuple (snd)
 import Effect.Class (class MonadEffect, liftEffect)
 import Test.Spec.Microtime (microtime)
 import Util (type (×), (×))
 
-newtype BenchAcc = BenchAcc (Array (String × BenchRow))
+newtype BenchAcc = BenchAcc (NonEmptyArray (String × BenchRow))
 
 instance Show BenchAcc where
    show (BenchAcc rows) =
-      fold $ A.intersperse "\n" ([ showHeader ] <> (showRow <$> rows))
+      fold $ A.intersperse "\n" ([ showHeader ] <> (toArray $ showRow <$> rows))
       where
-      BenchRow empty_row = mempty
+      BenchRow firstRow = head rows # snd
 
       showHeader :: String
       showHeader =
-         fold $ A.intersperse "," ([ "Test-Name" ] <> A.fromFoldable (keys empty_row))
+         fold $ A.intersperse "," ([ "Test-Name" ] <> A.fromFoldable (keys firstRow))
 
       showRow :: String × BenchRow -> String
       showRow (test_name × (BenchRow row)) =
          fold $ A.intersperse "," ([ test_name ] <> (show <$> A.fromFoldable (values row)))
 
 newtype BenchRow = BenchRow (Map String Number)
 
+derive instance Newtype BenchRow _
+
 instance Semigroup BenchRow where
-   append (BenchRow row1) (BenchRow row2) = BenchRow (unionWith (+) row1 row2)
+   append = unionWith (+) `flip over2` BenchRow
 
 instance Monoid BenchRow where
-   mempty = BenchRow
-      (fromFoldable [ ("Trace-Eval" × 0.0), ("Trace-Bwd" × 0.0), ("Trace-Fwd" × 0.0), ("Graph-Eval" × 0.0), ("Graph-Bwd" × 0.0), ("Graph-Fwd" × 0.0), ("Graph-BwdDual" × 0.0), ("Graph-BwdAll" × 0.0), ("Graph-FwdDual" × 0.0), ("Graph-FwdAsDeMorgan" × 0.0) ])
-
-tdiff :: Number -> Number -> Number
-tdiff x y = sub y x
-
-preciseTime :: forall m. MonadEffect m => m Number
-preciseTime = liftEffect microtime
+   mempty = BenchRow M.empty
 
 bench :: forall m a. MonadEffect m => MonadWriter BenchRow m => String -> (Unit -> m a) -> m a
 bench name prog = do
    t1 <- preciseTime
    r <- prog unit
    t2 <- preciseTime
-   tell (BenchRow $ singleton name (tdiff t1 t2))
+   tell (BenchRow $ singleton name (t2 `sub` t1))
    pure r
+   where
+   preciseTime :: m Number
+   preciseTime = liftEffect microtime
 
 divRow :: BenchRow -> Int -> BenchRow
-divRow (BenchRow row) n = BenchRow (map (_ `div` toNumber n) row)
-
+divRow (BenchRow row) n = BenchRow ((_ `div` toNumber n) <$> row)

test/Util.purs

@@ -77,14 +77,13 @@ testTrace s γ { δv, bwd_expect, fwd_expect } = do
       traceGC (erase <$> γ) e
 
    -- | Backward
-   (γ𝔹 × e𝔹) <- bench "Trace-Bwd" $ \_ -> do
-      let γ𝔹 × e𝔹 × _ = eval.bwd (δv (botOf v))
-      pure (γ𝔹 × e𝔹)
+   (γ𝔹 × e𝔹 × _) <- bench "Trace-Bwd" $ \_ ->
+      pure (eval.bwd (δv (botOf v)))
    let s𝔹 = desug𝔹.bwd e𝔹
 
    -- | Forward (round-tripping)
    let e𝔹' = desug𝔹.fwd s𝔹
-   v𝔹 <- bench "Trace-Fwd" $ \_ -> do
+   v𝔹 <- bench "Trace-Fwd" $ \_ ->
       pure (eval.fwd (γ𝔹 × e𝔹' × top))
 
    -- | Check backward selections
@@ -121,10 +120,10 @@ testGraph s gconfig { δv, bwd_expect, fwd_expect } is_bench = do
       pure (select𝔹s vα αs_out' × αs_out')
 
    -- | Check backward selections
-   unless (null bwd_expect) do
+   unless (null bwd_expect) $
       checkPretty "Graph-based source selection" bwd_expect s𝔹
    -- | Check round-trip selections
-   unless (isGraphical v𝔹) do
+   unless (isGraphical v𝔹) $
       checkPretty "Graph-based value" fwd_expect v𝔹
    αs_out `shouldSatisfy "fwd ⚬ bwd round-tripping property"`
       (flip subset αs_out')
@@ -139,7 +138,7 @@ testGraph s gconfig { δv, bwd_expect, fwd_expect } is_bench = do
          pure (select𝔹s eα αs_in_dual)
 
       -- | Backward (all outputs selected)
-      e𝔹_all <- bench "Graph-BwdAll" $ \_ -> do
+      e𝔹_all <- bench "Graph-BwdAll" $ \_ ->
          pure (select𝔹s eα $ eval.bwd (vertices vα))
 
       -- | De Morgan dual of forward