purescript-sync/test/Test.Main.purs

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