Internal.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : GHCup.Utils.Logger.Internal
Description : logger definition
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable

Breaking import cycles.
-}
module GHCup.Prelude.Logger.Internal where

import GHCup.Types
import GHCup.Types.Optics

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text              ( Text )
import Optics
import Prelude                hiding ( appendFile )
import System.Console.Pretty

import qualified Data.Text as T

logInfo :: ( MonadReader env m
           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
           , MonadIO m
           )
        => Text
        -> m ()
logInfo = logInternal Info

logWarn :: ( MonadReader env m
           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
           , MonadIO m
           )
        => Text
        -> m ()
logWarn = logInternal Warn

logDebug :: ( MonadReader env m
            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
            , MonadIO m
            )
         => Text
         -> m ()
logDebug = logInternal (Debug 1)

logDebug2 :: ( MonadReader env m
            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
            , MonadIO m
            )
         => Text
         -> m ()
logDebug2 = logInternal (Debug 2)

logError :: ( MonadReader env m
            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
            , MonadIO m
            )
         => Text
         -> m ()
logError = logInternal Error


logInternal :: ( MonadReader env m
               , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
               , MonadIO m
               ) => LogLevel
                 -> Text
                 -> m ()
logInternal logLevel msg = do
  LoggerConfig {..} <- gets @"loggerConfig"
  let color' c = if fancyColors then color c else id
  let style' = case logLevel of
        Debug _ -> style Bold . color' Blue
        Info    -> style Bold . color' Green
        Warn    -> style Bold . color' Yellow
        Error   -> style Bold . color' Red
  let l = case logLevel of
        Debug _ -> style' "[ Debug ]"
        Info    -> style' "[ Info  ]"
        Warn    -> style' "[ Warn  ]"
        Error   -> style' "[ Error ]"
  let strs = T.split (== '\n') . T.dropWhileEnd (`elem` ("\n\r" :: String)) $ msg
  let out = case strs of
              [] -> T.empty
              (x:xs) ->
                  foldr (\a b -> a <> "\n" <> b) mempty
                . ((l <> " " <> x) :)
                . fmap (\line' -> style' "[ ...   ] " <> line' )
                $ xs

  case logLevel of
    Debug lvl
      | Just cfgLvl <- lcPrintDebugLvl
      , lvl <= cfgLvl
      -> liftIO $ consoleOutter out
    Info  -> liftIO $ consoleOutter out
    Warn  -> liftIO $ consoleOutter out
    Error -> liftIO $ consoleOutter out
    _ -> pure ()

  -- raw output
  let lr = case logLevel of
        Debug _ -> "Debug:"
        Info    -> "Info:"
        Warn    -> "Warn:"
        Error   -> "Error:"
  let outr = lr <> " " <> msg <> "\n"
  liftIO $ fileOutter outr