Merge pull request #5 from natefaubion/hierarchy

Updated hierarchy

Author: natefaubion

bower.json

@@ -15,6 +15,6 @@
     "package.json"
   ],
   "dependencies": {
-    "purescript-aff": "^3.0.0"
+    "purescript-aff": "^4.0.0"
   }
 }

src/Control/Monad/Fork.purs

@@ -1,5 +1,5 @@
 {-
-Copyright 2016 SlamData, Inc.
+Copyright 2017 SlamData, Inc.
 
 Licensed under the Apache License, Version 2.0 (the "License");
 you may not use this file except in compliance with the License.
@@ -16,19 +16,107 @@ limitations under the License.
 
 module Control.Monad.Fork.Class where
 
-import Prelude
+import Prelude hiding (join)
 
 import Control.Monad.Aff as Aff
-import Control.Monad.Eff.Exception (Error)
-import Control.Monad.Reader.Trans (ReaderT(..))
+import Control.Monad.Error.Class (class MonadThrow, class MonadError)
+import Control.Monad.Reader.Trans (ReaderT(..), runReaderT)
 import Control.Monad.Trans.Class (lift)
 
-class Monad m ⇐ MonadFork e m | m → e where
-  fork ∷ ∀ a. m a → m (e → m Boolean)
+-- | Represents Monads which can be forked asynchronously.
+-- |
+-- | Laws:
+-- |
+-- | ```purescript
+-- | -- Unjoined suspension is a no-op
+-- | suspend a1 *> suspend a2 = suspend a2
+-- |
+-- | -- Suspend/join is identity
+-- | suspend >=> join = id
+-- |
+-- | -- Fork/join is identity
+-- | fork >=> join = id
+-- |
+-- | -- Join is idempotent
+-- | join t *> join t = join t
+-- | ```
+class (Monad m, Functor f) ⇐ MonadFork f m | m → f where
+  suspend ∷ ∀ a. m a → m (f a)
+  fork ∷ ∀ a. m a → m (f a)
+  join ∷ ∀ a. f a → m a
 
-instance monadForkAff ∷ MonadFork Error (Aff.Aff eff) where
-  fork = map Aff.cancel <<< Aff.forkAff
+instance monadForkAff ∷ MonadFork (Aff.Fiber eff) (Aff.Aff eff) where
+  suspend = Aff.suspendAff
+  fork = Aff.forkAff
+  join = Aff.joinFiber
 
-instance monadForkReaderT ∷ MonadFork e m ⇒ MonadFork e (ReaderT r m) where
-  fork (ReaderT ma) =
-    ReaderT \r → map lift <$> fork (ma r)
+instance monadForkReaderT ∷ MonadFork f m ⇒ MonadFork f (ReaderT r m) where
+  suspend (ReaderT ma) = ReaderT (suspend <<< ma)
+  fork (ReaderT ma) = ReaderT (fork <<< ma)
+  join = lift <<< join
+
+-- | Represents Monads which can be killed after being forked.
+-- |
+-- | Laws:
+-- |
+-- | ```purescript
+-- | -- Killed suspension is an exception
+-- | suspend a >>= \f -> kill e f *> join f = throwError e
+-- |
+-- | -- Suspend/kill is unit
+-- | suspend a >>= kill e = pure unit
+-- | ```
+class (MonadFork f m, MonadThrow e m) ⇐  MonadKill e f m | m → e f where
+  kill ∷ ∀ a. e → f a → m Unit
+
+instance monadKillAff ∷ MonadKill Aff.Error (Aff.Fiber eff) (Aff.Aff eff) where
+  kill = Aff.killFiber
+
+instance monadKillReaderT ∷ MonadKill e f m ⇒ MonadKill e f (ReaderT r m) where
+  kill e = lift <<< kill e
+
+data BracketCondition e a
+  = Completed a
+  | Failed e
+  | Killed e
+
+-- | Represents Monads which support cleanup in the presence of async
+-- | exceptions.
+-- |
+-- | Laws:
+-- | ```purescript
+-- | bracket a k \_ -> pure r
+-- |   = uninterruptible (a >>= k (Completed r))
+-- |
+-- | -- Release failed
+-- | bracket a k \_ -> throwError e
+-- |   = uninterruptible (a >>= k (Failed e) *> throwError e)
+-- |
+-- | -- Release killed
+-- | fork (bracket a k \_ -> never) >>= \f -> kill e f *> void (try (join f))
+-- |   = uninterruptible (a >>= k (Killed e))
+-- | ```
+class (MonadKill e f m, MonadError e m) ⇐ MonadBracket e f m | m → e f where
+  bracket ∷ ∀ r a. m r → (BracketCondition e a → r → m Unit) → (r → m a) → m a
+  uninterruptible ∷ ∀ a. m a → m a
+  never ∷ ∀ a. m a
+
+instance monadBracketAff ∷ MonadBracket Aff.Error (Aff.Fiber eff) (Aff.Aff eff) where
+  bracket acquire release run =
+    Aff.generalBracket acquire
+      { completed: release <<< Completed
+      , failed: release <<< Failed
+      , killed: release <<< Killed
+      }
+      run
+  uninterruptible = Aff.invincible
+  never = Aff.never
+
+instance monadBracketReaderT ∷ MonadBracket e f m ⇒ MonadBracket e f (ReaderT r m) where
+  bracket (ReaderT acquire) release run = ReaderT \r →
+    bracket (acquire r)
+      (\c a → runReaderT (release c a) r)
+      (\a → runReaderT (run a) r)
+  uninterruptible k = ReaderT \r ->
+    uninterruptible (runReaderT k r)
+  never = lift never