Render.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Status as text for people and JSON for scripts and agents.
module Hledger.Flow.Status.Render
  ( useColor,
    yellow,
    renderStatus,
    renderNext,
    renderEnvironment,
    statusJSON,
    nextStepHere,
    printStatus,
    printNext,
  )
where

import Data.Aeson (Value, object, (.=))
import Data.Aeson.Text (encodeToLazyText)
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.IO as TL
import Hledger.Flow.Common (findHledger, findHledgerConf, homeDirs, nativeShell, tildePath)
import Hledger.Flow.DateTime (currentYear)
import Hledger.Flow.Environment (coresSetting, environmentJSON, environmentSettings, renderSettings)
import Hledger.Flow.Internals (SystemInfo, systemInfo)
import Hledger.Flow.Status.Gather (gatherStatus)
import Hledger.Flow.Types (BaseDir)
import Path.IO (getCurrentDir)
import qualified Data.Text as T
import Hledger.Flow.Status
import Hledger.Flow.Types (HledgerConf, HledgerInfo (..))
import Path (toFilePath)
import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..), SGR (..), hSupportsANSIColor, setSGRCode)
import System.Environment (lookupEnv)
import qualified System.FilePath as FilePath
import System.IO (Handle, stdout)

-- | Colour only on a terminal, and only when NO_COLOR is unset or empty.
useColor :: Handle -> IO Bool
useColor h = do
  noColor <- lookupEnv "NO_COLOR"
  supported <- hSupportsANSIColor h
  return (supported && maybe True null noColor)

paint :: Bool -> [SGR] -> T.Text -> T.Text
paint False _ txt = txt
paint True sgr txt = T.pack (setSGRCode sgr) <> txt <> T.pack (setSGRCode [Reset])

green, red, yellow, bold :: Bool -> T.Text -> T.Text
green c = paint c [SetColor Foreground Vivid Green]
red c = paint c [SetColor Foreground Vivid Red]
yellow c = paint c [SetColor Foreground Vivid Yellow]
bold c = paint c [SetConsoleIntensity BoldIntensity]

baseText :: LedgerStatus -> FilePath
baseText = FilePath.dropTrailingPathSeparator . toFilePath . lsBaseDir

renderStatus :: Bool -> [FilePath] -> LedgerStatus -> NextStep -> T.Text
renderStatus color homes s next =
  T.unlines (header : accountBlock ++ misplacedBlock) <> renderNext color next
  where
    header = bold color "Ledger: " <> T.pack (tildePath homes (baseText s)) <> "   (" <> hledgerText <> ")"
    hledgerText = case lsHledger s of
      Just hl -> "hledger " <> hledgerVersionNumber (hlVersion hl) <> " found"
      Nothing -> red color "hledger not found"
    rows = [(asAccount a, counts a, state a) | a <- lsAccounts s]
    width f = maximum (0 : map (T.length . f) rows)
    accountBlock
      | null rows = []
      | otherwise =
          "" : ["  " <> T.justifyLeft (width fst3) ' ' name <> "   " <> T.justifyLeft (width snd3) ' ' n <> "   " <> st | (name, n, st) <- rows]
    fst3 (x, _, _) = x
    snd3 (_, x, _) = x
    counts a = plural (asStatements a) "statement" <> years (asYears a)
    years [] = ""
    years [y] = " (" <> tshow y <> ")"
    years (y : ys) = " (" <> tshow y <> "–" <> tshow (last ys) <> ")"
    state a
      | asWithoutRules a > 0 && not (asConstruct a) = red color "✗ no rules file"
      | otherwise =
          let missing = asJournalsMissing a
              outdated = asJournalsOutdated a
              imported = asStatements a - missing
              parts =
                [plural imported "journal" | imported > 0]
                  ++ [tshow missing <> " not imported" | missing > 0]
                  ++ [tshow outdated <> " outdated" | outdated > 0]
              txt = T.intercalate ", " parts
           in if missing + outdated > 0 then yellow color ("• " <> txt) else green color ("✓ " <> txt)
    misplacedBlock = case length (lsMisplaced s) of
      0 -> []
      n -> ["", "  " <> yellow color ("⚠ " <> plural n "file" <> " not where hledger-flow looks")]

renderNext :: Bool -> NextStep -> T.Text
renderNext color next =
  T.unlines $
    ""
      : (bold color "Next:" <> " " <> nsSummary next)
      : map ("      " <>) (["Run: " <> c | Just c <- [nsCommand next]] ++ nsDetail next ++ ["Docs: " <> d | Just d <- [nsDocs next]])

tshow :: Show a => a -> T.Text
tshow = T.pack . show

statusJSON :: SystemInfo -> Maybe HledgerConf -> LedgerStatus -> NextStep -> Value
statusJSON sys conf s next =
  object
    [ "schemaVersion" .= (1 :: Int),
      "environment" .= environmentJSON sys conf,
      "baseDir" .= baseText s,
      "hledger" .= fmap hledgerJSON (lsHledger s),
      "ledgerFile" .= fmap (\lf -> object ["value" .= lfValue lf, "exists" .= lfExists lf]) (lsLedgerFile s),
      "accounts" .= map accountJSON (lsAccounts s),
      "misplaced" .= [object ["path" .= mpPath m, "suggestion" .= mpSuggestion m] | m <- lsMisplaced s],
      "manualJournals" .= lsManualJournals s,
      "allYearsJournalExists" .= lsAllYearsExists s,
      "next"
        .= object
          [ "summary" .= nsSummary next,
            "command" .= nsCommand next,
            "detail" .= nsDetail next,
            "docs" .= nsDocs next
          ]
    ]
  where
    hledgerJSON hl = object ["path" .= toFilePath (hlPath hl), "version" .= hledgerVersionNumber (hlVersion hl)]
    accountJSON a =
      object
        [ "account" .= asAccount a,
          "statements" .= asStatements a,
          "years" .= asYears a,
          "rulesFile" .= asRulesFile a,
          "rulesCandidates" .= asRulesCandidates a,
          "statementsWithoutRules" .= asWithoutRules a,
          "hooks" .= object ["preprocess" .= asPreprocess a, "construct" .= asConstruct a],
          "journalsMissing" .= asJournalsMissing a,
          "journalsOutdated" .= asJournalsOutdated a
        ]

-- | The next step for people to read with @homes@, or for scripts with @[]@ (absolute paths).
nextStepHere :: [FilePath] -> LedgerStatus -> IO NextStep
nextStepHere homes status = do
  year <- currentYear
  cwd <- getCurrentDir
  return (nextStep year nativeShell homes cwd status)

-- | The versions and paths status ran with, for bug reports. Paths under the home folder show as @~@.
renderEnvironment :: Bool -> [FilePath] -> SystemInfo -> Maybe HledgerConf -> LedgerStatus -> T.Text
renderEnvironment color homes sys conf s =
  T.unlines ("" : bold color "Environment:" : map ("  " <>) (renderSettings (red color) settings))
  where
    settings = environmentSettings homes sys (lsHledger s) conf ++ [coresSetting sys]

-- | Print the ledger's status as text, or as JSON for scripts and agents.
printStatus :: Maybe FilePath -> Maybe FilePath -> Bool -> BaseDir -> IO ()
printStatus hledgerPath confOpt json base = do
  hledger <- findHledger hledgerPath
  conf <- findHledgerConf confOpt
  status <- gatherStatus hledger base
  sys <- systemInfo
  if json
    then do
      next <- nextStepHere [] status
      TL.putStrLn (encodeToLazyText (statusJSON sys conf status next))
    else do
      color <- useColor stdout
      homes <- homeDirs
      next <- nextStepHere homes status
      T.putStr (renderStatus color homes status next <> renderEnvironment color homes sys conf status)

-- | Print only the next step for a ledger.
printNext :: Maybe FilePath -> BaseDir -> IO ()
printNext hledgerPath base = do
  hledger <- findHledger hledgerPath
  status <- gatherStatus hledger base
  homes <- homeDirs
  next <- nextStepHere homes status
  color <- useColor stdout
  T.putStr (renderNext color next)