-- 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
 (esNew
 ,esUpdate
 ,esDraw
 ,esHandle
 ,uiCheckBalanceAssertions
 ,uiReloadJournal
 ,uiReloadJournalIfChanged
 )
where

import Brick
-- import Brick.Widgets.Border ("border")
import Control.Monad
import Control.Monad.IO.Class (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 (mode, progname,prognameandversion)
import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.UIScreens
import Hledger.UI.Editor

esDraw :: UIState -> [Widget Name]
esDraw :: UIState -> [Widget Name]
esDraw UIState{aScreen :: UIState -> Screen
aScreen=ES ESS{String
()
_essError :: String
_essUnused :: ()
_essError :: ErrorScreenState -> String
_essUnused :: ErrorScreenState -> ()
..}
              ,aMode :: UIState -> Mode
aMode=Mode
mode
              } =
  case Mode
mode of
    Mode
Help       -> [Widget Name
helpDialog, Widget Name
maincontent]
    Mode
_          -> [Widget Name
maincontent]
  where
    maincontent :: Widget Name
maincontent = Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
      Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Widget Name -> Widget Name -> Widget Name -> Widget Name
defaultLayout Widget Name
forall {n}. Widget n
toplabel Widget Name
bottomlabel (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withAttr (String -> AttrName
attrName String
"error") (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ String -> Widget Name
forall n. String -> Widget n
str (String -> Widget Name) -> String -> Widget Name
forall a b. (a -> b) -> a -> b
$ String
_essError
      where
        toplabel :: Widget n
toplabel =
              AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr (String -> AttrName
attrName String
"border" AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"bold") (String -> Widget n
forall n. String -> Widget n
str String
"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 :: Widget Name
bottomlabel = Widget Name
quickhelp
                        -- case mode of
                        -- Minibuffer ed -> minibuffer ed
                        -- _             -> quickhelp
          where
            quickhelp :: Widget Name
quickhelp = [(String, String)] -> Widget Name
borderKeysStr [
               (String
"h", String
"help")
              ,(String
"ESC", String
"cancel/top")
              ,(String
"E", String
"editor")
              ,(String
"g", String
"reload")
              ,(String
"q", String
"quit")
              ]

esDraw UIState
_ = String -> [Widget Name]
forall a. HasCallStack => String -> a
error String
"draw function called with wrong screen type, should not happen"  -- PARTIAL:

esHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
esHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
esHandle BrickEvent Name AppEvent
ev = do
  UIState
ui0 <- EventM Name UIState UIState
get'
  case UIState
ui0 of
    ui :: UIState
ui@UIState{aScreen :: UIState -> Screen
aScreen=ES ESS{String
()
_essError :: ErrorScreenState -> String
_essUnused :: ErrorScreenState -> ()
_essError :: String
_essUnused :: ()
..}
              ,aopts :: UIState -> UIOpts
aopts=UIOpts{uoCliOpts :: UIOpts -> CliOpts
uoCliOpts=CliOpts
copts}
              ,ajournal :: UIState -> Journal
ajournal=Journal
j
              ,aMode :: UIState -> Mode
aMode=Mode
mode
              } ->
      case Mode
mode of
        Mode
Help ->
          case BrickEvent Name AppEvent
ev of
            VtyEvent (EvKey (KChar Char
'q') []) -> EventM Name UIState ()
forall n s. EventM n s ()
halt
            VtyEvent (EvKey (KChar Char
'l') [Modifier
MCtrl]) -> EventM Name UIState ()
forall n s. EventM n s ()
redraw
            VtyEvent (EvKey (KChar Char
'z') [Modifier
MCtrl]) -> UIState -> EventM Name UIState ()
forall a s. Ord a => s -> EventM a s ()
suspend UIState
ui
            BrickEvent Name AppEvent
_                    -> BrickEvent Name AppEvent -> EventM Name UIState ()
helpHandle BrickEvent Name AppEvent
ev

        Mode
_ -> do
          Day
d <- IO Day -> EventM Name UIState Day
forall a. IO a -> EventM Name UIState a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Day
getCurrentDay
          case BrickEvent Name AppEvent
ev of
            VtyEvent (EvKey (KChar Char
'q') []) -> EventM Name UIState ()
forall n s. EventM n s ()
halt
            VtyEvent (EvKey Key
KEsc        []) -> UIState -> EventM Name UIState ()
put' (UIState -> EventM Name UIState ())
-> UIState -> EventM Name UIState ()
forall a b. (a -> b) -> a -> b
$ Day -> UIState -> UIState
uiCheckBalanceAssertions Day
d (UIState -> UIState) -> UIState -> UIState
forall a b. (a -> b) -> a -> b
$ Day -> UIState -> UIState
resetScreens Day
d UIState
ui
            VtyEvent (EvKey (KChar Char
c)   []) | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'h',Char
'?'] -> UIState -> EventM Name UIState ()
put' (UIState -> EventM Name UIState ())
-> UIState -> EventM Name UIState ()
forall a b. (a -> b) -> a -> b
$ Mode -> UIState -> UIState
setMode Mode
Help UIState
ui
            VtyEvent (EvKey (KChar Char
'E') []) -> IO UIState -> EventM Name UIState ()
forall n s. Ord n => IO s -> EventM n s ()
suspendAndResume (IO UIState -> EventM Name UIState ())
-> IO UIState -> EventM Name UIState ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe TextPosition -> String -> IO ExitCode
runEditor Maybe TextPosition
pos String
f) IO () -> IO UIState -> IO UIState
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CliOpts -> Day -> Journal -> UIState -> IO UIState
uiReloadJournalIfChanged CliOpts
copts Day
d Journal
j (UIState -> UIState
popScreen UIState
ui)
              where
                (Maybe TextPosition
pos,String
f) = case Parsec Void String (String, Int, Int)
-> String
-> Either (ParseErrorBundle String Void) (String, Int, Int)
forall e a.
Parsec e String a -> String -> Either (ParseErrorBundle String e) a
parsewithString Parsec Void String (String, Int, Int)
forall (t :: * -> *). ParsecT Void String t (String, Int, Int)
hledgerparseerrorpositionp String
_essError of
                            Right (String
f',Int
l,Int
c) -> (TextPosition -> Maybe TextPosition
forall a. a -> Maybe a
Just (Int
l, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
c),String
f')
                            Left  ParseErrorBundle String Void
_       -> (Maybe TextPosition
endPosition, Journal -> String
journalFilePath Journal
j)
            BrickEvent Name AppEvent
e | BrickEvent Name AppEvent
e BrickEvent Name AppEvent -> [BrickEvent Name AppEvent] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Event -> BrickEvent Name AppEvent
forall n e. Event -> BrickEvent n e
VtyEvent (Key -> [Modifier] -> Event
EvKey (Char -> Key
KChar Char
'g') []), AppEvent -> BrickEvent Name AppEvent
forall n e. e -> BrickEvent n e
AppEvent AppEvent
FileChange] ->
              IO UIState -> EventM Name UIState UIState
forall a. IO a -> EventM Name UIState a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CliOpts -> Day -> UIState -> IO UIState
uiReloadJournal CliOpts
copts Day
d (UIState -> UIState
popScreen UIState
ui)) EventM Name UIState UIState
-> (UIState -> EventM Name UIState ()) -> EventM Name UIState ()
forall a b.
EventM Name UIState a
-> (a -> EventM Name UIState b) -> EventM Name UIState b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UIState -> EventM Name UIState ()
put' (UIState -> EventM Name UIState ())
-> (UIState -> UIState) -> UIState -> EventM Name UIState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> UIState -> UIState
uiCheckBalanceAssertions Day
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 Char
'I') []) -> UIState -> EventM Name UIState ()
put' (UIState -> EventM Name UIState ())
-> UIState -> EventM Name UIState ()
forall a b. (a -> b) -> a -> b
$ Day -> UIState -> UIState
uiCheckBalanceAssertions Day
d (UIState -> UIState
popScreen (UIState -> UIState) -> UIState -> UIState
forall a b. (a -> b) -> a -> b
$ UIState -> UIState
toggleIgnoreBalanceAssertions UIState
ui)
            VtyEvent (EvKey (KChar Char
'l') [Modifier
MCtrl]) -> EventM Name UIState ()
forall n s. EventM n s ()
redraw
            VtyEvent (EvKey (KChar Char
'z') [Modifier
MCtrl]) -> UIState -> EventM Name UIState ()
forall a s. Ord a => s -> EventM a s ()
suspend UIState
ui
            BrickEvent Name AppEvent
