Mealy Machine experiments

Main.purs

module Main where

import Control.Applicative (class Applicative, pure)
import Control.Bind (bind)
import Control.Category (id)
import Control.Monad (class Monad)
import Control.Monad.Aff (Aff, forkAff, later', makeAff, runAff)
import Control.Monad.Aff.Console (CONSOLE, log, logShow)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (errorShow)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Machine.Mealy (MealyT, Step(..), loop, mealy, runMealy, singleton, sink, source, stepMealy, take, wrapEffect)
import Data.Monoid (class Monoid, mempty, (<>))
import Data.String (toUpper)
import Data.Unit (Unit, unit)
import Node.ReadLine (READLINE, close, createConsoleInterface, noCompletion, prompt, setLineHandler, setPrompt)
import Prelude (const, void, ($), (>>=), (>>>), (<$>))

type Effects eff = (console :: CONSOLE, readline :: READLINE, err :: EXCEPTION | eff)

readLine :: forall eff. Aff (console :: CONSOLE, readline :: READLINE, err :: EXCEPTION | eff) String
readLine = makeAff \reject resolve -> do
    interface <- createConsoleInterface noCompletion
    setPrompt "> " 2 interface
    prompt interface
    setLineHandler interface \str -> do
        close interface
        resolve str

delay :: forall s m. s -> (Applicative m) => MealyT m s s
delay v = mealy \s -> pure (Emit v (delay s))

wait :: forall a eff. Int -> MealyT (Aff (Effects eff)) a a
wait msecs = loop do
    x <- id
    wrapEffect $ makeAff \reject resolve -> void $ runAff errorShow pure $ later' msecs $ liftEff $ resolve unit
    pure x

interval :: forall eff. Int -> MealyT (Aff (Effects eff)) Unit Unit
interval msecs = singleton unit >>> wait msecs >>> (id >>= (\_ -> interval msecs))

data Command s = Add s | Flush

pool :: forall s m. Monoid s => s -> (Applicative m) => MealyT m (Command s) s
pool v = mealy \cmd -> pure case cmd of
    Add s -> Emit mempty (pool (v <> s))
    Flush -> Emit v (pool mempty)


upper :: forall m. (Monad m) => MealyT m String String
upper = mealy \s -> pure (Emit (toUpper s) upper)


logger :: forall s m. Monoid s => s -> (Applicative m) => MealyT m (Command s) s
logger v = mealy \cmd -> pure case cmd of
    Add s -> Emit s (logger (v <> s))
    Flush -> Emit v (pool v)

interplet :: forall m. (Monad m) => MealyT m String (Command String)
interplet = mealy case _ of
    "flush" -> pure (Emit Flush interplet)
    s -> pure (Emit (Add s) interplet)


---------------------------------------------------------------------------

greetings = take 100 (loop (pure "Merry Christmas!")) >>> sink log


machine :: forall eff. MealyT (Aff (Effects eff)) Unit Unit
machine = source readLine >>> delay mempty >>> sink log

machine' :: forall eff. MealyT (Aff (Effects eff)) Unit Unit
machine' = source readLine >>> interplet >>> pool mempty >>> sink log

machine'' :: forall eff. MealyT (Aff (Effects eff)) Unit Unit
machine'' = source readLine >>> wait 500 >>> sink log

machine''' :: forall eff. MealyT (Aff (Effects eff)) Unit Unit
machine''' = loop (source (later' 500 (pure unit)) >>> singleton "hello" >>> sink log)

machine'''' :: forall eff. MealyT (Aff (Effects eff)) Unit Unit
machine'''' = loop (source readLine >>> interplet >>> logger mempty >>> sink log)

machine''''' :: forall eff. MealyT (Aff (Effects eff)) Unit Unit
machine''''' = source readLine >>> id >>> sink log

main :: forall eff. Eff (Effects eff) Unit
main = void do
    runAff errorShow pure do
        runMealy machine'''''