diff --git a/.travis.yml b/.travis.yml index 27b95cd..3538f4a 100644 --- a/.travis.yml +++ b/.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 && diff --git a/bench/.gitignore b/bench/.gitignore new file mode 100644 index 0000000..f1237d3 --- /dev/null +++ b/bench/.gitignore @@ -0,0 +1,5 @@ +/.* +!/.gitignore +!/.travis.yml +/bower_components/ +/output/ diff --git a/bench/bower.json b/bench/bower.json new file mode 100644 index 0000000..6a64698 --- /dev/null +++ b/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" + } +} diff --git a/bench/node_modules b/bench/node_modules new file mode 120000 index 0000000..ea095f3 --- /dev/null +++ b/bench/node_modules @@ -0,0 +1 @@ +../node_modules/ \ No newline at end of file diff --git a/bench/package.json b/bench/package.json new file mode 100644 index 0000000..10a770f --- /dev/null +++ b/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" + } + } + \ No newline at end of file diff --git a/bench/src/Bench/Main.js b/bench/src/Bench/Main.js new file mode 100644 index 0000000..0001a5b --- /dev/null +++ b/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) + } +}; \ No newline at end of file diff --git a/bench/src/Bench/Main.purs b/bench/src/Bench/Main.purs new file mode 100644 index 0000000..5d3c6a8 --- /dev/null +++ b/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 + diff --git a/package.json b/package.json index 26d81a7..f440179 100644 --- a/package.json +++ b/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" } } diff --git a/src/Control/Monad/Eff.js b/src/Control/Monad/Eff.js index 851d4ca..77b45f8 100644 --- a/src/Control/Monad/Eff.js +++ b/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); }; }; diff --git a/src/Control/Monad/Eff.purs b/src/Control/Monad/Eff.purs index fc69b9c..2f8c18f 100644 --- a/src/Control/Monad/Eff.purs +++ b/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 diff --git a/test/Test/Main.js b/test/Test/Main.js new file mode 100644 index 0000000..2f6b9dc --- /dev/null +++ b/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) + } +}; diff --git a/test/Test/Main.purs b/test/Test/Main.purs new file mode 100644 index 0000000..91db844 --- /dev/null +++ b/test/Test/Main.purs @@ -0,0 +1,93 @@ +module Test.Main where + +import Prelude + +import Control.Monad.Eff (Eff) +import Control.Apply (lift2) + +testLift2 :: Eff () Unit +testLift2 = do + arr <- mkArr + res <- (pushToArr arr 1) `lift2 (+)` (pushToArr arr 2) + res' <- (pure 1) `lift2 (+)` (pure 2) + assert ([1, 2] == unArr arr) "lift2 1/3" + assert (3 == res') "lift2 2/3" + assert (3 == res) "lift2 3/3" + + +testApply :: Int -> Eff () Unit +testApply n' = do + arr <- mkArr + applyLoop (void <<< pushToArr arr) n' + assert (naturals n' == unArr arr) $ "apply " <> show n' + where + applyLoop eff max = go (pure unit) 0 + where + go acc n | n == max = acc + go acc n = go (acc <* eff n) (n + 1) + + + +testBindRight :: Int -> Eff () Unit +testBindRight n' = do + arr <- mkArr + bindRightLoop (void <<< pushToArr arr) n' + assert (naturals n' == unArr arr) $ "bind right " <> show n' + where + 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 :: Int -> Eff () Unit +testBindLeft n' = do + arr <- mkArr + bindLeftLoop (void <<< pushToArr arr) n' + assert (naturals n' == unArr arr) $ "bind left " <> show n' + where + 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 :: Int -> Eff () Unit +testMap n = do + arr <- mkArr + res <- mapLoop n (pushToArr arr 0) + assert (res == n) $ "map " <> show n + assert ([0] == unArr arr) $ "map" + where + mapLoop max i = + if max == 0 + then i + else mapLoop (max - 1) (map (_ + 1) i) + + +main :: Eff () Unit +main = do + test "testLift2" $ testLift2 + test "testBindRight" $ testBindRight 1000000 + test "testBindLeft" $ testMap 1000000 + test "testMap" $ testMap 5000000 + test "testApply" $ testApply 1000000 + where + test msg eff = do + time msg + eff + timeEnd msg + + +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 assert :: forall e. Boolean -> String -> Eff e Unit +foreign import log :: forall e a. a -> Eff e Unit +foreign import unArr :: forall a. Arr a -> Array a +foreign import naturals :: Int -> Array Int + +foreign import time :: forall e. String -> Eff e Unit +foreign import timeEnd :: forall e. String -> Eff e Unit