{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Dojang.Commands
  ( Admonition (..)
  , Color (..)
  , codeStyleFor
  , colorFor
  , die'
  , dieWithErrors
  , pathStyleFor
  , pathStyleFor'
  , printStderr
  , printStderr'
  , printTable
  ) where

import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO (liftIO))
import System.Environment (lookupEnv)
import System.Exit (ExitCode, exitWith)
import System.IO.Extra (Handle, hIsTerminalDevice, stderr, stdout)
import System.IO.Unsafe (unsafePerformIO)
import Prelude hiding (putStr, replicate)

import Data.List (transpose)
import Data.Text (Text, length, pack, replicate)
import Data.Text.IO (hPutStr, hPutStrLn, putStr)
import System.Console.Pretty
  ( Color (..)
  , Pretty
  , Style (..)
  , bgColor
  , style
  )
import System.Console.Pretty qualified (color)
import System.OsPath (OsPath, decodeFS)
import TextShow (FromStringShow (FromStringShow), TextShow (showt))


isColorAvailable :: (MonadIO m) => Handle -> m Bool
isColorAvailable :: forall (m :: * -> *). MonadIO m => Handle -> m Bool
isColorAvailable Handle
handle = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe String
term <- String -> IO (Maybe String)
lookupEnv String
"TERM"
  Maybe String
noColor <- String -> IO (Maybe String)
lookupEnv String
"NO_COLOR"
  case (Maybe String
term, Maybe String
noColor) of
    (Just String
"dumb", Maybe String
_) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    (Maybe String
_, Just (Char
_ : String
_)) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    (Maybe String, Maybe String)
_ -> Handle -> IO Bool
hIsTerminalDevice Handle
handle


colorFor
  :: forall a m. (Pretty a, MonadIO m) => Handle -> m (Color -> Color -> a -> a)
colorFor :: forall a (m :: * -> *).
(Pretty a, MonadIO m) =>
Handle -> m (Color -> Color -> a -> a)
colorFor Handle
handle = do
  Bool
colorAvailable <- Handle -> m Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
isColorAvailable Handle
handle
  (Color -> Color -> a -> a) -> m (Color -> Color -> a -> a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Color -> Color -> a -> a) -> m (Color -> Color -> a -> a))
-> (Color -> Color -> a -> a) -> m (Color -> Color -> a -> a)
forall a b. (a -> b) -> a -> b
$ if Bool
colorAvailable then Color -> Color -> a -> a
color else Color -> Color -> a -> a
dumb
 where
  dumb :: Color -> Color -> a -> a
  dumb :: Color -> Color -> a -> a
dumb Color
_ Color
_ = a -> a
forall a. a -> a
id
  color :: Color -> Color -> a -> a
  color :: Color -> Color -> a -> a
color Color
bg Color
text a
v = Color -> a -> a
forall a. Pretty a => Color -> a -> a
bgColor Color
bg (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Color -> a -> a
forall a. Pretty a => Color -> a -> a
System.Console.Pretty.color Color
text a
v


codeStyleFor :: forall a m. (Pretty a, MonadIO m) => Handle -> m (a -> a)
codeStyleFor :: forall a (m :: * -> *).
(Pretty a, MonadIO m) =>
Handle -> m (a -> a)
codeStyleFor Handle
handle = do
  Bool
colorAvailable <- Handle -> m Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
isColorAvailable Handle
handle
  (a -> a) -> m (a -> a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> a) -> m (a -> a)) -> (a -> a) -> m (a -> a)
forall a b. (a -> b) -> a -> b
$
    if Bool
colorAvailable
      then Style -> a -> a
forall a. Pretty a => Style -> a -> a
style Style
Bold
      else a -> a
forall a. a -> a
id


pathStyleFor :: forall m. (MonadIO m) => Handle -> m (OsPath -> Text)
pathStyleFor :: forall (m :: * -> *). MonadIO m => Handle -> m (OsPath -> Text)
pathStyleFor Handle
handle = do
  Text -> Text
pathStyle <- Handle -> m (Text -> Text)
forall a (m :: * -> *).
(Pretty a, MonadIO m) =>
Handle -> m (a -> a)
pathStyleFor' Handle
handle
  (OsPath -> Text) -> m (OsPath -> Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((OsPath -> Text) -> m (OsPath -> Text))
-> (OsPath -> Text) -> m (OsPath -> Text)
forall a b. (a -> b) -> a -> b
$ \OsPath
path -> Text -> Text
pathStyle (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OsPath -> Text
decodeFS' OsPath
path
 where
  decodeFS' :: OsPath -> Text
  decodeFS' :: OsPath -> Text
decodeFS' = String -> Text
pack (String -> Text) -> (OsPath -> String) -> OsPath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> (OsPath -> IO String) -> OsPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> IO String
decodeFS


pathStyleFor' :: forall a m. (Pretty a, MonadIO m) => Handle -> m (a -> a)
pathStyleFor' :: forall a (m :: * -> *).
(Pretty a, MonadIO m) =>
Handle -> m (a -> a)
pathStyleFor' Handle
handle = do
  Bool
colorAvailable <- Handle -> m Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
isColorAvailable Handle
handle
  (a -> a) -> m (a -> a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> a) -> m (a -> a)) -> (a -> a) -> m (a -> a)
forall a b. (a -> b) -> a -> b
$
    if Bool
colorAvailable
      then Style -> a -> a
forall a. Pretty a => Style -> a -> a
style Style
Italic
      else a -> a
forall a. a -> a
id


printStderr :: (MonadIO m) => Text -> m ()
printStderr :: forall (m :: * -> *). MonadIO m => Text -> m ()
printStderr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
hPutStrLn Handle
stderr


data Admonition = Hint | Note | Warning | Error
  deriving (Int -> Admonition -> ShowS
[Admonition] -> ShowS
Admonition -> String
(Int -> Admonition -> ShowS)
-> (Admonition -> String)
-> ([Admonition] -> ShowS)
-> Show Admonition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Admonition -> ShowS
showsPrec :: Int -> Admonition -> ShowS
$cshow :: Admonition -> String
show :: Admonition -> String
$cshowList :: [Admonition] -> ShowS
showList :: [Admonition] -> ShowS
Show, Admonition -> Admonition -> Bool
(Admonition -> Admonition -> Bool)
-> (Admonition -> Admonition -> Bool) -> Eq Admonition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Admonition -> Admonition -> Bool
== :: Admonition -> Admonition -> Bool
$c/= :: Admonition -> Admonition -> Bool
/= :: Admonition -> Admonition -> Bool
Eq, Eq Admonition
Eq Admonition =>
(Admonition -> Admonition -> Ordering)
-> (Admonition -> Admonition -> Bool)
-> (Admonition -> Admonition -> Bool)
-> (Admonition -> Admonition -> Bool)
-> (Admonition -> Admonition -> Bool)
-> (Admonition -> Admonition -> Admonition)
-> (Admonition -> Admonition -> Admonition)
-> Ord Admonition
Admonition -> Admonition -> Bool
Admonition -> Admonition -> Ordering
Admonition -> Admonition -> Admonition
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Admonition -> Admonition -> Ordering
compare :: Admonition -> Admonition -> Ordering
$c< :: Admonition -> Admonition -> Bool
< :: Admonition -> Admonition -> Bool
$c<= :: Admonition -> Admonition -> Bool
<= :: Admonition -> Admonition -> Bool
$c> :: Admonition -> Admonition -> Bool
> :: Admonition -> Admonition -> Bool
$c>= :: Admonition -> Admonition -> Bool
>= :: Admonition -> Admonition -> Bool
$cmax :: Admonition -> Admonition -> Admonition
max :: Admonition -> Admonition -> Admonition
$cmin :: Admonition -> Admonition -> Admonition
min :: Admonition -> Admonition -> Admonition
Ord, Int -> Admonition
Admonition -> Int
Admonition -> [Admonition]
Admonition -> Admonition
Admonition -> Admonition -> [Admonition]
Admonition -> Admonition -> Admonition -> [Admonition]
(Admonition -> Admonition)
-> (Admonition -> Admonition)
-> (Int -> Admonition)
-> (Admonition -> Int)
-> (Admonition -> [Admonition])
-> (Admonition -> Admonition -> [Admonition])
-> (Admonition -> Admonition -> [Admonition])
-> (Admonition -> Admonition -> Admonition -> [Admonition])
-> Enum Admonition
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Admonition -> Admonition
succ :: Admonition -> Admonition
$cpred :: Admonition -> Admonition
pred :: Admonition -> Admonition
$ctoEnum :: Int -> Admonition
toEnum :: Int -> Admonition
$cfromEnum :: Admonition -> Int
fromEnum :: Admonition -> Int
$cenumFrom :: Admonition -> [Admonition]
enumFrom :: Admonition -> [Admonition]
$cenumFromThen :: Admonition -> Admonition -> [Admonition]
enumFromThen :: Admonition -> Admonition -> [Admonition]
$cenumFromTo :: Admonition -> Admonition -> [Admonition]
enumFromTo :: Admonition -> Admonition -> [Admonition]
$cenumFromThenTo :: Admonition -> Admonition -> Admonition -> [Admonition]
enumFromThenTo :: Admonition -> Admonition -> Admonition -> [Admonition]
Enum, Admonition
Admonition -> Admonition -> Bounded Admonition
forall a. a -> a -> Bounded a
$cminBound :: Admonition
minBound :: Admonition
$cmaxBound :: Admonition
maxBound :: Admonition
Bounded)


printStderr' :: (MonadIO m) => Admonition -> Text -> m ()
printStderr' :: forall (m :: * -> *). MonadIO m => Admonition -> Text -> m ()
printStderr' Admonition
admonition Text
message = do
  Color -> Color -> Text -> Text
color <- Handle -> m (Color -> Color -> Text -> Text)
forall a (m :: * -> *).
(Pretty a, MonadIO m) =>
Handle -> m (Color -> Color -> a -> a)
colorFor Handle
stderr
  Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printStderr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Color -> Color -> Text -> Text
color Color
Default Color
color' Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message
 where
  color' :: Color
  color' :: Color
color' = case Admonition
admonition of
    Admonition
Hint -> Color
Cyan
    Admonition
Note -> Color
Yellow
    Admonition
Warning -> Color
Yellow
    Admonition
Error -> Color
Red
  prefix :: Text
  prefix :: Text
prefix = FromStringShow Admonition -> Text
forall a. TextShow a => a -> Text
showt (Admonition -> FromStringShow Admonition
forall a. a -> FromStringShow a
FromStringShow Admonition
admonition) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "


die' :: (MonadIO m) => ExitCode -> Text -> m a
die' :: forall (m :: * -> *) a. MonadIO m => ExitCode -> Text -> m a
die' ExitCode
exitCode Text
message = do
  Admonition -> Text -> m ()
forall (m :: * -> *). MonadIO m => Admonition -> Text -> m ()
printStderr' Admonition
Error Text
message
  IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode


dieWithErrors :: (MonadIO m) => ExitCode -> [Text] -> m a
dieWithErrors :: forall (m :: * -> *) a. MonadIO m => ExitCode -> [Text] -> m a
dieWithErrors ExitCode
exitCode [Text]
errors = do
  [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
errors ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Admonition -> Text -> m ()
forall (m :: * -> *). MonadIO m => Admonition -> Text -> m ()
printStderr' Admonition
Error
  IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode


printTable :: forall m. (MonadIO m) => [Text] -> [[(Color, Text)]] -> m ()
printTable :: forall (m :: * -> *).
MonadIO m =>
[Text] -> [[(Color, Text)]] -> m ()
printTable [Text]
headers [[(Color, Text)]]
rows = do
  -- Headers are printed to stderr, so that they can be piped to another
  -- program without interfering with the table.
  [(Text, Int)] -> ((Text, Int) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
headers [Int]
columnWidths) (((Text, Int) -> m ()) -> m ()) -> ((Text, Int) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Text
header, Int
width) -> do
    Handle -> Color -> Text -> Int -> m ()
putCol Handle
stderr Color
Cyan Text
header Int
width
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
hPutStr Handle
stderr Text
" "
  m ()
putLnStderr
  [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
columnWidths ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
width -> do
    Handle -> Color -> Text -> Int -> m ()
putCol Handle
stderr Color
Cyan (Int -> Text -> Text
replicate Int
width Text
"\x2500") Int
width
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
hPutStr Handle
stderr Text
" "
  m ()
putLnStderr
  [[(Color, Text)]] -> ([(Color, Text)] -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[(Color, Text)]]
rows (([(Color, Text)] -> m ()) -> m ())
-> ([(Color, Text)] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[(Color, Text)]
row -> do
    [((Color, Text), Int, Int)]
-> (((Color, Text), Int, Int) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Color, Text)] -> [Int] -> [Int] -> [((Color, Text), Int, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [(Color, Text)]
row [Int]
columnWidths [Int
1 ..]) ((((Color, Text), Int, Int) -> m ()) -> m ())
-> (((Color, Text), Int, Int) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \((Color
color', Text
value), Int
width, Int
i) -> do
      Handle -> Color -> Text -> Int -> m ()
putCol Handle
stdout Color
color' Text
value (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$
        if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Color, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [(Color, Text)]
row then Int
width else Text -> Int
Data.Text.length Text
value
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putStr Text
" "
    m ()
putLn
 where
  valueWidths :: [[Int]]
  valueWidths :: [[Int]]
valueWidths =
    [Text -> Int
Data.Text.length Text
c | Text
c <- [Text]
headers]
      [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Text -> Int
Data.Text.length Text
v | (Color
_, Text
v) <- [(Color, Text)]
row] | [(Color, Text)]
row <- [[(Color, Text)]]
rows]
  columnWidths :: [Int]
  columnWidths :: [Int]
columnWidths = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall a. [[a]] -> [[a]]
transpose [[Int]]
valueWidths
  putCol :: Handle -> Color -> Text -> Int -> m ()
  putCol :: Handle -> Color -> Text -> Int -> m ()
putCol Handle
h Color
color' Text
value Int
width = do
    Color -> Color -> Text -> Text
color <- Handle -> m (Color -> Color -> Text -> Text)
forall a (m :: * -> *).
(Pretty a, MonadIO m) =>
Handle -> m (Color -> Color -> a -> a)
colorFor Handle
stdout
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
hPutStr Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Color -> Text -> Text
color Color
Default Color
color' Text
value
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
hPutStr Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Data.Text.length Text
value) Text
" "
  putLn :: m ()
  putLn :: m ()
putLn = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
forall a. Monoid a => a
mempty
  putLnStderr :: m ()
  putLnStderr :: m ()
putLnStderr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
hPutStrLn Handle
stderr Text
forall a. Monoid a => a
mempty