add bench project

Author: safareli

.travis.yml

@@ -11,9 +11,10 @@ install:
   - chmod a+x $HOME/purescript
   - npm install -g bower
   - npm install
-  - bower install
+  - npm run install
 script:
   - npm run -s build
+  - npm run -s bench:build
   - npm run -s test
 after_success:
 - >-

bench/bower.json

@@ -0,0 +1,12 @@
+{
+  "name": "purescript-eff-aff-bench",
+  "dependencies": {
+    "purescript-foldable-traversable": "^3.6.1",
+    "purescript-minibench": "safareli/purescript-minibench#un-log",
+    "purescript-eff": "safareli/purescript-eff#fast",
+    "purescript-aff": "^4.0.1"
+  },
+  "resolutions": {
+    "purescript-eff": "fast"
+  }
+}

bench/src/Bench/Main.js

@@ -0,0 +1,20 @@
+"use strict";
+
+exports.mkArr = function(){
+  return { count: 0 };
+};
+
+exports.pushToArr = function(xs) {
+  return function(x) {
+    return function() {
+      xs.count += 1
+      return xs;
+    };
+  };
+};
+
+exports.log = function(x) {
+  return function(){
+    console.log(x)
+  }
+};

bench/src/Bench/Main.purs

@@ -0,0 +1,110 @@
+module Bench.Main where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Aff (Aff, launchAff_)
+import Control.Monad.Eff.Class (class MonadEff, liftEff)
+import Control.Monad.Eff.Console (CONSOLE)
+import Control.Monad.Eff.Unsafe (unsafePerformEff)
+import Data.Traversable (for_, intercalate)
+import Performance.Minibench (BenchResult, benchWith', withUnits)
+
+
+type BenchEff = (console :: CONSOLE)
+
+testApply :: forall m. MonadEff BenchEff m => Int -> m Unit
+testApply n' = do
+  arr <- liftEff mkArr
+  applyLoop (void <<< liftEff <<< pushToArr arr) n'
+  where
+  applyLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
+  applyLoop eff max = go (pure unit) 0
+    where 
+    go acc n | n == max = acc
+    go acc n = go (acc <* eff n) (n + 1)
+
+
+testBindRight :: forall m. MonadEff BenchEff m => Int -> m Unit
+testBindRight n' = do
+  arr <- liftEff mkArr
+  bindRightLoop (void <<< liftEff <<< pushToArr arr) n'
+  where
+  bindRightLoop :: Monad m => (Int -> m Unit)  -> Int -> m Unit
+  bindRightLoop eff max = go (pure unit) 0
+    where 
+    go acc n | n == max = acc
+    go acc n = go (eff (max - n - 1) >>= const acc) (n + 1)
+
+
+testBindLeft :: forall m. MonadEff BenchEff m => Int -> m Unit
+testBindLeft n' = do
+  arr <- liftEff mkArr
+  bindLeftLoop (void <<< liftEff <<< pushToArr arr) n'
+  where
+  bindLeftLoop :: Monad m => (Int -> m Unit)  -> Int -> m Unit
+  bindLeftLoop eff max = go (pure unit) 0
+    where 
+    go acc n | n == max = acc
+    go acc n = go (acc >>= const (eff n)) (n + 1)
+
+
+testMap :: forall m. MonadEff BenchEff m => Int -> m Unit
+testMap n = do
+  arr <- liftEff mkArr
+  res <- mapLoop n (liftEff $ pushToArr arr 0)
+  pure unit
+  where
+  mapLoop :: Monad m => Int -> m Int -> m Int
+  mapLoop max i = 
+    if max == 0 
+      then i 
+      else mapLoop (max - 1) (map (_ + 1) i)
+
+
+main :: Eff BenchEff Unit
+main = do
+  log "| bench | type | n | mean | stddev | min | max |"
+  log "| ----- | ---- | - | ---- | ------ | --- | --- |"
+  bench 1000 ">>=R" testBindRight testBindRight [100, 1000, 5000]
+  bench 1000 ">>=L" testBindLeft testBindLeft [100, 1000, 5000]
+  bench 1000 "map" testMap testMap [100, 1000, 5000]
+  bench 1000 "apply" testApply testApply [100, 1000, 5000]
+  log "| - | - | - | - | - | - | - |"
+  bench 5 ">>=R" testBindRight testBindRight [10000, 50000, 100000, 1000000]
+  bench 5 ">>=L" testBindLeft testBindLeft [10000, 50000, 100000, 1000000]
+  bench 5 "map" testMap testMap [10000, 50000, 100000, 1000000, 350000, 700000]
+  bench 5 "apply" testApply testApply [10000, 50000, 100000, 1000000]
+
+bench
+  :: Int
+  -> String
+  -> (Int -> Eff BenchEff Unit)
+  -> (Int -> Aff BenchEff Unit)
+  -> Array Int
+  -> Eff BenchEff Unit
+bench n name buildEff buildAff vals = for_ vals \val -> do 
+  logBench [name <> " build", "Eff", show val] $ benchWith' n \_ -> buildEff val
+  logBench' id [name <> " build", "Aff", show val] $ benchWith' n \_ -> buildAff val
+  let eff = liftEff $ buildEff val
+  logBench [name <> " run", "Eff", show val] $ benchWith' n \_ -> unsafePerformEff eff
+  let aff = launchAff_ $ buildAff val
+  logBench' id [name <> " run", "Aff", show val] $ benchWith' n \_ -> unsafePerformEff aff
+
+logBench' :: (String -> String) -> Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
+logBench' f msg benchEff = do
+  res <- benchEff
+  let 
+    logStr = intercalate " | " 
+      $ append msg 
+      $ map (f <<< withUnits) [res.mean, res.stdDev, res.min, res.max]
+  log $  "| "  <> logStr <>  " |"
+
+logBench :: Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
+logBench = logBench' \s -> "**" <> s <> "**"
+
+foreign import data Arr :: Type -> Type
+foreign import mkArr :: forall e a. Eff e (Arr a)
+foreign import pushToArr :: forall e a. Arr a -> a -> Eff e a
+foreign import log :: forall e a. a -> Eff e Unit
+

package.json

@@ -1,7 +1,11 @@
 {
   "private": true,
   "scripts": {
-    "clean": "rimraf output && rimraf .pulp-cache",
+    "clean": "rimraf output && rimraf .pulp-cache && rimraf bench/output && rimraf bench/.pulp-cache",
+    "install": "bower i && cd bench && bower i",
+    "bench": "cd bench && npm run bench:build && npm run bench:run",
+    "bench:run": "cd bench && node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
+    "bench:build": "cd bench && pulp build",
     "test": "pulp test",
     "build": "eslint src && pulp build -- --censor-lib --strict"
   },
@@ -11,4 +15,4 @@
     "purescript-psa": "^0.5.1",
     "rimraf": "^2.6.1"
   }
-}
+}