Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Free monad interpreter

Free monad interpreter pattern

This code has been taken from this two awesome blog posts

I only added the code that shows how to interact with other monads (Either Validation) in several ways and compose programs. Long live to Functors!

{-# LANGUAGE DeriveFunctor #-}

module Main where
  --import Control.Monad
  import Control.Monad.Free
  import Data.Either.Validation

  main :: IO ()
  --main = interpretIO helloWorld
  main = print (interpretPure "nicolas" helloWorld'' [])

  data Terminal a =
      WriteLine String a
      | ReadLine (String -> a)
      deriving (Functor)

  writeLine :: String -> Free Terminal ()
  writeLine s = liftF $ WriteLine s ()
  readLine :: Free Terminal String
  readLine = liftF $ ReadLine id

  validarNombre :: String -> Validation String String
  validarNombre nombre =
    if nombre == "nicolas" then
      Success nombre
    else Failure "Chale, no servia"


  helloWorld :: Free Terminal ()
  helloWorld =
      writeLine "Hi, what's your name?"
      >> readLine
      >>= (return . validarNombre)
      >>= \r -> case r of
        Success s -> writeLine $ "Hello " ++ s
        Failure s -> writeLine $ "Doh, " ++ s

  helloWorld' :: Free Terminal ()
  helloWorld' =
      validarNombre
      <$> (writeLine "Hi, what's your name?" >> readLine)
      >>= \r -> case r of
        Success s -> writeLine $ "Hello " ++ s
        Failure s -> writeLine $ "Doh, " ++ s

  helloWorld'' :: Free Terminal ()
  helloWorld'' = do
      writeLine "Hi, what's your name?"
      name <- readLine
      case validarNombre name of
        Success s -> writeLine $ "Hello " ++ s
        Failure s -> writeLine $ "Doh, " ++ s

  helloWorld''' :: Free Terminal ()
  helloWorld''' =
      fmap validarNombre (writeLine "Hi, what's your name?" >> readLine)
      >>= \r -> case r of
        Success s -> writeLine $ "Hello " ++ s
        Failure s -> writeLine $ "Doh, " ++ s

  interpretIO :: Free Terminal a -> IO a
  interpretIO (Free (WriteLine s a)) = putStrLn s >> interpretIO a
  interpretIO (Free (ReadLine f)) = getLine >>= interpretIO . f
  interpretIO (Pure a) = return a

  interpretPure :: String -> Free Terminal a -> [String] -> [String]
  interpretPure input (Free (WriteLine s next)) ls = interpretPure input next (s:ls)
  interpretPure input (Free (ReadLine f)) ls = interpretPure input (f input) ls
  interpretPure _ (Pure _) ls = reverse ls
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment