Formatting.hs

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

module HWM.Core.Formatting
  ( Color (..),
    chalk,
    formatStatus,
    Status (..),
    padDots,
    genMaxLen,
    separator,
    deriveStatus,
    statusFromSeverity,
    statusIcon,
    displayStatusM,
    Format (..),
    availableOptions,
    renderSummaryStatus,
    subPathSign,
    slugify,
    commonPrefix,
    indentBlockNum,
    indentBlock,
    formatTable,
    formatList,
    monadStatus,
    formatTemplate,
    toCamelCase,
    formatTableRow,
    StatusM,
    slugifyList,
    andMore,
    minRowSize,
  )
where

import Data.Aeson (Value, encode)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Char (isAlphaNum)
import Data.Foldable (maximum)
import qualified Data.List as List
import Data.Text (pack)
import qualified Data.Text as T
import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName)
import HWM.Core.Common (Name)
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 c = "\x1b[" <> T.pack (show (colorCode c)) <> "m"

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

chalk :: Color -> Text -> Text
chalk c x = toColor c <> x <> toColor None

type StatusM m = [(Name, m Status)]

data Status = Checked | Updated | Warning | Invalid
  deriving (Show, Eq, Ord)

instance Semigroup Status where
  a <> b = max a b

deriveStatus :: [Status] -> Status
deriveStatus [] = Checked
deriveStatus statuses = maximum statuses

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

monadStatus :: (Functor m, MonadIssue m) => m b -> m Status
monadStatus x = statusFromSeverity . fst <$> catchIssues x

displayStatusM :: (Monad m) => StatusM m -> m Text
displayStatusM ls = do
  statuses <- mapM snd ls
  let status = deriveStatus statuses
  if status == Checked then return (statusIcon status) else return (formatStatus (zip (map fst ls) statuses))

formatTemplate :: [(Text, Text)] -> Text -> Text
formatTemplate vars template =
  foldl' applyVar template vars
  where
    applyVar current (key, val) =
      T.replace ("{{" <> key <> "}}") val current

padDots :: Int -> Text -> Text
padDots width s = s <> " " <> chalk Dim (T.replicate (max 0 (width - T.length s)) ".") <> " "

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

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

formatStatus :: [(Text, Status)] -> Text
formatStatus = T.intercalate (chalk Dim " ") . map formatItem . sortBy (comparing (Down . snd)) . filter ((/= Checked) . snd)
  where
    formatItem (label, s) = statusIcon s <> " " <> chalk (labelColor s) label

minRowSize :: Int
minRowSize = 16

genMaxLen :: [Text] -> Int
genMaxLen names = if null names then minRowSize else maximum (map T.length names) + 4

separator :: Int -> Text
separator size = chalk Gray $ T.replicate size "─"

class Format a where
  format :: a -> Text

instance Format Int where
  format = show

instance Format String where
  format = pack

instance Format Text where
  format = id

instance Format Value where
  format = format . unpack . encode

instance Format UnqualComponentName where
  format = pack . unUnqualComponentName

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

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

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

subPathSign :: Text
subPathSign = chalk Dim "└── "

slugifyList :: [Text] -> Text
slugifyList = T.intercalate "-" . map slugify

slugify :: Text -> Text
slugify = T.map replaceChar . T.toLower
  where
    replaceChar c | isAlphaNum c = c | otherwise = '-'

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

    dropPrefix prefix text =
      let name = fromMaybe "" (T.stripPrefix prefix text)
       in if T.null name
            then "."
            else fromMaybe name (T.stripPrefix "-" name)

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

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

type Table = [Row]

type Row = [Text]

getSizes :: Table -> [Int]
getSizes xs = map size (transpose xs)
  where
    size :: Row -> Int
    size = maximum . map T.length

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

formatTableRow :: Table -> Row -> Text
formatTableRow table = printRow (getSizes table)

formatTable :: [Text] -> [Text]
formatTable deps = sort $ map (formatTableRow table) table
  where
    table = map words deps

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

toCamelCase :: Text -> Text
toCamelCase txt = T.concat $ capitalizeLs $ T.splitOn "-" $ T.replace "_" "-" txt
  where
    capitalizeLs (x : xs) = x : map capitalize xs
    capitalizeLs [] = []
    capitalize t =
      case T.uncons t of
        Nothing -> ""
        Just (c, rest) -> T.toUpper (T.singleton c) <> rest

andMore :: Text -> [Text] -> Text
andMore x xs = x <> if null xs then "" else " and " <> show (length xs) <> " more"