Implement MonadPar and MonadRace

.gitignore

@@ -1,6 +1,6 @@
 /.*
 !/.gitignore
 !/.travis.yml
-/output/
-/node_modules/
 /bower_components/
+/node_modules/
+/output/

.travis.yml

@@ -1,17 +1,17 @@
 language: node_js
-sudo: false
-node_js: 5
+dist: trusty
+sudo: required
+node_js: 6
 install:
+  - npm install -g bower
   - npm install
-  - npm install bower -g
-  - bower install
 script:
-  - npm test
+  - bower install --production
+  - npm run -s build
+  - bower install
+  - npm -s test
 after_success:
 - >-
   test $TRAVIS_TAG &&
-  node_modules/.bin/psc-publish > .pursuit.json &&
-  curl -X POST http://pursuit.purescript.org/packages \
-    -d @.pursuit.json \
-    -H 'Accept: application/json' \
-    -H "Authorization: token ${GITHUB_TOKEN}"
+  echo $GITHUB_TOKEN | pulp login &&
+  echo y | pulp publish --no-push

README.md

@@ -6,16 +6,16 @@
 
 An asynchronous effect monad for PureScript.
 
-The moral equivalent of `ErrorT (ContT Unit (Eff e) a`, for effects `e`.
+The moral equivalent of `ErrorT (ContT Unit (Eff e)) a`, for effects `e`.
 
 `Aff` lets you say goodbye to monad transformers and callback hell!
 
 # Example
 
 ```purescript
-main = launchAff $ 
-  do response <- Ajax.get "http://foo.bar"
-     liftEff $ log response.body
+main = launchAff do
+  response <- Ajax.get "http://foo.bar"
+  liftEff $ log response.body
 ```
 
 See the [tests](https://github.com/slamdata/purescript-aff/blob/master/test/Test/Main.purs) for more examples.
@@ -33,10 +33,10 @@ bower install purescript-aff
 An example of `Aff` is shown below:
 
 ```purescript
-deleteBlankLines path =
-  do  contents <- loadFile path
-      let contents' = S.join "\n" $ A.filter (\a -> S.length a > 0) (S.split "\n" contents)
-      saveFile path contents'
+deleteBlankLines path = do
+  contents <- loadFile path
+  let contents' = S.join "\n" $ A.filter (\a -> S.length a > 0) (S.split "\n" contents)
+  saveFile path contents'
 ```
 
 This looks like ordinary, synchronous, imperative code, but actually operates asynchronously without any callbacks. Error handling is baked in so you only deal with it when you want to.
@@ -149,23 +149,23 @@ Here's an example of how you can use them:
 
 ```purescript
 do resp <- (Ajax.get "http://foo.com") `catchError` (const $ pure defaultResponse)
-   if resp.statusCode != 200 then throwError myErr 
+   if resp.statusCode != 200 then throwError myErr
    else pure resp.body
 ```
 
 Thrown exceptions are propagated on the error channel, and can be recovered from using `attempt` or `catchError`.
 
 ## Forking
 
-Using the `forkAff`, you can "fork" an asynchronous computation, which means 
+Using the `forkAff`, you can "fork" an asynchronous computation, which means
 that its activities will not block the current thread of execution:
 
 ```purescript
 forkAff myAff
 ```
 
-Because Javascript is single-threaded, forking does not actually cause the 
-computation to be run in a separate thread. Forking just allows the subsequent 
+Because Javascript is single-threaded, forking does not actually cause the
+computation to be run in a separate thread. Forking just allows the subsequent
 actions to execute without waiting for the forked computation to complete.
 
 If the asynchronous computation supports it, you can "kill" a forked computation
@@ -191,28 +191,34 @@ The `Control.Monad.Aff.AVar` module contains asynchronous variables, which are v
 ```purescript
 do v <- makeVar
    forkAff (later $ putVar v 1.0)
-   a <- takeVar v 
+   a <- takeVar v
    liftEff $ log ("Succeeded with " ++ show a)
 ```
 
-You can use these constructs as one-sided blocking queues, which suspend (if 
+You can use these constructs as one-sided blocking queues, which suspend (if
 necessary) on `take` operations, or as asynchronous, empty-or-full variables.
 
 ## Parallel Execution
 
-If you only need the power of `Applicative`, then instead of using the monadic `Aff`, you can use the `Par` newtype wrapper defined in `Control.Monad.Aff.Par`.
+There are `MonadPar` and `MonadRace` instances defined for `Aff`, allowing for parallel execution of `Aff` computations.
 
-This provides parallel instances of `Apply` and `Alt`.
+There are two ways of taking advantage of these instances - directly through the `par` and `race` functions from these classes, or by using the `Parallel` newtype wrapper that enables parallel behaviours through the `Applicative` and `Alternative` operators.
 
-In the following example, two Ajax requests are initiated simultaneously (rather than in sequence, as they would be for `Aff`):
+In the following example, using the newtype, two Ajax requests are initiated simultaneously (rather than in sequence, as they would be for `Aff`):
 
 ```purescript
-runPar (f <$> Par (Ajax.get "http://foo.com") <*> Par (Ajax.get "http://foo.com"))
+runParallel (f <$> parallel (Ajax.get "http://foo.com") <*> parallel (Ajax.get "http://foo.com"))
 ```
 
-The `(<|>)` operator of the `Alt` instance of `Par` allows you to race two asynchronous computations, and use whichever value comes back first (or the first error, if both err).
+And the equivalent using the `MonadPar` function directly:
 
-The `runPar` function allows you to unwrap the `Aff` and return to normal monadic (sequential) composition.
+```purescript
+par f (Ajax.get "http://foo.com") (Ajax.get "http://foo.com")
+```
+
+The `race` function from `MonadPar` or the `(<|>)` operator of the `Alt` instance of `Parallel` allows you to race two asynchronous computations, and use whichever value comes back first (or the first error, if both err).
+
+The `runParallel` function allows you to unwrap the `Aff` and return to normal monadic (sequential) composition.
 
 A parallel computation can be canceled if both of its individual components can be canceled.
 

bower.json

@@ -20,7 +20,8 @@
     "purescript-console": "^1.0.0",
     "purescript-exceptions": "^1.0.0",
     "purescript-functions": "^1.0.0",
-    "purescript-transformers": "^1.0.0"
+    "purescript-transformers": "^1.0.0",
+    "purescript-parallel": "^1.0.0"
   },
   "devDependencies": {
     "purescript-partial": "^1.1.2"

package.json

@@ -2,12 +2,13 @@
   "private": true,
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
-    "build": "pulp build",
+    "build": "pulp build --censor-lib --strict",
     "test": "pulp test"
   },
   "devDependencies": {
-    "purescript": "^0.9.1-rc.1",
     "pulp": "^9.0.0",
-    "rimraf": "^2.5.2"
+    "purescript-psa": "^0.3.9",
+    "purescript": "^0.9.1",
+    "rimraf": "^2.5.0"
   }
 }

