Skip to content

Instantly share code, notes, and snippets.

@friedbrice

friedbrice/App.hs

Last active May 13, 2022 05:29
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save friedbrice/28e6c07dff75893288ba14890ec291d7 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save friedbrice/28e6c07dff75893288ba14890ec291d7 to your computer and use it in GitHub Desktop.
Download ZIP
Zero-parameter type classes as a dependency injection framework. (Don't ever do this in real life.)
Raw
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)
Raw
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
Raw
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
Raw
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"
]
@friedbrice
Copy link
Author

friedbrice commented May 12, 2022 •
edited
Loading

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.

@friedbrice
Copy link
Author

friedbrice commented May 12, 2022 •
edited
Loading

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.)

@friedbrice
Copy link
Author

friedbrice commented May 12, 2022 •
edited
Loading

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.

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