co-log-0.7.0.0: tutorials/Main.hs

{-# OPTIONS_GHC -Wno-unused-top-binds #-}

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE TypeApplications           #-}

module Main (main) where

import Prelude hiding (log)

import Control.Concurrent (threadDelay)
import Control.Exception (Exception)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader, ReaderT (..))

import Colog (HasLog (..), LogAction, Message, Msg (..), PureLogger, RichMsg (..), SimpleMsg (..),
              WithLog, cmap, cmapM, defaultFieldMap, fmtMessage, fmtRichMessageDefault,
              fmtSimpleRichMessageDefault, liftLogIO, log, logException, logInfo, logMessagePure,
              logMsg, logMsgs, logPrint, logStringStdout, logText, logTextStderr, logTextStdout,
              logWarning, pattern D, runPureLog, upgradeMessageAction, usingLoggerT, withLog,
              withLogTextFile, (*<), (<&), (>$), (>$<), (>*), (>*<), (>|<))

import Data.Dependent.Map (delete)
import Type.Reflection (typeRep)

example :: WithLog env Message m => m ()
example = do
    log D "First message..."
    logInfo "Second message..."

simpleApp :: (MonadIO m, WithLog env SimpleMsg m) => m ()
simpleApp = do
    logText "First simple message"
    logText "Second simple message"

app :: (WithLog env Message m, MonadIO m) => m ()
app = do
    logWarning "Starting application..."
    liftIO $ threadDelay $ 10 ^ (6 :: Int)
    withLog (cmap addApp) $ do
        example
        exceptionL
        logInfo "Application finished..."
  where
    addApp :: Message -> Message
    addApp msg = msg { msgText = "app: " <> msgText msg }



data ExampleException = ExampleException
    deriving stock (Show)
    deriving anyclass (Exception)

exceptionL :: (WithLog env Message m) => m ()
exceptionL = logException ExampleException

----------------------------------------------------------------------------
-- Message passing with pipes: &> and <&

-- Remember:
-- (<&) :: LogAction m msg -> msg -> m ()
----------------------------------------------------------------------------

data Collatz = Collatz {even :: Bool, n :: Int, iteration :: Int}

collatz :: LogAction IO String -> Collatz -> IO ()
collatz logger (Collatz False 1 iter) =
    logger <& ("Found 1 after " ++ show iter ++ " iterations")
collatz logger (Collatz even' x iter) = do
    logger <& (show x ++ " on iteration " ++ show iter)
    let newN = if even' then x `div` 2 else 3 * x + 1
    collatz logger $ Collatz (newN `mod` 2 == 0) newN (iter + 1)

----------------------------------------------------------------------------
-- Section with contravariant combinators example
----------------------------------------------------------------------------

data Engine = Pistons Int | Rocket

engineToEither :: Engine -> Either Int ()
engineToEither e = case e of
    Pistons i -> Left i
    Rocket    -> Right ()

data Car = Car
    { carMake   :: String
    , carModel  :: String
    , carEngine :: Engine
    }

carToTuple :: Car -> (String, (String, Engine))
carToTuple (Car make model engine) = (make, (model, engine))

stringL :: LogAction IO String
stringL = logStringStdout

-- Returns log action that logs given string ignoring its input.
constL :: String -> LogAction IO a
constL s = s >$ stringL

intL :: LogAction IO Int
intL = logPrint

-- log actions that logs single car module
carL :: LogAction IO Car
carL = carToTuple
    >$< (constL "Logging make..." *< stringL >* constL "Finished logging make...")
    >*< (constL "Logging model.." *< stringL >* constL "Finished logging model...")
    >*< ( engineToEither
      >$< constL "Logging pistons..." *< intL
      >|< constL "Logging rocket..."
        )

----------------------------------------------------------------------------
-- Custom monad and logger actions of different types
----------------------------------------------------------------------------

data Env m = Env
    { envLogString :: LogAction m String
    , envLogInt    :: LogAction m Int
    }

instance HasLog (Env m) String m where
    getLogAction :: Env m -> LogAction m String
    getLogAction = envLogString

    setLogAction :: LogAction m String -> Env m -> Env m
    setLogAction newAction env = env { envLogString = newAction }

instance HasLog (Env m) Int m where
    getLogAction :: Env m -> LogAction m Int
    getLogAction = envLogInt

    setLogAction :: LogAction m Int -> Env m -> Env m
    setLogAction newAction env = env { envLogInt = newAction }

newtype FooM a = FooM
    { runFooM :: ReaderT (Env FooM) IO a
    } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Env FooM))

usingFooM :: Env FooM -> FooM a -> IO a
usingFooM env = flip runReaderT env . runFooM

foo :: (WithLog env String m, WithLog env Int m) => m ()
foo = do
    logMsg ("String message..." :: String)
    logMsg @Int 42

logFoo :: IO ()
logFoo = usingFooM env foo
  where
    env :: Env FooM
    env = Env
        { envLogString = liftLogIO logStringStdout
        , envLogInt    = liftLogIO logPrint
        }

----------------------------------------------------------------------------
-- main runner
----------------------------------------------------------------------------

main :: IO ()
main = withLogTextFile "tutorials/example.log" $ \logTextFile -> do
    let runApp :: LogAction IO Message -> IO ()
        runApp action = usingLoggerT action app

    let runSimpleApp :: LogAction IO SimpleMsg -> IO ()
        runSimpleApp action = usingLoggerT action simpleApp

    let textAction = logTextStdout <> logTextStderr <> logTextFile

    let simpleMessageAction = cmap  fmtMessage            textAction
    let richMessageAction   = cmapM fmtRichMessageDefault textAction

    let richSimpleAction :: LogAction IO (RichMsg IO SimpleMsg)
        richSimpleAction = cmapM fmtSimpleRichMessageDefault textAction

    let simpleAction :: LogAction IO SimpleMsg
        simpleAction = upgradeMessageAction defaultFieldMap richSimpleAction

    let fullMessageAction = upgradeMessageAction defaultFieldMap richMessageAction
    let semiMessageAction = upgradeMessageAction
                                (delete (typeRep @"threadId") defaultFieldMap)
                                richMessageAction

    runApp simpleMessageAction
    runApp fullMessageAction
    runApp semiMessageAction

    runSimpleApp simpleAction

    usingLoggerT carL $ logMsg $ Car "Toyota" "Corolla" (Pistons 4)

    let pureAction :: PureLogger Message ()
        pureAction = usingLoggerT logMessagePure example
    let ((), msgs) = runPureLog pureAction
    usingLoggerT simpleMessageAction $ logMsgs msgs

    logFoo