Merge pull request #9 from safareli/eff-make

make using eff

bower.json

@@ -24,7 +24,7 @@
   ],
   "dependencies": {
     "purescript-prelude": "^3.0.0",
-    "purescript-aff": "^4.0.0"
+    "purescript-aff": "^4.1.0"
   },
   "devDependencies": {
     "purescript-refs": "^3.0.0"

src/Control/Monad/Aff/Bus.purs

@@ -31,8 +31,10 @@ module Control.Monad.Aff.Bus
 
 import Prelude
 
-import Control.Monad.Aff (Aff, attempt, forkAff)
-import Control.Monad.Aff.AVar (AVAR, AVar, killVar, makeEmptyVar, makeVar, putVar, takeVar)
+import Control.Monad.Aff (Aff, attempt, launchAff_)
+import Control.Monad.Aff.AVar (AVAR, AVar, killVar, makeEmptyVar, putVar, takeVar)
+import Control.Monad.Eff.AVar as EffAvar
+import Control.Monad.Eff.Class (class MonadEff, liftEff)
 import Control.Monad.Eff.Exception as Exn
 import Data.Foldable (foldl, sequence_, traverse_)
 import Data.List (List, (:))
@@ -54,18 +56,18 @@ type BusW' r = Bus (write ∷ Cap | r)
 type BusRW = Bus (read ∷ Cap, write ∷ Cap)
 
 -- | Creates a new bidirectional Bus which can be read from and written to.
-make ∷ ∀ eff a. Aff (avar ∷ AVAR | eff) (BusRW a)
-make = do
-  cell ← makeEmptyVar
-  consumers ← makeVar mempty
+make ∷ ∀ m eff a. MonadEff (avar ∷ AVAR | eff) m => m (BusRW a)
+make = liftEff do
+  cell ← EffAvar.makeEmptyVar
+  consumers ← EffAvar.makeVar mempty
   let
-    loop = do
-      attempt (takeVar cell) >>= traverse_ \res → do
-        vars ← takeVar consumers
-        putVar mempty consumers
-        sequence_ (foldl (\xs a → putVar res a : xs) mempty vars)
-        loop
-  _ ← forkAff loop
+    loop = attempt (takeVar cell) >>= traverse_ \res → do
+      vars ← takeVar consumers
+      putVar mempty consumers
+      sequence_ (foldl (\xs a → putVar res a : xs) mempty vars)
+      loop
+  launchAff_ loop
+
   pure $ Bus cell consumers
 
 -- | Blocks until a new value is pushed to the Bus, returning the value.

test/Main.purs

@@ -18,17 +18,16 @@ module Test.Main where
 
 import Prelude
 
-import Control.Monad.Aff (Aff, attempt, forkAff, joinFiber, launchAff)
+import Control.Monad.Aff (Aff, Milliseconds(..), attempt, delay, forkAff, joinFiber, runAff_)
 import Control.Monad.Aff.AVar (AVAR)
 import Control.Monad.Aff.Bus as Bus
-import Control.Monad.Aff.Console (log)
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Class (liftEff)
-import Control.Monad.Eff.Console (CONSOLE)
-import Control.Monad.Eff.Exception (EXCEPTION, error)
-import Control.Monad.Eff.Ref (REF, newRef, readRef, modifyRef)
+import Control.Monad.Eff.Console (log, CONSOLE)
+import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
+import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
 import Control.Monad.Error.Class (throwError)
-import Data.Either (Either(..))
+import Data.Either (Either(..), either)
 
 type Effects eff =
   ( console ∷ CONSOLE
@@ -37,12 +36,8 @@ type Effects eff =
   | eff
   )
 
-assert ∷ ∀ eff. Boolean → Aff eff Unit
-assert a = unless a (throwError (error "Assertion failed"))
-
-test_readWrite ∷ ∀ eff. Aff (Effects eff) Unit
-test_readWrite = do
-  bus ← Bus.make
+test_readWrite ∷ ∀ eff. Bus.BusRW Int -> Aff (Effects eff) Boolean
+test_readWrite bus = do
   ref ← liftEff $ newRef 0
 
   let
@@ -61,16 +56,38 @@ test_readWrite = do
   Bus.write 1 bus
   Bus.write 2 bus
   Bus.write 3 bus
+
+  -- without delay kill of bus interpats pending interactions with avar
+  -- so we need to wait for some time to be sure that all actions are finished
+  delay $ Milliseconds 10.0
   Bus.kill (error "Done") bus
 
   joinFiber f1
   joinFiber f2
 
   res <- liftEff $ readRef ref
-  assert (res == 212)
-  log "OK"
+  pure $ res == 212
+
 
 main ∷ Eff (Effects (exception ∷ EXCEPTION)) Unit
-main = void $ launchAff do
+main = do
   log "Testing read/write/kill..."
-  test_readWrite
+  runTest $ Bus.make >>= test_readWrite
+  runTest $ (liftEff Bus.make) >>= test_readWrite
+  where
+  runTest t = do
+    isFinishedRef <- newRef false
+    runAff_ (isOk isFinishedRef) t
+    runAff_ (either throwException pure) do
+      delay (Milliseconds 100.0)
+      isFinished <- liftEff $ readRef isFinishedRef
+      unless isFinished $ throwError (error "Timeout")
+    where
+    isOk isFinishedRef = case _ of
+      Left err -> throwException err
+      Right res ->
+        if res
+          then do
+            log "ok"
+            writeRef isFinishedRef true
+          else throwException $ error "failed"