{-# LANGUAGE GADTs #-}

-- | Free seat syntax: pipelines and hosts as inspectable terms that fold into
-- 'Circuit.Agent.Tensor.AgentShard' values, with STM agents via
-- 'interpretSeatS'.
module Free.Agent.Seat
  ( FreeSeat (..),
    SeatBehaviour,
    interpretSeat,
    interpretSeatA,
    interpretSeatS,
    runAgentSBox,
    pipelineSeat,
    hostSeat,
    silentSeat,
    forkSeat,
    awaitSeat,
    raceSeat,
    fanOutSeat,
    fanInSeat,
    bundleSeat,
  )
where

import Circuit (Body (..))
import Circuit.Agent
  ( Agent,
    Post,
    runAgentM,
  )
import Circuit.Agent.Tensor
  ( AgentShard,
    awaitShard,
    fanInShard,
    fanOutShard,
    raceShard,
    silentShard,
  )
import Circuit.Category (K (..))
import Circuit.Poles (compose0)
import Circuit.System (System, monoDir, system)
import Control.Concurrent.STM (STM, atomically)
import Data.Text (Text)
import Free.Agent.Host (Host, hostShard)
import Free.Agent.Pipeline (Pipeline, pipelineShard, runPipeline)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Free.Agent.Seat
-- >>> import Free.Agent.Pipeline
-- >>> import Free.Agent.Host
-- >>> import Circuit.Agent

-- | An inspectable '[Post Text]'-to-'[Post Text]' seat term.
--
--   * 'SeatPipeline' — a pure list-to-list pipeline over 'Post'.
--   * 'SeatHost' — a one-shot host (may perform IO).
--   * 'SeatSilent' — emits nothing and clears the buffer.
--   * 'SeatCompose' — sequential composition of seats.
--   * 'SeatFork' — syntactic marker that the input state is duplicated.
--   * 'SeatAwait' — product tensor: both branches speak on the same input.
--   * 'SeatRace' — coproduct tensor: left-biased race of branch emits.
--   * 'SeatFanOut' — run every branch on a copy of the input, concatenate.
--   * 'SeatFanIn' — fan-out then collapse the branch outputs with a summary.
data FreeSeat where
  -- | A pure pipeline stage.
  SeatPipeline :: Pipeline (Post Text) (Post Text) -> FreeSeat
  -- | A one-shot host stage (may perform IO).
  SeatHost :: Host -> FreeSeat
  -- | The silent seat: emits the empty list.
  SeatSilent :: FreeSeat
  -- | Sequential composition of seats.
  SeatCompose :: FreeSeat -> FreeSeat -> FreeSeat
  -- | Fork the current input session (semantically identity at this stage).
  SeatFork :: FreeSeat -> FreeSeat
  -- | Product / await: concatenate the emits of both branches.
  SeatAwait :: FreeSeat -> FreeSeat -> FreeSeat
  -- | Coproduct / race: left emit wins if non-empty, otherwise right.
  SeatRace :: FreeSeat -> FreeSeat -> FreeSeat
  -- | Fan-out: run every branch on a copy of the input.
  SeatFanOut :: [FreeSeat] -> FreeSeat
  -- | Fan-in: fan-out then summarize the collected branch outputs.
  SeatFanIn :: ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat

-- | Lift a pure pipeline into a free seat term.
pipelineSeat :: Pipeline (Post Text) (Post Text) -> FreeSeat
pipelineSeat :: Pipeline (Post Text) (Post Text) -> FreeSeat
pipelineSeat = Pipeline (Post Text) (Post Text) -> FreeSeat
SeatPipeline

-- | Lift a host into a free seat term.
hostSeat :: Host -> FreeSeat
hostSeat :: Host -> FreeSeat
hostSeat = Host -> FreeSeat
SeatHost

-- | The silent seat: emits nothing.
silentSeat :: FreeSeat
silentSeat :: FreeSeat
silentSeat = FreeSeat
SeatSilent

-- | Mark a seat as running on a forked copy of the input session.
forkSeat :: FreeSeat -> FreeSeat
forkSeat :: FreeSeat -> FreeSeat
forkSeat = FreeSeat -> FreeSeat
SeatFork

-- | Product / await of two seats.
awaitSeat :: FreeSeat -> FreeSeat -> FreeSeat
awaitSeat :: FreeSeat -> FreeSeat -> FreeSeat
awaitSeat = FreeSeat -> FreeSeat -> FreeSeat
SeatAwait

-- | Coproduct / race of two seats (left-biased).
raceSeat :: FreeSeat -> FreeSeat -> FreeSeat
raceSeat :: FreeSeat -> FreeSeat -> FreeSeat
raceSeat = FreeSeat -> FreeSeat -> FreeSeat
SeatRace

-- | Fan-out: run every seat on a copy of the input.
fanOutSeat :: [FreeSeat] -> FreeSeat
fanOutSeat :: [FreeSeat] -> FreeSeat
fanOutSeat = [FreeSeat] -> FreeSeat
SeatFanOut

-- | Fan-in: fan-out then summarize the branch outputs.
fanInSeat :: ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat
fanInSeat :: ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat
fanInSeat = ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat
SeatFanIn

-- | 'fanInSeat' synonym: a bundle is fan-out, map, fan-in.
bundleSeat :: ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat
bundleSeat :: ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat
bundleSeat = ([[Post Text]] -> [Post Text]) -> [FreeSeat] -> FreeSeat
fanInSeat

-- | Fold a free seat term into an agent shard by interpreting each generator
-- and composing the resulting shards with 'composeEnds0'.
--
-- The buffer state is carried by the base arrow ('Body (,) (K IO)
-- [Post Text]') rather than a monad transformer.
interpretSeat ::
  FreeSeat ->
  AgentShard [Post Text] [Post Text]
interpretSeat :: FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat (SeatPipeline Pipeline (Post Text) (Post Text)
p) = Pipeline (Post Text) (Post Text)
-> AgentShard [Post Text] [Post Text]
forall a b. Pipeline a b -> Poles (Body (,) [a] (K IO)) [a] [b]
pipelineShard Pipeline (Post Text) (Post Text)
p
interpretSeat (SeatHost Host
h) = Host -> AgentShard [Post Text] [Post Text]
hostShard Host
h
interpretSeat FreeSeat
SeatSilent = AgentShard [Post Text] [Post Text]
silentShard
interpretSeat (SeatCompose FreeSeat
g FreeSeat
f) =
  AgentShard [Post Text] [Post Text]
-> AgentShard [Post Text] [Post Text]
-> AgentShard [Post Text] [Post Text]
forall (arr :: * -> * -> *) a b c.
HasDual () arr =>
Poles arr a b -> Poles arr b c -> Poles arr a c
compose0 (FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
f) (FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
g)
interpretSeat (SeatFork FreeSeat
f) = FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
f
interpretSeat (SeatAwait FreeSeat
f FreeSeat
g) =
  AgentShard [Post Text] [Post Text]
-> AgentShard [Post Text] [Post Text]
-> AgentShard [Post Text] [Post Text]
awaitShard (FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
f) (FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
g)
interpretSeat (SeatRace FreeSeat
f FreeSeat
g) =
  AgentShard [Post Text] [Post Text]
-> AgentShard [Post Text] [Post Text]
-> AgentShard [Post Text] [Post Text]
raceShard (FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
f) (FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat FreeSeat
g)
interpretSeat (SeatFanOut [FreeSeat]
fs) =
  [AgentShard [Post Text] [Post Text]]
-> AgentShard [Post Text] [Post Text]
fanOutShard ((FreeSeat -> AgentShard [Post Text] [Post Text])
-> [FreeSeat] -> [AgentShard [Post Text] [Post Text]]
forall a b. (a -> b) -> [a] -> [b]
map FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat [FreeSeat]
fs)
interpretSeat (SeatFanIn [[Post Text]] -> [Post Text]
summary [FreeSeat]
fs) =
  ([[Post Text]] -> [Post Text])
-> [AgentShard [Post Text] [Post Text]]
-> AgentShard [Post Text] [Post Text]
fanInShard [[Post Text]] -> [Post Text]
summary ((FreeSeat -> AgentShard [Post Text] [Post Text])
-> [FreeSeat] -> [AgentShard [Post Text] [Post Text]]
forall a b. (a -> b) -> [a] -> [b]
map FreeSeat -> AgentShard [Post Text] [Post Text]
interpretSeat [FreeSeat]
fs)

-- | Pure behaviour semantics of a free seat: a function from committed posts
-- to emitted posts.
--
-- This is the specification-domain interpretation. Pipelines are list
-- transducers; 'SeatAwait'/'SeatRace'/'SeatFanOut'/'SeatFanIn' are the bundle
-- tensors; 'SeatFork' is identity. 'SeatHost' is not pure and raises a runtime
-- error.
type SeatBehaviour = [Post Text] -> [Post Text]

-- | Fold a free seat term into its pure behaviour.
--
-- The result is independent of any effectful boundary; it is the function that
-- the shard interpretation realises.
interpretSeatA :: FreeSeat -> SeatBehaviour
interpretSeatA :: FreeSeat -> SeatBehaviour
interpretSeatA (SeatPipeline Pipeline (Post Text) (Post Text)
p) = Pipeline (Post Text) (Post Text) -> SeatBehaviour
forall a b. Pipeline a b -> [a] -> [b]
runPipeline Pipeline (Post Text) (Post Text)
p
interpretSeatA FreeSeat
SeatSilent = [Post Text] -> SeatBehaviour
forall a b. a -> b -> a
const []
interpretSeatA (SeatHost Host
_) = [Char] -> SeatBehaviour
forall a. HasCallStack => [Char] -> a
error [Char]
"interpretSeatA: SeatHost cannot be interpreted as a pure behaviour"
interpretSeatA (SeatCompose FreeSeat
g FreeSeat
f) = FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
g SeatBehaviour -> SeatBehaviour -> SeatBehaviour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
f
interpretSeatA (SeatFork FreeSeat
f) = FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
f
interpretSeatA (SeatAwait FreeSeat
f FreeSeat
g) = \[Post Text]
xs -> FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
f [Post Text]
xs [Post Text] -> SeatBehaviour
forall a. [a] -> [a] -> [a]
++ FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
g [Post Text]
xs
interpretSeatA (SeatRace FreeSeat
f FreeSeat
g) =
  \[Post Text]
xs ->
    let o1 :: [Post Text]
o1 = FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
f [Post Text]
xs
     in if [Post Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Post Text]
o1 then FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
g [Post Text]
xs else [Post Text]
o1
interpretSeatA (SeatFanOut [FreeSeat]
fs) = \[Post Text]
xs -> (FreeSeat -> [Post Text]) -> [FreeSeat] -> [Post Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FreeSeat
f -> FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
f [Post Text]
xs) [FreeSeat]
fs
interpretSeatA (SeatFanIn [[Post Text]] -> [Post Text]
summary [FreeSeat]
fs) =
  \[Post Text]
xs -> [[Post Text]] -> [Post Text]
summary ((FreeSeat -> [Post Text]) -> [FreeSeat] -> [[Post Text]]
forall a b. (a -> b) -> [a] -> [b]
map (\FreeSeat
f -> FreeSeat -> SeatBehaviour
interpretSeatA FreeSeat
f [Post Text]
xs) [FreeSeat]
fs)

-- | Existential box around an STM agent, carrying its initial state.
--
-- The agent consumes one /batch/ of posts per step, so the whole free-seat
-- semantics @[Post Text] -> [Post Text]@ is realised in a single STM step.
data AgentSBox where
  AgentSBox :: s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox

-- | Run an STM-agent box over a list of posts, returning only the emitted
-- posts. The state is sealed inside the box; the caller sees the same
-- list-to-list interface as 'interpretSeatA'.
runAgentSBox :: AgentSBox -> [Post Text] -> IO [Post Text]
runAgentSBox :: AgentSBox -> [Post Text] -> IO [Post Text]
runAgentSBox (AgentSBox s
s0 Agent (K STM) s [Post Text] [Post Text]
ag) [Post Text]
ins =
  ([Post Text], s) -> [Post Text]
forall a b. (a, b) -> a
fst (([Post Text], s) -> [Post Text])
-> IO ([Post Text], s) -> IO [Post Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM ([Post Text], s) -> IO ([Post Text], s)
forall a. STM a -> IO a
atomically (Agent (K STM) s [Post Text] [Post Text]
-> s -> [Post Text] -> STM ([Post Text], s)
forall (m :: * -> *) s a b.
Monad m =>
Agent (K m) s a b -> s -> a -> m (b, s)
runAgentM Agent (K STM) s [Post Text] [Post Text]
ag s
s0 [Post Text]
ins)

-- | Heterogeneous list element for STM agents with varying state types.
data HAgentS where
  HAgentS :: s -> Agent (K STM) s [Post Text] [Post Text] -> HAgentS

-- | Lift a pure pipeline into a batch STM agent.
pipelineS :: Pipeline (Post Text) (Post Text) -> Agent (K STM) () [Post Text] [Post Text]
pipelineS :: Pipeline (Post Text) (Post Text)
-> Agent (K STM) () [Post Text] [Post Text]
pipelineS Pipeline (Post Text) (Post Text)
p = K STM
  ((), Dir (Mono [Post Text] [Post Text]))
  ((), Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) () [Post Text] [Post Text]
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ((), Dir (Mono [Post Text] [Post Text]))
   ((), Pos (Mono [Post Text] [Post Text]))
 -> Agent (K STM) () [Post Text] [Post Text])
-> K STM
     ((), Dir (Mono [Post Text] [Post Text]))
     ((), Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) () [Post Text] [Post Text]
forall a b. (a -> b) -> a -> b
$ (((), Dir (Mono [Post Text] [Post Text]))
 -> STM ((), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((), Dir (Mono [Post Text] [Post Text]))
     ((), Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((((), Dir (Mono [Post Text] [Post Text]))
  -> STM ((), Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ((), Dir (Mono [Post Text] [Post Text]))
      ((), Pos (Mono [Post Text] [Post Text])))
-> (((), Dir (Mono [Post Text] [Post Text]))
    -> STM ((), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((), Dir (Mono [Post Text] [Post Text]))
     ((), Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \((), Dir (Mono [Post Text] [Post Text])
d) ->
  ((), ([Post Text], ())) -> STM ((), ([Post Text], ()))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), (Pipeline (Post Text) (Post Text) -> SeatBehaviour
forall a b. Pipeline a b -> [a] -> [b]
runPipeline Pipeline (Post Text) (Post Text)
p (Dir (Mono [Post Text] (ZonkAny 7)) -> [Post Text]
forall i o. Dir (Mono i o) -> i
monoDir Dir (Mono [Post Text] [Post Text])
Dir (Mono [Post Text] (ZonkAny 7))
d), ()))

-- | Silent STM agent: emits nothing, state unchanged.
silentS :: Agent (K STM) () [Post Text] [Post Text]
silentS :: Agent (K STM) () [Post Text] [Post Text]
silentS = K STM
  ((), Dir (Mono [Post Text] [Post Text]))
  ((), Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) () [Post Text] [Post Text]
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ((), Dir (Mono [Post Text] [Post Text]))
   ((), Pos (Mono [Post Text] [Post Text]))
 -> Agent (K STM) () [Post Text] [Post Text])
-> K STM
     ((), Dir (Mono [Post Text] [Post Text]))
     ((), Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) () [Post Text] [Post Text]
forall a b. (a -> b) -> a -> b
$ (((), Dir (Mono [Post Text] [Post Text]))
 -> STM ((), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((), Dir (Mono [Post Text] [Post Text]))
     ((), Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((((), Dir (Mono [Post Text] [Post Text]))
  -> STM ((), Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ((), Dir (Mono [Post Text] [Post Text]))
      ((), Pos (Mono [Post Text] [Post Text])))
-> (((), Dir (Mono [Post Text] [Post Text]))
    -> STM ((), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((), Dir (Mono [Post Text] [Post Text]))
     ((), Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \((), Dir (Mono [Post Text] [Post Text])
_) -> ((), ([Post Text], ())) -> STM ((), ([Post Text], ()))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), ([], ()))

-- | Sequential composition in STM: outputs of @f@ on the whole batch are fed
-- as the next batch to @g@.
composeS ::
  Agent (K STM) sg [Post Text] [Post Text] ->
  Agent (K STM) sf [Post Text] [Post Text] ->
  Agent (K STM) (sf, sg) [Post Text] [Post Text]
composeS :: forall sg sf.
Agent (K STM) sg [Post Text] [Post Text]
-> Agent (K STM) sf [Post Text] [Post Text]
-> Agent (K STM) (sf, sg) [Post Text] [Post Text]
composeS Agent (K STM) sg [Post Text] [Post Text]
g Agent (K STM) sf [Post Text] [Post Text]
f = K STM
  ((sf, sg), Dir (Mono [Post Text] [Post Text]))
  ((sf, sg), Pos (Mono [Post Text] [Post Text]))
-> System (K STM) (sf, sg) (Mono [Post Text] [Post Text])
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ((sf, sg), Dir (Mono [Post Text] [Post Text]))
   ((sf, sg), Pos (Mono [Post Text] [Post Text]))
 -> System (K STM) (sf, sg) (Mono [Post Text] [Post Text]))
-> K STM
     ((sf, sg), Dir (Mono [Post Text] [Post Text]))
     ((sf, sg), Pos (Mono [Post Text] [Post Text]))
-> System (K STM) (sf, sg) (Mono [Post Text] [Post Text])
forall a b. (a -> b) -> a -> b
$ (((sf, sg), Dir (Mono [Post Text] [Post Text]))
 -> STM ((sf, sg), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((sf, sg), Dir (Mono [Post Text] [Post Text]))
     ((sf, sg), Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((((sf, sg), Dir (Mono [Post Text] [Post Text]))
  -> STM ((sf, sg), Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ((sf, sg), Dir (Mono [Post Text] [Post Text]))
      ((sf, sg), Pos (Mono [Post Text] [Post Text])))
-> (((sf, sg), Dir (Mono [Post Text] [Post Text]))
    -> STM ((sf, sg), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((sf, sg), Dir (Mono [Post Text] [Post Text]))
     ((sf, sg), Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \((sf
sf, sg
sg), Dir (Mono [Post Text] [Post Text])
d) -> do
  (outs, sf') <- Agent (K STM) sf [Post Text] [Post Text]
-> sf -> [Post Text] -> STM ([Post Text], sf)
forall (m :: * -> *) s a b.
Monad m =>
Agent (K m) s a b -> s -> a -> m (b, s)
runAgentM Agent (K STM) sf [Post Text] [Post Text]
f sf
sf (Dir (Mono [Post Text] (ZonkAny 6)) -> [Post Text]
forall i o. Dir (Mono i o) -> i
monoDir Dir (Mono [Post Text] [Post Text])
Dir (Mono [Post Text] (ZonkAny 6))
d)
  (outs', sg') <- runAgentM g sg outs
  pure ((sf', sg'), (outs', ()))

-- | Product / await in STM: both agents run on the same batch; emits are
-- concatenated.
awaitBatchS ::
  Agent (K STM) s1 [Post Text] [Post Text] ->
  Agent (K STM) s2 [Post Text] [Post Text] ->
  Agent (K STM) (s1, s2) [Post Text] [Post Text]
awaitBatchS :: forall s1 s2.
Agent (K STM) s1 [Post Text] [Post Text]
-> Agent (K STM) s2 [Post Text] [Post Text]
-> Agent (K STM) (s1, s2) [Post Text] [Post Text]
awaitBatchS Agent (K STM) s1 [Post Text] [Post Text]
f Agent (K STM) s2 [Post Text] [Post Text]
g = K STM
  ((s1, s2), Dir (Mono [Post Text] [Post Text]))
  ((s1, s2), Pos (Mono [Post Text] [Post Text]))
-> System (K STM) (s1, s2) (Mono [Post Text] [Post Text])
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ((s1, s2), Dir (Mono [Post Text] [Post Text]))
   ((s1, s2), Pos (Mono [Post Text] [Post Text]))
 -> System (K STM) (s1, s2) (Mono [Post Text] [Post Text]))
-> K STM
     ((s1, s2), Dir (Mono [Post Text] [Post Text]))
     ((s1, s2), Pos (Mono [Post Text] [Post Text]))
-> System (K STM) (s1, s2) (Mono [Post Text] [Post Text])
forall a b. (a -> b) -> a -> b
$ (((s1, s2), Dir (Mono [Post Text] [Post Text]))
 -> STM ((s1, s2), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((s1, s2), Dir (Mono [Post Text] [Post Text]))
     ((s1, s2), Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((((s1, s2), Dir (Mono [Post Text] [Post Text]))
  -> STM ((s1, s2), Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ((s1, s2), Dir (Mono [Post Text] [Post Text]))
      ((s1, s2), Pos (Mono [Post Text] [Post Text])))
-> (((s1, s2), Dir (Mono [Post Text] [Post Text]))
    -> STM ((s1, s2), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((s1, s2), Dir (Mono [Post Text] [Post Text]))
     ((s1, s2), Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \((s1
sf, s2
sg), Dir (Mono [Post Text] [Post Text])
d) -> do
  (outsF, sf') <- Agent (K STM) s1 [Post Text] [Post Text]
-> s1 -> [Post Text] -> STM ([Post Text], s1)
forall (m :: * -> *) s a b.
Monad m =>
Agent (K m) s a b -> s -> a -> m (b, s)
runAgentM Agent (K STM) s1 [Post Text] [Post Text]
f s1
sf (Dir (Mono [Post Text] (ZonkAny 4)) -> [Post Text]
forall i o. Dir (Mono i o) -> i
monoDir Dir (Mono [Post Text] [Post Text])
Dir (Mono [Post Text] (ZonkAny 4))
d)
  (outsG, sg') <- runAgentM g sg (monoDir d)
  pure ((sf', sg'), (outsF <> outsG, ()))

-- | Coproduct / race in STM: left emit wins if non-empty, otherwise right.
raceBatchS ::
  Agent (K STM) s1 [Post Text] [Post Text] ->
  Agent (K STM) s2 [Post Text] [Post Text] ->
  Agent (K STM) (s1, s2) [Post Text] [Post Text]
raceBatchS :: forall s1 s2.
Agent (K STM) s1 [Post Text] [Post Text]
-> Agent (K STM) s2 [Post Text] [Post Text]
-> Agent (K STM) (s1, s2) [Post Text] [Post Text]
raceBatchS Agent (K STM) s1 [Post Text] [Post Text]
f Agent (K STM) s2 [Post Text] [Post Text]
g = K STM
  ((s1, s2), Dir (Mono [Post Text] [Post Text]))
  ((s1, s2), Pos (Mono [Post Text] [Post Text]))
-> System (K STM) (s1, s2) (Mono [Post Text] [Post Text])
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ((s1, s2), Dir (Mono [Post Text] [Post Text]))
   ((s1, s2), Pos (Mono [Post Text] [Post Text]))
 -> System (K STM) (s1, s2) (Mono [Post Text] [Post Text]))
-> K STM
     ((s1, s2), Dir (Mono [Post Text] [Post Text]))
     ((s1, s2), Pos (Mono [Post Text] [Post Text]))
-> System (K STM) (s1, s2) (Mono [Post Text] [Post Text])
forall a b. (a -> b) -> a -> b
$ (((s1, s2), Dir (Mono [Post Text] [Post Text]))
 -> STM ((s1, s2), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((s1, s2), Dir (Mono [Post Text] [Post Text]))
     ((s1, s2), Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((((s1, s2), Dir (Mono [Post Text] [Post Text]))
  -> STM ((s1, s2), Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ((s1, s2), Dir (Mono [Post Text] [Post Text]))
      ((s1, s2), Pos (Mono [Post Text] [Post Text])))
-> (((s1, s2), Dir (Mono [Post Text] [Post Text]))
    -> STM ((s1, s2), Pos (Mono [Post Text] [Post Text])))
-> K STM
     ((s1, s2), Dir (Mono [Post Text] [Post Text]))
     ((s1, s2), Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \((s1
sf, s2
sg), Dir (Mono [Post Text] [Post Text])
d) -> do
  (outsF, sf') <- Agent (K STM) s1 [Post Text] [Post Text]
-> s1 -> [Post Text] -> STM ([Post Text], s1)
forall (m :: * -> *) s a b.
Monad m =>
Agent (K m) s a b -> s -> a -> m (b, s)
runAgentM Agent (K STM) s1 [Post Text] [Post Text]
f s1
sf (Dir (Mono [Post Text] (ZonkAny 2)) -> [Post Text]
forall i o. Dir (Mono i o) -> i
monoDir Dir (Mono [Post Text] [Post Text])
Dir (Mono [Post Text] (ZonkAny 2))
d)
  (outsG, sg') <- runAgentM g sg (monoDir d)
  let outs = if [Post Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Post Text]
outsF then [Post Text]
outsG else [Post Text]
outsF
  pure ((sf', sg'), (outs, ()))

-- | Fan-out in STM: run every branch on the same input batch and concatenate
-- the outputs. Branch states are kept in a heterogeneous list.
fanOutS :: Agent (K STM) [HAgentS] [Post Text] [Post Text]
fanOutS :: Agent (K STM) [HAgentS] [Post Text] [Post Text]
fanOutS = K STM
  ([HAgentS], Dir (Mono [Post Text] [Post Text]))
  ([HAgentS], Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) [HAgentS] [Post Text] [Post Text]
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ([HAgentS], Dir (Mono [Post Text] [Post Text]))
   ([HAgentS], Pos (Mono [Post Text] [Post Text]))
 -> Agent (K STM) [HAgentS] [Post Text] [Post Text])
-> K STM
     ([HAgentS], Dir (Mono [Post Text] [Post Text]))
     ([HAgentS], Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) [HAgentS] [Post Text] [Post Text]
forall a b. (a -> b) -> a -> b
$ (([HAgentS], Dir (Mono [Post Text] [Post Text]))
 -> STM ([HAgentS], Pos (Mono [Post Text] [Post Text])))
-> K STM
     ([HAgentS], Dir (Mono [Post Text] [Post Text]))
     ([HAgentS], Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((([HAgentS], Dir (Mono [Post Text] [Post Text]))
  -> STM ([HAgentS], Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ([HAgentS], Dir (Mono [Post Text] [Post Text]))
      ([HAgentS], Pos (Mono [Post Text] [Post Text])))
-> (([HAgentS], Dir (Mono [Post Text] [Post Text]))
    -> STM ([HAgentS], Pos (Mono [Post Text] [Post Text])))
-> K STM
     ([HAgentS], Dir (Mono [Post Text] [Post Text]))
     ([HAgentS], Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \([HAgentS]
hs, Dir (Mono [Post Text] [Post Text])
d) -> do
  let batch :: [Post Text]
batch = Dir (Mono [Post Text] (ZonkAny 1)) -> [Post Text]
forall i o. Dir (Mono i o) -> i
monoDir Dir (Mono [Post Text] [Post Text])
Dir (Mono [Post Text] (ZonkAny 1))
d
  pairs <- (HAgentS -> STM (HAgentS, [Post Text]))
-> [HAgentS] -> STM [(HAgentS, [Post Text])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(HAgentS s
s Agent (K STM) s [Post Text] [Post Text]
a) -> do (os, s') <- Agent (K STM) s [Post Text] [Post Text]
-> s -> [Post Text] -> STM ([Post Text], s)
forall (m :: * -> *) s a b.
Monad m =>
Agent (K m) s a b -> s -> a -> m (b, s)
runAgentM Agent (K STM) s [Post Text] [Post Text]
a s
s [Post Text]
batch; pure (HAgentS s' a, os)) [HAgentS]
hs
  let hs' = ((HAgentS, [Post Text]) -> HAgentS)
-> [(HAgentS, [Post Text])] -> [HAgentS]
forall a b. (a -> b) -> [a] -> [b]
map (HAgentS, [Post Text]) -> HAgentS
forall a b. (a, b) -> a
fst [(HAgentS, [Post Text])]
pairs
  pure (hs', (concatMap snd pairs, ()))

-- | Fan-in in STM: run every branch on the same input batch, then collapse
-- the branch outputs with the summary function.
fanInS :: ([[Post Text]] -> [Post Text]) -> Agent (K STM) [HAgentS] [Post Text] [Post Text]
fanInS :: ([[Post Text]] -> [Post Text])
-> Agent (K STM) [HAgentS] [Post Text] [Post Text]
fanInS [[Post Text]] -> [Post Text]
summary = K STM
  ([HAgentS], Dir (Mono [Post Text] [Post Text]))
  ([HAgentS], Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) [HAgentS] [Post Text] [Post Text]
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (K STM
   ([HAgentS], Dir (Mono [Post Text] [Post Text]))
   ([HAgentS], Pos (Mono [Post Text] [Post Text]))
 -> Agent (K STM) [HAgentS] [Post Text] [Post Text])
-> K STM
     ([HAgentS], Dir (Mono [Post Text] [Post Text]))
     ([HAgentS], Pos (Mono [Post Text] [Post Text]))
-> Agent (K STM) [HAgentS] [Post Text] [Post Text]
forall a b. (a -> b) -> a -> b
$ (([HAgentS], Dir (Mono [Post Text] [Post Text]))
 -> STM ([HAgentS], Pos (Mono [Post Text] [Post Text])))
-> K STM
     ([HAgentS], Dir (Mono [Post Text] [Post Text]))
     ([HAgentS], Pos (Mono [Post Text] [Post Text]))
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K ((([HAgentS], Dir (Mono [Post Text] [Post Text]))
  -> STM ([HAgentS], Pos (Mono [Post Text] [Post Text])))
 -> K STM
      ([HAgentS], Dir (Mono [Post Text] [Post Text]))
      ([HAgentS], Pos (Mono [Post Text] [Post Text])))
-> (([HAgentS], Dir (Mono [Post Text] [Post Text]))
    -> STM ([HAgentS], Pos (Mono [Post Text] [Post Text])))
-> K STM
     ([HAgentS], Dir (Mono [Post Text] [Post Text]))
     ([HAgentS], Pos (Mono [Post Text] [Post Text]))
forall a b. (a -> b) -> a -> b
$ \([HAgentS]
hs, Dir (Mono [Post Text] [Post Text])
d) -> do
  let batch :: [Post Text]
batch = Dir (Mono [Post Text] (ZonkAny 0)) -> [Post Text]
forall i o. Dir (Mono i o) -> i
monoDir Dir (Mono [Post Text] [Post Text])
Dir (Mono [Post Text] (ZonkAny 0))
d
  pairs <- (HAgentS -> STM (HAgentS, [Post Text]))
-> [HAgentS] -> STM [(HAgentS, [Post Text])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(HAgentS s
s Agent (K STM) s [Post Text] [Post Text]
a) -> do (os, s') <- Agent (K STM) s [Post Text] [Post Text]
-> s -> [Post Text] -> STM ([Post Text], s)
forall (m :: * -> *) s a b.
Monad m =>
Agent (K m) s a b -> s -> a -> m (b, s)
runAgentM Agent (K STM) s [Post Text] [Post Text]
a s
s [Post Text]
batch; pure (HAgentS s' a, os)) [HAgentS]
hs
  let hs' = ((HAgentS, [Post Text]) -> HAgentS)
-> [(HAgentS, [Post Text])] -> [HAgentS]
forall a b. (a -> b) -> [a] -> [b]
map (HAgentS, [Post Text]) -> HAgentS
forall a b. (a, b) -> a
fst [(HAgentS, [Post Text])]
pairs
  pure (hs', (summary (map snd pairs), ()))

-- | Unbox an 'AgentSBox' into a heterogeneous STM agent.
unboxH :: AgentSBox -> HAgentS
unboxH :: AgentSBox -> HAgentS
unboxH (AgentSBox s
s Agent (K STM) s [Post Text] [Post Text]
a) = s -> Agent (K STM) s [Post Text] [Post Text] -> HAgentS
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> HAgentS
HAgentS s
s Agent (K STM) s [Post Text] [Post Text]
a

-- | Fold a free seat term into an STM agent.
--
-- Hosts are not STM-pure and raise a runtime error. All other constructors are
-- interpreted as one-post-at-a-time STM agents whose state is hidden inside the
-- returned box.
interpretSeatS :: FreeSeat -> AgentSBox
interpretSeatS :: FreeSeat -> AgentSBox
interpretSeatS (SeatPipeline Pipeline (Post Text) (Post Text)
p) = () -> Agent (K STM) () [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox () (Pipeline (Post Text) (Post Text)
-> Agent (K STM) () [Post Text] [Post Text]
pipelineS Pipeline (Post Text) (Post Text)
p)
interpretSeatS (SeatHost Host
_) = [Char] -> AgentSBox
forall a. HasCallStack => [Char] -> a
error [Char]
"interpretSeatS: SeatHost cannot be interpreted in STM"
interpretSeatS FreeSeat
SeatSilent = () -> Agent (K STM) () [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox () Agent (K STM) () [Post Text] [Post Text]
silentS
interpretSeatS (SeatCompose FreeSeat
g FreeSeat
f) =
  case (FreeSeat -> AgentSBox
interpretSeatS FreeSeat
g, FreeSeat -> AgentSBox
interpretSeatS FreeSeat
f) of
    (AgentSBox s
sg0 Agent (K STM) s [Post Text] [Post Text]
gag, AgentSBox s
sf0 Agent (K STM) s [Post Text] [Post Text]
fag) -> (s, s) -> Agent (K STM) (s, s) [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox (s
sf0, s
sg0) (Agent (K STM) s [Post Text] [Post Text]
-> Agent (K STM) s [Post Text] [Post Text]
-> Agent (K STM) (s, s) [Post Text] [Post Text]
forall sg sf.
Agent (K STM) sg [Post Text] [Post Text]
-> Agent (K STM) sf [Post Text] [Post Text]
-> Agent (K STM) (sf, sg) [Post Text] [Post Text]
composeS Agent (K STM) s [Post Text] [Post Text]
gag Agent (K STM) s [Post Text] [Post Text]
fag)
interpretSeatS (SeatFork FreeSeat
f) = FreeSeat -> AgentSBox
interpretSeatS FreeSeat
f
interpretSeatS (SeatAwait FreeSeat
f FreeSeat
g) =
  case (FreeSeat -> AgentSBox
interpretSeatS FreeSeat
f, FreeSeat -> AgentSBox
interpretSeatS FreeSeat
g) of
    (AgentSBox s
sf0 Agent (K STM) s [Post Text] [Post Text]
fag, AgentSBox s
sg0 Agent (K STM) s [Post Text] [Post Text]
gag) -> (s, s) -> Agent (K STM) (s, s) [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox (s
sf0, s
sg0) (Agent (K STM) s [Post Text] [Post Text]
-> Agent (K STM) s [Post Text] [Post Text]
-> Agent (K STM) (s, s) [Post Text] [Post Text]
forall s1 s2.
Agent (K STM) s1 [Post Text] [Post Text]
-> Agent (K STM) s2 [Post Text] [Post Text]
-> Agent (K STM) (s1, s2) [Post Text] [Post Text]
awaitBatchS Agent (K STM) s [Post Text] [Post Text]
fag Agent (K STM) s [Post Text] [Post Text]
gag)
interpretSeatS (SeatRace FreeSeat
f FreeSeat
g) =
  case (FreeSeat -> AgentSBox
interpretSeatS FreeSeat
f, FreeSeat -> AgentSBox
interpretSeatS FreeSeat
g) of
    (AgentSBox s
sf0 Agent (K STM) s [Post Text] [Post Text]
fag, AgentSBox s
sg0 Agent (K STM) s [Post Text] [Post Text]
gag) -> (s, s) -> Agent (K STM) (s, s) [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox (s
sf0, s
sg0) (Agent (K STM) s [Post Text] [Post Text]
-> Agent (K STM) s [Post Text] [Post Text]
-> Agent (K STM) (s, s) [Post Text] [Post Text]
forall s1 s2.
Agent (K STM) s1 [Post Text] [Post Text]
-> Agent (K STM) s2 [Post Text] [Post Text]
-> Agent (K STM) (s1, s2) [Post Text] [Post Text]
raceBatchS Agent (K STM) s [Post Text] [Post Text]
fag Agent (K STM) s [Post Text] [Post Text]
gag)
interpretSeatS (SeatFanOut [FreeSeat]
fs) =
  let hs :: [HAgentS]
hs = (FreeSeat -> HAgentS) -> [FreeSeat] -> [HAgentS]
forall a b. (a -> b) -> [a] -> [b]
map (AgentSBox -> HAgentS
unboxH (AgentSBox -> HAgentS)
-> (FreeSeat -> AgentSBox) -> FreeSeat -> HAgentS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeSeat -> AgentSBox
interpretSeatS) [FreeSeat]
fs
   in [HAgentS]
-> Agent (K STM) [HAgentS] [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox [HAgentS]
hs Agent (K STM) [HAgentS] [Post Text] [Post Text]
fanOutS
interpretSeatS (SeatFanIn [[Post Text]] -> [Post Text]
summary [FreeSeat]
fs) =
  let hs :: [HAgentS]
hs = (FreeSeat -> HAgentS) -> [FreeSeat] -> [HAgentS]
forall a b. (a -> b) -> [a] -> [b]
map (AgentSBox -> HAgentS
unboxH (AgentSBox -> HAgentS)
-> (FreeSeat -> AgentSBox) -> FreeSeat -> HAgentS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeSeat -> AgentSBox
interpretSeatS) [FreeSeat]
fs
   in [HAgentS]
-> Agent (K STM) [HAgentS] [Post Text] [Post Text] -> AgentSBox
forall s. s -> Agent (K STM) s [Post Text] [Post Text] -> AgentSBox
AgentSBox [HAgentS]
hs (([[Post Text]] -> [Post Text])
-> Agent (K STM) [HAgentS] [Post Text] [Post Text]
fanInS [[Post Text]] -> [Post Text]
summary)