122 lines
3.9 KiB
Haskell
122 lines
3.9 KiB
Haskell
module Test.Main where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad.Error.Class (throwError, try)
|
|
import Control.Monad.Rec.Class (Step(..), forever, tailRecM, untilJust)
|
|
import Control.Monad.State.Async (AsyncStateT, asyncModify, asyncPut, asyncRead, asyncWrite, runAsyncState, runMutexState)
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Control.Parallel (parOneOf, parSequence_, parallel, sequential)
|
|
import Data.Array as Array
|
|
import Data.Async.Class (class AsyncState)
|
|
import Data.Async.Mutex (Mutex)
|
|
import Data.Async.RwLock (RwLock)
|
|
import Data.Either (isLeft)
|
|
import Data.Identity (Identity)
|
|
import Data.Maybe (Maybe(..))
|
|
import Data.Newtype (wrap)
|
|
import Data.Traversable (for_)
|
|
import Data.Tuple.Nested ((/\))
|
|
import Effect (Effect)
|
|
import Effect.Aff (Aff, delay, launchAff_)
|
|
import Effect.Aff.Class (liftAff)
|
|
import Effect.Class (liftEffect)
|
|
import Effect.Exception (error)
|
|
import Effect.Random (randomBool)
|
|
import Test.Spec (SpecT, describe, it)
|
|
import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
|
|
import Test.Spec.Reporter (consoleReporter)
|
|
import Test.Spec.Runner (runSpec)
|
|
|
|
common :: forall @w wl rl. AsyncState w wl rl => SpecT Aff Unit Identity Unit
|
|
common = do
|
|
it "does not throw" $ runAsyncState unit (pure @(AsyncStateT w Unit Aff) unit)
|
|
it "supports single-threaded state manipulation" do
|
|
runAsyncState 0 do
|
|
pure @(AsyncStateT w Int Aff) unit
|
|
flip shouldSatisfy isLeft =<< try (asyncRead $ shouldEqual 1)
|
|
asyncPut 1
|
|
asyncRead $ shouldEqual 1
|
|
asyncModify $ \n -> pure $ n + 2
|
|
asyncRead $ shouldEqual 3
|
|
it "supports concurrent state manipulation" do
|
|
let
|
|
t1 = parallel do
|
|
lift $ delay $ wrap 50.0
|
|
asyncModify
|
|
( \s -> do
|
|
delay $ wrap 100.0
|
|
pure $ s <> "john"
|
|
)
|
|
pure unit
|
|
t2 = parallel do
|
|
asyncPut "hello, "
|
|
lift $ delay $ wrap 60.0
|
|
asyncModify (pure <<< (_ <> "!"))
|
|
pure unit
|
|
|
|
runAsyncState "" do
|
|
pure @(AsyncStateT w String Aff) unit
|
|
sequential (pure (\_ _ -> unit) <*> t1 <*> t2)
|
|
asyncRead (shouldEqual "hello, john!")
|
|
it "supports concurrent state manipulation 2" do
|
|
let
|
|
t = do
|
|
_ <- asyncRead pure
|
|
asyncWrite (pure <<< (unit /\ _) <<< (_ <> "a"))
|
|
pure unit
|
|
|
|
runAsyncState "" do
|
|
pure @(AsyncStateT w String Aff) unit
|
|
parSequence_ $ Array.replicate 10 t
|
|
asyncRead (shouldEqual "aaaaaaaaaa")
|
|
it "supports parallel delay in monadrec" do
|
|
let
|
|
done = liftAff $ delay $ wrap 5000.0
|
|
go 0 = pure $ Done unit
|
|
go n = do
|
|
liftAff $ delay $ wrap 2.0
|
|
_ <- asyncRead pure
|
|
_ <- asyncModify pure
|
|
pure $ Loop (n - 1)
|
|
|
|
runAsyncState "" do
|
|
pure @(AsyncStateT w String Aff) unit
|
|
parOneOf
|
|
[ done
|
|
, tailRecM go 100
|
|
, tailRecM go 100
|
|
, tailRecM go 100
|
|
, tailRecM go 100
|
|
]
|
|
it "setting the state to a value unblocks MonadRec" do
|
|
let
|
|
delayThenDone = do
|
|
liftAff $ delay $ wrap 100.0
|
|
asyncPut true
|
|
wait = untilJust do
|
|
done <- asyncRead pure
|
|
pure $ if done then Just unit else Nothing
|
|
runMutexState false $ parSequence_ [ delayThenDone, wait ]
|
|
it "throwing with lock does not block other threads" do
|
|
let
|
|
t = do
|
|
readThrows <- liftEffect randomBool
|
|
writeThrows <- liftEffect randomBool
|
|
void $ try $ asyncRead (const $ if readThrows then throwError $ error "fail" else pure unit)
|
|
void $ try $ asyncModify (\s -> if writeThrows then throwError $ error "fail" else pure s)
|
|
pure unit
|
|
|
|
for_ (Array.replicate 100 unit) \_ -> do
|
|
runAsyncState "" do
|
|
pure @(AsyncStateT w String Aff) unit
|
|
parSequence_ $ Array.replicate 100 t
|
|
|
|
main :: Effect Unit
|
|
main = launchAff_ $ runSpec [ consoleReporter ] do
|
|
describe "AsyncStateT" do
|
|
describe "MutexStateT" do
|
|
common @Mutex
|
|
describe "RwLockStateT" do
|
|
common @RwLock
|