src/Control/Monad/Aff.js

@@ -320,3 +320,11 @@ exports._tailRecM = function (isLeft, f, a) {
     }(a);
   };
 };
+
+
+var avar = require("../Control.Monad.Aff.AVar/foreign.js");
+
+exports._makeVar = avar._makeVar;
+exports._takeVar = avar._takeVar;
+exports._putVar = avar._putVar;
+exports._killVar = avar._killVar;

src/Control/Monad/Aff.purs

@@ -21,6 +21,7 @@ module Control.Monad.Aff
   where
 
 import Prelude
+
 import Control.Alt (class Alt)
 import Control.Alternative (class Alternative)
 import Control.Monad.Cont.Class (class MonadCont)
@@ -30,7 +31,9 @@ import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error)
 import Control.Monad.Error.Class (class MonadError, throwError)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.MonadPlus (class MonadZero, class MonadPlus)
+import Control.Parallel.Class (class MonadRace, class MonadPar)
 import Control.Plus (class Plus)
+
 import Data.Either (Either(..), either, isLeft)
 import Data.Foldable (class Foldable, foldl)
 import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
@@ -202,6 +205,56 @@ instance semigroupCanceler :: Semigroup (Canceler e) where
 instance monoidCanceler :: Monoid (Canceler e) where
   mempty = Canceler (const (pure true))
 
+instance monadParAff :: MonadPar (Aff e) where
+  par f ma mb = do
+    va <- _makeVar nonCanceler
+    vb <- _makeVar nonCanceler
+    c1 <- forkAff (putOrKill va =<< attempt ma)
+    c2 <- forkAff (putOrKill vb =<< attempt mb)
+    f <$> (takeVar va) <*> (takeVar vb)
+    where
+    putOrKill :: forall a. AVar a -> Either Error a -> Aff e Unit
+    putOrKill v = either (killVar v) (putVar v)
+
+instance monadRaceAff :: MonadRace (Aff e) where
+  stall = throwError $ error "Stalled"
+  race a1 a2 = do
+    va <- _makeVar nonCanceler -- the `a` value
+    ve <- _makeVar nonCanceler -- the error count (starts at 0)
+    putVar ve 0
+    c1 <- forkAff $ either (maybeKill va ve) (putVar va) =<< attempt a1
+    c2 <- forkAff $ either (maybeKill va ve) (putVar va) =<< attempt a2
+    takeVar va `cancelWith` (c1 <> c2)
+    where
+    maybeKill :: forall a. AVar a -> AVar Int -> Error -> Aff e Unit
+    maybeKill va ve err = do
+      e <- takeVar ve
+      if e == 1 then killVar va err else pure unit
+      putVar ve (e + 1)
+
+--------------------------------
+
+foreign import data AVar :: * -> *
+
+takeVar :: forall e a. AVar a -> Aff e a
+takeVar q = runFn2 _takeVar nonCanceler q
+
+putVar :: forall e a. AVar a -> a -> Aff e Unit
+putVar q a = runFn3 _putVar nonCanceler q a
+
+killVar :: forall e a. AVar a -> Error -> Aff e Unit
+killVar q e = runFn3 _killVar nonCanceler q e
+
+foreign import _makeVar :: forall e a. Canceler e -> Aff e (AVar a)
+
+foreign import _takeVar :: forall e a. Fn2 (Canceler e) (AVar a) (Aff e a)
+
+foreign import _putVar :: forall e a. Fn3 (Canceler e) (AVar a) a (Aff e Unit)
+
+foreign import _killVar :: forall e a. Fn3 (Canceler e) (AVar a) Error (Aff e Unit)
+
+--------------------------------
+
 foreign import _cancelWith :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)
 
 foreign import _setTimeout :: forall e a. Fn3 (Canceler e) Int (Aff e a) (Aff e a)