-- | Compatibility between "Freckle.App" and "RIO"
--
-- "Freckle.App" was created before "RIO" existed. We need to decide if we're
-- going to move to using "RIO" without "Freckle.App" (and port the things
-- we've added to be "RIO"-based), or not.
--
-- As part of that decisions, some Apps are using "RIO". These should still be
-- able to make use of "Freckle.App", by using this module.
--
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)
  }