_ -> () -> EventM Name UIState ()
forall a. a -> EventM Name UIState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    UIState
_ -> String -> EventM Name UIState ()
forall a. String -> a
errorWrongScreenType String
"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 :: forall (t :: * -> *). ParsecT Void String t (String, Int, Int)
hledgerparseerrorpositionp = do
  ParsecT Void String t (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT Void String t (Token String)
-> ParsecT Void String t Char
-> ParsecT Void String t [Token String]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` Token String -> ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"'
  String
f <- ParsecT Void String t Char
ParsecT Void String t (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT Void String t Char
-> ParsecT Void String t (Token String)
-> ParsecT Void String t String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ([Token String] -> ParsecT Void String t (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'"',Char
'\n'])
  [ParsecT Void String t (String, Int, Int)]
-> ParsecT Void String t (String, Int, Int)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [
      do
          Tokens String -> ParsecT Void String t (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
" (line "
          Int
l <- String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT Void String t String -> ParsecT Void String t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String t Char -> ParsecT Void String t String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void String t Char
ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
          Tokens String -> ParsecT Void String t (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
", column "
          Int
c <- String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT Void String t String -> ParsecT Void String t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String t Char -> ParsecT Void String t String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void String t Char
ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
          (String, Int, Int) -> ParsecT Void String t (String, Int, Int)
forall a. a -> ParsecT Void String t a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f, Int
l, Int
c),
      do
          Tokens String -> ParsecT Void String t (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
" (lines "
          Int
l <- String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT Void String t String -> ParsecT Void String t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String t Char -> ParsecT Void String t String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void String t Char
ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
          Token String -> ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
          ParsecT Void String t Char -> ParsecT Void String t String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void String t Char
ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
          Token String -> ParsecT Void String t (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
')'
          (String, Int, Int) -> ParsecT Void String t (String, Int, Int)
forall a. a -> ParsecT Void String t a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f, Int
l, Int
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 :: CliOpts -> Day -> UIState -> IO UIState
uiReloadJournal CliOpts
copts Day
d UIState
ui = do
  Either String Journal
ej <-
    let copts' :: CliOpts
copts' = UIState -> CliOpts -> CliOpts
enableForecastPreservingPeriod UIState
ui CliOpts
copts
    in ExceptT String IO Journal -> IO (Either String Journal)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO Journal -> IO (Either String Journal))
-> ExceptT String IO Journal -> IO (Either String Journal)
forall a b. (a -> b) -> a -> b
$ CliOpts -> ExceptT String IO Journal
journalReload CliOpts
copts'
  -- dbg1IO "uiReloadJournal before reload" (map tdescription $ jtxns $ ajournal ui)
  UIState -> IO UIState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UIState -> IO UIState) -> UIState -> IO UIState
forall a b. (a -> b) -> a -> b
$ case Either String Journal
ej of
    Right Journal
j  ->
      -- dbg1 "uiReloadJournal after reload" (map tdescription $ jtxns j) $
      Journal -> Day -> UIState -> UIState
regenerateScreens Journal
j Day
d UIState
ui
    Left String
err ->
      case UIState
ui of
        UIState{aScreen :: UIState -> Screen
aScreen=ES ErrorScreenState
_} -> UIState
ui{aScreen=esNew err}
        UIState
_                      -> Screen -> UIState -> UIState
pushScreen (String -> Screen
esNew String
err) UIState
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 :: CliOpts -> Day -> Journal -> UIState -> IO UIState
uiReloadJournalIfChanged CliOpts
copts Day
d Journal
j UIState
ui = do
  let copts' :: CliOpts
copts' = UIState -> CliOpts -> CliOpts
enableForecastPreservingPeriod UIState
ui CliOpts
copts
  Either String (Journal, Bool)
ej <- ExceptT String IO (Journal, Bool)
-> IO (Either String (Journal, Bool))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO (Journal, Bool)
 -> IO (Either String (Journal, Bool)))
-> ExceptT String IO (Journal, Bool)
-> IO (Either String (Journal, Bool))
forall a b. (a -> b) -> a -> b
$ CliOpts -> Day -> Journal -> ExceptT String IO (Journal, Bool)
journalReloadIfChanged CliOpts
copts' Day
d Journal
j
  UIState -> IO UIState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UIState -> IO UIState) -> UIState -> IO UIState
forall a b. (a -> b) -> a -> b
$ case Either String (Journal, Bool)
ej of
    Right (Journal
j', Bool
_) -> Journal -> Day -> UIState -> UIState
regenerateScreens Journal
j' Day
d UIState
ui
    Left String
err -> case UIState -> Screen
aScreen UIState
ui of
        ES ErrorScreenState
_ -> UIState
ui{aScreen=esNew err}
        Screen
_    -> Screen -> UIState -> UIState
pushScreen (String -> Screen
esNew String
err) UIState
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 :: Day -> UIState -> UIState
uiCheckBalanceAssertions Day
_d ui :: UIState
ui@UIState{ajournal :: UIState -> Journal
ajournal=Journal
j}
  | UIState
uiUIState -> Getting Bool UIState Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool UIState Bool
forall c. HasBalancingOpts c => Lens' c Bool
Lens' UIState Bool
ignore_assertions = UIState
ui
  | Bool
otherwise =
    case Journal -> Maybe String
journalCheckBalanceAssertions Journal
j of
      Maybe String
Nothing  -> UIState
ui
      Just String
err ->
        case UIState
ui of
          UIState{aScreen :: UIState -> Screen
aScreen=ES ErrorScreenState
sst} -> UIState
ui{aScreen=ES sst{_essError=err}}
          UIState
_                        -> Screen -> UIState -> UIState
pushScreen (String -> Screen
esNew String
err) UIState
ui