Create a gist now

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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)))
@dnadales

This comment has been minimized.

Show comment
Hide comment
@dnadales

dnadales Nov 30, 2017

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

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

@dnadales

This comment has been minimized.

Show comment
Hide comment
@dnadales

dnadales Nov 30, 2017

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

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment