{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Core.Formatting
  ( Color (..),
    chalk,
    formatStatus,
    Status (..),
    padDots,
    genMaxLen,
    separator,
    deriveStatus,
    statusFromSeverity,
    statusIcon,
    isOk,
    displayStatus,
    Format (..),
    availableOptions,
    renderSummaryStatus,
    subPathSign,
    slugify,
    commonPrefix,
    indentBlockNum,
    indentBlock,
    formatTable,
    formatList,
    monadStatus,
  )
where

import Data.Aeson (Value, encode)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Foldable (maximum)
import qualified Data.List as List
import Data.Text (pack)
import qualified Data.Text as T
import HWM.Core.Result (MonadIssue (catchIssues), Severity (..))
import Relude

data Color
  = Red
  | Green
  | Yellow
  | Gray
  | Magenta
  | Cyan
  | Dim
  | Bold
  | White
  | None
  | RedBackground
  | GreenBackground
  | YellowBackground
  | BrightRed
  | BrightGreen
  | BrightYellow

toColor :: Color -> Text
toColor :: Color -> Text
toColor Color
c = Text
"\x1b[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Color -> Int
colorCode Color
c)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m"

colorCode :: Color -> Int
colorCode :: Color -> Int
colorCode Color
Red = Int
31
colorCode Color
Green = Int
32
colorCode Color
Yellow = Int
33
colorCode Color
Cyan = Int
36
colorCode Color
Magenta = Int
95
colorCode Color
Gray = Int
90
colorCode Color
Dim = Int
2
colorCode Color
None = Int
0
colorCode Color
Bold = Int
1
colorCode Color
RedBackground = Int
41
colorCode Color
GreenBackground = Int
42
colorCode Color
YellowBackground = Int
43
colorCode Color
BrightRed = Int
91
colorCode Color
BrightGreen = Int
92
colorCode Color
BrightYellow = Int
93
colorCode Color
White = Int
37

chalk :: Color -> Text -> Text
chalk :: Color -> Text -> Text
chalk Color
c Text
x = Color -> Text
toColor Color
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Color -> Text
toColor Color
None

data Status = Checked | Updated | Warning | Invalid
  deriving (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show, Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
/= :: Status -> Status -> Bool
Eq, Eq Status
Eq Status =>
(Status -> Status -> Ordering)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Status)
-> (Status -> Status -> Status)
-> Ord Status
Status -> Status -> Bool
Status -> Status -> Ordering
Status -> Status -> Status
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 :: Status -> Status -> Ordering
compare :: Status -> Status -> Ordering
$c< :: Status -> Status -> Bool
< :: Status -> Status -> Bool
$c<= :: Status -> Status -> Bool
<= :: Status -> Status -> Bool
$c> :: Status -> Status -> Bool
> :: Status -> Status -> Bool
$c>= :: Status -> Status -> Bool
>= :: Status -> Status -> Bool
$cmax :: Status -> Status -> Status
max :: Status -> Status -> Status
$cmin :: Status -> Status -> Status
min :: Status -> Status -> Status
Ord)

deriveStatus :: [Status] -> Status
deriveStatus :: [Status] -> Status
deriveStatus [] = Status
Checked
deriveStatus [Status]
statuses = [Status] -> Status
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Status]
statuses

-- | Convert issue severity to status
statusFromSeverity :: Maybe Severity -> Status
statusFromSeverity :: Maybe Severity -> Status
statusFromSeverity (Just Severity
SeverityError) = Status
Invalid
statusFromSeverity (Just Severity
SeverityWarning) = Status
Warning
statusFromSeverity Maybe Severity
Nothing = Status
Checked

monadStatus :: (Functor m, MonadIssue m) => m b -> m Status
monadStatus :: forall (m :: * -> *) b.
(Functor m, MonadIssue m) =>
m b -> m Status
monadStatus m b
x = Maybe Severity -> Status
statusFromSeverity (Maybe Severity -> Status)
-> ((Maybe Severity, b) -> Maybe Severity)
-> (Maybe Severity, b)
-> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Severity, b) -> Maybe Severity
forall a b. (a, b) -> a
fst ((Maybe Severity, b) -> Status)
-> m (Maybe Severity, b) -> m Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b -> m (Maybe Severity, b)
forall a. m a -> m (Maybe Severity, a)
forall (m :: * -> *) a.
MonadIssue m =>
m a -> m (Maybe Severity, a)
catchIssues m b
x

displayStatus :: [(Text, Status)] -> Text
displayStatus :: [(Text, Status)] -> Text
displayStatus [(Text, Status)]
ls =
  let status :: Status
status = [Status] -> Status
deriveStatus (((Text, Status) -> Status) -> [(Text, Status)] -> [Status]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Status) -> Status
forall a b. (a, b) -> b
snd [(Text, Status)]
ls)
   in if Status -> Bool
isOk Status
status then Status -> Text
statusIcon Status
status else [(Text, Status)] -> Text
formatStatus [(Text, Status)]
ls

padDots :: Int -> Text -> Text
padDots :: Int -> Text -> Text
padDots Int
width Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Color -> Text -> Text
chalk Color
Dim (Int -> Text -> Text
T.replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s)) Text
".") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "

