Zero-parameter type classes as a dependency injection framework. (Don't ever do this in real life.)

App.hs

module Yolo.App where

import Yolo.Capabilities

app :: (Console, Database, Exception, Logging) => IO ()
app = do
  x1 <- loggingDivision 6 2
  x2 <- loggingDivision 5 0

  x3 <- consoleDivision

  x4 <- lookupDivision 6 2
  x5 <- loggingDivision 5 0

  x6 <- throwingDivision 6 2
  x7 <- throwingDivision 5 0
  
  putLine $ encodeInt (product [x1, x2, x3, x4, x5, x6, x7])

loggingDivision :: (Logging) => Int -> Int -> IO Int
loggingDivision x y =
  if y == 0
    then do
      log Warn "Division by zero."
      return 0
    else 
      return (x `div` y)

consoleDivision :: (Console) => IO Int
consoleDivision = do
  let prompt :: (ByteString -> Maybe a) -> ByteString -> IO a
      prompt read msg = do
        putLine msg
        res <- fmap read getLine
        case res of
          Nothing -> prompt read msg
          Just x -> return x

  x <- prompt decodeInt "Numerator:"
  y <- prompt (mfilter (/= 0) . decodeInt) "Denominator:"
  let z = x `div` y
  putLine ("Answer: " <> encodeInt z)
  return z

lookupDivision :: (Database) => Int -> Int -> IO Int
lookupDivision x y = do
  let backoff :: Int -> IO DatabaseResult -> IO ByteString
      backoff n send = do
        res <- send
        case res of
          DatabaseRow x ->
            return x
          DatabaseError _ -> do
            sleep n
            backoff (n * 2) send

  backoff 1 (sendStatement divisionQuery [serialize x, serialize y])

throwingDivision :: (Throwing) => Int -> Int -> IO Int
throwingDivision x y = do
  if y == 0
    then throw DivisionByZeroError
    else return (x `div` y)

Capabilities.hs

module Yolo.Capabilities where

class Logging where
  log :: LogLevel -> LogMessage -> IO ()

class Console where
  getLine :: IO ByteString
  putLine :: ByteString -> IO ()

data DatabaseResult
  = DatabaseError ByteString
  | DatabaseRow ByteString

class Database where
  sendStatement :: SqlStatement -> [SqlValue] -> IO DatabaseResult

class Throwing where
  throw :: Error -> IO a

Main.hs

module Yolo.Main where

import Yolo.Capabilities
import Yolo.App

import Data.ByteString.Char8 as Char8

data Config =
  Config
    { connStr :: String
    , logLevel :: LogLevel
    , logPath :: Maybe FilePath
    }

{-# NOINLINE mainConfig #-}
mainConfig :: Config
mainConfig = unsafePerformIO $ do
  undefined "it's, like, however you get your config"

instance Logging where
  log lvl msg = do
    let formatted = formatLogMessage lvl msg
    if lvl < logLevel mainConfig
      then
        return ()
      else
        case logPath mainConfig of
          Nothing -> Char8.putLine formatted
          Just path -> Char8.appendFile path formatted

instance Throwing where
  throw err = ioError . userError $ show err

{-# NOINLINE mainPool #-}
mainPool :: ConnectionPool
mainPool = unsafePerformIO $ do
  pool <- libfooConnect (connStr mainConfig)
  return pool

instance Database where
  sendStatement qry args = libfooWithConnPool mainPool (prepare qry args)

instance Console where
  getLine = Char8.getLine
  putLine = Char8.putStrLn

main :: IO ()
main = app

Test.hs

module Yolo.Test where

import Yolo.Capabilities
import Yolo.App

import Data.ByteString.Char8 as Char8
import Data.Map as Map

type Mock a b = IORef ([a], [a] -> b)

newMock :: IO (Mock a b)
newMock = newIORef ([], \_ -> error "uninitialized mock")

resetMock :: Mock a b -> ([a] -> b) -> IO ()
resetMock mock fakes = writeIORef mock ([], fakes)

execMock :: Mock a b -> a -> IO b
execMock mock x = do
  (history, fakes) <- readIORef mock
  let history' = x : history
  writeIORef mock (history', fakes)
  return (fakes history')

readMock :: Mock a b -> IO [a]
readMock mock = fmap (reverse . fst) (readIORef mock)

{-# NOINLINE logs #-}
logs :: Mock (LogLevel, LogMessage) ()
logs = unsafePerformIO newMock

instance Logging where
  log lvl msg = execMock logs (lvl, msg)

{-# NOINLINE errors #-}
errors :: Mock Error String
errors = unsafePerformIO newMock

instance Throwing where
  throw err = fmap read (execMock errors err)

{-# NOINLINE database #-}
database :: Mock (SqlStatement, [SqlValue]) (Either DatabaseError DatabaseResult)
database = unsafePerformIO newMock

instance Database where
  sendStatement qry args = execMock database (qry, args)

{-# NOINLINE console #-}
console :: Mock ByteString ByteString
console = unsafePerformIO newMock

instance Console where
  getLine = do
    (history, fakes) <- readIORef console
    let history' = "<getLine>" : history
    writeIORef console (history', fakes)
    return (fakes history')

  putLine y = do
    (history, fakes) <- readIORef console
    let history' = ("<putLine> " <> y) : history
    writeIORef console (history', fakes)

main :: IO ()
main = suite "app" $ do
  let
    initializeMocks :: IO ()
    initializeMocks = do
      resetMock logs $ \_ -> failure "wasn't supposed to log"
      resetMock errors $ \_ -> failure "wasn't supposed to throw"
      resetMock database $ \_ -> failure "wasn't supposed to hit database"
      resetMock console $ \_ -> failure "wasn't supposed to access console"

    historyShouldBe :: Mock a b -> [a] -> IO ()
    historyShouldBe mock expected = do
      xs' <- readMock mock
      xs' `shouldBe` expected

  spec "throwingDivision" $ do
    beforeEach $ do
      initializeMocks
      resetMock errors $ \_ -> 0

    test "6 / 2 = 3" $ do
      x <- throwingDivision 6 2
      x `shouldBe` 3
      errors `historyShouldBe` []

    test "6 / 3 = 2" $ do
      x <- throwingDivision 6 3
      x `shouldBe` 2
      errors `historyShouldBe` []

    test "6 / 0 should throw" $ do
      _ <- throwingDivision 6 0
      errors `historyShouldBe` [DivisionByZeroError]

  spec "loggingDivision" $ do
    beforeEach $ do
      initializeMocks
      resetMock logs $ \_ -> ()

    test "6 / 2 = 3" $ do
      x <- loggingDivision 6 2
      x `shouldBe` 3
      logs `historyShouldBe` []

    test "6 / 3 = 2" $ do
      x <- loggingDivision 6 3
      x `shouldBe` 2
      logs `historyShouldBe` []

    test "6 / 0 should log and default to 0" $ do
      x <- loggingDivision 6 0
      x `shouldBe` 0
      logs `historyShouldBe` [(Warn, "Division by zero.")]

  spec "lookupDivision" $ do
    beforeEach $ do
      initializeMocks
      resetMock database $ \history ->
        let (_,[xRaw, yRaw]) : _ = history
            Just x = deserialize xRaw
            Just y = deserialize yRaw
            result
              | length history > 2 = DatabaseResult (serialize 0)
              | y == 0 = DatabaseError "fake error"
              | otherwise = DatabaseResult $ serialize (x `div` y)
         in result

    test "6 / 2 = 3" $ do
      x <- lookupDivision 6 2
      x `shouldBe` 3
      database `historyShouldBe` [(divisionQuery, [serialize 6, serialize 2])]

    test "6 / 3 = 2" $ do
      x <- lookupDivision 6 3
      x `shouldBe` 2
      database `historyShouldBe` [(divisionQuery, [serialize 6, serialize 3])]

    test "6 / 0 should repeat until success" $ do
      x <- lookupDivision 6 0
      x `shouldBe` 0
      database `historyShouldBe`
        [ (divisionQuery, [serialize 6, serialize 0])
        , (divisionQuery, [serialize 6, serialize 0])
        , (divisionQuery, [serialize 6, serialize 0])
        ]

  spec "consoleDivision" $ do
    beforeEach initializeMocks

    test "6 / 2 = 3" $ do
      resetMock console $ \history ->
        case history of
          [ "<getLine>"
          , "<putLine> Denominator:"
          , "<getLine>"
          , "<putLine> Numerator:"
          ] -> 2
          [ "<getLine>"
          , "<putLine> Numerator:"
          ] -> 6

      x <- consoleDivision
      x `shouldBe` 3
      console `historyShouldBe`
        [ "<putLine> Numerator:"
        , "<getLine>"
        , "<putLine> Denominator:"
        , "<getLine>"
        , "<putLine> Answer: 3"
        ]

    test "6 / 3 = 2" $ do
      resetMock console $ \history ->
        case history of
          [ "<getLine>"
          , "<putLine> Denominator:"
          , "<getLine>"
          , "<putLine> Numerator:"
          ] -> 3
          [ "<getLine>"
          , "<putLine> Numerator:"
          ] -> 6

      x <- consoleDivision
      x `shouldBe` 2
      console `historyShouldBe`
        [ "<putLine> Numerator:"
        , "<getLine>" -- 6
        , "<putLine> Denominator:"
        , "<getLine>" -- 3
        , "<putLine> Answer: 2"
        ]

    test "Input 0 should reprompt" $ do
      resetMock console $ \history ->
        case history of
          [ "<getLine>"
          , "<putLine> Denominator:"
          , "<getLine>"
          , "<putLine> Denominator:"
          , "<getLine>"
          , "<putLine> Numerator:"
          ] -> 1
          [ "<getLine>"
          , "<putLine> Denominator:"
          , "<getLine>"
          , "<putLine> Numerator:"
          ] -> 0
          [ "<getLine>"
          , "<putLine> Numerator:"
          ] -> 5

      x <- consoleDivision
      x `shouldBe` 5
      console `historyShouldBe`
        [ "<putLine> Numerator:"
        , "<getLine>"
        , "<putLine> Denominator:"
        , "<getLine>"
        , "<putLine> Denominator:"
        , "<getLine>"
        , "<putLine> Answer: 5"
        ]

The various config/state objects are not statically known. They remain unknown until runtime. You need unsafePerformIO here in order to be able to refer to these config/state objects from within instance declarations. For example, instance Database needs to be able to refer to mainPool :: ConnectionPool in order to implement sendStatement :: SqlStatement -> [SqlValue] -> IO DatabaseResult.

mainPool :: ConnectionPool
mainPool = unsafePerformIO $ ...

instance Database where
  sendStatement :: SqlStatement -> [SqlValue] -> IO DatabaseResult
  sendStatement qry args = libfooWithConnPool mainPool (prepare qry args)

But, you interject, sendStatement returns an IO _! Can't we refactor to mainPool :: IO ConnectionPool by omitting unsafePerformIO, and then bind the Connection in the definition of sendStatement?

mainPool :: IO ConnectionPool
mainPool = ...

instance Database where
  sendStatement :: SqlStatement -> [SqlValue] -> IO DatabaseResult
  sendStatement qry args = mainPool >>= \pool -> libfooWithConnPool pool (prepare qry args)

Yes, you can do that, here's the subtle thing. Look closely at the new signature for mainPool. We have mainPool :: IO ConnectionPool. A lot of people would interpret that as "an effectful connection pool," or put another way, "a connection pool that does some I/O when you use it." But that's not what IO ConnectionPool means. mainPool can't "[do] I/O when you use it." Nothing in Haskell can "[do] I/O when you use it." The type IO ConnectionPool doesn't mean mainPool is "an effectful connection pool." (What does "effectful" even mean, anyway?) The type IO ConnectionPool means that mainPool is a program that, when executed, will return a connection pool on a successful exit.

So what, isn't that just philosophy? No, not at all. The understanding of this meaning has profound implications for the meaning of our overall program. In particular, consider your refactor.

mainPool yields a connection pool, presumably by connecting. mainPool is a program that, when executed, will create a database connection pool. From this, we see that the refactored sendStatement means "a program that, when executed, will create a database connection pool, use that pool to send a statement, and then return the response from the database." It will create a new connection pool every time it's run.

If we want to be able to use a single connection pool and not reconnect every place sendStatement is used, we need access to an actual ConnectionPool. Having access to an IO ConnectionPool is not enough.

The above considerations illustrate an important principle in Haskell that underscores how it differs from other programming languages. This might even be the biggest single way in which Haskell differs from other programming languages. The principle, summarized, is

Haskell class instances cannot close over runtime values/objects.

In more detail, the principle we just observed in the example above is that the implementations of class instance methods don't have any way of referring to values/objects that are only known at runtime. This principle runs a little deeper than that, though. In fact, nothing in Haskell can close over runtime values/objects. Runtime values/objects must always be passed in as function arguments (unless you do something shady, like use unsafePerformIO). This sounds like a curse, but use Haskell for a while and you'll see that it's really a blessing in disguise. This principle is one of the things that makes Haskell programs reliable and makes Haskell code easy to understand and refactor. ("Easy to understand" once you're familiar with the syntax, obviously. Don't at me.)

In other languages, we try (and often fail) to enforce this same prohibition on implementations referring to runtime values/objects. It's called "Dependency Injection," and we devote thousands of hours to building, learning, and wrestling with various dependency injection frameworks. We try making them fit with our program's needs (trying to fit a square peg in a round hole, frequently).

Haskell gives us this for free, as part of the language semantics.