HQ App

hq-app.hs

{-# LANGUAGE ScopedTypeVariables #-}
import Prelude
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Maybe
import Pipes
-- import qualified Pipes.Prelude as P
import Pipes.Concurrent

-- The events
data Event = Echo String | Quit

-- The state
type AppState = String

handler :: () -> Consumer Event (StateT AppState (MaybeT IO)) r
handler () = forever $ do
    event  <- request ()
    stateChange <- lift $ do
        case event of
            Echo s -> modify (const s)
            Quit   -> mzero
        get
    liftIO $ putStrLn $ "AppState = " ++ show stateChange

user :: () -> Producer Event IO r
user () = forever $ do
    command <- lift getLine
    case command of
        "quit"   -> respond  Quit
        "error"  -> lift $ putStrLn "error typed in"
        x        -> respond (Echo x)

-- spawn :: Buffer a -> IO (Input a, Output a)

main :: IO (Maybe ())
main = do
    (input, output) <- spawn Unbounded
    forkIO $ do runEffect $ (user     >-> toInput input) ()
                performGC
    runMaybeT $ (`evalStateT` "") $ runEffect $
        (hoist (lift . lift) . fromOutput output >-> handler) ()