Makes Eff Harder, Better, Faster, Stronger

.travis.yml

@@ -11,9 +11,11 @@ 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:
 - >-
   test $TRAVIS_TAG &&

bench/.gitignore

@@ -0,0 +1,5 @@
+/.*
+!/.gitignore
+!/.travis.yml
+/bower_components/
+/output/

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/node_modules

@@ -0,0 +1 @@
+../node_modules/

bench/package.json

@@ -0,0 +1,10 @@
+{
+    "private": true,
+    "scripts": {
+      "clean": "rimraf output && rimraf .pulp-cache",
+      "bench": "npm run build && npm run run",
+      "run": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
+      "build": "pulp build -- --censor-lib --strict"
+    }
+  }
+

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 10 ">>=R" testBindRight testBindRight [100, 1000, 5000]
+  bench 10 ">>=L" testBindLeft testBindLeft [100, 1000, 5000]
+  bench 10 "map" testMap testMap [100, 1000, 5000]
+  bench 10 "apply" testApply testApply [100, 1000, 5000]
+  log "| - | - | - | - | - | - | - |"
+  bench 2 ">>=R" testBindRight testBindRight [10000, 50000, 100000, 1000000]
+  bench 2 ">>=L" testBindLeft testBindLeft [10000, 50000, 100000, 1000000]
+  bench 2 "map" testMap testMap [10000, 50000, 100000, 1000000, 350000, 700000]
+  bench 2 "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

@@ -2,12 +2,13 @@
   "private": true,
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
+    "test": "pulp test",
     "build": "eslint src && pulp build -- --censor-lib --strict"
   },
   "devDependencies": {
     "eslint": "^3.17.1",
-    "pulp": "^10.0.4",
-    "purescript-psa": "^0.5.0-rc.1",
+    "pulp": "^11.0.0",
+    "purescript-psa": "^0.5.1",
     "rimraf": "^2.6.1"
   }
 }

src/Control/Monad/Eff.js

@@ -1,16 +1,89 @@
 "use strict";
 
-exports.pureE = function (a) {
-  return function () {
-    return a;
+// Eff a
+// = { () -> a }
+// | { () -> a, tag: "PURE",   _0 :: a,         _1 :: Void  }
+// | { () -> a, tag: "MAP",    _0 :: b -> a,    _1 :: Ef b }
+// | { () -> a, tag: "APPLY",  _0 :: Ef b,      _1 :: Ef (b -> a) }
+// | { () -> a, tag: "BIND",   _0 :: b -> Ef a, _1 :: Ef b }
+
+// Operation a b
+// = { tag: "MAP",        _0 :: a -> b }
+// | { tag: "APPLY",      _0 :: Ef a }
+// | { tag: "APPLY_FUNC", _0 :: a -> b }
+// | { tag: "BIND",       _0 :: a -> Ef b }
+
+var PURE = "PURE";
+var MAP = "MAP";
+var APPLY = "APPLY";
+var BIND = "BIND";
+var APPLY_FUNC = "APPLY_FUNC";
+
+var runEff = function (inputEff) {
+  var operations = [];
+  var eff = inputEff;
+  var res;
+  var op;
+  var tag;
+  effLoop: for (;;) {
+    tag = eff.tag;
+    if (tag !== undefined) {
+      if (tag === MAP || tag === BIND || tag === APPLY) {
+        operations.push(eff);
+        eff = eff._1;
+        continue;
+      }
+      // here `tag === PURE`
+      res = eff._0;
+    } else {
+      res = eff();
+    }
+
+    while ((op = operations.pop())) {
+      if (op.tag === MAP) {
+        res = op._0(res);
+      } else if (op.tag === APPLY_FUNC) {
+        res = op._0(res);
+      } else if (op.tag === APPLY) {
+        eff = op._0;
+        operations.push({ tag: APPLY_FUNC, _0: res });
+        continue effLoop;
+      } else { // op.tag === BIND
+        eff = op._0(res);
+        continue effLoop;
+      }
+    }
+    return res;
+  }
+};
+
+var mkEff = function (tag, _0, _1) {
+  var eff = function eff_() { return runEff(eff_); };
+  eff.tag = tag;
+  eff._0 = _0;
+  eff._1 = _1;
+  return eff;
+};
+
+exports.pureE = function (x) {
+  return mkEff(PURE, x);
+};
+
+exports.mapE = function (f) {
+  return function (eff) {
+    return mkEff(MAP, f, eff);
   };
 };
 
-exports.bindE = function (a) {
+exports.applyE = function (effF) {
+  return function (eff) {
+    return mkEff(APPLY, eff, effF);
+  };
+};
+
+exports.bindE = function (eff) {
   return function (f) {
-    return function () {
-      return f(a())();
-    };
+    return mkEff(BIND, f, eff);
   };
 };
 

src/Control/Monad/Eff.purs

@@ -6,10 +6,10 @@ module Control.Monad.Eff
   , untilE, whileE, forE, foreachE
   ) where
 
-import Control.Applicative (class Applicative, liftA1)
+import Control.Applicative (class Applicative)
 import Control.Apply (class Apply)
 import Control.Bind (class Bind)
-import Control.Monad (class Monad, ap)
+import Control.Monad (class Monad)
 
 import Data.Functor (class Functor)
 import Data.Unit (Unit)
@@ -36,10 +36,14 @@ foreign import kind Effect
 foreign import data Eff :: # Effect -> Type -> Type
 
 instance functorEff :: Functor (Eff e) where
-  map = liftA1
+  map = mapE
+
+foreign import mapE :: forall e a b. (a -> b) -> Eff e a -> Eff e b
 
 instance applyEff :: Apply (Eff e) where
-  apply = ap
+  apply = applyE
+
+foreign import applyE :: forall e a b. Eff e (a -> b) -> Eff e a-> Eff e b
 
 instance applicativeEff :: Applicative (Eff e) where
   pure = pureE

test/Test/Main.js

@@ -0,0 +1,56 @@
+"use strict";
+
+exports.mkArr = function(){
+  return [];
+};
+
+exports.unArr = function(xs){
+  return xs.slice(0);
+};
+
+exports.pushToArr = function(xs) {
+  return function(x) {
+    return function() {
+      xs.push(x);
+      return x;
+    };
+  };
+};
+
+exports.assert = function(isOk) {
+  return function(msg) {
+    return function() {
+      if (isOk == false) {
+        throw new Error("assertion failed: " + msg);
+      };
+    };
+  };
+};
+
+exports.naturals = function(n) {
+  var res = [];
+  for (var index = 0; index < n; index++) {
+    res[index] = index;
+  }
+  return res;
+};
+
+exports.log = function(x) {
+  return function(){
+    console.log(x)
+  }
+};
+
+
+exports.time = function(x) {
+  return function(){
+    console.time(x)
+  }
+};
+
+
+exports.timeEnd = function(x) {
+  return function(){
+    console.timeEnd(x)
+  }
+};