isOk :: Status -> Bool
isOk :: Status -> Bool
isOk Status
Checked = Bool
True
isOk Status
Updated = Bool
True
isOk Status
_ = Bool
False

labelColor :: Status -> Color
labelColor :: Status -> Color
labelColor Status
Checked = Color
Dim
labelColor Status
Updated = Color
Dim
labelColor Status
Warning = Color
Yellow
labelColor Status
Invalid = Color
Red

statusIcon :: Status -> Text
statusIcon :: Status -> Text
statusIcon Status
s = case Status
s of
  Status
Checked -> Color -> Text -> Text
chalk Color
Green Text
"✓"
  Status
Updated -> Color -> Text -> Text
chalk Color
Cyan Text
"⟳"
  Status
Invalid -> Color -> Text -> Text
chalk Color
Red Text
"✖"
  Status
Warning -> Color -> Text -> Text
chalk Color
Yellow Text
"!"

formatStatus :: [(Text, Status)] -> Text
formatStatus :: [(Text, Status)] -> Text
formatStatus = Text -> [Text] -> Text
T.intercalate (Color -> Text -> Text
chalk Color
Dim Text
" ") ([Text] -> Text)
-> ([(Text, Status)] -> [Text]) -> [(Text, Status)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Status) -> Text) -> [(Text, Status)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Status) -> Text
formatItem ([(Text, Status)] -> [Text])
-> ([(Text, Status)] -> [(Text, Status)])
-> [(Text, Status)]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Status) -> (Text, Status) -> Ordering)
-> [(Text, Status)] -> [(Text, Status)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Text, Status) -> Down Status)
-> (Text, Status) -> (Text, Status) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Status -> Down Status
forall a. a -> Down a
Down (Status -> Down Status)
-> ((Text, Status) -> Status) -> (Text, Status) -> Down Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Status) -> Status
forall a b. (a, b) -> b
snd)) ([(Text, Status)] -> [(Text, Status)])
-> ([(Text, Status)] -> [(Text, Status)])
-> [(Text, Status)]
-> [(Text, Status)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Status) -> Bool) -> [(Text, Status)] -> [(Text, Status)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
/= Status
Checked) (Status -> Bool)
-> ((Text, Status) -> Status) -> (Text, Status) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Status) -> Status
forall a b. (a, b) -> b
snd)
  where
    formatItem :: (Text, Status) -> Text
formatItem (Text
label, Status
s) = Status -> Text
statusIcon Status
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Color -> Text -> Text
chalk (Status -> Color
labelColor Status
s) Text
label

genMaxLen :: [Text] -> Int
genMaxLen :: [Text] -> Int
genMaxLen [Text]
names = if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
names then Int
16 else [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
T.length [Text]
names) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4

separator :: Int -> Text
separator :: Int -> Text
separator Int
size = Color -> Text -> Text
chalk Color
Gray (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate Int
size Text
"─"

class Format a where
  format :: a -> Text

instance Format Int where
  format :: Int -> Text
format = Int -> Text
forall b a. (Show a, IsString b) => a -> b
show

instance Format String where
  format :: String -> Text
format = String -> Text
pack

instance Format Text where
  format :: Text -> Text
format = Text -> Text
forall a. a -> a
id

instance Format Value where
  format :: Value -> Text
format = String -> Text
forall a. Format a => a -> Text
format (String -> Text) -> (Value -> String) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpack (ByteString -> String) -> (Value -> ByteString) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode

availableOptions :: (Format a) => [a] -> Text
availableOptions :: forall a. Format a => [a] -> Text
availableOptions [a]
xs = Text
"Available options: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall a. Format a => a -> Text
format [a]
xs)

boxed :: Color -> Text -> Text
boxed :: Color -> Text -> Text
boxed Color
color Text
text = Color -> Text -> Text
chalk Color
Bold Text
"• " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
block Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Color -> Text -> Text
chalk Color
color Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
block
  where
    block :: Text
block = Color -> Text -> Text
chalk Color
color Text
"▌"

renderSummaryStatus :: Status -> Text
renderSummaryStatus :: Status -> Text
renderSummaryStatus Status
Warning = Color -> Text -> Text
boxed Color
BrightYellow Text
"warning"
renderSummaryStatus Status
Invalid = Color -> Text -> Text
boxed Color
Red Text
"errors"
renderSummaryStatus Status
_ = Color -> Text -> Text
boxed Color
BrightGreen Text
"success"

subPathSign :: Text
subPathSign :: Text
subPathSign = Color -> Text -> Text
chalk Color
Dim Text
"└─- "

