{-# 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

-- A somewhat hacky way of deciding whether or not to use SGR codes, by writing
-- and reading a global variable unsafely.
-- This should be fine as long as the IORef is written right after argument
-- parsing, and as long as the value is never changed.
-- NOTE: this won't work in GHCi.

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

-- XXX: this assumes as single thread
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
      -- don't wrap if the error ain't too long
      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
' '
  -- we use `intercalate "\n"` because `unlines` prints an extra newline at
  -- the end
  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."
    ]