{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module WikiMusic.SSR.Console.Logger () where

import Data.ByteString.Lazy qualified as BL
import Data.Text qualified as T
import Data.Time
import Free.AlaCarte
import Relude
import WikiMusic.SSR.Free.Logger

instance Exec Logger where
  execAlgebra :: forall a. Logger (IO a) -> IO a
execAlgebra (LogInfo Text
msg IO a
next) = do
    Text
now <- IO Text
forall (m :: * -> *). MonadIO m => m Text
iso8601
    ()
_ <- Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
textToStdout (Text -> Text -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a -> a -> a
logExpr Text
now Text
"INFO" Text
msg)
    IO a
next
  execAlgebra (LogError Text
msg IO a
next) = do
    Text
now <- IO Text
forall (m :: * -> *). MonadIO m => m Text
iso8601
    ()
_ <- Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
textToStderr (Text -> Text -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a -> a -> a
logExpr Text
now Text
"ERROR" Text
msg)
    IO a
next
  execAlgebra (LogDebug Text
msg IO a
next) = do
    Text
now <- IO Text
forall (m :: * -> *). MonadIO m => m Text
iso8601
    ()
_ <- Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
textToStdout (Text -> Text -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a -> a -> a
logExpr Text
now Text
"DEBUG" Text
msg)
    IO a
next

textToStdout :: (MonadIO m) => Text -> m ()
textToStdout :: forall (m :: * -> *). MonadIO m => Text -> m ()
textToStdout = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> IO ()
BL.hPutStr Handle
stdout (ByteString -> IO ()) -> (Text -> ByteString) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
liner

textToStderr :: (MonadIO m) => Text -> m ()
textToStderr :: forall (m :: * -> *). MonadIO m => Text -> m ()
textToStderr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> IO ()
BL.hPutStr Handle
stderr (ByteString -> IO ()) -> (Text -> ByteString) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
liner

liner :: Text -> Text
liner :: Text -> Text
liner = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")

-- Construct format string according to <http://en.wikipedia.org/wiki/ISO_8601 ISO-8601>.
iso8601 :: (MonadIO m) => m Text
iso8601 :: forall (m :: * -> *). MonadIO m => m Text
iso8601 = do
  UTCTime
n <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let n' :: Text
n' = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale (Text -> String
T.unpack Text
"%Y-%m-%dT%H:%M:%SZ") UTCTime
n
  Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
n'

logExpr :: (Semigroup a, IsString a) => a -> a -> a -> a
logExpr :: forall a. (Semigroup a, IsString a) => a -> a -> a -> a
logExpr a
now a
lev a
msg = a
"[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
now a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"][" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
lev a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"] " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
msg