Playing with `FreeT`

freet.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad.Trans.Free
import Control.Monad.State
import Control.Monad.IO.Class (liftIO)

import System.IO (hFlush, stdout)

data TeletypeF k
  = GetString (String -> k)
  | PutString String k
  deriving Functor

newtype TeletypeT m a = TeletypeT
  { runTeletypeT :: FreeT TeletypeF m a }
  deriving (Functor, Applicative, Monad, MonadTrans)

class Monad m => MonadTeletype m where
  putString :: String -> m ()
  getString :: m String

instance Monad m => MonadTeletype (TeletypeT m) where
  putString s = TeletypeT (liftF (PutString s ()))
  getString   = TeletypeT (liftF (GetString id))

instance MonadTeletype m => MonadTeletype (KittenStoreT m) where
  putString s = lift (putString s)
  getString   = lift getString

data Kitten = Kitten
  { kittenName :: String }
  deriving Show

data KittenStoreF k
  = PutKitten Kitten k
  | GetAllKittens ([Kitten] -> k)
  deriving Functor

newtype KittenStoreT m a = KittenStoreT
  { runKittenStoreT :: FreeT KittenStoreF m a }
  deriving (Functor, Applicative, Monad, MonadTrans)

class Monad m => MonadKittenStore m where
  putKitten     :: Monad m => Kitten -> m ()
  getAllKittens :: Monad m => m [Kitten]

instance Monad m => MonadKittenStore (KittenStoreT m) where
  putKitten k   = KittenStoreT (liftF (PutKitten k ()))
  getAllKittens = KittenStoreT (liftF (GetAllKittens id))

type Kittens a = KittenStoreT (TeletypeT IO) a

test :: Kittens ()
test = do
  putString "Name that kitty> "
  name  <- getString

  let kitty = Kitten name

  putKitten kitty
  kittens <- getAllKittens
  putString (show kittens ++ "\n")

  test

interpKittenStoreState :: Monad m => KittenStoreT m a -> StateT [Kitten] m a
interpKittenStoreState c = lift (runFreeT (runKittenStoreT c)) >>= \case
  Pure x                 -> return x
  Free (GetAllKittens k) -> get >>= interpKittenStoreState . KittenStoreT . k
  Free (PutKitten x k)   -> modify (x:) >> interpKittenStoreState (KittenStoreT k)

interpTeletypeIO :: MonadIO m => TeletypeT m a -> m a
interpTeletypeIO c = runFreeT (runTeletypeT c) >>= \case
  Pure x               -> return x
  Free (GetString k)   -> liftIO getLine >>= interpTeletypeIO . TeletypeT . k
  Free (PutString s k) -> liftIO (putStr s >> hFlush stdout) >> interpTeletypeIO (TeletypeT k)

runKittens :: Kittens a -> IO a
runKittens = interpTeletypeIO . flip evalStateT [] . interpKittenStoreState

main :: IO ()
main = runKittens test