Modern FP with mtl.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Prelude hiding (log)

--------------------------------------------------------------------------------
-- The API for cloud files.
class Monad m => MonadCloud m where
  saveFile :: Path -> Bytes -> m ()
  listFiles :: Path -> m [Path]

type Bytes = String

type Path = String

--------------------------------------------------------------------------------
-- The API for logging.
class Monad m => MonadLog m where
  log :: Level -> String -> m ()

data Level
  = Debug
  | Info

--------------------------------------------------------------------------------
-- The API for REST clients.
class Monad m => MonadRest m where
  get :: Path -> m Bytes
  put :: Path -> Bytes -> m Bytes

--------------------------------------------------------------------------------
-- An instrumenting implementation that adds logging to every call.
newtype CloudFilesLogT m a =
  CloudFilesLogT {runCloudFilesLogging :: m a}
  deriving (Monad,Functor,Applicative,MonadLog)

instance (MonadLog m,MonadCloud m) => MonadCloud (CloudFilesLogT m) where
  saveFile p bytes = do
    log Debug ("Saving file: " ++ p)
    lift (saveFile p bytes)
  listFiles path = do
    log Debug ("Listing " ++ path)
    lift (listFiles path)

instance MonadTrans CloudFilesLogT where
  lift = CloudFilesLogT

--------------------------------------------------------------------------------
-- An implementation of logging to standard out.
newtype StdoutLoggingT m a =
  StdoutLoggingT {runStdoutLoggingT :: m a}
  deriving (Monad,Functor,Applicative,MonadIO)

instance MonadIO m => MonadLog (StdoutLoggingT m) where
  log Info msg = liftIO (putStrLn ("[Info] " ++ msg))
  log Debug msg = liftIO (putStrLn ("[Debug] " ++ msg))

--------------------------------------------------------------------------------
-- An implementation of MonadCloud that uses a REST client.
newtype CloudFilesRestT m a =
  CloudFilesRestT {runCloudFilesRestT :: m a}
  deriving (Monad,Functor,Applicative,MonadRest,MonadLog)

instance MonadRest m => MonadCloud (CloudFilesRestT m) where
  saveFile path bytes = do
    put ("/file/" ++ path) bytes
    return ()
  listFiles path = do
    get ("/files/" ++ path)
    return ["MockFile"]

--------------------------------------------------------------------------------
-- A (non-functional) REST client.
newtype RestClientT m a =
  RestClientT {runRestClient :: m a}
  deriving (Monad,Functor,Applicative,MonadIO,MonadLog)

instance MonadIO m => MonadRest (RestClientT m) where
  get path = do
    liftIO (putStrLn $ "I should GET " ++ path)
    return []
  put path bytes = do
    liftIO (putStrLn $ "I should PUT " ++ path ++ " " ++ bytes)
    return []

--------------------------------------------------------------------------------
-- Our application only talks about MonadCloud and MonadLog.
app :: (MonadCloud m, MonadLog m) => m ()
app = do
  [f] <- listFiles "/home/ollie"
  log Info ("Found " ++ f)
  saveFile f "Ollie"
  return ()

-- Running the application chooses to instrument with extra logging, use the
-- REST client and to send all logs to stdout.
main :: IO ()
main =
  runStdoutLoggingT (runRestClient (runCloudFilesRestT (runCloudFilesLogging app)))

I'm wondering how these ideas could be put to practice when you have orthogonal concerns.

And whether stacking monads have any advantages over using just functions.