free-monad-foldFree.md

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Control.Monad.Except (ExceptT)
import qualified Control.Monad.Except as Except
import Control.Monad.Free
import Control.Monad.Free.TH
import Control.Monad.IO.Class (liftIO)

data Console next
  = ReadLine (String -> next)
  | WriteLine String
              next
  | ThrowError String
  deriving (Functor)

makeFree ''Console

program :: Free Console ()
program = do
  l <- readLine
  throwError "Error"
  writeLine l

interpret' :: Console next -> ExceptT String IO next
interpret' (ReadLine n) = do
  l <- liftIO getLine
  pure $ n l
interpret' (WriteLine l n) = do
  liftIO $ putStrLn l
  pure n
interpret' (ThrowError e) = Except.throwError e

main = do
  r <- Except.runExceptT $ foldFree interpret' program
  print r