{-# options_ghc -Wall #-}
module Control.Monad.Log.Colors where

import Control.Monad.Log
import Data.String
import System.Console.ANSI
import Data.Text.Prettyprint.Doc

-- | Apply 'SGR' codes to a string to modify its display attributes, resetting
-- SGR codes afterward.
wrapSGRCode :: (IsString a, Monoid a) => [SGR] -> a -> a
wrapSGRCode :: [SGR] -> a -> a
wrapSGRCode [SGR]
codes a
t = [a] -> a
forall a. Monoid a => [a] -> a
mconcat
  [ String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR]
codes
  , a
t
  , String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]
  ]

-- | Mapping of 'Severity' levels to SGR styles
severitySgr :: Severity -> [SGR]
severitySgr :: Severity -> [SGR]
severitySgr = \case
  Severity
Emergency  ->
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
Vivid Color
Red
    , ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black
    , ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity
    ]
  Severity
Alert ->
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red
    , ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity
    ]
  Severity
Critical ->
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red
    , ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity
    ]
  Severity
Error ->
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red
    ]
  Severity
Warning ->
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Yellow
    ]
  Severity
Notice ->
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue
    ]
  Severity
Informational -> []
  Severity
Debug -> 
    [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green
    ]

-- | Color based on severity with a custom mapping of severity to SGR styles
colorizeWith
  :: (Monoid msg, IsString msg)
  => (Severity -> [SGR])
  -> WithSeverity msg
  -> WithSeverity msg
colorizeWith :: (Severity -> [SGR]) -> WithSeverity msg -> WithSeverity msg
colorizeWith Severity -> [SGR]
f (WithSeverity Severity
sev msg
msg) =
  Severity -> msg -> WithSeverity msg
forall a. Severity -> a -> WithSeverity a
WithSeverity Severity
sev (msg -> WithSeverity msg) -> msg -> WithSeverity msg
forall a b. (a -> b) -> a -> b
$ [SGR] -> msg -> msg
forall a. (IsString a, Monoid a) => [SGR] -> a -> a
wrapSGRCode (Severity -> [SGR]
f Severity
sev) msg
msg

-- | Color based on severity with the default mapping of severity to SGR styles
colorize 
  :: (Monoid msg, IsString msg)
  => WithSeverity msg
  -> WithSeverity msg
colorize :: WithSeverity msg -> WithSeverity msg
colorize = (Severity -> [SGR]) -> WithSeverity msg -> WithSeverity msg
forall msg.
(Monoid msg, IsString msg) =>
(Severity -> [SGR]) -> WithSeverity msg -> WithSeverity msg
colorizeWith Severity -> [SGR]
severitySgr

renderWithColor :: (Monoid msg, IsString msg, Pretty msg) => WithSeverity msg -> Doc ann
renderWithColor :: WithSeverity msg -> Doc ann
renderWithColor = (msg -> Doc ann) -> WithSeverity msg -> Doc ann
forall a ann. (a -> Doc ann) -> WithSeverity a -> Doc ann
renderWithSeverity msg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (WithSeverity msg -> Doc ann)
-> (WithSeverity msg -> WithSeverity msg)
-> WithSeverity msg
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithSeverity msg -> WithSeverity msg
forall msg.
(Monoid msg, IsString msg) =>
WithSeverity msg -> WithSeverity msg
colorize