Skip to content

Commit 7b4b550

Browse files
safarelisafareli
committed
initial version
1 parent 283f817 commit 7b4b550

File tree

13 files changed

+638
-0
lines changed

13 files changed

+638
-0
lines changed

‎.eslintrc.json‎

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
{
2+
"parserOptions": {
3+
"ecmaVersion": 5
4+
},
5+
"extends": "eslint:recommended",
6+
"env": {
7+
"commonjs": true
8+
},
9+
"rules": {
10+
"strict": [2, "global"],
11+
"block-scoped-var": 2,
12+
"consistent-return": 2,
13+
"eqeqeq": [2, "smart"],
14+
"guard-for-in": 2,
15+
"no-caller": 2,
16+
"no-extend-native": 2,
17+
"no-loop-func": 2,
18+
"no-new": 2,
19+
"no-param-reassign": 2,
20+
"no-return-assign": 2,
21+
"no-unused-expressions": 2,
22+
"no-use-before-define": 2,
23+
"radix": [2, "always"],
24+
"indent": [2, 2, { "SwitchCase": 1 }],
25+
"quotes": [2, "double"],
26+
"semi": [2, "always"]
27+
}
28+
}

‎.gitignore‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
/.*
2+
!/.gitignore
3+
!/.eslintrc.json
4+
!/.travis.yml
5+
/bower_components/
6+
/node_modules/
7+
/output/

‎.travis.yml‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
language: node_js
2+
dist: trusty
3+
sudo: required
4+
node_js: stable
5+
env:
6+
- PATH=$HOME/purescript:$PATH
7+
install:
8+
- 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')
9+
- wget -O $HOME/purescript.tar.gz https://github.com/purescript/purescript/releases/download/$TAG/linux64.tar.gz
10+
- tar -xvf $HOME/purescript.tar.gz -C $HOME/
11+
- chmod a+x $HOME/purescript
12+
- npm install -g bower
13+
- npm install
14+
- bower install
15+
script:
16+
- npm run -s build
17+
after_success:
18+
- >-
19+
test $TRAVIS_TAG &&
20+
echo $GITHUB_TOKEN | pulp login &&
21+
echo y | pulp publish --no-push

