{-# 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 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")
bottomlabel :: Widget Name
bottomlabel = Widget Name
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"
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
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"
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)
]
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'
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 ->
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
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
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