slugify :: Text -> Text
slugify :: Text -> Text
slugify = (Char -> Char) -> Text -> Text
T.map Char -> Char
replaceChar (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower
  where
    replaceChar :: Char -> Char
replaceChar Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = Char
'-'
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = Char
'-'
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = Char
'-'
      | Bool
otherwise = Char
c

commonPrefix :: [Text] -> (Maybe Text, [Text])
commonPrefix :: [Text] -> (Maybe Text, [Text])
commonPrefix [] = (Maybe Text
forall a. Maybe a
Nothing, [])
commonPrefix [Text
name] = (Maybe Text
forall a. Maybe a
Nothing, [Text
name])
commonPrefix [Text]
names =
  [Text] -> Text -> (Maybe Text, [Text])
refine [Text]
names ((Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') ((Text -> Text -> Text) -> [Text] -> Text
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
List.foldl1' Text -> Text -> Text
pairwisePrefix [Text]
names))
  where
    pairwisePrefix :: Text -> Text -> Text
pairwisePrefix Text
a Text
b = Text
-> ((Text, Text, Text) -> Text) -> Maybe (Text, Text, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\(Text
prefix, Text
_, Text
_) -> Text
prefix) (Text -> Text -> Maybe (Text, Text, Text)
T.commonPrefixes Text
a Text
b)
    refine :: [Text] -> Text -> (Maybe Text, [Text])
refine [Text]
_ Text
candidate | Text -> Bool
T.null Text
candidate = (Maybe Text
forall a. Maybe a
Nothing, [Text]
names)
    refine [Text]
sources Text
candidate
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Text -> Bool
matches Text
candidate) [Text]
sources = (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
candidate, (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
dropPrefix Text
candidate) [Text]
sources)
      | Bool
otherwise = [Text] -> Text -> (Maybe Text, [Text])
refine [Text]
sources (Text -> Text
shrink Text
candidate)
    matches :: Text -> Text -> Bool
matches Text
prefix Text
name
      | Text
prefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name = Bool
True
      | Text
prefix Text -> Text -> Bool
`T.isPrefixOf` Text
name = Text -> Bool
startsWithHyphen (Int -> Text -> Text
T.drop (Text -> Int
T.length Text
prefix) Text
name)
      | Bool
otherwise = Bool
False
    startsWithHyphen :: Text -> Bool
startsWithHyphen Text
remainder =
      case Text -> Maybe (Char, Text)
T.uncons Text
remainder of
        Maybe (Char, Text)
Nothing -> Bool
True
        Just (Char
'-', Text
_) -> Bool
True
        Maybe (Char, Text)
_ -> Bool
False
    shrink :: Text -> Text
shrink Text
prefix =
      case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"-" Text
prefix of
        (Text
rest, Text
_) | Text -> Bool
T.null Text
rest -> Text
""
        (Text
rest, Text
_) -> (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
rest

    dropPrefix :: Text -> Text -> Text
dropPrefix Text
prefix Text
text =
      let name :: Text
name = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Text -> Maybe Text
T.stripPrefix Text
prefix Text
text)
       in if Text -> Bool
T.null Text
name
            then Text
"."
            else Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
name (Text -> Text -> Maybe Text
T.stripPrefix Text
"-" Text
name)

indentBlockNum :: Int -> Text -> Text
indentBlockNum :: Int -> Text -> Text
indentBlockNum Int
i = Text -> Text -> Text
indentBlock (Int -> Text -> Text
T.replicate Int
i Text
" ")

indentBlock :: Text -> Text -> Text
indentBlock :: Text -> Text -> Text
indentBlock Text
prefix Text
text
  | Text -> Bool
T.null Text
text = Text
text
  | Bool
otherwise =
      let linesList :: [Text]
linesList = Text -> [Text]
T.lines Text
text
          indented :: [Text]
indented = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
linesList
          joined :: Text
joined = Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
indented
       in if Text -> Text -> Bool
T.isSuffixOf Text
"\n" Text
text
            then Text
joined Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
            else Text
joined

type Table = [Row]

type Row = [Text]

getSizes :: Table -> [Int]
getSizes :: Table -> [Int]
getSizes Table
xs = ([Text] -> Int) -> Table -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Int
size (Table -> Table
forall a. [[a]] -> [[a]]
transpose Table
xs)
  where
    size :: Row -> Int
    size :: [Text] -> Int
size = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([Text] -> [Int]) -> [Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
T.length

printRow :: [Int] -> Row -> Text
printRow :: [Int] -> [Text] -> Text
printRow [Int]
sizes [Text]
ls =
  Text -> Text
T.strip
    (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"  "
    ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Int -> Text) -> [Text] -> [Int] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Text
item Int
s -> Int -> Char -> Text -> Text
T.justifyLeft Int
s Char
' ' Text
item) [Text]
ls [Int]
sizes

formatTable :: [Text] -> [Text]
formatTable :: [Text] -> [Text]
formatTable [Text]
deps = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Text) -> Table -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
printRow (Table -> [Int]
getSizes Table
table)) Table
table
  where
    table :: Table
table = (Text -> [Text]) -> [Text] -> Table
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Text]
forall t. IsText t "words" => t -> [t]
words [Text]
deps

formatList :: (Format a) => Text -> [a] -> Text
formatList :: forall a. Format a => Text -> [a] -> Text
formatList Text
x = Text -> [Text] -> Text
T.intercalate Text
x ([Text] -> Text) -> ([a] -> [Text]) -> [a] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall a. Format a => a -> Text
format