Add tests for cancel in parallel races

Add tests for cancel in parallel races

module Test.Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, runAff, makeAff, launchAff, later, later', forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize)
import Control.Monad.Aff.AVar (AVAR, makeVar, makeVar', putVar, modifyVar, takeVar, peekVar, killVar)
import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log) as Eff
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error, message, try)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parallel, sequential)
import Data.Either (either, fromLeft, fromRight)
import Data.Maybe (Maybe(..))
import Data.Unfoldable (replicate)
import Partial.Unsafe (unsafePartial)

type Test a = forall e. Aff (console :: CONSOLE | e) a
type TestAVar a = forall e. Aff (console :: CONSOLE, avar :: AVAR | e) a

timeout :: Int → TestAVar Unit → TestAVar Unit
timeout ms aff = do
  exn <- makeVar
  clr1 <- forkAff (later' ms (putVar exn (Just "Timed out")))
  clr2 <- forkAff (aff *> putVar exn Nothing)
  res ← takeVar exn
  log (show res)
  case res of
    Nothing -> void (clr1 `cancel` error "Done")
    Just e -> void (clr2 `cancel` error "Done") *> throwError (error e)

replicateArray :: forall a. Int -> a -> Array a
replicateArray = replicate

test_sequencing :: Int -> Test Unit
test_sequencing 0 = log "Done"
test_sequencing n = do
  later' 100 (log (show (n / 10) <> " seconds left"))
  test_sequencing (n - 1)

foreign import synchronousUnexpectedThrowError :: forall e. Eff e Unit

test_makeAff :: Test Unit
test_makeAff = unsafePartial do
  s <- attempt $ makeAff \reject resolve -> resolve "ok"
  log $ "makeAff success is " <> fromRight s

  asyncF <- attempt $ makeAff \reject resolve -> reject (error "ok")
  log $ "makeAff asynchronous failure is " <> message (fromLeft asyncF)

  asyncF' <- attempt $ makeAff \reject resolve -> synchronousUnexpectedThrowError
  log $ "makeAff synchronous failure is " <> message (fromLeft asyncF')

  log "Success: makeAff is ok"

test_pure :: Test Unit
test_pure = do
  pure unit
  pure unit
  pure unit
  log "Success: Got all the way past 4 pures"

test_attempt :: Test Unit
test_attempt = do
  e <- attempt (throwError (error "Oh noes!"))
  either (const $ log "Success: Exception caught") (const $ log "Failure: Exception NOT caught!!!") e

test_apathize :: Test Unit
test_apathize = do
  apathize $ throwError (error "Oh noes!")
  log "Success: Exceptions don't stop the apathetic"

test_putTakeVar :: TestAVar Unit
test_putTakeVar = do
  v <- makeVar
  forkAff (later $ putVar v 1.0)
  a <- takeVar v
  log ("Success: Value " <> show a)

test_peekVar :: TestAVar Unit
test_peekVar = do
  timeout 1000 do
    v <- makeVar
    forkAff (later $ putVar v 1.0)
    a1 <- peekVar v
    a2 <- takeVar v
    when (a1 /= a2) do
      throwError (error "Something horrible went wrong - peeked var is not equal to taken var")
    log ("Success: Peeked value not consumed")

  timeout 1000 do
    w <- makeVar
    putVar w true
    b <- peekVar w
    when (not b) do
      throwError (error "Something horrible went wrong - peeked var is not true")
    log ("Success: Peeked value read from written var")

  timeout 1000 do
    x <- makeVar
    res <- makeVar' 1
    forkAff do
      c <- peekVar x
      putVar x 1000
      d <- peekVar x
      modifyVar (_ + (c + d)) res
    putVar x 10
    count <- takeVar res
    e <- takeVar x
    f <- takeVar x
    when (not (count == 21 && e == 10 && f == 1000)) do
      throwError (error "Something horrible went wrong - peeked consumers/producer ordering")
    log "Success: peekVar consumer/producer order maintained"

test_killFirstForked :: Test Unit
test_killFirstForked = do
  c <- forkAff (later' 100 $ pure "Failure: This should have been killed!")
  b <- c `cancel` (error "Just die")
  log (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked")

test_killVar :: TestAVar Unit
test_killVar = do
  v <- makeVar
  killVar v (error "DOA")
  e <- attempt $ takeVar v
  either (const $ log "Success: Killed queue dead") (const $ log "Failure: Oh noes, queue survived!") e

test_finally :: TestAVar Unit
test_finally = do
  v <- makeVar
  finally
    (putVar v 0)
    (putVar v 2)
  apathize $ finally
    (throwError (error "poof!") *> putVar v 666) -- this putVar should not get executed
    (putVar v 40)
  n1 <- takeVar v
  n2 <- takeVar v
  n3 <- takeVar v
  log $ if n1 + n2 + n3 == 42 then "Success: effects amount to 42."
                                else "Failure: Expected 42."

test_parRace :: TestAVar Unit
test_parRace = do
  s <- sequential (parallel (later' 100 $ pure "Success: Early bird got the worm") <|>
               parallel (later' 200 $ pure "Failure: Late bird got the worm"))
  log s

test_parError :: TestAVar Unit
test_parError = do
  e <- attempt $ sequential (parallel (throwError (error ("Oh noes!"))) *> pure unit)
  either (const $ log "Success: Exception propagated") (const $ log "Failure: Exception missing") e

test_parRaceKill1 :: TestAVar Unit
test_parRaceKill1 = do
  s <- sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
               parallel (later' 200 $ pure "Success: Early error was ignored in favor of late success"))
  log s

test_parRaceKill2 :: TestAVar Unit
test_parRaceKill2 = do
  e <- attempt $ sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
                         parallel (later' 200 $ throwError (error ("Oh noes!"))))
  either (const $ log "Success: Killing both kills it dead") (const $ log "Failure: It's alive!!!") e

test_semigroupCanceler :: Test Unit
test_semigroupCanceler =
  let
    c = Canceler (const (pure true)) <> Canceler (const (pure true))
  in do
    v <- cancel c (error "CANCEL")
    log (if v then "Success: Canceled semigroup composite canceler"
                     else "Failure: Could not cancel semigroup composite canceler")

test_cancelLater :: TestAVar Unit
test_cancelLater = do
  c <- forkAff $ (do pure "Binding"
                     _ <- later' 100 $ log ("Failure: Later was not canceled!")
                     pure "Binding")
  v <- cancel c (error "Cause")
  log (if v then "Success: Canceled later" else "Failure: Did not cancel later")

test_cancelLaunchLater :: forall e. Eff (console :: CONSOLE, err :: EXCEPTION | e) Unit
test_cancelLaunchLater = do
  c <- launchAff $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ launchAff $ (do v <- cancel c (error "Cause")
                         log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelRunLater :: forall e. Eff (console :: CONSOLE | e) Unit
test_cancelRunLater = do
  c <- runAff (const (pure unit)) (const (pure unit)) $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ try $ launchAff $ (do v <- cancel c (error "Cause")
                               log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelParallel :: TestAVar Unit
test_cancelParallel = do
  c  <- forkAff <<< sequential $ parallel (later' 100 $ log "Failure: #1 should not get through") <|>
                             parallel (later' 100 $ log "Failure: #2 should not get through")
  v  <- c `cancel` (error "Must cancel")
  log (if v then "Success: Canceling composite of two Parallel succeeded"
                   else "Failure: Canceling composite of two Parallel failed")

test_cancelRaceLeft :: TestAVar Unit
test_cancelRaceLeft = do
  var <- makeVar
  c  <- sequential
    $ parallel (later' 250 $ putVar var true)
    <|> parallel (later' 100 $ pure unit)
  later' 500 $ putVar var false
  l <- takeVar var
  when l $ throwError (error "Failure: left side ran even though it lost the race")

test_cancelRaceRight :: TestAVar Unit
test_cancelRaceRight = do
  var <- makeVar
  c  <- sequential
    $ parallel (later' 100 $ pure unit)
    <|> parallel (later' 250 $ putVar var true)
  later' 500 $ putVar var false
  l <- takeVar var
  when l $ throwError (error "Failure: right side ran even though it lost the race")

test_syncTailRecM :: TestAVar Unit
test_syncTailRecM = do
  v <- makeVar' false
  _ <- forkAff $ tailRecM go { n: 1000000, v }
  b <- takeVar v
  log (if b then "Success: Synchronous tailRecM resolved synchronously"
            else "Failure: Synchronous tailRecM resolved asynchronously")
  where
  go { n: 0, v } = do
    modifyVar (const true) v
    pure (Done 0)
  go { n, v } = pure (Loop { n: n - 1, v })

loopAndBounce :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
loopAndBounce n = do
  res <- tailRecM go n
  log $ "Done: " <> show res
  where
  go 0 = pure (Done 0)
  go k | mod k 30000 == 0 = do
    later' 10 (pure unit)
    pure (Loop (k - 1))
  go k = pure (Loop (k - 1))

all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
all n = do
  var <- makeVar' 0
  forkAll $ replicateArray n (modifyVar (_ + 1) var)
  count <- takeVar var
  log ("Forked " <> show count)

cancelAll :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
cancelAll n = do
  canceler <- forkAll $ replicateArray n (later' 100000 (log "oops"))
  canceled <- cancel canceler (error "bye")
  log ("Cancelled all: " <> show canceled)

delay :: forall eff. Int -> Aff eff Unit
delay n = later' n (pure unit)

main :: Eff (console :: CONSOLE, avar :: AVAR, err :: EXCEPTION) Unit
main = do
  Eff.log "Testing kill of later launched in separate Aff"
  test_cancelLaunchLater

  Eff.log "Testing kill of later run in separate Aff"
  test_cancelRunLater

  void $ runAff throwException (const (pure unit)) $ do
    log "Testing sequencing"
    test_sequencing 3

    log "Testing pure"
    test_pure

    log "Testing makeAff"
    test_makeAff

    log "Testing attempt"
    test_attempt

    log "Testing later"
    later $ log "Success: It happened later"

    log "Testing kill of later"
    test_cancelLater

    log "Testing kill of first forked"
    test_killFirstForked

    log "Testing apathize"
    test_apathize

    log "Testing semigroup canceler"
    test_semigroupCanceler

    log "Testing AVar - putVar, takeVar"
    test_putTakeVar

    log "Testing AVar - peekVar"
    test_peekVar

    log "Testing AVar killVar"
    test_killVar

    log "Testing finally"
    test_finally

    log "Test Parallel (*>)"
    test_parError

    log "Testing Parallel (<|>)"
    test_parRace

    log "Testing Parallel (<|>) - kill one"
    test_parRaceKill1

    log "Testing Parallel (<|>) - kill two"
    test_parRaceKill2

    log "Testing cancel of Parallel (<|>)"
    test_cancelParallel

    log "Testing cancel of left branch in parallel (<|>)"
    test_cancelRaceLeft

    log "Testing cancel of right branch in parallel (<|>)"
    test_cancelRaceRight

    log "Testing synchronous tailRecM"
    test_syncTailRecM

    log "pre-delay"
    delay 1000
    log "post-delay"

    loopAndBounce 1000000

    all 100000

    cancelAll 100000

    log "Done testing"

module Test.Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, runAff, makeAff, launchAff, later, later', forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize)
import Control.Monad.Aff.AVar (AVAR, makeVar, makeVar', putVar, modifyVar, takeVar, peekVar, killVar)
import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log) as Eff
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error, message, try)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parallel, sequential)
import Data.Either (either, fromLeft, fromRight)
import Data.Maybe (Maybe(..))
import Data.Unfoldable (replicate)
import Partial.Unsafe (unsafePartial)

type Test a = forall e. Aff (console :: CONSOLE | e) a
type TestAVar a = forall e. Aff (console :: CONSOLE, avar :: AVAR | e) a

timeout :: Int → TestAVar Unit → TestAVar Unit
timeout ms aff = do
  exn <- makeVar
  clr1 <- forkAff (later' ms (putVar exn (Just "Timed out")))
  clr2 <- forkAff (aff *> putVar exn Nothing)
  res ← takeVar exn
  log (show res)
  case res of
    Nothing -> void (clr1 `cancel` error "Done")
    Just e -> void (clr2 `cancel` error "Done") *> throwError (error e)

replicateArray :: forall a. Int -> a -> Array a
replicateArray = replicate

test_sequencing :: Int -> Test Unit
test_sequencing 0 = log "Done"
test_sequencing n = do
  later' 100 (log (show (n / 10) <> " seconds left"))
  test_sequencing (n - 1)

foreign import synchronousUnexpectedThrowError :: forall e. Eff e Unit

test_makeAff :: Test Unit
test_makeAff = unsafePartial do
  s <- attempt $ makeAff \reject resolve -> resolve "ok"
  log $ "makeAff success is " <> fromRight s

  asyncF <- attempt $ makeAff \reject resolve -> reject (error "ok")
  log $ "makeAff asynchronous failure is " <> message (fromLeft asyncF)

  asyncF' <- attempt $ makeAff \reject resolve -> synchronousUnexpectedThrowError
  log $ "makeAff synchronous failure is " <> message (fromLeft asyncF')

  log "Success: makeAff is ok"

test_pure :: Test Unit
test_pure = do
  pure unit
  pure unit
  pure unit
  log "Success: Got all the way past 4 pures"

test_attempt :: Test Unit
test_attempt = do
  e <- attempt (throwError (error "Oh noes!"))
  either (const $ log "Success: Exception caught") (const $ log "Failure: Exception NOT caught!!!") e

test_apathize :: Test Unit
test_apathize = do
  apathize $ throwError (error "Oh noes!")
  log "Success: Exceptions don't stop the apathetic"

test_putTakeVar :: TestAVar Unit
test_putTakeVar = do
  v <- makeVar
  forkAff (later $ putVar v 1.0)
  a <- takeVar v
  log ("Success: Value " <> show a)

test_peekVar :: TestAVar Unit
test_peekVar = do
  timeout 1000 do
    v <- makeVar
    forkAff (later $ putVar v 1.0)
    a1 <- peekVar v
    a2 <- takeVar v
    when (a1 /= a2) do
      throwError (error "Something horrible went wrong - peeked var is not equal to taken var")
    log ("Success: Peeked value not consumed")

  timeout 1000 do
    w <- makeVar
    putVar w true
    b <- peekVar w
    when (not b) do
      throwError (error "Something horrible went wrong - peeked var is not true")
    log ("Success: Peeked value read from written var")

  timeout 1000 do
    x <- makeVar
    res <- makeVar' 1
    forkAff do
      c <- peekVar x
      putVar x 1000
      d <- peekVar x
      modifyVar (_ + (c + d)) res
    putVar x 10
    count <- takeVar res
    e <- takeVar x
    f <- takeVar x
    when (not (count == 21 && e == 10 && f == 1000)) do
      throwError (error "Something horrible went wrong - peeked consumers/producer ordering")
    log "Success: peekVar consumer/producer order maintained"

test_killFirstForked :: Test Unit
test_killFirstForked = do
  c <- forkAff (later' 100 $ pure "Failure: This should have been killed!")
  b <- c `cancel` (error "Just die")
  log (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked")

test_killVar :: TestAVar Unit
test_killVar = do
  v <- makeVar
  killVar v (error "DOA")
  e <- attempt $ takeVar v
  either (const $ log "Success: Killed queue dead") (const $ log "Failure: Oh noes, queue survived!") e

test_finally :: TestAVar Unit
test_finally = do
  v <- makeVar
  finally
    (putVar v 0)
    (putVar v 2)
  apathize $ finally
    (throwError (error "poof!") *> putVar v 666) -- this putVar should not get executed
    (putVar v 40)
  n1 <- takeVar v
  n2 <- takeVar v
  n3 <- takeVar v
  log $ if n1 + n2 + n3 == 42 then "Success: effects amount to 42."
                                else "Failure: Expected 42."

test_parRace :: TestAVar Unit
test_parRace = do
  s <- sequential (parallel (later' 100 $ pure "Success: Early bird got the worm") <|>
               parallel (later' 200 $ pure "Failure: Late bird got the worm"))
  log s

test_parError :: TestAVar Unit
test_parError = do
  e <- attempt $ sequential (parallel (throwError (error ("Oh noes!"))) *> pure unit)
  either (const $ log "Success: Exception propagated") (const $ log "Failure: Exception missing") e

test_parRaceKill1 :: TestAVar Unit
test_parRaceKill1 = do
  s <- sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
               parallel (later' 200 $ pure "Success: Early error was ignored in favor of late success"))
  log s

test_parRaceKill2 :: TestAVar Unit
test_parRaceKill2 = do
  e <- attempt $ sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
                         parallel (later' 200 $ throwError (error ("Oh noes!"))))
  either (const $ log "Success: Killing both kills it dead") (const $ log "Failure: It's alive!!!") e

test_semigroupCanceler :: Test Unit
test_semigroupCanceler =
  let
    c = Canceler (const (pure true)) <> Canceler (const (pure true))
  in do
    v <- cancel c (error "CANCEL")
    log (if v then "Success: Canceled semigroup composite canceler"
                     else "Failure: Could not cancel semigroup composite canceler")

test_cancelLater :: TestAVar Unit
test_cancelLater = do
  c <- forkAff $ (do pure "Binding"
                     _ <- later' 100 $ log ("Failure: Later was not canceled!")
                     pure "Binding")
  v <- cancel c (error "Cause")
  log (if v then "Success: Canceled later" else "Failure: Did not cancel later")

test_cancelLaunchLater :: forall e. Eff (console :: CONSOLE, err :: EXCEPTION | e) Unit
test_cancelLaunchLater = do
  c <- launchAff $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ launchAff $ (do v <- cancel c (error "Cause")
                         log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelRunLater :: forall e. Eff (console :: CONSOLE | e) Unit
test_cancelRunLater = do
  c <- runAff (const (pure unit)) (const (pure unit)) $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ try $ launchAff $ (do v <- cancel c (error "Cause")
                               log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelParallel :: TestAVar Unit
test_cancelParallel = do
  c  <- forkAff <<< sequential $ parallel (later' 100 $ log "Failure: #1 should not get through") <|>
                             parallel (later' 100 $ log "Failure: #2 should not get through")
  v  <- c `cancel` (error "Must cancel")
  log (if v then "Success: Canceling composite of two Parallel succeeded"
                   else "Failure: Canceling composite of two Parallel failed")

test_syncTailRecM :: TestAVar Unit
test_syncTailRecM = do
  v <- makeVar' false
  _ <- forkAff $ tailRecM go { n: 1000000, v }
  b <- takeVar v
  log (if b then "Success: Synchronous tailRecM resolved synchronously"
            else "Failure: Synchronous tailRecM resolved asynchronously")
  where
  go { n: 0, v } = do
    modifyVar (const true) v
    pure (Done 0)
  go { n, v } = pure (Loop { n: n - 1, v })

loopAndBounce :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
loopAndBounce n = do
  res <- tailRecM go n
  log $ "Done: " <> show res
  where
  go 0 = pure (Done 0)
  go k | mod k 30000 == 0 = do
    later' 10 (pure unit)
    pure (Loop (k - 1))
  go k = pure (Loop (k - 1))

all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
all n = do
  var <- makeVar' 0
  forkAll $ replicateArray n (modifyVar (_ + 1) var)
  count <- takeVar var
  log ("Forked " <> show count)

cancelAll :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
cancelAll n = do
  canceler <- forkAll $ replicateArray n (later' 100000 (log "oops"))
  canceled <- cancel canceler (error "bye")
  log ("Cancelled all: " <> show canceled)

delay :: forall eff. Int -> Aff eff Unit
delay n = later' n (pure unit)

main :: Eff (console :: CONSOLE, avar :: AVAR, err :: EXCEPTION) Unit
main = do
  Eff.log "Testing kill of later launched in separate Aff"
  test_cancelLaunchLater

  Eff.log "Testing kill of later run in separate Aff"
  test_cancelRunLater

  void $ runAff throwException (const (pure unit)) $ do
    log "Testing sequencing"
    test_sequencing 3

    log "Testing pure"
    test_pure

    log "Testing makeAff"
    test_makeAff

    log "Testing attempt"
    test_attempt

    log "Testing later"
    later $ log "Success: It happened later"

    log "Testing kill of later"
    test_cancelLater

    log "Testing kill of first forked"
    test_killFirstForked

    log "Testing apathize"
    test_apathize

    log "Testing semigroup canceler"
    test_semigroupCanceler

    log "Testing AVar - putVar, takeVar"
    test_putTakeVar

    log "Testing AVar - peekVar"
    test_peekVar

    log "Testing AVar killVar"
    test_killVar

    log "Testing finally"
    test_finally

    log "Test Parallel (*>)"
    test_parError

    log "Testing Parallel (<|>)"
    test_parRace

    log "Testing Parallel (<|>) - kill one"
    test_parRaceKill1

    log "Testing Parallel (<|>) - kill two"
    test_parRaceKill2

    log "Testing cancel of Parallel (<|>)"
    test_cancelParallel

    log "Testing synchronous tailRecM"
    test_syncTailRecM

    log "pre-delay"
    delay 1000
    log "post-delay"

    loopAndBounce 1000000

    all 100000

    cancelAll 100000

    log "Done testing"


Delay based on type of turn

Delay based on type of turn

-- / Game round
module App.Round where

import App.Animation as Animation
import App.Board as Board
import App.Hand as Hand
import App.Turn as Turn
import App.View as View
import App.View (class HasBoard, ViewConfig(..), getBoard, getBoardViewConfig)
import Control.Monad.Aff (later')
import Data.Either (Either(..))
import Data.List (length)
import Data.Maybe (Maybe(..))
import Prelude (bind, pure, show, unit, ($), (<>), (>))
import Pux (EffModel, noEffects)
import Pux.Html (Html, div, text)

type HandA = Animation.State Turn.Turn' Hand.State

type Error = String

data State
  = Sowing HandA
  | Awaiting (Maybe Error) Board.Player Board.State

data Action
  = AnimateTurn
  | PlayerSelect Board.PitRef

instance hasBoardRound :: HasBoard State where
  getBoard (Sowing handA) =
    getBoard handA.current
  getBoard (Awaiting _ _ board) =
    board

  getBoardViewConfig (Sowing handA) =
    getBoardViewConfig handA.current
  getBoardViewConfig (Awaiting _ player board) =
    ViewConfig
      { focusPit: Nothing
      , focusPlayer: Just player
      }

init :: Board.Player -> Board.State -> State
init player = Awaiting Nothing player

initSow :: Board.Player -> Board.PitRef -> Board.State -> Either Error State
initSow player pitRef board = do
  _ <- verifyPlayer
  _ <- verifyPit
  pure $ initSow' player pitRef board
    where verifyPlayer = if Board.belongsTo pitRef player
                            then Right unit
                            else Left "Cannot play opponent's pit"
          verifyPit = if Board.lookup pitRef board > 0
                        then Right unit
                        else Left "Cannot play from empty pit"

initSow' :: Board.Player -> Board.PitRef -> Board.State -> State
initSow' player pitRef board = Sowing $ Animation.init hand rest
  where hand = Hand.init player pitRef board
        rest = Turn.unfoldTurns hand

update :: forall eff. Action -> State -> EffModel State Action (eff)
update AnimateTurn (Sowing handA) =
  case Animation.step handA of
    Nothing -> -- End of turn.
      -- TODO: sould we end the round itself?
      let opponent = Hand.opponent handA.current
      in noEffects $ Awaiting Nothing opponent $ getBoard handA.current
    Just handA' ->
      animateSow $ Sowing handA'
update (PlayerSelect pitRef) (Awaiting _ player board) =
  case initSow player pitRef board of
    Right state ->
      animateSow state
    Left error ->
      noEffects $ Awaiting (Just error) player board
update _ state =
  -- TODO: make this state transition impossible.
  noEffects state

animateSow :: forall eff. State -> EffModel State Action (eff)
animateSow state = { state: state
                   , effects: [ later' delay $ pure AnimateTurn ] }
                      where delay = animateDelay state

animateDelay :: State -> Int
animateDelay (Sowing handA) =
  case handA.lastTransition of
    Just (Turn.Capture _) -> 1000
    Just (Turn.Lift _) -> 500
    Just (Turn.Sow _) -> 120
    _ -> 80
animateDelay _ =
  100

view :: State -> Html Action
view state =
  div []
    [ heading state
    , errorDiv state
    , View.viewBoard PlayerSelect state
    , hand state
    , lastTransition state
    ]
    where errorDiv (Awaiting (Just error) _ _) =
            div [] [ text $ "ERROR: " <> error ]
          errorDiv _ =
            div [] []
          heading (Sowing handA) =
            div [] [ text $ "Sowing - " <> show (length handA.rest) <> " turns left"]
          heading (Awaiting _ player _) =
            div [] [ text $ "Awaiting turn by " <> show player ]
          hand (Sowing handA) =
            Hand.view handA.current
          hand (Awaiting _ _ _) =
            div [] [ text "No hand" ]
          lastTransition (Sowing handA) =
            case handA.lastTransition of
              Just t -> div [] [ text $ "Last transition: " <> show t ]
              Nothing -> div [] [ text "No last transition" ]
          lastTransition _ =
            div [] [ text "" ]

-- / Game round
module App.Round where

import App.Animation as Animation
import App.Board as Board
import App.Hand as Hand
import App.Turn as Turn
import App.View as View
import App.View (class HasBoard, ViewConfig(..), getBoard, getBoardViewConfig)
import Control.Monad.Aff (later')
import Data.Either (Either(..))
import Data.List (length)
import Data.Maybe (Maybe(..))
import Prelude (($), (<>), (<$>), (==), (>), pure, bind, unit, show)
import Pux (EffModel, noEffects)
import Pux.Html (Html, div, hr, text, (#), (!))

type HandA = Animation.State Turn.Turn' Hand.State

type Error = String

data State
  = Sowing HandA
  | Awaiting (Maybe Error) Board.Player Board.State

data Action
  = AnimateTurn
  | PlayerSelect Board.PitRef

instance hasBoardRound :: HasBoard State where
  getBoard (Sowing handA) =
    getBoard handA.current
  getBoard (Awaiting _ _ board) =
    board

  getBoardViewConfig (Sowing handA) =
    getBoardViewConfig handA.current
  getBoardViewConfig (Awaiting _ player board) =
    ViewConfig
      { focusPit: Nothing
      , focusPlayer: Just player
      }

init :: Board.Player -> Board.State -> State
init player = Awaiting Nothing player

initSow :: Board.Player -> Board.PitRef -> Board.State -> Either Error State
initSow player pitRef board = do
  _ <- verifyPlayer
  _ <- verifyPit
  pure $ initSow' player pitRef board
    where verifyPlayer = if Board.belongsTo pitRef player
                            then Right unit
                            else Left "Cannot play opponent's pit"
          verifyPit = if Board.lookup pitRef board > 0
                        then Right unit
                        else Left "Cannot play from empty pit"

initSow' :: Board.Player -> Board.PitRef -> Board.State -> State
initSow' player pitRef board = Sowing $ Animation.init hand rest
  where hand = Hand.init player pitRef board
        rest = Turn.unfoldTurns hand

update :: forall eff. Action -> State -> EffModel State Action (eff)
update AnimateTurn (Sowing handA) =
  case Animation.step handA of
    Nothing -> -- End of turn.
      -- TODO: sould we end the round itself?
      let opponent = Hand.opponent handA.current
      in noEffects $ Awaiting Nothing opponent $ getBoard handA.current
    Just handA' ->
      animateSow $ Sowing handA'
update (PlayerSelect pitRef) (Awaiting _ player board) =
  case initSow player pitRef board of
    Right state ->
      animateSow state
    Left error ->
      noEffects $ Awaiting (Just error) player board
update _ state =
  -- TODO: make this state transition impossible.
  noEffects state

animateSow :: forall eff. State -> EffModel State Action (eff)
animateSow state = { state: state
                   , effects: [ later' 100 $ pure AnimateTurn ] }

view :: State -> Html Action
view state =
  div []
    [ heading state
    , errorDiv state
    , View.viewBoard PlayerSelect state
    , hand state
    , lastTransition state
    ]
    where errorDiv (Awaiting (Just error) _ _) =
            div [] [ text $ "ERROR: " <> error ]
          errorDiv _ =
            div [] []
          heading (Sowing handA) =
            div [] [ text $ "Sowing - " <> show (length handA.rest) <> " turns left"]
          heading (Awaiting _ player _) =
            div [] [ text $ "Awaiting turn by " <> show player ]
          hand (Sowing handA) =
            Hand.view handA.current
          hand (Awaiting _ _ _) =
            div [] [ text "No hand" ]
          lastTransition (Sowing handA) =
            case handA.lastTransition of
              Just t -> div [] [ text $ "Last transition: " <> show t ]
              Nothing -> div [] [ text "No last transition" ]
          lastTransition _ =
            div [] [ text "" ]


fixed issue with multi line functions not working

module Main where

import Prelude

import Notebook.Types (Notebook)
import App.Types
import App.State as App
import App.View as App
import BackendConnection.Types as BackendConnection
import BackendConnection.State as BackendConnection
import Cells.Types as Cells
import Cells.State as Cells
import Cells.View as Cells
import Console.Types as Console
import Console.State as Console
import Columns.Types as Columns
import Columns.State as Columns
import Notebook.Types

import WebSocket (URL(..))
import DOM
import Signal
import Control.Monad.Eff (Eff)
import Global.Effects (GlobalEffects)
import Pux (CoreEffects, renderToDOM, fromSimple, start)
import Signal.Channel (subscribe, channel, CHANNEL, Channel)

main :: Eff (CoreEffects GlobalEffects) Unit
main = do
    cellsChannel <- channel Cells.NoOp
    backendConnectionChannel <- channel (BackendConnection.NoOp :: BackendConnection.Action Notebook)
    consoleChannel <- channel Console.NoOp
    backendConnectionState <- BackendConnection.initialState backendConnectionChannel (URL "ws://127.0.0.1:3000")

    let cellsState             = Cells.initialState cellsChannel
        consoleState           = Console.initialState consoleChannel
        inputSignals =
            [ consoleChannel `liftAction` buildAndSend
            , backendConnectionChannel `liftAction` updateStateAfterReceiving
            , cellsChannel `liftAction` CellsAction
            ]

    app <- start
        { initialState : App.initialState cellsState {} backendConnectionState consoleState
        , update : App.update
        , view : App.view
        , inputs : inputSignals
        }
    renderToDOM "#app" app.html

buildAndSend :: Console.Action -> Action
buildAndSend Console.PackAndSendToBackend = BuildAndSend
buildAndSend _ = NoOp

updateStateAfterReceiving :: BackendConnection.Action Notebook -> Action
updateStateAfterReceiving (BackendConnection.Receive n) = case n of
  Notebook { loaded : true } -> UpdateState n
  Notebook { title : t, subtitle : st, date : d, author : a, cells: c, console: cl, filepath : fp, loaded : false } -> LoadNotebook $ Notebook { title : t, subtitle : st, date : d, author : a, cells: c, console: cl, filepath : fp, loaded : true }
updateStateAfterReceiving _ = NoOp

liftAction :: forall subaction action . Channel subaction -> (subaction -> action) -> Signal action
liftAction chan act = map act $ subscribe chan

module Main where

import Prelude

import Notebook.Types (Notebook)
import App.Types
import App.State as App
import App.View as App
import BackendConnection.Types as BackendConnection
import BackendConnection.State as BackendConnection
import Cells.Types as Cells
import Cells.State as Cells
import Cells.View as Cells
import Console.Types as Console
import Console.State as Console
import Columns.Types as Columns
import Columns.State as Columns
import Notebook.Types

import WebSocket (URL(..))
import DOM
import Signal
import Control.Monad.Eff (Eff)
import Global.Effects (GlobalEffects)
import Pux (CoreEffects, renderToDOM, fromSimple, start)
import Signal.Channel (subscribe, channel, CHANNEL, Channel)

main :: Eff (CoreEffects GlobalEffects) Unit
main = do
    cellsChannel <- channel Cells.NoOp
    backendConnectionChannel <- channel (BackendConnection.NoOp :: BackendConnection.Action Notebook)
    consoleChannel <- channel Console.NoOp
    backendConnectionState <- BackendConnection.initialState backendConnectionChannel (URL "ws://127.0.0.1:3000")

    let cellsState             = Cells.initialState cellsChannel
        consoleState           = Console.initialState consoleChannel
        inputSignals =
            [ consoleChannel `liftAction` buildAndSend
            , backendConnectionChannel `liftAction` updateStateAfterReceiving
            , cellsChannel `liftAction` CellsAction
            ]

    app <- start
        { initialState : App.initialState cellsState {} backendConnectionState consoleState
        , update : App.update
        , view : App.view
        , inputs : inputSignals
        }
    renderToDOM "#app" app.html

buildAndSend :: Console.Action -> Action
buildAndSend Console.PackAndSendToBackend = BuildAndSend
buildAndSend _ = NoOp

updateStateAfterReceiving :: BackendConnection.Action Notebook -> Action
updateStateAfterReceiving (BackendConnection.Receive n) = case n of
  Notebook { title : t, subtitle : st, date : d, author : a, cells: c, console: cl, filepath : fp, loaded : true } -> UpdateState $ Notebook { title : t, subtitle : st, date : d, author : a, cells: c, console: cl, filepath : fp, loaded : true }
  Notebook { title : t, subtitle : st, date : d, author : a, cells: c, console: cl, filepath : fp, loaded : false } -> LoadNotebook $ Notebook { title : t, subtitle : st, date : d, author : a, cells: c, console: cl, filepath : fp, loaded : true }
updateStateAfterReceiving _ = NoOp

liftAction :: forall subaction action . Channel subaction -> (subaction -> action) -> Signal action
liftAction chan act = map act $ subscribe chan


added tests for container & middleware

added tests for container & middleware

module Test.Main where

import Prelude                     (..)
import Test.QuickCheck             (..)
import Unsafe.Coerce               (unsafeCoerce)
import Control.Monad.Eff           (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console   (..)
import Control.Monad.Eff.Random    (RANDOM)
import Control.Monad.Eff.Redux     (..)
import Debug.Trace                 (..)

-- | A simple reducer reacting to two actions: INCREMENT, DECREMENT
counter ::  forall a. Int -> { "type" :: String | a } -> Int
counter = \v t -> case t.type of
                        "INCREMENT" -> v + 1
                        "DECREMENT" -> v - 1
                        _ -> v

-- | This is a middleware for logging
-- | It receives a subset of the Store API (getState & dispatch) and processes `actions`
simpleLogger :: forall a e. Store ->
                            (Next) ->
                            { "type" :: String, "payload" :: String | a } ->
                            Eff (
                              reduxM :: ReduxM,
                              console :: CONSOLE
                              | e
                              )
                            { "type" :: String, "payload" :: String | a }
simpleLogger = \store next action -> do
                                     traceA $ "Middleware (Logger) :: Action: " ++
                                            action.type ++ ", payload: " ++
                                            action.payload
                                     (next action)

-- | A simple listener for displaying current state
numericListener :: forall e. Store -> Eff (reduxM :: ReduxM, console :: CONSOLE | e) Unit
numericListener = \store -> do
                     currentState <- (getState store)
                     traceA $ "STATE: " ++ (unsafeCoerce currentState)

-- | Wrapper for testing the 'counter'-reducer
testReducer :: forall a. Int -> { "type" :: String | a } -> Boolean
testReducer v a = (counter v a) /= v

-- | Test middleware by sending actions which lead to state chages
testMiddleware :: forall e. Int ->
                            Store ->
                            Eff(
                                reduxM  :: ReduxM
                              , console :: CONSOLE
                              | e) Unit
testMiddleware v store = do
                        actInc <- (dispatch { "type" : "INCREMENT", payload: v} store)
                        currentState <- (getState store)
                        traceA $ "STATE: " ++ currentState
                        actDec <- (dispatch { "type" : "DECREMENT", payload: v} store)
                        currentState2 <- (getState store)
                        traceA $ "STATE: " ++  currentState2
                        pure unit

main :: forall e.
            Eff
              (
                console :: CONSOLE
              , random  :: RANDOM
              , err     :: EXCEPTION
              , reduxM  :: ReduxM
              | e
              )
              Unit
main = do
      -- | Preparation
      let middlewares = [ simpleLogger ]
      let increment = { "type" : "INCREMENT" }
      let decrement = { "type" : "DECREMENT" }

      -- | Try to init a new container with middleware
      store <- (applyMiddleware middlewares counter 1)

      -- | Test reducer
      quickCheck \n -> (testReducer n increment) === true
      quickCheck \n -> (testReducer n decrement) === true

      -- | Test middleware
      (testMiddleware 1 store)

module Test.Main where

import Prelude                     (Unit, bind, (/=), (-), (+))
import Test.QuickCheck             ((===), quickCheck)
import Control.Monad.Eff           (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console   (CONSOLE)
import Control.Monad.Eff.Random    (RANDOM)
import Control.Monad.Eff.Redux     (ReduxM, Action)

-- | A simple reducer reacting to two actions: INCREMENT, DECREMENT
counter ::  forall a. Int -> { "type" :: String | a } -> Int
counter = \v t -> case t.type of
                        "INCREMENT" -> v + 1
                        "DECREMENT" -> v - 1
                        _ -> v

testReducer :: forall a. Int -> { "type" :: String | a } -> Boolean
testReducer v a = (counter v a) /= v

main :: forall e.
            Eff
              (
                console :: CONSOLE
              , random  :: RANDOM
              , err     :: EXCEPTION
              , reduxM  :: ReduxM
              | e
              )
              Unit
main = do
      let increment = { "type" : "INCREMENT" }
      let decrement = { "type" : "DECREMENT" }

      quickCheck \n -> (testReducer n increment) === true
      quickCheck \n -> (testReducer n decrement) === true


Indentation

Indentation

module Hyper.Node.Cookie
       (cookies
       ) where

import Prelude
import Data.NonEmpty as NonEmpty
import Data.StrMap as StrMap
import Hyper.Cookie as Cookie
import Control.IxMonad ((:>>=))
import Control.Monad.Error.Class (throwError)
import Data.Array (filter, foldMap, uncons, (:))
import Data.Either (Either)
import Data.Maybe (Maybe(..), maybe)
import Data.NonEmpty (NonEmpty(NonEmpty), (:|))
import Data.StrMap (StrMap)
import Data.String (Pattern(..), joinWith, split, trim)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..))
import Global (decodeURIComponent)
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware)
import Hyper.Middleware.Class (getConn, putConn)

toPair :: Array String -> Either String (Tuple String (Array String))
toPair kv =
  case kv of
    [key, value] ->
      pure (Tuple (decodeURIComponent key) [decodeURIComponent value])
    parts ->
      throwError ("Invalid cookie-pair: " <> joinWith " " parts)

splitPairs :: String → Either String (Array (Tuple String (Array String)))
splitPairs =
  split (Pattern ";")
  >>> map trim
  >>> filter ((/=) "")
  >>> map (split (Pattern "="))
  >>> map toPair
  >>> sequence

parseCookies :: String -> Either String (StrMap Cookie.Values)
parseCookies s =
  splitPairs s
  # map (foldMap toCookieMap)
  # map (StrMap.fromFoldableWith combineCookies)
  where
    toCookieMap (Tuple name values) =
      case uncons values of
        Just { head, tail } -> [Tuple name (NonEmpty head tail)]
        Nothing -> []

    combineCookies xs xs' =
      NonEmpty.head xs :| NonEmpty.head xs' : NonEmpty.tail xs <> NonEmpty.tail xs'

cookies
  :: forall m req res c.
     Monad m =>
     Middleware
     m
     (Conn { headers :: StrMap String | req } res { cookies :: Unit | c})
     (Conn { headers :: StrMap String | req } res { cookies :: Either String (StrMap Cookie.Values) | c})
     Unit
cookies =
  getConn :>>= \conn ->
  let cookies' = maybe (pure StrMap.empty) parseCookies (StrMap.lookup "cookie" conn.request.headers)
  in putConn conn { components { cookies = cookies' }}


Export apathize

Export apathize

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Use SlamEngine's "out" field

Use SlamEngine's "out" field

This allows us to run queries like:

    SELECT * FROM "cities"

And actually get results back.

Fixes #114

module Controller.Notebook.Cell.JTableContent
  ( goPage
  , stepPage
  , inputPage
  , inputPageSize
  , loadPage
  , changePageSize
  , runJTable
  , queryToJTable
  ) where

import Api.Fs (delete)
import Api.Query (port, query, sample, count)
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message)
import Control.Plus (empty)
import Controller.Notebook.Common (I(), run, update, finish)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (Json(), JObject(), fromArray)
import Data.Argonaut.Decode (decodeJson)
import Data.Array (head)
import Data.Bifunctor (lmap)
import Data.Date (now)
import Data.Either (Either(..), either)
import Data.Foreign.Class (readJSON)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.These (These(..), these, theseRight, thisOrBoth)
import Global (isNaN, readInt)
import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..), CellResultContent(..))
import Model.Notebook.Cell
import Model.Resource (Resource(), mkFile)
import Optic.Core ((^.), (.~), (..))
import Optic.Extended (TraversalP(), (^?))

import Data.Path.Pathy ((</>), parseAbsFile, rootDir, sandbox)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Int as I
import qualified Model.Notebook.Cell.JTableContent as JTC

_page :: TraversalP Cell (These String I.Int)
_page = _content .. _JTableContent .. JTC._page

_perPage :: TraversalP Cell (Either (These String I.Int) I.Int)
_perPage = _content .. _JTableContent .. JTC._perPage

currentPage :: Cell -> Maybe I.Int
currentPage cell = maybe Nothing theseRight (cell ^? _page)

currentPageSize :: Cell -> Maybe I.Int
currentPageSize cell = maybe Nothing (either theseRight Just) (cell ^? _perPage)

goPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
goPage page cell go = run cell `andThen` \_ -> go (cell # _page .~ That page)

stepPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
stepPage delta cell = goPage (maybe one (delta +) (currentPage cell)) cell

inputPage :: forall e. Cell -> String -> I e
inputPage cell val = update cell (_page .~ thisOrBoth val (currentPage cell))

inputPageSize :: forall e. Cell -> String -> I e
inputPageSize cell val = update cell (_perPage .~ Left (thisOrBoth val $ currentPageSize cell))

loadPage :: forall e. Cell -> (Cell -> I e) -> I e
loadPage cell go = case cell ^? _content .. _JTableContent of
  Nothing -> empty
  Just table ->
    let page = these (readPageNum one) id (flip readPageNum) (table ^. JTC._page)
        perPage = either (these (readPageNum one) id (flip readPageNum)) id (table ^. JTC._perPage)
    in run cell `andThen` \_ -> go (cell # (_page .~ That page)
                                        .. (_perPage .~ Right perPage))
    where
    readPageNum :: I.Int -> String -> I.Int
    readPageNum default str =
      let num = readInt 10 str
      in if isNaN num then default else I.fromNumber num

changePageSize :: forall e. Cell -> (Cell -> I e) -> String -> I e
changePageSize cell go "Custom" = update cell (_perPage .~ Left (That $ fromMaybe Config.defaultPageSize $ currentPageSize cell))
changePageSize cell go value = case readJSON value of
  Left _ -> empty
  Right n -> run cell
    `andThen` \_ -> go (cell # (_perPage .~ Right (I.fromNumber n))
                            .. (_page .~ That one))

runJTable :: forall e. Resource -> Cell -> I e
runJTable file cell = do
  let perPage = fromMaybe Config.defaultPageSize (currentPageSize cell)
      pageNumber = fromMaybe one (currentPage cell)
      pageIndex = pageNumber - one
  results <- liftAff $ attempt $ { numItems: _, json: _ }
    <$> count file
    <*> sample file (pageIndex * perPage) perPage
  now' <- liftEff now
  return $ case results of
      Left err -> CellResult (cell ^. _cellId) now' (Left $ NEL.singleton $ message err)
      Right results -> do
        CellResult (cell ^. _cellId) now' $ Right $ JTableContent $
          JTC.JTableContent { perPage: Right perPage
                            , page: That pageNumber
                            , result: Just $ JTC.Result
                              { totalPages: I.fromNumber $ Math.ceil (results.numItems / I.toNumber perPage)
                              , values: Just $ fromArray results.json
                              }
                            }

-- TODO: Remove String from being our error type.
queryToJTable :: forall e. Cell -> String -> Resource -> Resource -> I e
queryToJTable cell sql inp out = do
  jobj <- liftAff do
    delete out
    attempt (port inp out sql)
  either errorInQuery (\out -> runJTable (mkFile (Left $ rootDir </> out)) cell) do
    j <- lmap message jobj
    out' <- j .? "out"
    path <- maybe (Left "Invalid file from SlamEngine") Right $ parseAbsFile out'
    maybe (Left "Could not sandbox SlamEngine file") Right $ sandbox rootDir path
  where
  errorInQuery :: _ -> I e
  errorInQuery err =
    update cell (_failures .~ ["Error in query: " <> err])
      `andThen` \_ -> finish cell

module Controller.Notebook.Cell.JTableContent
  ( goPage
  , stepPage
  , inputPage
  , inputPageSize
  , loadPage
  , changePageSize
  , runJTable
  , queryToJTable
  ) where

import Api.Fs (delete)
import Api.Query (port, query, sample, count)
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message)
import Control.Plus (empty)
import Controller.Notebook.Common (I(), run, update, finish)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (Json(), JObject(), fromArray)
import Data.Argonaut.Decode (decodeJson)
import Data.Array (head)
import Data.Date (now)
import Data.Either (Either(..), either)
import Data.Foreign.Class (readJSON)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.These (These(..), these, theseRight, thisOrBoth)
import Global (isNaN, readInt)
import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..), CellResultContent(..))
import Model.Notebook.Cell
import Model.Resource (Resource())
import Optic.Core ((^.), (.~), (..))
import Optic.Extended (TraversalP(), (^?))

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Int as I
import qualified Model.Notebook.Cell.JTableContent as JTC

_page :: TraversalP Cell (These String I.Int)
_page = _content .. _JTableContent .. JTC._page

_perPage :: TraversalP Cell (Either (These String I.Int) I.Int)
_perPage = _content .. _JTableContent .. JTC._perPage

currentPage :: Cell -> Maybe I.Int
currentPage cell = maybe Nothing theseRight (cell ^? _page)

currentPageSize :: Cell -> Maybe I.Int
currentPageSize cell = maybe Nothing (either theseRight Just) (cell ^? _perPage)

goPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
goPage page cell go = run cell `andThen` \_ -> go (cell # _page .~ That page)

stepPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
stepPage delta cell = goPage (maybe one (delta +) (currentPage cell)) cell

inputPage :: forall e. Cell -> String -> I e
inputPage cell val = update cell (_page .~ thisOrBoth val (currentPage cell))

inputPageSize :: forall e. Cell -> String -> I e
inputPageSize cell val = update cell (_perPage .~ Left (thisOrBoth val $ currentPageSize cell))

loadPage :: forall e. Cell -> (Cell -> I e) -> I e
loadPage cell go = case cell ^? _content .. _JTableContent of
  Nothing -> empty
  Just table ->
    let page = these (readPageNum one) id (flip readPageNum) (table ^. JTC._page)
        perPage = either (these (readPageNum one) id (flip readPageNum)) id (table ^. JTC._perPage)
    in run cell `andThen` \_ -> go (cell # (_page .~ That page)
                                        .. (_perPage .~ Right perPage))
    where
    readPageNum :: I.Int -> String -> I.Int
    readPageNum default str =
      let num = readInt 10 str
      in if isNaN num then default else I.fromNumber num

changePageSize :: forall e. Cell -> (Cell -> I e) -> String -> I e
changePageSize cell go "Custom" = update cell (_perPage .~ Left (That $ fromMaybe Config.defaultPageSize $ currentPageSize cell))
changePageSize cell go value = case readJSON value of
  Left _ -> empty
  Right n -> run cell
    `andThen` \_ -> go (cell # (_perPage .~ Right (I.fromNumber n))
                            .. (_page .~ That one))

runJTable :: forall e. Resource -> Cell -> I e
runJTable file cell = do
  let perPage = fromMaybe Config.defaultPageSize (currentPageSize cell)
      pageNumber = fromMaybe one (currentPage cell)
      pageIndex = pageNumber - one
  results <- liftAff $ attempt $ { numItems: _, json: _ }
    <$> count file
    <*> sample file (pageIndex * perPage) perPage
  now' <- liftEff now
  return $ case results of
      Left err -> CellResult (cell ^. _cellId) now' (Left $ NEL.singleton $ message err)
      Right results -> do
        CellResult (cell ^. _cellId) now' $ Right $ JTableContent $
          JTC.JTableContent { perPage: Right perPage
                            , page: That pageNumber
                            , result: Just $ JTC.Result
                              { totalPages: I.fromNumber $ Math.ceil (results.numItems / I.toNumber perPage)
                              , values: Just $ fromArray results.json
                              }
                            }

queryToJTable :: forall e. Cell -> String -> Resource -> Resource -> I e
queryToJTable cell sql inp out = do
  jobj <- liftAff do
    delete out
    attempt (port inp out sql)
  either errorInQuery (const $ runJTable out cell) jobj
  where
  correct :: String -> Resource -> Resource -> I e
  correct sql inp out = do
    jobj <- liftAff do
      delete out
      attempt (port inp out sql)
    either errorInQuery (const $ runJTable out cell) jobj

  errorInQuery :: _ -> I e
  errorInQuery err =
    update cell (_failures .~ ["Error in query: " <> message err])
      `andThen` \_ -> finish cell