content: {-# LANGUAGE
    BangPatterns,
    BlockArguments,
    DataKinds,
    RankNTypes,
    ScopedTypeVariables,
    TypeApplications,
    TypeOperators #-}
  module Main (main) where
  
  import Control.Monad (join)
  import Data.Functor (void)
  import Data.Void (absurd)
  import Test.Tasty (defaultMain, testGroup, TestTree)
  import Test.Tasty.HUnit
  import Bluefin.Eff (Eff, runPureEff, bracket, type (:&), type (:>))
  import qualified Bluefin.State as B
  import Bluefin.Algae
  import Bluefin.Algae.State
  import Bluefin.Algae.Exception
  import qualified Bluefin.Algae.Exception.DynExn as EC
  import Bluefin.Algae.NonDeterminism as NonDet
  import Bluefin.Algae.Coroutine
  import qualified Bluefin.Exception as E
  import qualified Bluefin.Exception.Dynamic as ED
  
  -- * State
  
  -- Simple sanity test
  
  incr :: z :> zz => Handler (State Int) z -> Eff zz ()
  incr state = modify state (+ 1)
  
  -- Distinguishing Bluefin.Algae.State (pure state) from Bluefin.State (IORef)
  
  algaeStateLitmus :: [Int]
  algaeStateLitmus = runPureEff $ NonDet.toList \choice ->
    execState 0 \state -> do
      _ <- choose choice True False
      incr state
  
  bluefinStateLitmus :: [Int]
  bluefinStateLitmus = runPureEff $ NonDet.toList \choice ->
    snd <$> B.runState 0 \state -> do
      _ <- choose choice True False
      B.modify state (+ 1)
  
  testState :: TestTree
  testState = testGroup "State"
    [ testCase "simple" $ runPureEff (runState 0 incr) @?= ((), 1)
    , testCase "litmus-0" $ algaeStateLitmus @?= [1,1]
    , testCase "litmus-1" $ bluefinStateLitmus @?= [1,2]
    ]
  
  -- * Exception
  
  onException :: Eff es a -> Eff es () -> Eff es a
  onException run post = bracket (pure ()) (\_ -> post) (\_ -> run)
  
  exceptionLitmus :: Int
  exceptionLitmus = runPureEff $ snd <$> runState 0 \state ->
    void (try \exn ->
      onException (throw exn ()) (incr state))
  
  exceptionDynLitmus :: Int
  exceptionDynLitmus = ED.runDynExn \ex -> snd <$> runState 0 \state ->
    void (EC.try ex \exn ->
      onException (EC.throw exn ()) (incr state))
  
  exceptionNoCancelLitmus :: Int
  exceptionNoCancelLitmus = runPureEff $ snd <$> runState 0 \state ->
    void (try' \exn ->
      onException (throw exn ()) (incr state))
  
  exnLitmus :: Int
  exnLitmus = runPureEff $ snd <$> runState 0 \state ->
    void (E.try \exn ->
      onException (E.throw exn ()) (incr state))
  
  testException :: TestTree
  testException = testGroup "Exception"
    [ testCase "litmus-exception" $ exceptionLitmus @?= 1
    , testCase "litmus-exception-dyn" $ exceptionDynLitmus @?= 1
    , testCase "litmus-exception-no-cancel" $ exceptionNoCancelLitmus @?= 0
    , testCase "litmus-exn" $ exnLitmus @?= 1
    ]
  
  -- * Nondeterminism
  
  coinFlip :: z :> zz => Handler Choice z -> Eff zz Bool
  coinFlip choice =
    join $ choose choice -- flip coin
      (nil choice)     -- coin falls in gutter
      (join $ choose choice
        (pure True)    -- heads
        (pure False))  -- tails
  
  coinFlipList :: [Bool]
  coinFlipList = runPureEff (NonDet.toList coinFlip)
  
  toStream :: z :> zz =>
    (forall z0. Handler Choice z0 -> Eff (z0 :& zz) a) ->
    Handler (Coroutine a ()) z -> Eff zz ()
  toStream f h = forAllChoices f (yield h)
  
  permuts :: z :> zz => Handler Choice z -> [a] -> Eff zz [a]
  permuts _ [] = pure []
  permuts choice xs = do
    (x, ys) <- removeFrom choice xs
    zs <- permuts choice ys
    pure (x : zs)
  
  pythagoras :: z :> zz => Handler Choice z -> Eff zz (Int, Int, Int)
  pythagoras choice = do
    x <- pick choice [1 .. 10]
    y <- pick choice [1 .. 10]
    z <- pick choice [1 .. 10]
    assume choice (x .^ 2 + y .^ 2 == z .^ 2)
    pure (x, y, z)
    where (.^) = (Prelude.^) :: Int -> Int -> Int
  
  testNonDet :: TestTree
  testNonDet = testGroup "NonDet"
    [ testCase "coin-flip" $ coinFlipList @?= [True, False]
    , testCase "via-stream" $ runPureEff (feedCoroutine [(), ()] (toStream coinFlip)) @?= [True, False]
    , testCase "permutations" $ runPureEff (NonDet.toList (flip permuts [1,2,3::Int]))
        @?= [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
    , testCase "pythagoras" $ runPureEff (NonDet.toList pythagoras)
        @?= [(3,4,5),(4,3,5),(6,8,10),(8,6,10)]
    ]
  
  -- * Streaming
  
  cumulSum :: z :> zz => Handler (Coroutine Int Int) z -> Eff zz a
  cumulSum h = loop 0 where
    loop !n = do
      m <- yield h n
      loop (m + n)
  
  feedCoroutine :: [i] -> (forall zz0. ScopedEff (Coroutine o i) zz0 a) -> Eff zz [o]
  feedCoroutine is f = do
    r <- try \exn -> runState (is, []) \state ->
      forCoroutine f (coyield state exn)
    pure $ reverse $ case r of
      Left os -> os
      Right (_, (_, os)) -> os
  
  coyield :: (z :> zz, z' :> zz) =>
    Handler (State ([i], [o])) z -> Handler (Exception [o]) z' -> o -> Eff zz i
  coyield state exn o = do
    (is, os) <- get state
    case is of
      [] -> throw exn (o : os)
      i : ys -> put state (ys, o : os) >> pure i
  
  -- * Concurrency
  
  range1to4 :: z :> zz => Handler (Coroutine Int ()) z -> Eff zz ()
  range1to4 h = do
    yield h 1
    yield h 2
    yield h 3
    yield h 4
  
  filterEven :: z :> zz => Handler (State [Int]) z -> Eff zz ()
  filterEven h =
    forCoroutine range1to4 \n ->
      if n `mod` 2 == 0
      then modify h (n :)
      else pure ()
  
  filterEvenResult :: Eff zz [Int]
  filterEvenResult = execState [] filterEven
  
  pingpong :: Eff ss String
  pingpong = withCoroutine coThread mainThread
    where
      coThread z0 h = do
        z1 <- yield h (z0 ++ "pong")
        z2 <- yield h (z1 ++ "dong")
        yield h (z2 ++ "bong")
      mainThread h = do
        s1 <- yield h "ping"
        s2 <- yield h (s1 ++ "ding")
        s3 <- yield h (s2 ++ "bing")
        pure s3
  
  echo :: Eff ss String
  echo = loopCoPipe ((userLL |+ userLR) |+ (userRL |+ userRR)) (Left (Left "S"))
    where
      userLL = toCoPipe \s h -> do
        s' <- yield h (Left (Right (s ++ "-LL")))
        yield h (Right (Left (s' ++ "-LL")))
      userLR = toCoPipe \s h -> do
        s' <- yield h (Right (Left (s ++ "-LR")))
        yield h (Right (Right (s' ++ "-LR")))
      userRL = toCoPipe \s h -> do
        s' <- yield h (Right (Right (s ++ "-RL")))
        yield h (Left (Right (s' ++ "-RL")))
      userRR = toCoPipe \s h -> do
        s' <- yield h (Left (Left (s ++ "-RR")))
        pure (s' ++ "-RR")
      (|+) = eitherCoPipe id
  
  -- | Coroutine identifier
  newtype Cid = Cid Int deriving (Eq, Show)
  
  -- | Next coroutine identifier (wraps around at maxCid).
  nextCid :: Cid -> Cid
  nextCid (Cid c) = Cid (c + 1)
  
  type Yell a = Exception a
  
  -- | Hot potato coroutine:
  --
  -- - receive hot @potato@ (whose value represents the temperature of the potato);
  -- - if it is too hot (@potato > 0@), pass the potato to the next coroutine,
  --   the potato cools down slightly at every pass;
  -- - once the potato is cool enough, the coroutine which owns the potato yells its @Cid@.
  hotpotato :: (z :> zz, z' :> zz) =>
    Handler (Yell Cid) z ->  -- ^ the coroutine may yell using this handle
    Cid ->                   -- ^ coroutine ID
    Int ->                   -- ^ hot @potato@
    Handler (Coroutine (Cid, Int) Int) z' ->  -- ^ handle to yield to another coroutine
    Eff zz void              -- ^ does not return (the yell is an exception)
  hotpotato yell c potato0 cr = loop potato0 where
    loop potato | potato > 0 = do                  -- if potato is too hot,
      potato' <- yield cr (nextCid c, potato - 1)  -- pass to the next coroutine, the potato cools down,
      loop potato'                                 -- wait for the potato to come back and repeat.
    loop _ | otherwise = throw yell c  -- if potato has cooled down, we won the potato.
  
  -- | Four coroutines play the hot potato game.
  hotpotatoes :: Eff ss Cid
  hotpotatoes = do
    e <- try \yell ->
      -- Wrap Cid into [0 .. 3]
      let wrapCid = mapCoPipe id (\(Cid n, potato) -> (Cid (n `mod` 4), potato)) id in
      loopCoPipe (wrapCid
        (  hotpotato yell (Cid 0)
        +| hotpotato yell (Cid 1)
        +| hotpotato yell (Cid 2)
        +| hotpotato yell (Cid 3)
        +| nobody)) (Cid 3, 42)
    case e of
      Left c -> pure c
      Right o -> absurd o
  
  -- | Empty copipe
  nobody :: CoPipe (Cid, Int) o (Eff zz) void
  nobody = mapCoPipe (\(_, _) -> error "don't call me") id id voidCoPipe
  
  infixr 4 +|
  
  -- | Add another hot potato coroutine to the mix.
  --
  -- The coroutines are numbered sequentially.
  (+|) ::
    CoPipeSEff i o zz a ->
    CoPipe (Cid, i) o (Eff zz) a ->
    CoPipe (Cid, i) o (Eff zz) a
  (+|) l r = eitherCoPipe split l' r
    where
      l' = mapCoPipe (\(_ :: Cid, potato) -> potato) id id (toCoPipe l)
  
  split :: (Cid, i) -> Either (Cid, i) (Cid, i)
  split (Cid 0, potato) = Left (Cid 0, potato)
  split (Cid c, potato) = Right (Cid (c-1), potato)
  
  testCoroutine :: TestTree
  testCoroutine = testGroup "Coroutine"
    [ testCase "feedPipe-sum" $ runPureEff (feedPipe [1,2,3] (toPipe cumulSum)) @?= [0,1,3,6]
    , testCase "feedCoroutine-sum" $ runPureEff (feedCoroutine [1,2,3] cumulSum) @?= [0,1,3,6]
    , testCase "filterEven" $ runPureEff filterEvenResult @?= [4,2]
    , testCase "pingpong" $ runPureEff pingpong @?= "pingpongdingdongbingbong"
    , testCase "echo" $ runPureEff echo @?= "S-LL-LR-RL-RR-LL-RL-LR-RR"
    , testCase "hotpotato" $ runPureEff hotpotatoes @?= Cid 1
    ]
  
  main :: IO ()
  main = defaultMain tests
  
  tests :: TestTree
  tests = testGroup "Tests"
    [ testState
    , testException
    , testNonDet
    , testCoroutine
    ]
  