Update Main example

Also make Teletype example more useful
(= show how to make evaluators more composable).

examples/src/Main.hs

@@ -1,22 +1,51 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 module Main where
 
+import Control.Monad (forever, when)
+import System.Environment (getArgs)
+
 import Control.Monad.Freer
+
+import Capitalize
 import Teletype
 
-runner :: (Member Teletype r) => Eff r ()
-runner = do
-  x <- getLine'
-  _ <- getLine'
-  putStrLn' x
-  z <- getLine'
-  putStrLn' z
-  putStrLn' x
-  putStrLn' x
+-------------------------------------------------------------------------------
+-- Example
+-------------------------------------------------------------------------------
+capitalizingTeletype :: (Member Teletype r, Member Capitalize r) => Eff r ()
+capitalizingTeletype = forever $ do
+    putStrLn' "Send something to capitalize..."
+    l <- getLine'
+    when (null l) exitSuccess'
+    capitalize l >>= putStrLn'
+-------------------------------------------------------------------------------
+
+mainPure :: IO ()
+mainPure = print . run
+    . runTeletypePureM ["cat", "fish", "dog", "bird", ""]
+    $ runCapitalizeM capitalizingTeletype
+
+mainConsoleA :: IO ()
+mainConsoleA = runM (runTeletypeM (runCapitalizeM capitalizingTeletype))
+--             |     |             |              |
+--      IO () -'     |             |              |
+--     Eff '[IO] () -'             |              |
+--         Eff '[Teletype, IO] () -'              |
+--            Eff '[Capitalize, Teletype, IO] () -'
+
+mainConsoleB :: IO ()
+mainConsoleB = runM (runCapitalizeM (runTeletypeM capitalizingTeletype))
+--             |     |             |              |
+--      IO () -'     |             |              |
+--     Eff '[IO] () -'             |              |
+--       Eff '[Capitalize, IO] () -'              |
+--            Eff '[Teletype, Capitalize, IO] () -'
 
 main :: IO ()
-main = do
-  let xs = runTeletypePure ["cat", "fish", "dog", "bird"] runner
-  print xs
-  runTeletype runner
+main = getArgs >>= \case
+    ["pure"] -> mainPure
+    ["consoleA"] -> mainConsoleA
+    ["consoleB"] -> mainConsoleB
+    _ -> putStrLn "Bad argument. Look into source for possible values."

examples/src/Teletype.hs

@@ -11,10 +11,11 @@ import Control.Applicative (pure)
 import System.Exit hiding (ExitSuccess)
 
 import Control.Monad.Freer
+import Control.Monad.Freer.Internal
 
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
                           -- Effect Model --
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
 data Teletype s where
   PutStrLn    :: String -> Teletype ()
   GetLine     :: Teletype String
@@ -29,9 +30,9 @@ getLine' = send GetLine
 exitSuccess' :: Member Teletype r => Eff r ()
 exitSuccess' = send ExitSuccess
 
---------------------------------------------------------------------------------
-                     -- Effectful Interpreter --
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+                     -- Effectful Interpreter Simple --
+-------------------------------------------------------------------------------
 runTeletype :: Eff '[Teletype, IO] w -> IO w
 runTeletype req = runM (handleRelay pure go req)
   where
@@ -40,9 +41,9 @@ runTeletype req = runM (handleRelay pure go req)
    go GetLine q = send getLine >>= q
    go ExitSuccess q = send exitSuccess >>= q
 
---------------------------------------------------------------------------------
-                        -- Pure Interpreter --
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+                        -- Pure Interpreter Simple --
+-------------------------------------------------------------------------------
 runTeletypePure :: [String] -> Eff '[Teletype] w -> [String]
 runTeletypePure inputs req =
   reverse . snd $ run (handleRelayS (inputs, []) (\s _ -> pure s) go req)
@@ -55,3 +56,37 @@ runTeletypePure inputs req =
     go (i:is, os) GetLine q = q (is, os) i
     go ([], _) GetLine _ = error "Not enough lines"
     go (_, os) ExitSuccess _ = pure ([], os)
+
+
+-------------------------------------------------------------------------------
+                     -- Effectful Interpreter for Deeper Stack --
+-------------------------------------------------------------------------------
+runTeletypeM :: Member IO r => Eff (Teletype ': r) w -> Eff r w
+runTeletypeM (Val x) = return x
+runTeletypeM (E u q) = case decomp u of
+    Right (PutStrLn msg) -> send (putStrLn msg) >> runTeletypeM (qApp q ())
+    Right GetLine        -> send getLine >>= \s -> runTeletypeM (qApp q s)
+    Right ExitSuccess    -> send exitSuccess
+    Left u'              -> E u' (tsingleton (\s -> runTeletypeM (qApp q s)))
+
+-------------------------------------------------------------------------------
+                     -- Pure Interpreter for Deeper Stack --
+-------------------------------------------------------------------------------
+runTeletypePureM
+    :: [String]
+    -> Eff (Teletype ': r) w
+    -> Eff r (Maybe w,([String],[String]))
+    -- ^ (Nothing for ExitSuccess, (unconsumed input, produced output))
+runTeletypePureM inputs = f (inputs,[]) where
+    f
+        :: ([String],[String])
+        -> Eff (Teletype ': r) w
+        -> Eff r (Maybe w,([String],[String]))
+    f st (Val x) = return (Just x, st)
+    f st@(is,os) (E u q) = case decomp u of
+        Right (PutStrLn msg) -> f (is, msg : os) (qApp q ())
+        Right GetLine        -> case is of
+            x:s -> f (s,os) (qApp q x)
+            []  -> error "Not enough lines"
+        Right ExitSuccess    -> pure (Nothing, st)
+        Left u'              -> E u' (tsingleton (\s -> f st (qApp q s)))