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

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