{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Niv.Logger
( Colors (Always, Never),
job,
setColors,
bug,
tsay,
say,
twarn,
mkWarn,
mkNote,
green,
tgreen,
red,
tred,
blue,
tblue,
yellow,
tyellow,
bold,
tbold,
faint,
tfaint,
)
where
import Control.Monad
import Data.List
import Data.Profunctor
import qualified Data.Text as T
import qualified System.Console.ANSI as ANSI
import System.Exit (exitFailure)
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO
data Colors
= Always
| Never
deriving (Colors -> Colors -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Colors -> Colors -> Bool
$c/= :: Colors -> Colors -> Bool
== :: Colors -> Colors -> Bool
$c== :: Colors -> Colors -> Bool
Eq)
colors :: IORef Colors
colors :: IORef Colors
colors = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Colors
Always
{-# NOINLINE colors #-}
setColors :: Colors -> IO ()
setColors :: Colors -> IO ()
setColors = forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Colors
colors
useColors :: Bool
useColors :: Bool
useColors = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ (\Colors
c -> Colors
c forall a. Eq a => a -> a -> Bool
== Colors
Always) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Colors
colors
type S = String -> String
type T = T.Text -> T.Text
job :: (MonadUnliftIO io, MonadIO io) => String -> io () -> io ()
job :: forall (io :: * -> *).
(MonadUnliftIO io, MonadIO io) =>
String -> io () -> io ()
job String
str io ()
act = do
forall (io :: * -> *). MonadIO io => String -> io ()
say (S
bold String
str)
io ()
indent
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny io ()
act forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* io ()
deindent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right () -> forall (io :: * -> *). MonadIO io => String -> io ()
say forall a b. (a -> b) -> a -> b
$ S
green String
"Done" forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
str
Left SomeException
e -> do
let showErr :: String
showErr = do
let se :: String
se = forall a. Show a => a -> String
show SomeException
e
(if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
se forall a. Ord a => a -> a -> Bool
> Int
40 then String
":\n" else String
": ") forall a. Semigroup a => a -> a -> a
<> String
se
forall (io :: * -> *). MonadIO io => String -> io ()
say forall a b. (a -> b) -> a -> b
$ S
red String
"ERROR" forall a. Semigroup a => a -> a -> a
<> String
showErr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure
where
indent :: io ()
indent = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef Int
jobStack (\Int
x -> (Int
x forall a. Num a => a -> a -> a
+ Int
1, forall a. HasCallStack => a
undefined))
deindent :: io ()
deindent = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef Int
jobStack (\Int
x -> (Int
x forall a. Num a => a -> a -> a
- Int
1, forall a. HasCallStack => a
undefined))
jobStackSize :: MonadIO io => io Int
jobStackSize :: forall (io :: * -> *). MonadIO io => io Int
jobStackSize = forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
jobStack
jobStack :: IORef Int
jobStack :: IORef Int
jobStack = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int
0
{-# NOINLINE jobStackSize #-}
tsay :: MonadIO io => T.Text -> io ()
tsay :: forall (io :: * -> *). MonadIO io => Text -> io ()
tsay = forall (io :: * -> *). MonadIO io => String -> io ()
say forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
say :: MonadIO io => String -> io ()
say :: forall (io :: * -> *). MonadIO io => String -> io ()
say String
msg = do
Int
stackSize <- forall (io :: * -> *). MonadIO io => io Int
jobStackSize
let indent :: String
indent = forall a. Int -> a -> [a]
replicate (Int
stackSize forall a. Num a => a -> a -> a
* Int
2) Char
' '
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ (String
indent forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines String
msg
mkWarn :: T.Text -> T.Text
mkWarn :: Text -> Text
mkWarn Text
w = Text -> Text
tbold (Text -> Text
tyellow Text
"WARNING") forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
w
twarn :: MonadIO io => T.Text -> io ()
twarn :: forall (io :: * -> *). MonadIO io => Text -> io ()
twarn = forall (io :: * -> *). MonadIO io => Text -> io ()
tsay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
mkWarn
mkNote :: T.Text -> T.Text
mkNote :: Text -> Text
mkNote Text
w = Text -> Text
tbold (Text -> Text
tblue Text
"NOTE") forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
w
color :: ANSI.Color -> String -> String
color :: Color -> S
color Color
c String
str =
if Bool
useColors
then
[SGR] -> String
ANSI.setSGRCode [ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity ConsoleIntensity
ANSI.BoldIntensity]
forall a. Semigroup a => a -> a -> a
<> [SGR] -> String
ANSI.setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
c]
forall a. Semigroup a => a -> a -> a
<> String
str
forall a. Semigroup a => a -> a -> a
<> [SGR] -> String
ANSI.setSGRCode [SGR
ANSI.Reset]
else String
str
colorFaint :: ANSI.Color -> String -> String
colorFaint :: Color -> S
colorFaint Color
c String
str =
if Bool
useColors
then
[SGR] -> String
ANSI.setSGRCode [ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity ConsoleIntensity
ANSI.FaintIntensity]
forall a. Semigroup a => a -> a -> a
<> [SGR] -> String
ANSI.setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
c]
forall a. Semigroup a => a -> a -> a
<> String
str
forall a. Semigroup a => a -> a -> a
<> [SGR] -> String
ANSI.setSGRCode [SGR
ANSI.Reset]
else String
str
green :: S
green :: S
green = Color -> S
color Color
ANSI.Green
tgreen :: T
tgreen :: Text -> Text
tgreen = S -> Text -> Text
t S
green
yellow :: S
yellow :: S
yellow = Color -> S
color Color
ANSI.Yellow
tyellow :: T
tyellow :: Text -> Text
tyellow = S -> Text -> Text
t S
yellow
blue :: S
blue :: S
blue = Color -> S
color Color
ANSI.Blue
tblue :: T
tblue :: Text -> Text
tblue = S -> Text -> Text
t S
blue
red :: S
red :: S
red = Color -> S
color Color
ANSI.Red
tred :: T
tred :: Text -> Text
tred = S -> Text -> Text
t S
red
bold :: S
bold :: S
bold = Color -> S
color Color
ANSI.White
tbold :: T
tbold :: Text -> Text
tbold = S -> Text -> Text
t S
bold
faint :: String -> String
faint :: S
faint = Color -> S
colorFaint Color
ANSI.White
tfaint :: T
tfaint :: Text -> Text
tfaint = S -> Text -> Text
t S
faint
t :: (String -> String) -> T.Text -> T.Text
t :: S -> Text -> Text
t = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Text -> String
T.unpack String -> Text
T.pack
bug :: T.Text -> T.Text
bug :: Text -> Text
bug Text
txt =
[Text] -> Text
T.unlines
[ Text
txt,
Text
"This is a bug. Please create a ticket:",
Text
" https://github.com/nmattia/niv/issues/new",
Text
"Thanks! I'll buy you a beer."
]