hledger/hledger-ui/Hledger/UI/ErrorScreen.hs

-- The error screen, showing a current error condition (such as a parse error after reloading the journal)

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module Hledger.UI.ErrorScreen
 (errorScreen
 ,uiCheckBalanceAssertions
 ,uiReloadJournal
 ,uiReloadJournalIfChanged
 )
where

import Brick
-- import Brick.Widgets.Border ("border")
import Control.Monad
import Control.Monad.Except (liftIO)
import Data.Time.Calendar (Day)
import Data.Void (Void)
import Graphics.Vty (Event(..),Key(..),Modifier(..))
import Lens.Micro ((^.))
import Text.Megaparsec
import Text.Megaparsec.Char

import Hledger.Cli hiding (progname,prognameandversion)
import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.Editor

errorScreen :: Screen
errorScreen = ErrorScreen{
   sInit    = esInit
  ,sDraw    = esDraw
  ,sHandle  = esHandle
  ,esError  = ""
  }

esInit :: Day -> Bool -> UIState -> UIState
esInit _ _ ui@UIState{aScreen=ErrorScreen{}} = ui
esInit _ _ _ = error "init function called with wrong screen type, should not happen"  -- PARTIAL:

esDraw :: UIState -> [Widget Name]
esDraw UIState{aopts=UIOpts{uoCliOpts=copts}
              ,aScreen=ErrorScreen{..}
              ,aMode=mode
              } =
  case mode of
    Help       -> [helpDialog copts, maincontent]
    -- Minibuffer e -> [minibuffer e, maincontent]
    _          -> [maincontent]
  where
    maincontent = Widget Greedy Greedy $ do
      render $ defaultLayout toplabel bottomlabel $ withAttr (attrName "error") $ str $ esError
      where
        toplabel =
              withAttr (attrName "border" <> attrName "bold") (str "Oops. Please fix this problem then press g to reload")
              -- <+> (if ignore_assertions_ copts then withAttr ("border" <> "query") (str " ignoring") else str " not ignoring")

        bottomlabel = quickhelp
                        -- case mode of
                        -- Minibuffer ed -> minibuffer ed
                        -- _             -> quickhelp
          where
            quickhelp = borderKeysStr [
               ("h", "help")
              ,("ESC", "cancel/top")
              ,("E", "editor")
              ,("g", "reload")
              ,("q", "quit")
              ]

esDraw _ = error "draw function called with wrong screen type, should not happen"  -- PARTIAL:

esHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
esHandle ev = do
  ui0 <- get'
  case ui0 of
    ui@UIState{aScreen=ErrorScreen{..}
              ,aopts=UIOpts{uoCliOpts=copts}
              ,ajournal=j
              ,aMode=mode
              } ->
      case mode of
        Help ->
          case ev of
            VtyEvent (EvKey (KChar 'q') []) -> halt
            VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
            VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
            _                    -> helpHandle ev

        _ -> do
          let d = copts^.rsDay
          case ev of
            VtyEvent (EvKey (KChar 'q') []) -> halt
            VtyEvent (EvKey KEsc        []) -> put' $ uiCheckBalanceAssertions d $ resetScreens d ui
            VtyEvent (EvKey (KChar c)   []) | c `elem` ['h','?'] -> put' $ setMode Help ui
            VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
              where
                (pos,f) = case parsewithString hledgerparseerrorpositionp esError of
                            Right (f,l,c) -> (Just (l, Just c),f)
                            Left  _       -> (endPosition, journalFilePath j)
            e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] ->
              liftIO (uiReloadJournal copts d (popScreen ui)) >>= put' . uiCheckBalanceAssertions d
              -- (ej, _) <- liftIO $ journalReloadIfChanged copts d j
              -- case ej of
              --   Left err -> continue ui{aScreen=s{esError=err}} -- show latest parse error
              --   Right j' -> continue $ regenerateScreens j' d $ popScreen ui  -- return to previous screen, and reload it
            VtyEvent (EvKey (KChar 'I') []) -> put' $ uiCheckBalanceAssertions d (popScreen $ toggleIgnoreBalanceAssertions ui)
            VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
            VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
            _ -> return ()

    _ -> errorWrongScreenType "event handler"

-- | Parse the file name, line and column number from a hledger parse error message, if possible.
-- Temporary, we should keep the original parse error location. XXX
-- Keep in sync with 'Hledger.Data.Transaction.showGenericSourcePos'
hledgerparseerrorpositionp :: ParsecT Void String t (String, Int, Int)
hledgerparseerrorpositionp = do
  anySingle `manyTill` char '"'
  f <- anySingle `manyTill` (oneOf ['"','\n'])
  choice [
      do
          string " (line "
          l <- read <$> some digitChar
          string ", column "
          c <- read <$> some digitChar
          return (f, l, c),
      do
          string " (lines "
          l <- read <$> some digitChar
          char '-'
          some digitChar
          char ')'
          return (f, l, 1)
      ]


-- | Unconditionally reload the journal, regenerating the current screen
-- and all previous screens in the history as of the provided today-date.
-- If reloading fails, enter the error screen, or if we're already
-- on the error screen, update the error displayed.
-- Defined here so it can reference the error screen.
--
-- The provided CliOpts are used for reloading, and then saved in the
-- UIState if reloading is successful (otherwise the UIState keeps its old
-- CliOpts.) (XXX needed for.. ?)
--
-- Forecasted transactions are always generated, as at hledger-ui startup.
-- If a forecast period is specified in the provided opts, or was specified
-- at startup, it is preserved.
--
uiReloadJournal :: CliOpts -> Day -> UIState -> IO UIState
uiReloadJournal copts d ui = do
  ej <-
    let copts' = enableForecastPreservingPeriod ui copts
    in runExceptT $ journalReload copts'
  return $ case ej of
    Right j  -> regenerateScreens j d ui
    Left err ->
      case ui of
        UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}}
        _                                -> screenEnter d errorScreen{esError=err} ui
      -- XXX GHC 9.2 warning:
      -- hledger-ui/Hledger/UI/ErrorScreen.hs:164:59: warning: [-Wincomplete-record-updates]
      --     Pattern match(es) are non-exhaustive
      --     In a record-update construct:
      --         Patterns of type ‘Screen’ not matched:
      --             AccountsScreen _ _ _ _ _
      --             RegisterScreen _ _ _ _ _ _
      --             TransactionScreen _ _ _ _ _ _

-- | Like uiReloadJournal, but does not re-parse the journal if the file(s)
-- have not changed since last loaded. Always regenerates the screens though,
-- since the provided options or today-date may have changed.
uiReloadJournalIfChanged :: CliOpts -> Day -> Journal -> UIState -> IO UIState
uiReloadJournalIfChanged copts d j ui = do
  let copts' = enableForecastPreservingPeriod ui copts
  ej <- runExceptT $ journalReloadIfChanged copts' d j
  return $ case ej of
    Right (j', _) -> regenerateScreens j' d ui
    Left err -> case ui of
        UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}}
        _                                -> screenEnter d errorScreen{esError=err} ui

-- Re-check any balance assertions in the current journal, and if any
-- fail, enter (or update) the error screen. Or if balance assertions
-- are disabled, do nothing.
uiCheckBalanceAssertions :: Day -> UIState -> UIState
uiCheckBalanceAssertions d ui@UIState{ajournal=j}
  | ui^.ignore_assertions = ui
  | otherwise =
    case journalCheckBalanceAssertions j of
      Nothing  -> ui
      Just err ->
        case ui of
          UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}}
          _                                -> screenEnter d errorScreen{esError=err} ui