gistfile1.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Main where

import Control.Monad.Free
import Control.Monad.State hiding (withState)

import Data.Functor.Coyoneda
import Data.Char (toUpper)

data InteractionC a where
  Ask  :: InteractionC String
  Tell :: String -> InteractionC ()

type Interaction = Free (Coyoneda InteractionC)

ask :: Interaction String
ask = liftF (liftCoyoneda Ask)

tell :: String -> Interaction ()
tell msg = liftF (liftCoyoneda (Tell msg))

withIO :: InteractionC a -> IO a
withIO Ask        = getLine
withIO (Tell msg) = putStrLn msg

withState :: InteractionC a -> State String a
withState Ask        = get
withState (Tell msg) = put msg

type NatT f g = forall a. f a -> g a

runInteraction :: Monad g => NatT InteractionC g -> Interaction a -> g a
runInteraction f = iterM $ \(Coyoneda g x) -> f x >>= g

yell :: Interaction ()
yell = do
  msg <- ask
  tell $ map toUpper msg

main :: IO ()
main = do
  putStrLn "Yelling with IO:"
  runInteraction withIO yell

  putStrLn "Yelling with State:"
  putStrLn $ execState (runInteraction withState yell) "yay, coyoneda!"