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"
        ]

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.