Created
October 28, 2014 22:28
-
-
Save tfausak/ef99e90e4deeb67ec9d5 to your computer and use it in GitHub Desktop.
A comparison between explicitly passing function parameters and using a monad transformer stack in Haskell.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE OverloadedStrings #-} | |
import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVar) | |
import Control.Monad.IO.Class (liftIO) | |
import Data.ByteString.Lazy.Char8 (pack) | |
import Network.HTTP.Types (hContentType, status200) | |
import Network.Wai (Application, Request, Response, rawPathInfo, responseLBS) | |
import Network.Wai.Handler.Warp (run) | |
main :: IO () | |
main = do | |
let counter = 0 | |
counterVar <- newTVarIO counter | |
run 8000 (application counterVar) | |
application :: TVar Integer -> Application | |
application counterVar request respond = do | |
response <- action counterVar request | |
respond response | |
action :: TVar Integer -> Request -> IO Response | |
action counterVar request = do | |
counter <- liftIO . atomically $ do | |
modifyTVar counterVar succ | |
readTVar counterVar | |
let route = rawPathInfo request | |
let status = status200 | |
let headers = | |
[ (hContentType, "text/plain") | |
, ("X-Route", route) | |
] | |
let body = pack (show counter) | |
return (responseLBS status headers body) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
module MainWithState where | |
import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVar) | |
import Control.Monad.IO.Class (liftIO) | |
import Control.Monad.State (StateT, evalStateT, get) | |
import Control.Monad.Trans.Class (lift) | |
import Data.ByteString.Lazy.Char8 (pack) | |
import Network.HTTP.Types (hContentType, status200) | |
import Network.Wai (Application, Request, Response, rawPathInfo, responseLBS) | |
import Network.Wai.Handler.Warp (run) | |
main :: IO () | |
main = do | |
let counter = 0 :: Integer | |
counterVar <- newTVarIO counter | |
run 8000 (application counterVar) | |
application :: TVar Integer -> Application | |
-- We could generalize this type signature based on our usage of `show` and | |
-- `succ`. | |
-- application :: (Enum a, Show a) => TVar a -> Application | |
application counterVar request respond = do | |
response <- evalStateT (evalStateT action counterVar) request | |
-- We could express this from the inside out using `flip` and `$`. | |
-- response <- flip evalStateT request $ flip evalStateT counterVar $ action | |
-- Or we could define a helper function that accepts the states as parameters. | |
-- response <- let runAction x y = evalStateT (evalStateT action x) y in runAction counterVar request | |
respond response | |
action :: StateT (TVar Integer) (StateT Request IO) Response | |
-- This type signature can also be generalized. In fact, you would have to if | |
-- you changed the one for `application`. | |
-- action :: (Enum a, Show a) => StateT (TVar a) (StateT Request IO) Response | |
-- We could also generalize the stateful part of it. This allows the request | |
-- state to be implemented using any instance of `MonadState` that wraps an | |
-- instance of `MonadIO`. | |
-- action :: (MonadState Request m, MonadIO m) => StateT (TVar Integer) m Response | |
action = do | |
counterVar <- get | |
counter <- liftIO . atomically $ do | |
modifyTVar counterVar succ | |
readTVar counterVar | |
request <- lift get | |
let route = rawPathInfo request | |
let status = status200 | |
let headers = | |
[ (hContentType, "text/plain") | |
, ("X-Route", route) | |
] | |
let body = pack (show counter) | |
return (responseLBS status headers body) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment