UI.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Runtime.UI
  ( MonadUI (..),
    UIT,
    runUIT,
    runUI,
    putLine,
    indent,
    section_,
    sectionWorkspace,
    sectionEnvironments,
    sectionConfig,
    sectionTableM,
    forTable_,
    printSummary,
    uiFormatTable,
    forTable,
    statusTableM,
    section,
    uiSpace,
    uiRow,
    uiSubPath,
    uiSubPathRow,
    uiLabel,
    minRowSize,
    uiIndicator,
  )
where

import Control.Concurrent (threadDelay)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Except (MonadError (..))
import Data.List (groupBy, maximum, (!!))
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Color (..), Format (..), Status (..), chalk, indentBlockNum, minRowSize, padDots, renderSummaryStatus, statusIcon, subPathSign)
import HWM.Core.Options (whenCI)
import HWM.Core.Result
  ( Issue (..),
    IssueDetails (..),
    ResultT (..),
    Severity (..),
  )
import Relude
import System.Console.ANSI (clearLine, setCursorColumn)

data UIContext m = UIContext
  { uiWriter :: Text -> m (),
    uiIndent :: Int
  }

newtype UIT m a = UIT {_unUIT :: ReaderT (UIContext m) m a}
  deriving newtype (Functor, Applicative, Monad, MonadIO)

instance MonadTrans UIT where
  lift = UIT . lift

instance (MonadError err m) => MonadError err (UIT m) where
  throwError = UIT . lift . throwError
  catchError (UIT action) handler = UIT $ ReaderT $ \ctx ->
    catchError (runReaderT action ctx) (\e -> runReaderT (_unUIT (handler e)) ctx)

runUIT :: (Monad m) => (Text -> m ()) -> UIT m a -> m a
runUIT writer (UIT action) =
  let ctx = UIContext {uiWriter = writer, uiIndent = 0}
   in runReaderT action ctx

runUI :: UIT IO a -> IO a
runUI = runUIT (putStr . toString)

class (Monad m) => MonadUI m where
  uiWrite :: Text -> m ()
  uiIndentLevel :: m Int
  uiWithIndent :: (Int -> Int) -> m a -> m a

instance (Monad m) => MonadUI (UIT m) where
  uiWrite txt = UIT $ do
    UIContext {uiWriter} <- ask
    lift (uiWriter txt)
  uiIndentLevel = UIT $ asks uiIndent
  uiWithIndent f (UIT action) = UIT $ local adjust action
    where
      adjust ctx = ctx {uiIndent = f (uiIndent ctx)}

instance (MonadUI m) => MonadUI (ResultT m) where
  uiWrite txt = lift (uiWrite txt)
  uiIndentLevel = lift uiIndentLevel
  uiWithIndent f (ResultT action) = ResultT $ uiWithIndent f action

uiSpace :: (MonadUI m) => m ()
uiSpace = uiWrite "\n"

uiSubPath :: (MonadUI m, Format a) => a -> m ()
uiSubPath value = putLine $ subPathSign <> format value

uiSubPathRow :: (MonadUI m) => Int -> Text -> Text -> m ()
uiSubPathRow size key value = putLine $ subPathSign <> padDots size key <> value

uiRow :: (MonadUI m) => Int -> Text -> Text -> m ()
uiRow size key value = putLine $ padDots size key <> value

uiLabel :: (MonadUI m) => Text -> m ()
uiLabel name = putLine $ "• " <> chalk Bold name

putLine :: (MonadUI m) => Text -> m ()
putLine txt = do
  level <- uiIndentLevel
  uiWrite (indentBlockNum level (txt <> "\n"))

indent :: (MonadUI m) => Int -> m a -> m a
indent amount = uiWithIndent (+ amount)

sectionBase :: (MonadUI m) => Text -> Text -> m a -> m a
sectionBase emoji title action = do
  uiSpace
  putLine (emoji <> " " <> chalk Bold title)
  indent 1 action

section_ :: (MonadUI m) => Text -> m a -> m ()
section_ t m = sectionBase "•" t m $> ()

section :: (MonadUI m) => Text -> m a -> m a
section = sectionBase "•"

sectionWorkspace :: (MonadUI m) => m a -> m ()
sectionWorkspace m = sectionBase "./" "workspace" m $> ()

sectionEnvironments :: (MonadUI m) => Maybe Text -> m a -> m ()
sectionEnvironments title = section_ ("environments" <> maybe "" (\name -> chalk Dim " (default: " <> chalk Magenta name <> chalk Dim ")") title)

forHLTable :: (MonadUI m) => [a] -> (a -> (Name, m (Name, b))) -> m [(Name, b)]
forHLTable as f = traverse formatRow rows
  where
    rows = map f as
    maxLabelLen = maximum (minRowSize : map (T.length . fst) rows) + 2
    formatRow (label, valueM) = do
      (value, mvalue) <- valueM
      putLine $ padDots maxLabelLen label <> value
      pure (label, mvalue)

forTable :: (MonadUI m) => Name -> [a] -> (a -> (Name, m (Name, b))) -> m [(Name, b)]
forTable title as f = sectionBase "•" title $ forHLTable as f

forTable_ :: (MonadUI m) => [a] -> (a -> (Text, m Text)) -> m ()
forTable_ rows f = tableM_ (map f rows)

tableM_ :: (MonadUI m) => [(Text, m Text)] -> m ()
tableM_ rows = forHLTable rows (second ((,()) <$>)) $> ()

statusTableM :: (MonadUI m) => [(Text, m Status)] -> m ()
statusTableM = tableM_ . map (second render)
  where
    render s = statusIcon <$> s

sectionTableM :: (MonadUI m) => Text -> [(Text, m Text)] -> m ()
sectionTableM title = section_ title . tableM_

sectionConfig :: (MonadUI m) => [(Text, m Status)] -> m ()
sectionConfig = section_ "config" . tableM_ . map (second render)
  where
    render s = statusIcon <$> s

uiFormatTable :: (MonadUI m) => [[Text]] -> m ()
uiFormatTable rows =
  let n = if null rows then 0 else maximum (map length rows)
      padRow r = take n (r ++ repeat "")
      paddedRows = map padRow rows
      colWidths = [maximum (0 : map (T.length . (!! i)) paddedRows) | i <- [0 .. n - 1]]
      formatRow row =
        let padded = padRow row
            cells = zipWith (`T.justifyLeft` ' ') colWidths padded
         in putLine $ T.intercalate "  " cells
   in traverse_ formatRow rows

isError :: Issue -> Bool
isError i = issueSeverity i == SeverityError

