-- | Small logging library. Typical usage, import qualified:
--
--   import qualified Unison.Util.Logger as L
--
--   do
--     logger <- L.atomic . L.atInfo . L.scope "worker" . L.toHandle $ stderr
--     L.warn logger "WARNING!!!"
--     L.debug logger "Debug message, will be ignored"
--     let logger2 = L.atDebug logger
--     L.debug logger2 "Debug message, will be printed"
--     logger' <- L.at L.warnLevel
module Unison.Util.Logger where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Exception (bracket)
import Data.List
import System.IO (Handle, hGetLine, hPutStrLn, stderr, stdout)
import System.IO.Error (isEOFError)
import Unison.Prelude

type Level = Int

type Scope = [String]

data Logger = Logger
  { Logger -> Scope
getScope :: !Scope,
    Logger -> [Char] -> [Char]
prefix :: String -> String,
    Logger -> Level
getLevel :: !Level,
    Logger -> [Char] -> IO ()
raw :: String -> IO ()
  }

-- | Ensure at most one message is logged at the same time
atomic :: Logger -> IO Logger
atomic :: Logger -> IO Logger
atomic Logger
logger = do
  MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  pure $
    let raw' :: [Char] -> IO ()
raw' [Char]
msg = IO () -> (() -> IO ()) -> (() -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock) (\()
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) (\()
_ -> Logger -> [Char] -> IO ()
raw Logger
logger [Char]
msg)
     in Logger
logger {raw = raw'}

toHandle :: Handle -> Logger
toHandle :: Handle -> Logger
toHandle Handle
h = ([Char] -> IO ()) -> Logger
logger (Handle -> [Char] -> IO ()
hPutStrLn Handle
h)

toStandardError :: Logger
toStandardError :: Logger
toStandardError = Handle -> Logger
toHandle Handle
stderr

toStandardOut :: Logger
toStandardOut :: Logger
toStandardOut = Handle -> Logger
toHandle Handle
stdout

logHandleAt :: Logger -> Level -> Handle -> IO ()
logHandleAt :: Logger -> Level -> Handle -> IO ()
logHandleAt Logger
logger Level
lvl Handle
h
  | Level
lvl Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
> Logger -> Level
getLevel Logger
logger = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
loop
  where
    loop :: IO ()
loop = do
      Either IOError [Char]
line <- IO [Char] -> IO (Either IOError [Char])
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Handle -> IO [Char]
hGetLine Handle
h)
      case Either IOError [Char]
line of
        Left IOError
ioe
          | IOError -> Bool
isEOFError IOError
ioe -> Logger -> Level -> [Char] -> IO ()
logAt ([Char] -> Logger -> Logger
scope [Char]
"logHandleAt" Logger
logger) Level
3 [Char]
"EOF"
          | Bool
otherwise -> Logger -> Level -> [Char] -> IO ()
logAt ([Char] -> Logger -> Logger
scope [Char]
"logHandleAt" Logger
logger) Level
2 (IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
ioe)
        Right [Char]
line -> Logger -> Level -> [Char] -> IO ()
logAt Logger
logger Level
lvl [Char]
line IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop

logAt' :: Logger -> Level -> IO String -> IO ()
logAt' :: Logger -> Level -> IO [Char] -> IO ()
logAt' Logger
logger Level
lvl IO [Char]
msg
  | Level
