Created
May 9, 2020 10:50
-
-
Save fycth/335f8df489473ff4a576c98ba1581adc to your computer and use it in GitHub Desktop.
HFM vs MTL
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 GADTSyntax #-} | |
| import Control.Monad.Free | |
| randomRIO :: (Int, Int) -> IO Int | |
| randomRIO = undefined | |
| data LogLevel = Info | |
| type Message = String | |
| -- Algebra (interface) for the LoggerL Free monadic language with only 1 method | |
| data LoggerF next where | |
| LogMessage :: LogLevel -> Message -> (() -> next) -> LoggerF next | |
| -- Functor instance needed for the Free machinery | |
| instance Functor LoggerF where | |
| fmap f (LogMessage lvl msg next) = LogMessage lvl msg (f . next) | |
| -- Free monadic language | |
| type Logger a = Free LoggerF a | |
| data AppF next where | |
| GetRandomInt :: (Int, Int) -> (Int -> next) -> AppF next | |
| EvalLogger :: Logger () -> (() -> next) -> AppF next | |
| instance Functor AppF where | |
| fmap f (GetRandomInt range next) = GetRandomInt range (f . next) | |
| fmap f (EvalLogger logAct next) = EvalLogger logAct (f . next) | |
| type App a = Free AppF a | |
| -- Simple console logger | |
| interpretLoggerF :: LoggerF a -> IO a | |
| interpretLoggerF (LogMessage lvl msg next) = do | |
| putStrLn msg | |
| pure $ next () | |
| runLogger :: Logger a -> IO a | |
| runLogger = foldFree interpretLoggerF | |
| -- Interpreting function | |
| interpretAppF :: AppF a -> IO a | |
| interpretAppF (EvalLogger loggerAct next) = next <$> runLogger loggerAct | |
| interpretAppF (GetRandomInt range next) = next <$> randomRIO range | |
| -- Interpreter entry point | |
| runApp :: App a -> IO a | |
| runApp = foldFree interpretAppF | |
| -- Log message with Info level. | |
| logInfo :: Message -> App () | |
| logInfo msg = evalLogger (logMessage Info msg) | |
| -- Helper function to wrap LoggerF method | |
| logMessage :: LogLevel -> Message -> Logger () | |
| logMessage lvl msg = liftF $ LogMessage lvl msg id | |
| -- Helper function to wrap AppF method | |
| evalLogger :: Logger () -> App () | |
| evalLogger logger = liftF $ EvalLogger logger id | |
| getRandomInt :: (Int, Int) -> App Int | |
| getRandomInt range = liftF $ GetRandomInt range id | |
| printRandomFactorial :: App () | |
| printRandomFactorial = do | |
| n <- getRandomInt (1, 100) | |
| logInfo $ show $ product [1..n] |
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
| randomRIO :: (Int, Int) -> IO Int | |
| randomRIO = undefined | |
| data LogLevel = Info | |
| type Message = String | |
| class Monad m => MonadLogger m where | |
| logMessage :: LogLevel -> Message -> m () | |
| class MonadLogger m => MonadApp m where | |
| getRandomInt :: (Int, Int) -> m Int | |
| instance MonadLogger IO where | |
| logMessage _ = putStrLn | |
| instance MonadApp IO where | |
| getRandomInt range = randomRIO range | |
| runApp :: IO a -> IO a | |
| runApp = id | |
| -- Corresponds to the original @logInfo :: Message -> App ()@ | |
| logInfo :: MonadApp m => Message -> m () | |
| logInfo = logMessage Info | |
| printRandomFactorial :: MonadApp m => m () | |
| printRandomFactorial = do | |
| n <- getRandomInt (1, 100) | |
| logInfo $ show $ product [1..n] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment