Reasonably Priced Monads in Haskell

reasonable.hs

-- | simple/basic Scala -> Haskell translation of Runar's presentation
-- | (https://dl.dropboxusercontent.com/u/4588997/ReasonablyPriced.pdf)
-- | trying to use minimal extensions and magic. 
-- | (earlier I had a version using MultiParamTypeClasses for Runar's
-- | Inject class, but scraped it opting for simplicity)
-- | my question: what do we lose by moving towards simplicity?
-- | Future work: use DataKinds, TypeOperators, and potentially TypeFamilies
-- | to maintain and automate the folding of types in Coproduct.

{-# LANGUAGE Rank2Types, DeriveFunctor #-}

module Main where

import Control.Applicative ((<$>), Applicative(..))
import Data.Functor.Coproduct (Coproduct(Coproduct), getCoproduct)

data Free f a = Pure a
              | Free( f (Free f a) )
              deriving Functor

instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure f <*> Pure x = Pure $ f x
  Pure f <*> Free mx = Free $ fmap f <$> mx
  Free mf <*> x = Free $ (<*> x) <$> mf

instance Functor f => Monad (Free f) where
  return = Pure
  Pure x >>= f = f x
  Free mx >>= f = Free ((>>= f) <$> mx)

infixr 6 |*|
(|*|) :: (Functor f, Functor g) => (forall a. f a -> g a) -> (forall b. h b -> g b) -> Coproduct f h c -> g c
fg |*| hg = \x -> case getCoproduct x of
  Left f -> fg f
  Right h -> hg h

-- TOOD: this function will probably explode the stack for deep nesting. can we optimize?
--       is optimization necessary?
threadF :: (Functor f, Functor g) => (forall b. f b -> g b) -> Free f a -> Free g a
threadF _ (Pure x)   = Pure x
threadF t (Free fa) = Free(t $ fmap (threadF t) fa)

-- Data

data Interaction a = Ask String (String -> a)
                   | Tell String a
                   deriving Functor

data User = User String

data Auth a = Login String String (Maybe User -> a)
            | HasPermission User String (Bool -> a)
            deriving Functor

data Logging a = Logging String a deriving Functor

-- Combinators

tellC :: (Functor f) => (forall a. Interaction a -> f a) -> String -> Free f ()
tellC fa msg = threadF fa (Free(Tell msg (Pure ())))

askC :: (Functor f) => (forall a. Interaction a -> f a) -> String -> Free f String
askC fa msg = threadF fa (Free(Ask msg Pure))

loginC :: (Functor f) => (forall a. Auth a -> f a) -> String -> String -> Free f (Maybe User)
loginC fa username password = threadF fa (Free(Login username password Pure))

hasPermissionC :: (Functor f) => (forall a. Auth a -> f a) -> User -> String -> Free f Bool
hasPermissionC fa user permission = threadF fa (Free(HasPermission user permission Pure))

logC :: (Functor f) => (forall a. Logging a -> f a) -> String -> Free f ()
logC fa msg = threadF fa (Free(Logging msg (Pure ())))

-- Program

newtype Program a = Program { run :: Coproduct Interaction (Coproduct Auth Logging) a } deriving Functor

-- Program-specific combinators
-- This is where the complexity happens if you add a new layer

tell :: String -> Free Program ()
tell = tellC (Program . Coproduct . Left)

ask :: String -> Free Program String
ask = askC (Program . Coproduct . Left)

login :: String -> String -> Free Program (Maybe User)
login = loginC (Program . Coproduct . Right . Coproduct . Left)

hasPermission :: User -> String -> Free Program Bool
hasPermission = hasPermissionC (Program . Coproduct . Right . Coproduct . Left)

logger :: String -> Free Program ()
logger = logC (Program . Coproduct . Right . Coproduct . Right)

-- IO Interpreters

interactionIO :: Interaction a -> IO a
interactionIO (Tell msg a) = do
  putStrLn msg
  return a
interactionIO (Ask msg f) = do
  putStrLn msg
  s <- getLine
  return (f s)

authIO :: Auth a -> IO a
authIO (Login _ _ next) = do
  putStrLn "logging in user"
  return (next Nothing)
authIO (HasPermission _ permission next) = return $ next (permission == "admin")

loggingIO :: Logging a -> IO a
loggingIO (Logging msg a) = do
  putStrLn $ "LOG: " ++ msg
  return a

-- A Program

program :: Free Program ()
program = do
  userid <- ask "what's your user id?"
  logger $ "user id: " ++ userid
  pass <- ask "password please:"
  logger $ "password: " ++ pass
  permission <- ask "permission level"
  user <- login userid pass
  case user of
    Just u -> hasPermission u permission >>= \t -> tell (if t then "permission!" else "no permission :(")
    Nothing -> tell "user failed"
  return ()

-- helper

foldRunar :: (Functor f, Monad g) => (forall b. f b -> g b) -> Free f a -> g a
foldRunar _ (Pure a) = return a
foldRunar f (Free fa) = f fa >>= foldRunar f

-- main

main :: IO ()
main = foldRunar ( (interactionIO |*| authIO |*| loggingIO) . run) program