Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Mealy Machine experiments
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'''''
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment