initial version

Author: safareli

.eslintrc.json

@@ -0,0 +1,28 @@
+{
+  "parserOptions": {
+    "ecmaVersion": 5
+  },
+  "extends": "eslint:recommended",
+  "env": {
+    "commonjs": true
+  },
+  "rules": {
+    "strict": [2, "global"],
+    "block-scoped-var": 2,
+    "consistent-return": 2,
+    "eqeqeq": [2, "smart"],
+    "guard-for-in": 2,
+    "no-caller": 2,
+    "no-extend-native": 2,
+    "no-loop-func": 2,
+    "no-new": 2,
+    "no-param-reassign": 2,
+    "no-return-assign": 2,
+    "no-unused-expressions": 2,
+    "no-use-before-define": 2,
+    "radix": [2, "always"],
+    "indent": [2, 2, { "SwitchCase": 1 }],
+    "quotes": [2, "double"],
+    "semi": [2, "always"]
+  }
+}

.gitignore

@@ -0,0 +1,7 @@
+/.*
+!/.gitignore
+!/.eslintrc.json
+!/.travis.yml
+/bower_components/
+/node_modules/
+/output/

.travis.yml

@@ -0,0 +1,21 @@
+language: node_js
+dist: trusty
+sudo: required
+node_js: stable
+env:
+  - PATH=$HOME/purescript:$PATH
+install:
+  - TAG=$(wget -q -O - https://github.com/purescript/purescript/releases/latest --server-response --max-redirect 0 2>&1 | sed -n -e 's/.*Location:.*tag\///p')
+  - wget -O $HOME/purescript.tar.gz https://github.com/purescript/purescript/releases/download/$TAG/linux64.tar.gz
+  - tar -xvf $HOME/purescript.tar.gz -C $HOME/
+  - chmod a+x $HOME/purescript
+  - npm install -g bower
+  - npm install
+  - bower install
+script:
+  - npm run -s build
+after_success:
+- >-
+  test $TRAVIS_TAG &&
+  echo $GITHUB_TOKEN | pulp login &&
+  echo y | pulp publish --no-push

README.md

@@ -0,0 +1,20 @@
+# purescript-ef EXPERIMENTAL
+
+[![Latest release](http://img.shields.io/github/release/safareli/purescript-ef.svg)](https://github.com/safareli/purescript-ef/releases)
+[![Build status](https://travis-ci.org/safareli/purescript-ef.svg?branch=master)](https://travis-ci.org/safareli/purescript-ef)
+
+Faster and safer implementation of the Effect monad.
+
+## Ef vs Eff
+
+`Ef` is faster then `Eff`, plus it's stacksafe. Also it's faster to type :p
+
+## Installation
+
+```
+bower install purescript-ef
+```
+
+## Documentation
+
+Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-ef).

bench/Bench/Main.js

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

bench/Bench/Main.purs

@@ -0,0 +1,136 @@
+module Bench.Main where
+
+import Prelude
+
+import Control.Monad.Ef (Ef)
+import Control.Monad.Ef.Class (liftEf)
+import Control.Monad.Eff (Eff)
+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
+  res <- mapLoop n (pure 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 header
+  bench "bind assocR" testBindRight testBindRight [100, 500, 1000, 2000, 4000, 8000, 10000]
+  bench "bind assocL" testMap testMap [100, 500, 1000, 2000, 4000, 8000]
+  bench "map" testMap testMap [100, 500, 1000, 2000, 4000, 5000]
+  bench "apply" testApply testApply [100, 500, 1000, 2000, 4000, 5000]
+
+extended :: Eff BenchEff Unit
+extended = do
+  log header
+  timed ["bind assocR", "Ef", "100000"] $ testBindRight 100000 
+  timed ["bind assocR", "Ef", "1000000"] $ testBindRight 1000000 -- ~ 1 sec
+--timed ["bind assocR", "Ef", "10000000"] $ testBindRight 10000000 -- ~ 10 sec
+--timed ["bind assocR", "Ef", "100000000"] $ testBindRight 100000000  -- JavaScript heap out of memory  
+  timed ["bind assocL", "Ef", "20000"] $ testBindLeft 20000
+  timed ["bind assocL", "Ef", "40000"] $ testBindLeft 40000
+  timed ["bind assocL", "Ef", "80000"] $ testBindLeft 80000
+  timed ["map", "Ef", "10000"] $ testMap 10000
+  timed ["map", "Ef", "20000"] $ testMap 20000
+  timed ["map", "Ef", "40000"] $ testMap 40000
+  timed ["map", "Ef", "80000"] $ testMap 80000
+  timed ["apply", "Ef", "10000"] $ testApply 10000
+  timed ["apply", "Ef", "20000"] $ testApply 20000
+  timed ["apply", "Ef", "40000"] $ testApply 40000
+
+header :: String
+header = 
+  "| bench | type | n | mean | stddev | min | max |\n" <>
+  "| ----- | ---- | - | ---- | ------ | --- | --- |"
+
+bench
+  :: String
+  -> (Int -> Eff BenchEff Unit)
+  -> (Int -> Ef BenchEff Unit)
+  -> Array Int
+  -> Eff BenchEff Unit
+bench name buildEff buildEf vals = for_ vals \val -> do 
+  logBench [name <> " build", "Eff", show val] $ benchWith' 2000 \_ -> buildEff val
+  logBench' [name <> " build", "Ef", show val] $ benchWith' 2000 \_ -> buildEf val
+  let eff = liftEff $ buildEff val
+  logBench [name <> " run", "Eff", show val] $ benchWith' 2000 \_ -> unsafePerformEff eff
+  let ef = liftEf $ buildEf val
+  logBench' [name <> " run", "Ef", show val] $ benchWith' 2000 \_ -> unsafePerformEff ef
+
+
+timed :: Array String -> Ef BenchEff Unit -> Eff BenchEff Unit
+timed msg eff = 
+  logBench' msg $ benchWith' 5 \_ -> unsafePerformEff $ liftEf eff
+
+logBench'' :: (String -> String) -> Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
+logBench'' f msg benchEff = do
+  res <- benchEff
+  let 
+    logStr = intercalate " | " 
+      $ map f
+      $ append msg 
+      $ map withUnits [res.mean, res.stdDev, res.min, res.max]
+  log $  "| "  <> logStr <>  " |"
+
+logBench :: Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
+logBench = logBench'' id
+
+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
+

bower.json

@@ -0,0 +1,25 @@
+{
+  "name": "purescript-ef",
+  "homepage": "https://github.com/safareli/purescript-ef",
+  "description": "Faster and safer implementation of the Effect monad",
+  "license": "MIT",
+  "repository": {
+    "type": "git",
+    "url": "git://github.com/safareli/purescript-ef.git"
+  },
+  "ignore": [
+    "**/.*",
+    "bower_components",
+    "node_modules",
+    "output",
+    "test",
+    "bower.json",
+    "package.json"
+  ],
+  "dependencies": {
+    "purescript-prelude": "^3.0.0",
+    "purescript-eff": "^3.1.0",
+    "purescript-foldable-traversable": "^3.6.1",
+    "purescript-minibench": "safareli/purescript-minibench#un-log"
+  }
+}

package.json

@@ -0,0 +1,18 @@
+{
+  "private": true,
+  "scripts": {
+    "clean": "rimraf output && rimraf .pulp-cache",
+    "build": "eslint src && pulp build -- --censor-lib --strict",
+    "test": "pulp test",
+    "bench:build": "purs compile 'bench/**/*.purs' 'src/**/*.purs' 'bower_components/*/src/**/*.purs'",
+    "bench:run": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
+    "bench:run:extended": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").extended()'",
+    "bench": "npm run bench:build && npm run bench:run"
+  },
+  "devDependencies": {
+    "eslint": "^3.17.1",
+    "pulp": "^11.0.0",
+    "purescript-psa": "^0.5.1",
+    "rimraf": "^2.6.1"
+  }
+}

src/Control/Monad/Ff.js

@@ -0,0 +1,91 @@
+"use strict";
+
+
+// Ef a 
+// = { tag: "EFFECT", _0 :: () -> a,   _1 :: Void  }
+// | { tag: "PURE",   _0 :: a,         _1 :: Void  }
+// | { tag: "MAP",    _0 :: b -> a,    _1 :: Ef b }
+// | { tag: "APPLY",  _0 :: Ef b,      _1 :: Ef (b -> 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 }
+
+
+function Ef(tag, _0, _1) {
+  this.tag = tag;
+  this._0 = _0;
+  this._1 = _1;
+}
+
+var EFFECT = "EFFECT";
+var PURE = "PURE";
+var MAP = "MAP";
+var APPLY = "APPLY";
+var BIND = "BIND";
+var APPLY_FUNC = "APPLY_FUNC";
+
+exports.liftEffE = function (f) {
+  return new Ef(EFFECT, f);
+};
+
+exports.pureE = function (x) {
+  return new Ef(PURE, x);
+};
+
+exports.mapE = function (f) {
+  return function (eff) {
+    return new Ef(MAP, f, eff);
+  };
+};
+
+exports.applyE = function (effF) {
+  return function (eff) {
+    return new Ef(APPLY, eff, effF);
+  };
+};
+
+exports.bindE = function (eff) {
+  return function (f) {
+    return new Ef(BIND, f, eff);
+  };
+};
+
+exports.toEff = function (inputEff) {
+  return function() {
+    var operations = [];
+    var eff = inputEff;
+    var res;
+    var op;
+    effLoop: for (;;) {
+      if (eff.tag === MAP || eff.tag === BIND || eff.tag === APPLY) {
+        operations.unshift(eff);
+        eff = eff._1;
+      } else {
+        if (eff.tag === EFFECT) {
+          res = eff._0();
+        } else { // eff.tag === PURE
+          res = eff._0;
+        }
+        while ((op = operations.shift())) {
+          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.unshift(new Ef(APPLY_FUNC, res));
+            continue effLoop;
+          } else { // op.tag === BIND
+            eff = op._0(res);
+            continue effLoop;
+          }
+        }
+        return res;
+      }
+    }
+  };
+};