renderSummaryLines :: [Issue] -> [Text]
renderSummaryLines [] = ["", renderSummaryStatus Checked, ""]
renderSummaryLines issues =
  let headerLine =
        if any isError issues
          then renderSummaryStatus Invalid
          else renderSummaryStatus Warning
      grouped = groupBy ((==) `on` issueTopic) (sortOn issueTopic issues)
      renderGroup [] = []
      renderGroup pkgIssues@(Issue {issueTopic = header} : _) =
        let l1 = "  "
            step = l1 <> subPathSign <> chalk Dim "• "
            l2 = l1 <> "    " <> subPathSign
            headerText = l1 <> chalk Dim "• " <> chalk Bold header
            renderMultilineIssue prefix continuation severity message =
              case T.lines message of
                [] -> [prefix]
                (line1 : restLines) ->
                  (prefix <> chalk (levelColor severity) line1)
                    : map (\line -> continuation <> chalk (levelColor severity) line) restLines
            renderIssue Issue {issueDetails = Nothing, issueSeverity, issueMessage} =
              renderMultilineIssue step (l1 <> "    ") issueSeverity issueMessage
            renderIssue Issue {issueDetails = Just (GenericIssue {issueFile}), issueSeverity, issueMessage} =
              renderMultilineIssue step (l1 <> "    ") issueSeverity issueMessage
                <> [l2 <> chalk Dim ("file: " <> format issueFile)]
            renderIssue Issue {issueDetails = Just (CommandIssue {issueCommand, issueLogFile}), issueSeverity, issueMessage} =
              let cmd =
                    if T.length issueCommand > 60
                      then T.take 60 issueCommand <> chalk Dim "..."
                      else issueCommand
               in [ step <> chalk (levelColor issueSeverity) (issueMessage <> ": ") <> cmd,
                    l2 <> chalk Dim ("logs: " <> format issueLogFile)
                  ]
            renderIssue Issue {issueDetails = Just (DependencyIssue {issueDependencies, issueFile}), issueSeverity, issueMessage} =
              let groupedDeps = Map.toList $ Map.fromListWith (++) [(scope, [(depName, actual, expected)]) | (scope, depName, actual, expected) <- issueDependencies]
                  depLines = concatMap formatGroup groupedDeps
                  formatGroup (scope, deps) =
                    (l2 <> chalk Dim "• " <> chalk Dim scope) : map formatDepLine deps
                  formatDepLine (depName, actual, expected) =
                    l1 <> "        " <> subPathSign <> depName <> ": " <> chalk Dim (actual <> " → " <> expected)
               in step <> chalk (levelColor issueSeverity) issueMessage
                    : l2 <> chalk Dim ("file: " <> format issueFile)
                    : depLines
            renderIssue Issue {issueDetails = Just (SourceInclusionIssue {issueComponent, issueTargets}), issueSeverity, issueMessage} =
              let targets = take 8 issueTargets
                  rest = length issueTargets - length targets
               in (step <> chalk (levelColor issueSeverity) issueMessage)
                    : (l2 <> chalk Dim ("component: " <> issueComponent <> " (" <> show (length issueTargets) <> ")"))
                    : map (\file -> l1 <> "        " <> subPathSign <> chalk Dim file) targets
                      <> [l1 <> "        " <> subPathSign <> chalk Dim ("… (+" <> show rest <> " more)") | rest > 0]
            detailLines = concatMap renderIssue pkgIssues
         in headerText : detailLines
   in ["", headerLine, ""] <> concatMap renderGroup grouped <> [""]

levelColor :: Severity -> Color
levelColor SeverityError = Red
levelColor SeverityWarning = Yellow

printSummary :: (MonadUI m, MonadIO m) => [Issue] -> m ()
printSummary issues = do
  uiSpace
  traverse_ putLine (renderSummaryLines issues) >> whenCI (traverse_ extractLog issues)
  where
    extractLog Issue {issueDetails = Just (CommandIssue {issueLogFile})} = do
      content <- liftIO $ T.readFile (toString issueLogFile)
      putLine $ chalk Dim ("--- CI logs for " <> format issueLogFile <> " ---")
      putLine content
    extractLog _ = pure ()

refreshFrame :: Text -> IO ()
refreshFrame f = do
  clearLine
  setCursorColumn 0
  putStr $ toString f
  hFlush stdout

loopFrames :: (Text -> Text) -> [Text] -> IO ()
loopFrames g = loop
  where
    loop (f : fs) = do
      refreshFrame (g f)
      threadDelay 200000
      loop (fs ++ [f])
    loop [] = pure ()

uiIndicator :: (MonadIO m) => (Text -> Text) -> Bool -> Maybe Status -> m ()
uiIndicator f False Nothing = liftIO $ refreshFrame $ f "►"
uiIndicator f True Nothing = liftIO $ loopFrames f ["◜", "◠", "◝", "◞", "◡", "◟"]
uiIndicator f _ (Just s) = liftIO $ refreshFrame $ f (statusIcon s)