Fun with monads

ReaderT.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Fun with monads
module ReaderT where

import           Control.Monad.IO.Class                   ( MonadIO
                                                          , liftIO
                                                          )
import           Control.Monad.Writer.Strict              ( MonadWriter
                                                          , Writer
                                                          , runWriter
                                                          , tell
                                                          , listen
                                                          , pass
                                                          )

-- ReaderT from scratch

newtype ReaderT r m a = ReaderT { unReaderT :: r -> m a }

instance Functor m => Functor (ReaderT r m) where
  fmap f (ReaderT rma) = ReaderT $ fmap f . rma

instance Applicative m => Applicative (ReaderT r m) where
  pure = ReaderT . const . pure
  (ReaderT rmab) <*> (ReaderT rma) = ReaderT $ \r -> rmab r <*> rma r

instance Monad m => Monad (ReaderT r m) where
  return = pure
  (ReaderT rma) >>= f = ReaderT $ \r -> rma r >>= (flip unReaderT r . f)

instance MonadIO m => MonadIO (ReaderT r m) where
  liftIO = ReaderT . const . liftIO

instance MonadWriter w m => MonadWriter w (ReaderT r m) where
  tell = ReaderT . const . tell
  listen (ReaderT rma) = ReaderT $ listen . rma
  pass (ReaderT rmaww) = ReaderT $ pass . rmaww

runReaderT :: ReaderT r m a -> r -> m a
runReaderT (ReaderT rma) = rma

-- MonadReader from scratch

class Monad m => MonadReader r m | m -> r where
  ask :: m r

instance Monad m => MonadReader r (ReaderT r m) where
  ask = ReaderT return

asks :: MonadReader r m => (r -> a) -> m a
asks f = fmap f ask

-- App environment

data Env = Env { _version :: String, _host :: String, _port :: Int }

class HasEnv r where
  env :: r -> Env
  version :: r -> String
  host :: r -> String
  port :: r -> Int

  version = _version . env
  host = _host . env
  port = _port . env

instance HasEnv Env where
  env = id

-- Business logic

class Monad m => Output m where
  outputLn :: String -> m ()

putVersionLn :: (MonadReader r m, Output m, HasEnv r) => m ()
putVersionLn = asks version >>= outputLn

putAddrLn :: (MonadReader r m, Output m, HasEnv r) => m ()
putAddrLn = do
  h <- asks host
  p <- asks port
  outputLn $ h <> ":" <> show p

putVersionAddrLn :: (MonadReader r m, Output m, HasEnv r) => m ()
putVersionAddrLn = putVersionLn >> putAddrLn

-- Util

launch :: (MonadReader r m, Output m, HasEnv r) => (Env -> m () -> t) -> t
launch runner = runner e app
 where
  e   = Env "1.0.0" "localhost" 8080
  app = putVersionAddrLn

-- App with IO stack

newtype AppIO a =
  AppIO { unAppIO :: ReaderT Env IO a }
  deriving (Functor, Applicative, Monad, (MonadReader Env), MonadIO)

instance Output AppIO where
  outputLn = liftIO . putStrLn

runAppIO :: Env -> AppIO a -> IO a
runAppIO e = flip runReaderT e . unAppIO

mainIO :: IO ()
mainIO = launch runAppIO

-- App with pure stack

newtype AppPure a =
  AppPure { unAppPure :: ReaderT Env (Writer [String]) a }
  deriving (Functor, Applicative, Monad, (MonadReader Env), (MonadWriter [String]))

instance Output AppPure where
  outputLn = tell . pure

runAppPure :: Env -> AppPure a -> (a, [String])
runAppPure e = runWriter . flip runReaderT e . unAppPure

mainPure :: IO ()
mainPure = mapM_ putStrLn $ snd $ launch runAppPure