content: {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE OverloadedStrings, LambdaCase #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module Main where
  
  import Brick
    ( Widget, App(..), AttrMap, BrickEvent(..), EventM
    , (<=>), (<+>), txt, halt, attrMap, on, fg
    , defaultMain, showFirstCursor, padBottom, Padding(Max,Pad)
    , padAll, padLeft, nestEventM', nestEventM, modify, gets, get, attrName
    )
  import Brick.Widgets.BetterDialog (dialog)
  import Brick.Widgets.Border (hBorder)
  import Brick.Widgets.Edit.EmacsBindings
    ( Editor, renderEditor, handleEditorEvent, getEditContents, editContentsL
    , editorText
    )
  import Brick.Widgets.List
    ( List, listMoveDown, listMoveUp, listMoveTo, listSelectedElement
    , listSelectedAttr, list
    )
  import Brick.Widgets.List.Utils (listSimpleReplace)
  import Graphics.Vty
    (Event(EvKey), Modifier(MCtrl,MMeta), Key(..), defAttr, black, white, green)
  
  import Control.Exception (SomeException, try)
  import Control.Monad (msum, when, void)
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Trans.Except (runExceptT)
  import Data.Functor.Identity (Identity(..), runIdentity)
  import Data.Maybe (fromMaybe, fromJust)
  import Data.Monoid (First(..), getFirst)
  import qualified Data.Semigroup as Sem
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import Data.Text.Zipper (gotoEOL, textZipper)
  import qualified Data.Vector as V
  import qualified Hledger as HL
  import qualified Hledger.Read.JournalReader as HL
  import Lens.Micro ((&), (.~), (^.), (%~))
  import Lens.Micro.Mtl
  import qualified Options.Applicative as OA
  import Options.Applicative
    ( ReadM, Parser, value, help, long, metavar, switch, helper, fullDesc, info
    , header, short, (<|>), eitherReader, execParser
    )
  import System.Directory (getHomeDirectory)
  import System.Environment (lookupEnv)
  import System.Environment.XDG.BaseDir (getUserConfigFile)
  import System.Exit (exitFailure, exitSuccess)
  import System.IO (hPutStr, hPutStrLn, stderr)
  import qualified Text.Megaparsec as P
  import qualified Text.Megaparsec.Char as P
  
  import Brick.Widgets.CommentDialog
  import Brick.Widgets.HelpMessage
  import Brick.Widgets.Border.Utils (borderLeft)
  import ConfigParser hiding (parseConfigFile)
  import DateParser
  import Model
  import View
  
  import Lens.Micro.TH
  
  import Data.Version (showVersion)
  import qualified Paths_hledger_iadd as Paths
  
  
  data Name = HelpName | ListName | EditorName | CommentName
    deriving (Ord, Show, Eq)
  
  data CommentType = TransactionComment | CurrentComment
  
  instance Show CommentType where
    show TransactionComment = "Transaction comment"
    show CurrentComment = "Comment"
  
  data DialogShown = NoDialog
                   | HelpDialog (HelpWidget Name)
                   | QuitDialog
                   | AbortDialog
                   | CommentDialog CommentType (CommentWidget Name)
  
  
  
  data AppState = AppState
    { _asEditor :: Editor Name
    , _asStep :: Step
    , _asJournal :: HL.Journal
    , _asContext :: List Name Text
    , _asSuggestion :: Maybe Text
    , _asMessage :: Text
    , _asFilename :: FilePath
    , _asDateFormat :: DateFormat
    , _asMatchAlgo :: MatchAlgo
    , _asDialog :: DialogShown
    , _asInputHistory :: [Text]
    }
  
  makeLenses ''AppState
  
  
  myHelpDialog :: DialogShown
  myHelpDialog = HelpDialog (helpWidget HelpName bindings)
  
  myCommentDialog :: CommentType -> Text -> DialogShown
  myCommentDialog typ comment =
    CommentDialog typ (commentWidget CommentName (T.pack $ show typ) comment)
  
  bindings :: KeyBindings
  bindings = KeyBindings
    [ ("Denial",
       [ ("C-c, C-d", "Quit without saving the current transaction")
       , ("Esc", "Abort the current transaction or exit when at toplevel")
       ])
    , ("Anger",
       [ ("F1, Alt-?", "Show help screen")])
    , ("Bargaining",
       [ ("C-n", "Select the next context item")
         , ("C-p", "Select the previous context item")
         , ("Tab", "Insert currently selected answer into text area")
         , ("C-z", "Undo")
         , (";", "Edit comment for current prompt")
         , ("Alt-;", "Edit transaction comment")
         ])
    , ("Acceptance",
       [ ("Ret", "Accept the currently selected answer")
       , ("Alt-Ret", "Accept the current answer verbatim, ignoring selection")
       ])]
  
  draw :: AppState -> [Widget Name]
  draw as = case as^.asDialog of
    HelpDialog h -> [renderHelpWidget h, ui]
    QuitDialog -> [quitDialog, ui]
    AbortDialog -> [abortDialog, ui]
    CommentDialog _ c -> [renderCommentWidget c, ui]
    NoDialog -> [ui]
  
    where ui =  txt "New Transaction:"
            <=> padAll 1 (borderLeft $ padLeft (Pad 1) $ viewState (as^.asStep))
            <=> hBorder
            <=> (viewQuestion (as^.asStep)
                 <+> viewSuggestion (as^.asSuggestion)
                 <+> txt ": "
                 <+> renderEditor True (as^.asEditor))
            <=> hBorder
            <=> expand (viewContext (as^.asContext))
            <=> hBorder
            <=> viewMessage (as^.asMessage)
  
          quitDialog = dialog "Quit" "Really quit without saving the current transaction? (Y/n)"
          abortDialog = dialog "Abort" "Really abort this transaction (Y/n)"
  
  setComment :: CommentType -> Text -> Step -> Step
  setComment TransactionComment = setTransactionComment
  setComment CurrentComment     = setCurrentComment
  
  -- TODO Refactor to remove code duplication in individual case statements
  event :: BrickEvent Name Event -> EventM Name AppState ()
  event (VtyEvent ev) = use asDialog >>= \case
    HelpDialog helpDia -> case ev of
      EvKey key []
        | key `elem` [KChar 'q', KEsc] -> asDialog .= NoDialog
        | otherwise                    -> do
            nestEventM' helpDia (handleHelpEvent ev) >>= assign asDialog . HelpDialog
      _ -> return ()
    QuitDialog -> case ev of
      EvKey key []
        | key `elem` [KChar 'y', KChar 'Y', KEnter] -> halt
        | otherwise -> asDialog .= NoDialog
      _ -> return ()
    AbortDialog -> case ev of
      EvKey key []
        | key `elem` [KChar 'y', KChar 'Y', KEnter] -> do
            asDialog .= NoDialog
            reset
        | otherwise -> asDialog .= NoDialog
      _ -> return ()
    CommentDialog typ dia -> nestEventM dia (handleCommentEvent ev) >>= \case
      (dia', CommentContinue) -> do
        asDialog .= CommentDialog typ dia'
        asStep %= setComment typ (commentDialogComment dia')
      (_, CommentFinished comment) -> do
        asDialog .= NoDialog
        asStep %= setComment typ comment
  
    NoDialog -> case ev of
      EvKey (KChar 'c') [MCtrl] -> use asStep >>= \case
        DateQuestion _ -> halt
        _              -> asDialog .= QuitDialog
      EvKey (KChar 'd') [MCtrl] -> use asStep >>= \case
        DateQuestion _ -> halt
        _              -> asDialog .= QuitDialog
      EvKey (KChar 'n') [MCtrl] -> do
        asContext %= listMoveDown
        asMessage .= ""
      EvKey KDown [] -> do
        asContext %= listMoveDown
        asMessage .= ""
      EvKey (KChar 'p') [MCtrl] -> do
        asContext %= listMoveUp
        asMessage .= ""
      EvKey KUp [] -> do
        asContext %= listMoveUp
        asMessage .= ""
      EvKey (KChar '\t') [] -> modify insertSelected
      EvKey (KChar ';') [] -> do
        step <- use asStep
        asDialog .= myCommentDialog CurrentComment (getCurrentComment step)
      EvKey (KChar ';') [MMeta] -> do
        step <- use asStep
        asDialog .= myCommentDialog TransactionComment (getTransactionComment step)
      EvKey KEsc [] -> use asStep >>= \case
        DateQuestion _ -> do
          t <- gets editText
          if T.null t then halt else reset
        _ -> asDialog .= AbortDialog
      EvKey (KChar 'z') [MCtrl] -> doUndo
      EvKey KEnter [MMeta] -> doNextStep False
      EvKey KEnter [] -> doNextStep True
      EvKey (KFun 1) [] -> asDialog .= myHelpDialog
      EvKey (KChar '?') [MMeta] -> asDialog .= myHelpDialog >> asMessage .= "Help"
      _ -> do
        zoom asEditor $ handleEditorEvent ev
        setContext
  event _ = return ()
  
  reset :: EventM n AppState ()
  reset = do
    as <- get
    sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) (DateQuestion "")
    
    asStep .= DateQuestion ""
    asEditor %= clearEdit
    asContext .= ctxList V.empty
    asSuggestion .= sugg
    asMessage .= "Transaction aborted"
  
  
  setContext :: EventM n AppState ()
  setContext = do
    as <- get
    newCtx <- liftIO $ context (as^.asJournal) (as^.asMatchAlgo) (as^.asDateFormat) (editText as) (as^.asStep)
    asContext %= listSimpleReplace (V.fromList newCtx)
        
  
  editText :: AppState -> Text
  editText = T.concat . getEditContents . _asEditor
  
  -- | Add a tranaction at the end of a journal
  --
  -- Hledgers `HL.addTransaction` adds it to the beginning, but our suggestion
  -- system expects newer transactions to be at the end.
  addTransactionEnd :: HL.Transaction -> HL.Journal -> HL.Journal
  addTransactionEnd t j = j { HL.jtxns = HL.jtxns j ++ [t] }
  
  doNextStep :: Bool -> EventM n AppState ()
  doNextStep useSelected = do
    as <- get
    let inputText = editText as
        name = fromMaybe (Left inputText) $
                 msum [ Right <$> if useSelected then snd <$> listSelectedElement (as^.asContext) else Nothing
                      , Left <$> asMaybe (editText as)
                      , Left <$> as^.asSuggestion
                      ]
    s <- liftIO $ nextStep (as^.asJournal) (as^.asDateFormat) name (as^.asStep)
    case s of
      Left err -> asMessage .= err
      Right (Finished trans) -> do
        liftIO $ addToJournal trans (as^.asFilename)
        sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) (DateQuestion "")
        asStep .= DateQuestion ""
        asJournal %= addTransactionEnd trans
        asEditor %= clearEdit
        asContext .= ctxList V.empty
        asSuggestion .= sugg
        asMessage .= "Transaction written to journal file"
        asDialog .= NoDialog
        asInputHistory .= []
      Right (Step s') -> do
        sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) s'
        ctx' <- ctxList . V.fromList <$> liftIO (context (as^.asJournal) (as^.asMatchAlgo) (as^.asDateFormat) "" s')
        asStep .= s'
        asEditor %= clearEdit
        asContext .= ctx'
        asSuggestion .= sugg
        asMessage .= ""
        -- Adhere to the 'undo' behaviour: when in the final
        -- confirmation question, 'undo' jumps back to the last amount
        -- question instead of to the last account question. So do not
        -- save the last empty account answer which indicates the end
        -- of the transaction.
        -- Furthermore, don't save the input if the FinalQuestion is
        -- answered by 'n' (for no).
        case (as^.asStep, s') of
          (FinalQuestion _ _, _) -> return ()
          (_, FinalQuestion _ _) -> return ()
          _                      -> asInputHistory %= (inputText :)
  
  doUndo :: EventM n AppState ()
  doUndo = use asStep >>= \s -> case undo s of
    Left msg -> asMessage .= "Undo failed: " <> msg
    Right step -> do
      as <- get
      let (lastInput,historyTail) =
            case as^.asInputHistory of
              x:t -> (x,t)
              [] -> ("",[])
  
      sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) step
      asStep .= step
      asEditor %= setEdit lastInput
      asSuggestion .= sugg
      asMessage .= "Undo."
      asInputHistory .= historyTail
      setContext
  
  insertSelected :: AppState -> AppState
  insertSelected as = case listSelectedElement (as^.asContext) of
    Nothing -> as
    Just (_, line) -> as & asEditor %~ setEdit line
  
  
  asMaybe :: Text -> Maybe Text
  asMaybe t
    | T.null t  = Nothing
    | otherwise = Just t
  
  attrs :: AttrMap
  attrs = attrMap defAttr
    [ (listSelectedAttr, black `on` white)
    , (helpAttr <> attrName "title", fg green)
    ]
  
  clearEdit :: Editor n -> Editor n
  clearEdit = setEdit ""
  
  setEdit :: Text -> Editor n -> Editor n
  setEdit content edit = edit & editContentsL .~ zipper
    where zipper = gotoEOL (textZipper [content] (Just 1))
  
  addToJournal :: HL.Transaction -> FilePath -> IO ()
  addToJournal trans path = appendFile path (T.unpack $ moveEmptyLine $ HL.showTransaction trans)
    where
      -- showTransactionUnelided adds an empty line to the end of the transaction. We want
      -- the empty line to be at the start instead, to allow it to be added to a
      -- journal that doesn't end with a newline.
      moveEmptyLine :: Text -> Text
      moveEmptyLine = T.unlines . ("":) . init . T.lines
  
  --------------------------------------------------------------------------------
  -- Command line and config parsing
  --------------------------------------------------------------------------------
  
  data CommonOptions f = CommonOptions
    { optLedgerFile :: f FilePath
    , optDateFormat :: f String
    , optMatchAlgo  :: f MatchAlgo
    }
  
  instance Sem.Semigroup (CommonOptions Maybe) where
    (<>) opt1 opt2 =
      let opt1' = optNatTrans First opt1
          opt2' = optNatTrans First opt2
      in optNatTrans getFirst $ CommonOptions
         { optLedgerFile = optLedgerFile opt1' <> optLedgerFile opt2'
         , optDateFormat = optDateFormat opt1' <> optDateFormat opt2'
         , optMatchAlgo = optMatchAlgo opt1' <> optMatchAlgo opt2'
         }
  
  instance Monoid (CommonOptions Maybe) where
    mappend = (Sem.<>)
    mempty = CommonOptions Nothing Nothing Nothing
  
  optNatTrans :: (forall a. f a -> g a) -> CommonOptions f -> CommonOptions g
  optNatTrans nat opts = CommonOptions
    { optLedgerFile = nat $ optLedgerFile opts
    , optDateFormat = nat $ optDateFormat opts
    , optMatchAlgo = nat $ optMatchAlgo opts
    }
  
  optFromJust :: CommonOptions Identity -> CommonOptions Maybe -> CommonOptions Identity
  optFromJust def opts =
    optNatTrans (Identity . fromJust) ( opts <> optNatTrans (Just . runIdentity) def)
  
  data CmdLineOptions = CmdLineOptions
    { cmdCommon :: CommonOptions Maybe
    , cmdDumpConfig :: Bool
    , cmdVersion :: Bool
    }
  
  data ConfOptions = ConfOptions { confCommon :: CommonOptions Maybe }
  
  defaultOptions :: FilePath -> CommonOptions Identity
  defaultOptions home = CommonOptions
    { optLedgerFile = Identity (ledgerPath home)
    , optDateFormat = Identity "[[%y/]%m/]%d"
    , optMatchAlgo = Identity Substrings
    }
  
  ledgerPath :: FilePath -> FilePath
  ledgerPath home = home <> "/.hledger.journal"
  
  configPath :: IO FilePath
  configPath = getUserConfigFile "hledger-iadd" "config.conf"
  
  -- | Megaparsec parser for MatchAlgo, used for config file parsing
  parseMatchAlgo :: OParser MatchAlgo
  parseMatchAlgo =  (P.string "fuzzy" *> pure Fuzzy)
                <|> (P.string "substrings" *> pure Substrings)
  
  -- | ReadM parser for MatchAlgo, used for command line option parsing
  readMatchAlgo :: ReadM MatchAlgo
  readMatchAlgo = eitherReader reader
    where
      reader str
        | str == "fuzzy" = return Fuzzy
        | str == "substrings" = return Substrings
        | otherwise = Left "Expected \"fuzzy\" or \"substrings\""
  
  -- | Parser for our config file
  confParser :: CommonOptions Identity -> OptParser ConfOptions
  confParser def = fmap ConfOptions $ CommonOptions
    -- TODO Convert leading tilde to home
    <$> (Just <$> option "file" (runIdentity $ optLedgerFile def) "Path to the journal file")
    <*> (Just <$> option "date-format" (runIdentity $ optDateFormat def) "Format used to parse dates")
    <*> (Just <$> customOption "completion-engine" matchAlgo (T.toLower $ T.pack $ show matchAlgo)
        ( "Algorithm used to find completions for account names. Possible values are:\n"
        <> "  - substrings: Every word in the search string has to occur somewhere in the account name\n"
        <> "  - fuzzy: All letters from the search string have to appear in the name in the same order"
        )
        "string"
        parseMatchAlgo
        )
  
    where matchAlgo = runIdentity (optMatchAlgo def)
  
  -- | IO Action to read and parse config file
  parseConfigFile :: IO ConfOptions
  parseConfigFile = do
    path <- configPath
    home <- getHomeDirectory
    let def = defaultOptions home
  
    try (T.readFile path) >>= \case
      Left (_ :: SomeException) -> return (parserDefault $ confParser def)
      Right res -> case parseConfig path res (confParser def) of
        Left err -> do
          putStr (P.errorBundlePretty err)
          exitFailure
        Right res' -> return res'
  
  -- | command line option parser
  cmdOptionParser :: Parser CmdLineOptions
  cmdOptionParser = CmdLineOptions
    <$> (CommonOptions
         <$> OA.option (Just <$> OA.str)
             (  long "file"
             <> short 'f'
             <> metavar "FILE"
             <> value Nothing
             <> help "Path to the journal file"
             )
         <*> OA.option (Just <$> OA.str)
               (  long "date-format"
               <> metavar "FORMAT"
               <> value Nothing
               <> help "Format used to parse dates"
               )
        <*> OA.option (Just <$> readMatchAlgo)
              (  long "completion-engine"
              <> metavar "ENGINE"
              <> value Nothing
              <> help "Algorithm for account name completion. Possible values: \"fuzzy\", \"substrings\"")
        )
    <*> switch
          ( long "dump-default-config"
         <> help "Print an example configuration file to stdout and exit"
          )
    <*> switch
          ( long "version"
         <> help "Print version number and exit"
          )
  
  parseEnvVariables :: IO (CommonOptions Maybe)
  parseEnvVariables = do
    maybeFilePath <- lookupEnv "LEDGER_FILE"
    return mempty
      { optLedgerFile = maybeFilePath }
  
  main :: IO ()
  main = do
    home <- getHomeDirectory
    path <- configPath
    let defOpts = defaultOptions home
  
    cmdOpts <- execParser $ info (helper <*> cmdOptionParser) $
                 fullDesc <> header "A terminal UI as drop-in replacement for hledger add."
  
    when (cmdVersion cmdOpts) $ do
      putStrLn $ "This is hledger-iadd version " <> showVersion Paths.version
      exitSuccess
  
    when (cmdDumpConfig cmdOpts) $ do
      T.putStrLn $ "# Write this to " <> T.pack path <> "\n"
      T.putStrLn (parserExample $ confParser defOpts)
      exitSuccess
  
    confOpts <- parseConfigFile
  
    envOpts <- parseEnvVariables
  
    -- The order of precedence here is:
    -- arguments > environment > config file
    let opts = optFromJust defOpts $ cmdCommon cmdOpts <> envOpts <> confCommon confOpts
  
    date <- case parseDateFormat (T.pack $ runIdentity $ optDateFormat opts) of
      Left err -> do
        hPutStr stderr "Could not parse date format: "
        T.hPutStr stderr err
        exitFailure
      Right res -> return res
  
    let path = runIdentity $ optLedgerFile opts
    journalContents <- T.readFile path
  
    let hlIopts = HL.definputopts
  
    runExceptT (HL.parseAndFinaliseJournal (HL.journalp hlIopts) hlIopts path journalContents) >>= \case
      Left err -> hPutStrLn stderr err >> exitFailure
      Right journal -> do
        let edit = editorText EditorName (txt . T.concat) (Just 1) ""
  
        sugg <- suggest journal date (DateQuestion "")
  
        let welcome = "Welcome! Press F1 (or Alt-?) for help. Exit with Ctrl-d."
            matchAlgo = runIdentity $ optMatchAlgo opts
            as = AppState edit (DateQuestion "") journal (ctxList V.empty) sugg welcome path date matchAlgo NoDialog []
  
        void $ defaultMain app as
  
      where app = App { appDraw = draw
                      , appChooseCursor = showFirstCursor
                      , appHandleEvent = event
                      , appAttrMap = const attrs
                      , appStartEvent = return ()
                      } :: App AppState Event Name
  
  expand :: Widget n -> Widget n
  expand = padBottom Max
  
  ctxList :: V.Vector e -> List Name e
  ctxList v = (if V.null v then id else listMoveTo 0) $ list ListName v 1
  