lvl Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
<= Logger -> Level
getLevel Logger
logger = IO [Char]
msg IO [Char] -> ([Char] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
msg -> Logger -> [Char] -> IO ()
raw Logger
logger (Logger -> [Char] -> [Char]
prefix Logger
logger [Char]
msg)
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

logAt :: Logger -> Level -> String -> IO ()
logAt :: Logger -> Level -> [Char] -> IO ()
logAt Logger
logger Level
lvl [Char]
msg
  | Level
lvl Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
<= Logger -> Level
getLevel Logger
logger = Logger -> [Char] -> IO ()
raw Logger
logger (Logger -> [Char] -> [Char]
prefix Logger
logger [Char]
msg)
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

scope :: String -> Logger -> Logger
scope :: [Char] -> Logger -> Logger
scope [Char]
s (Logger Scope
s0 [Char] -> [Char]
_ Level
lvl [Char] -> IO ()
raw) = Scope -> ([Char] -> [Char]) -> Level -> ([Char] -> IO ()) -> Logger
Logger Scope
s' [Char] -> [Char]
prefix' Level
lvl [Char] -> IO ()
raw
  where
    prefix' :: [Char] -> [Char]
prefix' [Char]
msg = [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg
    prefix :: [Char]
prefix = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Scope -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " Scope
s' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"] "
    s' :: Scope
s' = [Char]
s [Char] -> Scope -> Scope
forall a. a -> [a] -> [a]
: Scope
s0

scope' :: [String] -> Logger -> Logger
scope' :: Scope -> Logger -> Logger
scope' Scope
s Logger
l = ([Char] -> Logger -> Logger) -> Logger -> Scope -> Logger
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> Logger -> Logger
scope Logger
l Scope
s

logger :: (String -> IO ()) -> Logger
logger :: ([Char] -> IO ()) -> Logger
logger [Char] -> IO ()
log = Scope -> ([Char] -> [Char]) -> Level -> ([Char] -> IO ()) -> Logger
Logger [] [Char] -> [Char]
forall a. a -> a
id Level
0 [Char] -> IO ()
log

error, warn, info, debug, trace :: Logger -> String -> IO ()
error :: Logger -> [Char] -> IO ()
error Logger
l = Logger -> Level -> [Char] -> IO ()
logAt Logger
l Level
errorLevel
warn :: Logger -> [Char] -> IO ()
warn Logger
l = Logger -> Level -> [Char] -> IO ()
logAt Logger
l Level
warnLevel
info :: Logger -> [Char] -> IO ()
info Logger
l = Logger -> Level -> [Char] -> IO ()
logAt Logger
l Level
infoLevel
debug :: Logger -> [Char] -> IO ()
debug Logger
l = Logger -> Level -> [Char] -> IO ()
logAt Logger
l Level
debugLevel
trace :: Logger -> [Char] -> IO ()
trace Logger
l = Logger -> Level -> [Char] -> IO ()
logAt Logger
l Level
traceLevel

error', warn', info', debug', trace' :: Logger -> IO String -> IO ()
error' :: Logger -> IO [Char] -> IO ()
error' Logger
l = Logger -> Level -> IO [Char] -> IO ()
logAt' Logger
l Level
errorLevel
warn' :: Logger -> IO [Char] -> IO ()
warn' Logger
l = Logger -> Level -> IO [Char] -> IO ()
logAt' Logger
l Level
warnLevel
info' :: Logger -> IO [Char] -> IO ()
info' Logger
l = Logger -> Level -> IO [Char] -> IO ()
logAt' Logger
l Level
infoLevel
debug' :: Logger -> IO [Char] -> IO ()
debug' Logger
l = Logger -> Level -> IO [Char] -> IO ()
logAt' Logger
l Level
debugLevel
trace' :: Logger -> IO [Char] -> IO ()
trace' Logger
l = Logger -> Level -> IO [Char] -> IO ()
logAt' Logger
l Level
traceLevel

errorLevel, warnLevel, infoLevel, debugLevel, traceLevel :: Level
(Level
errorLevel, Level
warnLevel, Level
infoLevel, Level
debugLevel, Level
traceLevel) = (Level
1, Level
2, Level
3, Level
4, Level
5)

at :: Level -> Logger -> Logger
at :: Level -> Logger -> Logger
at Level
lvl Logger
logger = Logger
logger {getLevel = lvl}

atError, atWarn, atInfo, atDebug, atTrace :: Logger -> Logger
(Logger -> Logger
atError, Logger -> Logger
atWarn, Logger -> Logger
atInfo, Logger -> Logger
atDebug, Logger -> Logger
atTrace) =
  (Level -> Logger -> Logger
at Level
errorLevel, Level -> Logger -> Logger
at Level
warnLevel, Level -> Logger -> Logger
at Level
infoLevel, Level -> Logger -> Logger
at Level
debugLevel, Level -> Logger -> Logger
at Level
traceLevel)

increment :: Logger -> Logger
increment :: Logger -> Logger
increment (Logger Scope
s [Char] -> [Char]
p Level
n [Char] -> IO ()
l) = Scope -> ([Char] -> [Char]) -> Level -> ([Char] -> IO ()) -> Logger
Logger Scope
s [Char] -> [Char]
p (Level
n Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
1) [Char] -> IO ()
l

decrement :: Logger -> Logger
decrement :: Logger -> Logger
decrement (Logger Scope
s [Char] -> [Char]
p Level
n [Char] -> IO ()
l) = Scope -> ([Char] -> [Char]) -> Level -> ([Char] -> IO ()) -> Logger
Logger Scope
s [Char] -> [Char]
p (Level
n Level -> Level -> Level
forall a. Num a => a -> a -> a
- Level
1) [Char] -> IO ()
l