How To Add Orville to an Existing Reader Context

This guide will show you how to add Orville to a monad that is already using ReaderT in its monad stack. It builds conceptually on top of the previous guide, which assumed there was not already a ReaderT in the application monad stack. It’s recommended that you read that guide before this one.

The file listing below shows a simple application with its own Application monad that already has a reader context. When there is already a reader context in the application stack it’s generally perferrable to incorporate Orville into the existing reader context rather than adding a new ReaderT layer atop the one that’s already there.

Main.hs (Before) : haskell 
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main
  ( main
  ) where

import qualified Control.Monad.IO.Class as MIO
import qualified Control.Monad.Reader as Reader

data ApplicationContext =
  ApplicationContext
    { applicationGreeting :: String
    }

newtype Application a =
  Application (Reader.ReaderT ApplicationContext IO a)
  deriving
    ( Functor
    , Applicative
    , Monad
    , MIO.MonadIO
    )

getGreeting :: Application String
getGreeting =
  Application (Reader.asks applicationGreeting)

runApplication :: String -> Application a -> IO a
runApplication greeting (Application io) =
  let
    context =
      ApplicationContext
        { applicationGreeting = greeting
        }
  in
    Reader.runReaderT io context

myApplication :: Application ()
myApplication = do
  greeting <- getGreeting
  MIO.liftIO . putStrLn $ greeting

main :: IO ()
main =
  runApplication "Hello Application" myApplication

As in the last guide, we will first add an OrvilleState to our application monad. In this case we’ll add it as a new field to the existing ApplicationContext.

Main.hs : diff 
*** Main.hs (Old)
--- Main.hs (New)
***************
*** 7,8 ****
--- 7,9 ----
  import qualified Control.Monad.Reader as Reader
+ import qualified Orville.PostgreSQL as O
  
***************
*** 11,12 ****
--- 12,14 ----
      { applicationGreeting :: String
+     , applicationOrvilleState :: O.OrvilleState
      }

This requires that the new applicationOrvilleState field be populated in the runApplication function using a ConnectionPool. The ConnectionPool is created in the main function and passed in where runApplication is called.

Main.hs : diff 
*** Main.hs (Old)
--- Main.hs (New)
***************
*** 28,32 ****
  
! runApplication :: String -> Application a -> IO a
! runApplication greeting (Application io) =
    let
      context =
--- 28,37 ----
  
! runApplication :: O.ConnectionPool -> String -> Application a -> IO a
! runApplication pool greeting (Application io) =
    let
+     orvilleState =
+       O.newOrvilleState
+         O.defaultErrorDetailLevel
+         pool
+ 
      context =
***************
*** 34,35 ****
--- 39,41 ----
          { applicationGreeting = greeting
+         , applicationOrvilleState = orvilleState
          }
***************
*** 44,46 ****
  main :: IO ()
! main =
!   runApplication "Hello Application" myApplication
--- 50,62 ----
  main :: IO ()
! main = do
!   pool <-
!     O.createConnectionPool
!         O.ConnectionOptions
!           { O.connectionString = "host=localhost user=postgres password=postgres"
!           , O.connectionNoticeReporting = O.DisableNoticeReporting
!           , O.connectionPoolStripes = O.OneStripePerCapability
!           , O.connectionPoolLingerTime = 10
!           , O.connectionPoolMaxConnections = O.MaxConnectionsPerStripe 1
!           }
! 
!   runApplication pool "Hello Application" myApplication

Now we must declare an instance of HasOrvilleState to allow Orville access to the OrvilleState state that is stored in our custom ApplicationContext field. The askOrvilleState function is generally quite easy to implement. It’s the equivalent of the ask function from the Reader module. In this example we use the asks function from the Reader module to access the applicationOrvilleState field in the reader context.

The localOrvilleState function is the equivalent of the local function from the Reader module. It’s slightly more complicated to implemented because we have adapt the function that Orville passes to localOrvilleState (which has type OrvilleState -> OrvilleState) so that the function is applied within the ApplicationContext. The adapted function is then passed Reader.local to complete our implementation of localOrvilleState. We’ve included a type signature for mkLocalContext in the example so you can clearly see the type of function being passed to Reader.local, but this is not necessary for the code to compile.

Main.hs : diff 
*** Main.hs (Old)
--- Main.hs (New)
***************
*** 24,25 ****
--- 24,39 ----
  
+ instance O.HasOrvilleState Application where
+   askOrvilleState =
+     Application (Reader.asks applicationOrvilleState)
+ 
+   localOrvilleState f (Application reader) =
+     let
+       mkLocalContext :: ApplicationContext -> ApplicationContext
+       mkLocalContext ctx =
+         ctx
+           { applicationOrvilleState = f (applicationOrvilleState ctx)
+           }
+     in
+       Application (Reader.local mkLocalContext reader)
+ 
  getGreeting :: Application String

Once we have defined our instance of HasOrvilleState we can add MonadOrville and MonadOrvilleControl to the list of derived instances for Application.

Main.hs : diff 
*** Main.hs (Old)
--- Main.hs (New)
***************
*** 22,23 ****
--- 22,25 ----
      , MIO.MonadIO
+     , O.MonadOrville
+     , O.MonadOrvilleControl
      )

Now our Application monad is fully equipped with Orville capabilities! The previous guide showed how to add a first table and Orville operation as well. That part is exactly the same from this point, so we won’t include it again here. We’ll conclude this guide with the final listing of Main.hs with all our changes applied.

Main.hs (After) : haskell 
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main
  ( main
  ) where

import qualified Control.Monad.IO.Class as MIO
import qualified Control.Monad.Reader as Reader
import qualified Orville.PostgreSQL as O

data ApplicationContext =
  ApplicationContext
    { applicationGreeting :: String
    , applicationOrvilleState :: O.OrvilleState
    }

newtype Application a =
  Application (Reader.ReaderT ApplicationContext IO a)
  deriving
    ( Functor
    , Applicative
    , Monad
    , MIO.MonadIO
    , O.MonadOrville
    , O.MonadOrvilleControl
    )

instance O.HasOrvilleState Application where
  askOrvilleState =
    Application (Reader.asks applicationOrvilleState)

  localOrvilleState f (Application reader) =
    let
      mkLocalContext :: ApplicationContext -> ApplicationContext
      mkLocalContext ctx =
        ctx
          { applicationOrvilleState = f (applicationOrvilleState ctx)
          }
    in
      Application (Reader.local mkLocalContext reader)

getGreeting :: Application String
getGreeting =
  Application (Reader.asks applicationGreeting)

runApplication :: O.ConnectionPool -> String -> Application a -> IO a
runApplication pool greeting (Application io) =
  let
    orvilleState =
      O.newOrvilleState
        O.defaultErrorDetailLevel
        pool

    context =
      ApplicationContext
        { applicationGreeting = greeting
        , applicationOrvilleState = orvilleState
        }
  in
    Reader.runReaderT io context

myApplication :: Application ()
myApplication = do
  greeting <- getGreeting
  MIO.liftIO . putStrLn $ greeting

main :: IO ()
main = do
  pool <-
    O.createConnectionPool
        O.ConnectionOptions
          { O.connectionString = "host=localhost user=postgres password=postgres"
          , O.connectionNoticeReporting = O.DisableNoticeReporting
          , O.connectionPoolStripes = O.OneStripePerCapability
          , O.connectionPoolLingerTime = 10
          , O.connectionPoolMaxConnections = O.MaxConnectionsPerStripe 1
          }

  runApplication pool "Hello Application" myApplication