Logging.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module GLuaFixer.Effects.Logging where

import Control.Monad.IO.Class (liftIO)
import Data.Maybe (isJust)
import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, (:>))
import Effectful.Dispatch.Dynamic (interpret, send)
import qualified Effectful.Environment as Env
import GLuaFixer.LintMessage (LintMessage, LogFormat (..), LogFormatChoice (..), formatLintMessage)
import System.IO (hPutStrLn, stderr)

-- | The effect for emitting lint messages to the right channel
data Logging :: Effect where
  -- | Emit a single lint message in the given format
  EmitLintMessage :: LogFormat -> LintMessage -> Logging m ()
  -- | Find out which logging format to use
  GetLogFormat :: LogFormatChoice -> Logging m LogFormat
  -- | Print a string in stdout
  PutStrLnStdOut :: String -> Logging m ()
  -- | Print a string in stdout
  PutStrStdOut :: String -> Logging m ()
  -- | Print a string in stderr
  PutStrLnStdError :: String -> Logging m ()

type instance DispatchOf Logging = Dynamic

putStrLnStdError :: Logging :> es => String -> Eff es ()
putStrLnStdError str = send $ PutStrLnStdError str

putStrStdOut :: Logging :> es => String -> Eff es ()
putStrStdOut str = send $ PutStrStdOut str

putStrLnStdOut :: Logging :> es => String -> Eff es ()
putStrLnStdOut str = send $ PutStrLnStdOut str

getLogFormat :: Logging :> es => LogFormatChoice -> Eff es LogFormat
getLogFormat logFormatChoice = send $ GetLogFormat logFormatChoice

emitLintMessage :: Logging :> es => LogFormat -> LintMessage -> Eff es ()
emitLintMessage logFormat lintMessage = send $ EmitLintMessage logFormat lintMessage

-- | Run the logging in IO
runLoggingIO :: (IOE :> es, Env.Environment :> es) => Eff (Logging : es) a -> Eff es a
runLoggingIO = interpret $ \_ -> \case
  EmitLintMessage logFormat lintMessage -> case logFormat of
    StandardLogFormat ->
      liftIO $ putStrLn $ formatLintMessage StandardLogFormat lintMessage
    GithubLogFormat -> do
      liftIO $ putStrLn $ formatLintMessage GithubLogFormat lintMessage
      liftIO $ putStrLn $ formatLintMessage StandardLogFormat lintMessage
  GetLogFormat (LogFormatChoice format) -> pure format
  GetLogFormat AutoLogFormatChoice -> do
    actionsExists <- isJust <$> Env.lookupEnv "GITHUB_ACTIONS"
    workflowExists <- isJust <$> Env.lookupEnv "GITHUB_WORKFLOW"

    pure $
      if actionsExists && workflowExists
        then GithubLogFormat
        else StandardLogFormat
  PutStrLnStdOut str ->
    liftIO $ putStrLn str
  PutStrStdOut str ->
    liftIO $ putStr str
  PutStrLnStdError str ->
    liftIO $ hPutStrLn stderr str

runLoggingPureNoop :: Eff (Logging : es) a -> Eff es a
runLoggingPureNoop = interpret $ \_ -> \case
  EmitLintMessage _ _ -> pure ()
  GetLogFormat (LogFormatChoice format) -> pure format
  GetLogFormat AutoLogFormatChoice -> pure StandardLogFormat
  PutStrLnStdOut _ -> pure ()
  PutStrStdOut _ -> pure ()
  PutStrLnStdError _ -> pure ()