{-# 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
(Colors -> Colors -> Bool)
-> (Colors -> Colors -> Bool) -> Eq Colors
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 = IO (IORef Colors) -> IORef Colors
forall a. IO a -> a
unsafePerformIO (IO (IORef Colors) -> IORef Colors)
-> IO (IORef Colors) -> IORef Colors
forall a b. (a -> b) -> a -> b
$ Colors -> IO (IORef Colors)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Colors
Always
{-# NOINLINE colors #-}
setColors :: Colors -> IO ()
setColors :: Colors -> IO ()
setColors = IORef Colors -> Colors -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Colors
colors
useColors :: Bool
useColors :: Bool
useColors = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (\Colors
c -> Colors
c Colors -> Colors -> Bool
forall a. Eq a => a -> a -> Bool
== Colors
Always) (Colors -> Bool) -> IO Colors -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Colors -> IO Colors
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 :: String -> io () -> io ()
job String
str io ()
act = do
String -> io ()
forall (io :: * -> *). MonadIO io => String -> io ()
say (S
bold String
str)
io ()
indent
io () -> io (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny io ()
act io (Either SomeException ())
-> io () -> io (Either SomeException ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* io ()
deindent io (Either SomeException ())
-> (Either SomeException () -> io ()) -> io ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right () -> String -> io ()
forall (io :: * -> *). MonadIO io => String -> io ()
say (String -> io ()) -> String -> io ()
forall a b. (a -> b) -> a -> b
$ S
green String
"Done" String -> S
forall a. Semigroup a => a -> a -> a
<> String
": " String -> S
forall a. Semigroup a => a -> a -> a
<> String
str
Left SomeException
e -> do
let showErr :: String
showErr = do
let se :: String
se = SomeException -> String
forall a. Show a => a -> String
show SomeException
e
(if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
se Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
40 then String
":\n" else String
": ") String -> S
forall a. Semigroup a => a -> a -> a
<> String
se
String -> io ()
forall (io :: * -> *). MonadIO io => String -> io ()
say (String -> io ()) -> String -> io ()
forall a b. (a -> b) -> a -> b
$ S
red String
"ERROR" String -> S
forall a. Semigroup a => a -> a -> a
<> String
showErr
IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
exitFailure
where
indent :: io ()
indent = io Any -> io ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (io Any -> io ()) -> io Any -> io ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Any)) -> io Any
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef Int
jobStack (\Int
x -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Any
forall a. HasCallStack => a
undefined))
deindent :: io ()
deindent = io Any -> io ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (io Any -> io ()) -> io Any -> io ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Any)) -> io Any
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef Int
jobStack (\Int
x -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Any
forall a. HasCallStack => a
undefined))
jobStackSize :: MonadIO io => io Int
jobStackSize :: io Int
jobStackSize = IORef Int -> io Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
jobStack
jobStack :: IORef Int
jobStack :: IORef Int
jobStack = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int
0
{-# NOINLINE jobStackSize #-}
tsay :: MonadIO io => T.Text -> io ()
tsay :: Text -> io ()
tsay = String -> io ()
forall (io :: * -> *). MonadIO io => String -> io ()
say (String -> io ()) -> (Text -> String) -> Text -> io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
say :: MonadIO io => String -> io ()
say :: String -> io ()
say String
msg = do
Int
stackSize <- io Int
forall (io :: * -> *). MonadIO io => io Int
jobStackSize
let indent :: String
indent = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
stackSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '
IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
indent String -> S
forall a. Semigroup a => a -> a -> a
<>) S -> [String] -> [String]
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") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w
twarn :: MonadIO io => T.Text -> io ()
twarn :: Text -> io ()
twarn = Text -> io ()
forall (io :: * -> *). MonadIO io => Text -> io ()
tsay (Text -> io ()) -> (Text -> Text) -> Text -> io ()
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") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> 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]
String -> S
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]
String -> S
forall a. Semigroup a => a -> a -> a
<> String
str
String -> S
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]
String -> S
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]
String -> S
forall a. Semigroup a => a -> a -> a
<> String
str
String -> S
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 = (Text -> String) -> (String -> Text) -> S -> Text -> Text
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."
]