‎README.md‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
# purescript-ef EXPERIMENTAL
2+
3+
[![Latest release](http://img.shields.io/github/release/safareli/purescript-ef.svg)](https://github.com/safareli/purescript-ef/releases)
4+
[![Build status](https://travis-ci.org/safareli/purescript-ef.svg?branch=master)](https://travis-ci.org/safareli/purescript-ef)
5+
6+
Faster and safer implementation of the Effect monad.
7+
8+
## Ef vs Eff
9+
10+
`Ef` is faster then `Eff`, plus it's stacksafe. Also it's faster to type :p
11+
12+
## Installation
13+
14+
```
15+
bower install purescript-ef
16+
```
17+
18+
## Documentation
19+
20+
Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-ef).

‎bench/Bench/Main.js‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
"use strict";
2+
3+
exports.mkArr = function(){
4+
return [];
5+
};
6+
7+
exports.pushToArr = function(xs) {
8+
return function(x) {
9+
return function() {
10+
xs.push(x);
11+
return x;
12+
};
13+
};
14+
};
15+
16+
exports.log = function(x) {
17+
return function(){
18+
console.log(x)
19+
}
20+
};

‎bench/Bench/Main.purs‎

Lines changed: 137 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,137 @@
1+
module Bench.Main where
2+
3+
import Prelude
4+
5+
import Control.Monad.Ef (Ef)
6+
import Control.Monad.Ef.Class (liftEf)
7+
import Control.Monad.Eff (Eff)
8+
import Control.Monad.Eff.Class (class MonadEff, liftEff)
9+
import Control.Monad.Eff.Console (CONSOLE)
10+
import Control.Monad.Eff.Unsafe (unsafePerformEff)
11+
import Data.Traversable (for_, intercalate)
12+
import Performance.Minibench (BenchResult, benchWith', withUnits)
13+
14+
15+
type BenchEff = (console :: CONSOLE)
16+
17+
testApply :: forall m. MonadEff BenchEff m => Int -> m Unit
18+
testApply n' = do
19+
arr <- liftEff mkArr
20+
applyLoop (void <<< liftEff <<< pushToArr arr) n'
21+
where
22+
applyLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
23+
applyLoop eff max = go (pure unit) 0
24+
where
25+
go acc n | n == max = acc
26+
go acc n = go (acc <* eff n) (n + 1)
27+
28+
29+
testBindRight :: forall m. MonadEff BenchEff m => Int -> m Unit
30+
testBindRight n' = do
31+
arr <- liftEff mkArr
32+
bindRightLoop (void <<< liftEff <<< pushToArr arr) n'
33+
where
34+
bindRightLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
35+
bindRightLoop eff max = go (pure unit) 0
36+
where
37+
go acc n | n == max = acc
38+
go acc n = go (eff (max - n - 1) >>= const acc) (n + 1)
39+
40+
41+
testBindLeft :: forall m. MonadEff BenchEff m => Int -> m Unit
42+
testBindLeft n' = do
43+
arr <- liftEff mkArr
44+
bindLeftLoop (void <<< liftEff <<< pushToArr arr) n'
45+
where
46+
bindLeftLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
47+
bindLeftLoop eff max = go (pure unit) 0
48+
where
49+
go acc n | n == max = acc
50+
go acc n = go (acc >>= const (eff n)) (n + 1)
51+
52+
53+
testMap :: forall m. MonadEff BenchEff m => Int -> m Unit
54+
testMap n = do
55+
res <- mapLoop n (pure 0)
56+
pure unit
57+
where
58+
mapLoop :: Monad m => Int -> m Int -> m Int
59+
mapLoop max i =
60+
if max == 0
61+
then i
62+
else mapLoop (max - 1) (map (_ + 1) i)
63+
64+
65+
main :: Eff BenchEff Unit
66+
main = do
67+
log header
68+
bench "bind assocR" testBindRight testBindRight [100, 500, 1000, 2000, 4000, 8000, 10000]
69+
bench "bind assocL" testMap testMap [100, 500, 1000, 2000, 4000, 8000]
70+
bench "map" testMap testMap [100, 500, 1000, 2000, 4000, 5000]
71+
bench "apply" testApply testApply [100, 500, 1000, 2000, 4000, 5000]
72+
73+
extended :: Eff BenchEff Unit
74+
extended = do
75+
log header
76+
timed ["bind assocR", "Ef", "100000"] $ testBindRight 100000
77+
timed ["bind assocR", "Ef", "1000000"] $ testBindRight 1000000 -- ~ 1 sec
78+
--timed ["bind assocR", "Ef", "10000000"] $ testBindRight 10000000 -- ~ 10 sec
79+
--timed ["bind assocR", "Ef", "100000000"] $ testBindRight 100000000 -- JavaScript heap out of memory
80+
timed ["bind assocL", "Ef", "20000"] $ testBindLeft 20000
81+
timed ["bind assocL", "Ef", "40000"] $ testBindLeft 40000
82+
timed ["bind assocL", "Ef", "80000"] $ testBindLeft 80000
83+
timed ["map", "Ef", "10000"] $ testMap 10000
84+
timed ["map", "Ef", "20000"] $ testMap 20000
85+
timed ["map", "Ef", "40000"] $ testMap 40000
86+
timed ["map", "Ef", "80000"] $ testMap 80000
87+
timed ["apply", "Ef", "10000"] $ testApply 10000
88+
timed ["apply", "Ef", "20000"] $ testApply 20000
89+
timed ["apply", "Ef", "40000"] $ testApply 40000
90+
timed ["apply", "Ef", "80000"] $ testApply 80000
91+
92+
header :: String
93+
header =
94+
"| bench | type | n | mean | stddev | min | max |\n" <>
95+
"| ----- | ---- | - | ---- | ------ | --- | --- |"
96+
97+
bench
98+
:: String
99+
-> (Int -> Eff BenchEff Unit)
100+
-> (Int -> Ef BenchEff Unit)
101+
-> Array Int
102+
-> Eff BenchEff Unit
103+
bench name buildEff buildEf vals = for_ vals \val -> do
104+
logBench [name <> " build", "Eff", show val] $ benchWith' 2000 \_ -> buildEff val
105+
logBench' [name <> " build", "Ef", show val] $ benchWith' 2000 \_ -> buildEf val
106+
let eff = liftEff $ buildEff val
107+
logBench [name <> " run", "Eff", show val] $ benchWith' 2000 \_ -> unsafePerformEff eff
108+
let ef = liftEf $ buildEf val
109+
logBench' [name <> " run", "Ef", show val] $ benchWith' 2000 \_ -> unsafePerformEff ef
110+
111+
112+
timed :: Array String -> Ef BenchEff Unit -> Eff BenchEff Unit
113+
timed msg eff =
114+
logBench' msg $ benchWith' 5 \_ -> unsafePerformEff $ liftEf eff
115+
116+
logBench'' :: (String -> String) -> Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
117+
logBench'' f msg benchEff = do
118+
res <- benchEff
119+
let
120+
logStr = intercalate " | "
121+
$ map f
122+
$ append msg
123+
$ map withUnits [res.mean, res.stdDev, res.min, res.max]
124+
log $ "| " <> logStr <> " |"
125+
126+
logBench :: Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
127+
logBench = logBench'' id
128+
129+
logBench' :: Array String -> Eff BenchEff BenchResult -> Eff BenchEff Unit
130+
logBench' = logBench'' \s -> "**" <> s <> "**"
131+
132+
foreign import data Arr :: Type -> Type
133+
134+
foreign import mkArr :: forall e a. Eff e (Arr a)
135+
foreign import pushToArr :: forall e a. Arr a -> a -> Eff e a
136+
foreign import log :: forall e a. a -> Eff e Unit
137+

‎bower.json‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
{
2+
"name": "purescript-ef",
3+
"homepage": "https://github.com/safareli/purescript-ef",
4+
"description": "Faster and safer implementation of the Effect monad",
5+
"license": "MIT",
6+
"repository": {
7+
"type": "git",
8+
"url": "git://github.com/safareli/purescript-ef.git"
9+
},
10+
"ignore": [
11+
"**/.*",
12+
"bower_components",
13+
"node_modules",
14+
"output",
15+
"test",
16+
"bower.json",
17+
"package.json"
18+
],
19+
"dependencies": {
20+
"purescript-prelude": "^3.0.0",
21+
"purescript-eff": "^3.1.0",
22+
"purescript-foldable-traversable": "^3.6.1",
23+
"purescript-minibench": "safareli/purescript-minibench#un-log"
24+
}
25+
}

‎package.json‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
{
2+
"private": true,
3+
"scripts": {
4+
"clean": "rimraf output && rimraf .pulp-cache",
5+
"build": "eslint src && pulp build -- --censor-lib --strict",
6+
"test": "pulp test",
7+
"bench:build": "purs compile 'bench/**/*.purs' 'src/**/*.purs' 'bower_components/*/src/**/*.purs'",
8+
"bench:run": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
9+
"bench:run:extended": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").extended()'",
10+
"bench": "npm run bench:build && npm run bench:run"
11+
},
12+
"devDependencies": {
13+
"eslint": "^3.17.1",
14+
"pulp": "^11.0.0",
15+
"purescript-psa": "^0.5.1",
16+
"rimraf": "^2.6.1"
17+
}
18+
}

‎src/Control/Monad/Ff.js‎

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
"use strict";
2+
3+
4+
// Ef a
5+
// = { tag: "EFFECT", _0 :: () -> a, _1 :: Void }
6+
// | { tag: "PURE", _0 :: a, _1 :: Void }
7+
// | { tag: "MAP", _0 :: b -> a, _1 :: Ef b }
8+
// | { tag: "APPLY", _0 :: Ef b, _1 :: Ef (b -> a) }
9+
// | { tag: "BIND", _0 :: b -> Ef a, _1 :: Ef b }
10+
11+
// Operation a b
12+
// = { tag: "MAP", _0 :: a -> b }
13+
// | { tag: "APPLY", _0 :: Ef a }
14+
// | { tag: "APPLY_FUNC", _0 :: a -> b }
15+
// | { tag: "BIND", _0 :: a -> Ef b }
16+
17+
18+
function Ef(tag, _0, _1) {
19+
this.tag = tag;
20+
this._0 = _0;
21+
this._1 = _1;
22+
}
23+
24+
var EFFECT = "EFFECT";
25+
var PURE = "PURE";
26+
var MAP = "MAP";
27+
var APPLY = "APPLY";
28+
var BIND = "BIND";
29+
var APPLY_FUNC = "APPLY_FUNC";
30+
31+
exports.liftEffE = function (f) {
32+
return new Ef(EFFECT, f);
33+
};
34+
35+
exports.pureE = function (x) {
36+
return new Ef(PURE, x);
37+
};
38+
39+
exports.mapE = function (f) {
40+
return function (eff) {
41+
return new Ef(MAP, f, eff);
42+
};
43+
};
44+
45+
exports.applyE = function (effF) {
46+
return function (eff) {
47+
return new Ef(APPLY, eff, effF);
48+
};
49+
};
50+
51+
exports.bindE = function (eff) {
52+
return function (f) {
53+
return new Ef(BIND, f, eff);
54+
};
55+
};
56+
57+
exports.toEff = function (inputEff) {
58+
return function() {
59+
var operations = [];
60+
var eff = inputEff;
61+
var res;
62+
var op;
63+
effLoop: for (;;) {
64+
if (eff.tag === MAP || eff.tag === BIND || eff.tag === APPLY) {
65+
operations.unshift(eff);
66+
eff = eff._1;
67+
} else {
68+
if (eff.tag === EFFECT) {
69+
res = eff._0();
70+
} else { // eff.tag === PURE
71+
res = eff._0;
72+
}
73+
while ((op = operations.shift())) {
74+
if (op.tag === MAP) {
75+
res = op._0(res);
76+
} else if (op.tag === APPLY_FUNC) {
77+
res = op._0(res);
78+
} else if (op.tag === APPLY) {
79+
eff = op._0;
80+
operations.unshift(new Ef(APPLY_FUNC, res));
81+
continue effLoop;
82+
} else { // op.tag === BIND
83+
eff = op._0(res);
84+
continue effLoop;
85+
}
86+
}
87+
return res;
88+
}
89+
}
90+
};
91+
};

0 commit comments

Comments
 (0)