module Freckle.App.RIO
( toAppLogLevel
, fromAppLogLevel
, makeLogFunc
) where
import Freckle.App.Prelude
import Control.Monad.Logger (Loc(..), LogLevel(..))
import Freckle.App.Logging
import GHC.Exception (CallStack, SrcLoc(..), getCallStack)
import qualified RIO
toAppLogLevel :: RIO.LogLevel -> LogLevel
toAppLogLevel :: LogLevel -> LogLevel
toAppLogLevel = \case
LogLevel
RIO.LevelDebug -> LogLevel
LevelDebug
LogLevel
RIO.LevelInfo -> LogLevel
LevelInfo
LogLevel
RIO.LevelWarn -> LogLevel
LevelWarn
LogLevel
RIO.LevelError -> LogLevel
LevelError
RIO.LevelOther Text
x -> Text -> LogLevel
LevelOther Text
x
fromAppLogLevel :: LogLevel -> RIO.LogLevel
fromAppLogLevel :: LogLevel -> LogLevel
fromAppLogLevel = \case
LogLevel
LevelDebug -> LogLevel
RIO.LevelDebug
LogLevel
LevelInfo -> LogLevel
RIO.LevelInfo
LogLevel
LevelWarn -> LogLevel
RIO.LevelWarn
LogLevel
LevelError -> LogLevel
RIO.LevelError
LevelOther Text
x -> Text -> LogLevel
RIO.LevelOther Text
x
makeLogFunc :: HasLogging a => a -> IO RIO.LogFunc
makeLogFunc :: a -> IO LogFunc
makeLogFunc a
app = do
(ByteString -> IO ()
putLogLine, Bool
isANSI) <- a -> IO (ByteString -> IO (), Bool)
forall a. HasLogging a => a -> IO (ByteString -> IO (), Bool)
getLogBehaviors a
app
LogFunc -> IO LogFunc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogFunc -> IO LogFunc) -> LogFunc -> IO LogFunc
forall a b. (a -> b) -> a -> b
$ (CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
RIO.mkLogFunc ((CallStack -> Text -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc)
-> (CallStack -> Text -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
forall a b. (a -> b) -> a -> b
$ \CallStack
cs Text
src LogLevel
rioLevel Utf8Builder
builder -> do
let
level :: LogLevel
level = LogLevel -> LogLevel
toAppLogLevel LogLevel
rioLevel
msg :: Text
msg = Utf8Builder -> Text
RIO.utf8BuilderToText Utf8Builder
builder
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> LogLevel
forall a. HasLogging a => a -> LogLevel
getLogLevel a
app) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
putLogLine (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ case a -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat a
app of
LogFormat
FormatJSON -> Maybe Loc -> Maybe Text -> LogLevel -> Text -> ByteString
forall a.
ToJSON a =>
Maybe Loc -> Maybe Text -> LogLevel -> a -> ByteString
formatJson (Loc -> Maybe Loc
forall a. a -> Maybe a
Just (Loc -> Maybe Loc) -> Loc -> Maybe Loc
forall a b. (a -> b) -> a -> b
$ CallStack -> Loc
callStackToLoc CallStack
cs) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
src) LogLevel
level Text
msg
LogFormat
FormatTerminal -> Bool -> Loc -> Text -> LogLevel -> Text -> ByteString
forall a.
ToLogStr a =>
Bool -> Loc -> Text -> LogLevel -> a -> ByteString
formatTerminal Bool
isANSI (CallStack -> Loc
callStackToLoc CallStack
cs) Text
src LogLevel
level Text
msg
callStackToLoc :: CallStack -> Loc
callStackToLoc :: CallStack -> Loc
callStackToLoc CallStack
cs = Loc -> Maybe Loc -> Loc
forall a. a -> Maybe a -> a
fromMaybe Loc
unknownLoc (Maybe Loc -> Loc) -> Maybe Loc -> Loc
forall a b. (a -> b) -> a -> b
$ do
([Char]
_, SrcLoc {Int
[Char]
srcLocPackage :: SrcLoc -> [Char]
srcLocModule :: SrcLoc -> [Char]
srcLocFile :: SrcLoc -> [Char]
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: [Char]
srcLocModule :: [Char]
srcLocPackage :: [Char]
..}) <- [([Char], SrcLoc)] -> Maybe ([Char], SrcLoc)
forall a. [a] -> Maybe a
listToMaybe ([([Char], SrcLoc)] -> Maybe ([Char], SrcLoc))
-> [([Char], SrcLoc)] -> Maybe ([Char], SrcLoc)
forall a b. (a -> b) -> a -> b
$ CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
cs
Loc -> Maybe Loc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Loc -> Maybe Loc) -> Loc -> Maybe Loc
forall a b. (a -> b) -> a -> b
$ Loc :: [Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Loc
{ loc_filename :: [Char]
loc_filename = [Char]
srcLocFile
, loc_package :: [Char]
loc_package = [Char]
srcLocPackage
, loc_module :: [Char]
loc_module = [Char]
srcLocModule
, loc_start :: CharPos
loc_start = (Int
srcLocStartLine, Int
srcLocStartCol)
, loc_end :: CharPos
loc_end = (Int
srcLocEndLine, Int
srcLocEndCol)
}
unknownLoc :: Loc
unknownLoc :: Loc
unknownLoc = Loc :: [Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Loc
{ loc_filename :: [Char]
loc_filename = [Char]
"<unknown>"
, loc_package :: [Char]
loc_package = [Char]
"<unknown>"
, loc_module :: [Char]
loc_module = [Char]
"unknown"
, loc_start :: CharPos
loc_start = (Int
0, Int
0)
, loc_end :: CharPos
loc_end = (Int
0, Int
0)
}