diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Hans-Peter Deifel (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hans-Peter Deifel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hledger-iadd.cabal b/hledger-iadd.cabal new file mode 100644 --- /dev/null +++ b/hledger-iadd.cabal @@ -0,0 +1,94 @@ +name: hledger-iadd +version: 1.1 +synopsis: A terminal UI as drop-in replacement for hledger add +description: Please see README.md +homepage: http://github.com/rootzlevel/hledger-iadd#readme +license: BSD3 +license-file: LICENSE +author: Hans-Peter Deifel +maintainer: hpd@hpdeifel.de +copyright: 2016 Hans-Peter Deifel +category: Finance, Console +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/rootzlevel/hledger-iadd.git + +library + hs-source-dirs: src + exposed-modules: Model + , View + , AmountParser + , DateParser + , ConfigParser + , Brick.Widgets.List.Utils + , Brick.Widgets.HelpMessage + , Brick.Widgets.BetterDialog + , Brick.Widgets.WrappedText + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , hledger-lib >= 1.0 && < 1.1 + , brick >= 0.14 && < 0.16 + , vty >= 5.4 + , text + , microlens + , text-zipper + , transformers >= 0.3 + , time >= 1.5 + , vector + , megaparsec >= 5.0 && <5.2 + , containers + , optparse-applicative + , directory + , text-format + , xdg-basedir + , unordered-containers + , free >= 4.12.4 + +executable hledger-iadd + hs-source-dirs: src/main + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , hledger-iadd + , hledger-lib >= 1.0 && < 1.1 + , brick >= 0.14 && < 0.16 + , vty >= 5.4 + , text + , microlens + , text-zipper + , transformers >= 0.3 + , time >= 1.5 + , vector + , optparse-applicative + , directory + , text-format + , xdg-basedir + , unordered-containers + , free >= 4.12.4 + , megaparsec >= 5.0 && <5.2 + + ghc-options: -threaded + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + other-modules: DateParserSpec + , ConfigParserSpec + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , hledger-iadd + , hledger-lib >= 1.0 && < 1.1 + , text + , transformers >= 0.3 + , time >= 1.5 + , vector + , hspec + , QuickCheck + , text-format + , free >= 4.12.4 + , megaparsec >= 5.0 && <5.2 + ghc-options: -threaded -Wall diff --git a/src/AmountParser.hs b/src/AmountParser.hs new file mode 100644 --- /dev/null +++ b/src/AmountParser.hs @@ -0,0 +1,29 @@ +module AmountParser (parseAmount) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Hledger as HL +import Data.Functor.Identity +import Control.Monad.Trans.State.Strict +import Text.Megaparsec + +type Parser a = HL.JournalStateParser Identity a + +parseAmount :: HL.Journal -> Text -> Either String HL.MixedAmount +parseAmount journal t = case runIdentity $ runParserT (evalStateT (mixed <* optional space <* eof) journal) "" t of + Left err -> Left (parseErrorPretty err) + Right res -> Right res + +mixed :: Parser HL.MixedAmount +mixed = HL.mixed <$> expr + +expr :: Parser [HL.Amount] +expr = some (try $ lexeme factor) + +factor :: Parser HL.Amount +factor = (char '+' >> lexeme HL.amountp) + <|> (char '-' >> flip HL.divideAmount (-1) <$> lexeme HL.amountp) + <|> HL.amountp + +lexeme :: Parser a -> Parser a +lexeme p = space >> p diff --git a/src/Brick/Widgets/BetterDialog.hs b/src/Brick/Widgets/BetterDialog.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/BetterDialog.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Brick.Widgets.BetterDialog ( dialog )where + +import Brick +import Brick.Widgets.Border +import Graphics.Vty +import Data.Text (Text) +import Lens.Micro + +dialog :: Text -> Text -> Widget n +dialog title = center . dialog' title + +-- TODO Remove duplication from HelpMessage +center :: Widget n -> Widget n +center w = Widget Fixed Fixed $ do + c <- getContext + res <- render w + let rWidth = res^.imageL.to imageWidth + rHeight = res^.imageL.to imageHeight + x = (c^.availWidthL `div` 2) - (rWidth `div` 2) + y = (c^.availHeightL `div` 2) - (rHeight `div` 2) + + render $ translateBy (Location (x,y)) $ raw (res^.imageL) + +dialog' :: Text -> Text -> Widget n +dialog' title content = Widget Fixed Fixed $ do + c <- getContext + + render $ + hLimit (min 80 $ c^.availWidthL) $ + vLimit (min 30 $ c^.availHeightL) $ + borderWithLabel (txt title) $ + txt " " + <=> (txt " " <+> txt content <+> txt " ") + <=> txt " " diff --git a/src/Brick/Widgets/HelpMessage.hs b/src/Brick/Widgets/HelpMessage.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/HelpMessage.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings, NamedFieldPuns, ConstraintKinds #-} +module Brick.Widgets.HelpMessage + ( HelpWidget + , Title + , KeyBindings(..) + , helpWidget + , renderHelpWidget + , helpAttr + , resetHelpWidget + , handleHelpEvent + ) where + +import Brick +import Brick.Markup +import Brick.Widgets.Border +import Graphics.Vty +import Data.Text (Text) +import Data.Monoid +import Data.List +import Lens.Micro + +type Title = Text + +-- [(Title, [(Key, Description)])] +newtype KeyBindings = KeyBindings [(Title, [(Text, Text)])] + +data HelpWidget n = HelpWidget + { keyBindings :: KeyBindings + , name :: n + } + +type Name n = (Ord n, Show n) + +helpWidget :: n -> KeyBindings -> HelpWidget n +helpWidget = flip HelpWidget + +renderHelpWidget :: Name n => HelpWidget n -> Widget n +renderHelpWidget HelpWidget{keyBindings, name} = + center $ renderHelpWidget' name keyBindings + +center :: Widget n -> Widget n +center w = Widget Fixed Fixed $ do + c <- getContext + res <- render w + let rWidth = res^.imageL.to imageWidth + rHeight = res^.imageL.to imageHeight + x = (c^.availWidthL `div` 2) - (rWidth `div` 2) + y = (c^.availHeightL `div` 2) - (rHeight `div` 2) + + render $ translateBy (Location (x,y)) $ raw (res^.imageL) + +renderHelpWidget' :: Name n => n -> KeyBindings -> Widget n +renderHelpWidget' name (KeyBindings bindings) = Widget Fixed Fixed $ do + c <- getContext + + render $ + hLimit (min 80 $ c^.availWidthL) $ + vLimit (min 30 $ c^.availHeightL) $ + borderWithLabel (txt "Help") $ + viewport name Vertical $ + vBox $ intersperse (txt " ") $ + map (uncurry section) bindings + +scroller :: HelpWidget n -> ViewportScroll n +scroller HelpWidget{name} = viewportScroll name + +handleHelpEvent :: HelpWidget n -> Event -> EventM n (HelpWidget n) +handleHelpEvent help (EvKey k _) = case k of + KChar 'j' -> vScrollBy (scroller help) 1 >> return help + KDown -> vScrollBy (scroller help) 1 >> return help + KChar 'k' -> vScrollBy (scroller help) (-1) >> return help + KUp -> vScrollBy (scroller help) (-1) >> return help + KChar 'g' -> vScrollToBeginning (scroller help) >> return help + KHome -> vScrollToBeginning (scroller help) >> return help + KChar 'G' -> vScrollToEnd (scroller help) >> return help + KEnd -> vScrollToEnd (scroller help) >> return help + KPageUp -> vScrollPage (scroller help) Up >> return help + KPageDown -> vScrollPage (scroller help) Down >> return help + _ -> return help +handleHelpEvent help _ = return help + + +resetHelpWidget :: HelpWidget n -> EventM n () +resetHelpWidget = vScrollToBeginning . scroller + +key :: Text -> Text -> Widget n +key k h = markup ((" " <> k) @? (helpAttr <> "key")) + <+> padLeft Max (markup (h @? (helpAttr <> "description"))) + +helpAttr :: AttrName +helpAttr = "help" + +section :: Title -> [(Text, Text)] -> Widget n +section title keys = markup ((title <> ":") @? (helpAttr <> "title")) + <=> vBox (map (uncurry key) keys) diff --git a/src/Brick/Widgets/List/Utils.hs b/src/Brick/Widgets/List/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/List/Utils.hs @@ -0,0 +1,22 @@ +module Brick.Widgets.List.Utils where + +import Brick.Widgets.List +import Data.Maybe +import qualified Data.Vector as V +import Lens.Micro + +-- | Replace the contents of a list with a new set of elements but preserve the +-- currently selected index. +-- +-- This is a version of listReplace that doesn't try to be smart, but assumes +-- that all the elements in one list are distinct. +-- +-- listReplace itself is broken as of brick-0.2 due to a bogus implementation of +-- the `merge` function. +listSimpleReplace :: Eq e => V.Vector e -> List n e -> List n e +listSimpleReplace elems oldList = + let selected = flip V.elemIndex elems . snd =<< listSelectedElement oldList + newSelected = if V.null elems + then Nothing + else Just $ fromMaybe 0 selected + in oldList & listElementsL .~ elems & listSelectedL .~ newSelected diff --git a/src/Brick/Widgets/WrappedText.hs b/src/Brick/Widgets/WrappedText.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/WrappedText.hs @@ -0,0 +1,25 @@ +module Brick.Widgets.WrappedText (wrappedText) where + +import Brick +import Data.Text (Text) +import qualified Data.Text as T +import Lens.Micro + +-- | Widget like 'txt', but wrap all lines to fit on the screen. +-- +-- Doesn't do word wrap, just breaks the line whenever the maximum width is +-- exceeded. +wrappedText :: Text -> Widget n +wrappedText theText = Widget Fixed Fixed $ do + ctx <- getContext + let newText = wrapLines (ctx^.availWidthL) theText + render $ txt newText + +-- | Wrap all lines in input to fit into maximum width. +-- +-- Doesn't do word wrap, just breaks the line whenever the maximum width is +-- exceeded. +wrapLines :: Int -> Text -> Text +wrapLines width = T.unlines . concat . map wrap . T.lines + where + wrap = T.chunksOf width diff --git a/src/ConfigParser.hs b/src/ConfigParser.hs new file mode 100644 --- /dev/null +++ b/src/ConfigParser.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs, DeriveFunctor, ScopedTypeVariables #-} + +-- | Applicative config parser. +-- +-- This parses config files in the style of optparse-applicative. It supports +-- automatic generation of a default config both as datatype and in printed +-- form. +-- +-- Example: +-- +-- @ +-- data Config = Config +-- { test :: Text +-- , foobar :: Int +-- } +-- +-- confParser :: ConfParser Config +-- confParser = Config +-- \<$\> option "test" "default value" "Help for test" +-- \<*\> option "foobar" 42 "Help for foobar" +-- @ +-- +-- This parses a config file like the following: +-- +-- > # This is a comment +-- > test = "something" +-- > foobar = 23 +module ConfigParser + ( OptParser + , parseConfig + , parseConfigFile + , option + , customOption + , parserDefault + , parserExample + , ConfParseError + , Option + , OptionArgument() + ) where + +import Control.Applicative +import Control.Applicative.Free +import Control.Arrow +import Control.Monad +import Data.Char +import Data.Functor.Identity +import Data.Monoid +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Set as S +import qualified Text.Megaparsec as P +import Text.Megaparsec hiding ((<|>), many, option, optional) +import Text.Megaparsec.Char +import Text.Megaparsec.Error +import Text.Megaparsec.Text + +-- | Parse a config file from a 'Text'. +parseConfig :: FilePath -- ^ File path to use in error messages + -> Text -- ^ The input test + -> OptParser a -- ^ The parser to use + -> Either ConfParseError a +parseConfig path input parser = case parse (assignmentList <* eof) path input of + Left err -> Left $ SyntaxError err + Right res -> runOptionParser res parser + +-- | Parse a config file from an actual file in the filesystem. +parseConfigFile :: FilePath -- ^ Path to the file + -> OptParser a -- ^ The parser to use + -> IO (Either ConfParseError a) +parseConfigFile path parser = do + input <- T.readFile path + return $ parseConfig path input parser + +-- | An option in the config file. Use 'option' as a smart constructor. +data Option a = Option + { optParser :: Parser a + , optType :: Text -- Something like "string" or "integer" + , optName :: Text + , optHelp :: Text + , optDefault :: a + , optDefaultTxt :: Text -- printed version of optDefault + } deriving (Functor) + +-- | The main parser type. Use 'option' and the 'Applicative' instance to create those. +type OptParser a = Ap Option a + +-- | Errors that can occur during parsing. Use the 'Show' instance for printing. +data ConfParseError = SyntaxError (ParseError Char Dec) + | UnknownOption SourcePos Text + | TypeError (ParseError Char Dec) + deriving (Eq) + +instance Show ConfParseError where + show (SyntaxError e) = parseErrorPretty e + show (UnknownOption pos key) = + show pos ++ ": Unknown option " ++ T.unpack key + show (TypeError e) = parseErrorPretty e + +-- | Class for supported option types. +-- +-- At the moment, orphan instances are not supported +class OptionArgument a where + mkParser :: (Text, Parser a) + printArgument :: a -> Text + +-- | 'OptParser' that parses one option. +-- +-- Can be combined with the 'Applicative' instance for 'OptParser'. See the +-- module documentation for an example. +option :: OptionArgument a + => Text -- ^ The option name + -> a -- ^ The default value + -> Text + -- ^ A help string for the option. Will be used by 'parserExample' to + -- create helpful comments. + -> OptParser a +option name def help = liftAp $ Option parser typename name help def (printArgument def) + where (typename, parser) = mkParser + +customOption :: Text -- ^ The option name + -> a -- ^ The default Value + -> Text -- ^ A textual representation of the default value + -> Text -- ^ A help string for the option + -> Text -- ^ A description of the expected type such sas "string" or "integer" + -> Parser a -- ^ Parser for the option + -> OptParser a +customOption optName optDefault optDefaultTxt optHelp optType optParser = liftAp $ Option {..} + +instance OptionArgument Int where + mkParser = ("integer", parseNumber) + printArgument = T.pack . show + +instance OptionArgument Integer where + mkParser = ("integer", parseNumber) + printArgument = T.pack . show + +instance OptionArgument String where + mkParser = ("string", many anyChar) + printArgument = quote . T.pack + +instance OptionArgument Text where + mkParser = ("string", T.pack <$> many anyChar) + printArgument = quote + +quote :: Text -> Text +quote x = "\"" <> escape x <> "\"" + where + escape = T.replace "\"" "\\\"" . T.replace "\\" "\\\\" + +runOptionParser :: [Assignment] -> OptParser a -> Either ConfParseError a +runOptionParser (a:as) parser = parseOption parser a >>= runOptionParser as +runOptionParser [] parser = Right $ parserDefault parser + +-- | Returns the default value of a given parser. +-- +-- This default value is computed from the default arguments of the 'option' +-- constructor. For the parser from the module description, the default value +-- would be: +-- +-- > Config { test = "default value" +-- > , foobar :: 42 +-- > } +parserDefault :: OptParser a -> a +parserDefault = runIdentity . runAp (Identity . optDefault) + +-- | Generate the default config file. +-- +-- This returns a valid config file, filled with the default values of every +-- option and using the help string of these options as comments. +parserExample :: OptParser a -> Text +parserExample = T.strip . runAp_ example1 + where example1 a = commentify (optHelp a) <> optName a <> " = " <> optDefaultTxt a <> "\n\n" + commentify = T.unlines . map ("# " <>) . T.lines + +parseOption :: OptParser a -> Assignment -> Either ConfParseError (OptParser a) +parseOption (Pure _) ass = + Left $ UnknownOption (assignmentPosition ass) (assignmentKey ass) +parseOption (Ap opt rest) ass + | optName opt == assignmentKey ass = + let content = (valueContent $ assignmentValue ass) + pos = (valuePosition $ assignmentValue ass) + in case parseWithStart (optParser opt <* eof) pos content of + Left e -> Left $ TypeError $ addErrorMessage e $ + "in " ++ T.unpack (optType opt) ++ " argument for option " ++ T.unpack (assignmentKey ass) + Right res -> Right $ fmap ($ res) rest + | otherwise = fmap (Ap opt) $ parseOption rest ass + + where testParse = Nothing + +-- Low level assignment parser + +data Assignment = Assignment + { assignmentPosition :: SourcePos + , assignmentKey :: Text + , assignmentValue :: AssignmentValue + } deriving (Show) + +data AssignmentValue = AssignmentValue + { valuePosition :: SourcePos + , valueContent :: Text + } deriving (Show) + +assignmentList :: Parser [Assignment] +assignmentList = whitespace *> many (assignment <* whitespace) + +assignment :: Parser Assignment +assignment = do + Assignment + <$> getPosition <*> key <* whitespaceNoComment + <* char '=' <* whitespaceNoComment + <*> value + +key :: Parser Text +key = T.pack <$> some (alphaNumChar <|> char '_' <|> char '-') + +value :: Parser AssignmentValue +value = AssignmentValue <$> getPosition <*> content <* whitespaceNoEOL <* (void eol <|> eof) + +content :: Parser Text +content = escapedString + <|> bareString + +bareString :: Parser Text +bareString = (T.strip . T.pack <$> some (noneOf ("#\n" :: String))) + "bare string" + +escapedString :: Parser Text +escapedString = (T.pack <$> (char '"' *> many escapedChar <* char '"')) + "quoted string" + where escapedChar = char '\\' *> anyChar + <|> noneOf ("\"" :: String) + +whitespace :: Parser () +whitespace = skipMany $ (void $ oneOf (" \t\n" :: String)) <|> comment + +whitespaceNoEOL :: Parser () +whitespaceNoEOL = skipMany $ (void $ oneOf (" \t" :: String)) <|> comment + +whitespaceNoComment :: Parser () +whitespaceNoComment = skipMany $ oneOf (" \t" :: String) + +comment :: Parser () +comment = char '#' >> skipMany (noneOf ("\n" :: String)) + +parseWithStart :: (Stream s, ErrorComponent e) + => Parsec e s a -> SourcePos -> s -> Either (ParseError (Token s) e) a +parseWithStart p pos = parse p' (sourceName pos) + where p' = do setPosition pos; p + +parseNumber :: Read a => Parser a +parseNumber = read <$> ((<>) <$> (P.option "" $ string "-") <*> some digitChar) + +-- | Helper function brought over from parsec +addErrorMessage :: ParseError t Dec -> String -> ParseError t Dec +addErrorMessage e errorMsg = e { errorCustom = S.insert (DecFail errorMsg) (errorCustom e) } diff --git a/src/DateParser.hs b/src/DateParser.hs new file mode 100644 --- /dev/null +++ b/src/DateParser.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TupleSections #-} +{-# LANGUAGE DeriveFunctor, LambdaCase, ViewPatterns #-} + +module DateParser + ( DateFormat + , parseDateFormat + , german + + , parseDate + , parseDateWithToday + + , parseHLDate + , parseHLDateWithToday + + , printDate + + -- * Utilities + , weekDay + ) where + +import Control.Applicative +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Buildable (Buildable,build) +import Data.Text.Format hiding (build) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder (Builder, toLazyText) +import Data.Time hiding (parseTime) +import Data.Time.Calendar.WeekDate +import qualified Hledger.Data.Dates as HL +import Text.Megaparsec hiding ((<|>), many) +import Text.Megaparsec.Text + +newtype DateFormat = DateFormat [DateSpec] + deriving (Eq, Show) + +-- TODO Add show instance that corresponds to parsed expression + +data DateSpec = DateYear + | DateYearShort + | DateMonth + | DateDay + | DateString Text + | DateOptional [DateSpec] + deriving (Show, Eq) + + +parseHLDate :: Day -> Text -> Either Text Day +parseHLDate current text = case parse HL.smartdate "date" text of + Right res -> Right $ HL.fixSmartDate current res + Left err -> Left $ T.pack $ parseErrorPretty err + +parseHLDateWithToday :: Text -> IO (Either Text Day) +parseHLDateWithToday text = flip parseHLDate text . utctDay <$> getCurrentTime + +-- | Corresponds to %d[.[%m[.[%y]]]] +german :: DateFormat +german = DateFormat + [ DateDay + , DateOptional [DateString "." + ,DateOptional [DateMonth + ,DateOptional [DateString "." + ,DateOptional [DateYearShort]]]]] + +parseDateFormat :: Text -> Either Text DateFormat +parseDateFormat text = case parse dateSpec "date-format" text of + Left err -> Left $ T.pack $ parseErrorPretty err + Right res -> Right res + +dateSpec :: Parser DateFormat +dateSpec = DateFormat <$> (many oneTok <* eof) + +oneTok :: Parser DateSpec +oneTok = char '%' *> percent + <|> char '\\' *> escape + <|> DateOptional <$> between (char '[') (char ']') (many oneTok) + <|> DateString . T.pack <$> some (noneOf ("\\[]%" :: String)) + +percent :: Parser DateSpec +percent = char 'y' *> pure DateYearShort + <|> char 'Y' *> pure DateYear + <|> char 'm' *> pure DateMonth + <|> char 'd' *> pure DateDay + <|> char '%' *> pure (DateString "%") + +escape :: Parser DateSpec +escape = char '\\' *> pure (DateString "\\") + <|> char '[' *> pure (DateString "[") + <|> char ']' *> pure (DateString "]") + +-- | Parse text with given format and fill in missing fields with todays date. +parseDateWithToday :: DateFormat -> Text -> IO (Either Text Day) +parseDateWithToday spec text = do + today <- utctDay <$> getCurrentTime + return (parseDate today spec text) + +parseDate :: Day -> DateFormat -> Text -> Either Text Day +parseDate current (DateFormat spec) text = + let en = Just <$> parseEnglish current + completeIDate :: IncompleteDate (Maybe Int) -> Maybe Day + completeIDate d = + completeNearDate Past current d + <|> completeNearDate Future current d + num = completeIDate . fmap getFirst <$> parseDate' spec <* eof + + in case parse ((try en <|> num) <* eof) "date" text of + Left err -> Left $ T.pack $ parseErrorPretty err + Right Nothing -> Left "Invalid Date" + Right (Just d) -> Right d + +-- (y, m, d) +newtype IncompleteDate a = IDate (a, a, a) + deriving (Monoid, Functor, Show) + +data Direction = Future | Past deriving (Eq,Show) +-- find a date that matches the incomplete date and is as near as possible to +-- the current date in the given direction (Future means only today and in the +-- future; Past means only today and in the past). +completeNearDate :: Direction -> Day -> IncompleteDate (Maybe Int) -> Maybe Day +completeNearDate dir current (IDate (i_year,i_month,i_day)) = + let + sign = if dir == Past then -1 else 1 + (currentYear, _, _) = toGregorian current + singleton a = [a] + withDefaultRange :: Maybe a -> [a] -> [a] + withDefaultRange maybe_value range = + fromMaybe + (if dir == Past then reverse range else range) + (singleton <$> maybe_value) + in listToMaybe $ do + -- every date occours at least once in 8 years + -- That is because the years divisible by 100 but not by 400 are no leap + -- years. Depending on dir, choose the past or the next 8 years + y <- (toInteger <$> i_year) `withDefaultRange` + [currentYear + sign*4 - 4 .. currentYear + sign*4 + 4] + m <- i_month `withDefaultRange` [1..12] + d <- i_day `withDefaultRange` [1..31] + completed <- maybeToList (fromGregorianValid y m d) + if ((completed `diffDays` current) * sign >= 0) + then return completed + else fail $ "Completed day not the " ++ show dir ++ "." + + +parseDate' :: [DateSpec] -> Parser (IncompleteDate (First Int)) +parseDate' [] = return mempty +parseDate' (d:ds) = case d of + DateOptional sub -> try ((<>) <$> parseDate' sub <*> parseDate' ds) + <|> parseDate' ds + + _ -> (<>) <$> parseDate1 d <*> parseDate' ds + + +parseDate1 :: DateSpec -> Parser (IncompleteDate (First Int)) +parseDate1 ds = case ds of + DateYear -> part (,mempty,mempty) + DateYearShort -> part $ (,mempty,mempty) . fmap completeYear + DateMonth -> part (mempty,,mempty) + DateDay -> part (mempty,mempty,) + DateString s -> string (T.unpack s) >> pure mempty + DateOptional ds' -> option mempty (try $ parseDate' ds') + + where digits = some digitChar + part f = IDate . f . First . Just . (read :: String -> Int) <$> digits + completeYear year + | year < 100 = year + 2000 + | otherwise = year + + +-- Parses an english word such as 'yesterday' or 'monday' +parseEnglish :: Day -> Parser Day +parseEnglish current = ($ current) <$> choice (relativeDays ++ weekDays) + +relativeDays :: [Parser (Day -> Day)] +relativeDays = map try + [ addDays 1 <$ string "tomorrow" + , id <$ string "today" + , addDays (-1) <$ string "yesterday" + ] + +weekDays :: [Parser (Day -> Day)] +weekDays = zipWith (\i name -> weekDay i <$ try (string name)) [1..] + [ "monday" + , "tuesday" + , "wednesday" + , "thursday" + , "friday" + , "saturday" + , "sunday" + ] + +-- | Computes a relative date by the given weekday +-- +-- Returns the first weekday with index wday, that's before the current date. +weekDay :: Int -> Day -> Day +weekDay wday current = + let (_, _, wday') = toWeekDate current + difference = negate $ (wday' - wday) `mod` 7 + in addDays (toInteger difference) current + + +printDate :: DateFormat -> Day -> Text +printDate (DateFormat spec) day = TL.toStrict $ toLazyText $ printDate' spec day + +printDate' :: [DateSpec] -> Day -> Builder +printDate' [] _ = "" +printDate' (DateYear:ds) day@(toGregorian -> (y,_,_)) = + build y <> printDate' ds day +printDate' (DateYearShort:ds) day@(toGregorian -> (y,_,_)) + | y > 2000 = twoDigits (y-2000) <> printDate' ds day + | otherwise = twoDigits y <> printDate' ds day +printDate' (DateMonth:ds) day@(toGregorian -> (_,m,_)) = + twoDigits m <> printDate' ds day +printDate' (DateDay:ds) day@(toGregorian -> (_,_,d)) = + twoDigits d <> printDate' ds day +printDate' (DateString s:ds) day = + build s <> printDate' ds day +printDate' (DateOptional opt:ds) day = + printDate' opt day <> printDate' ds day + +twoDigits :: Buildable a => a -> Builder +twoDigits = left 2 '0' diff --git a/src/Model.hs b/src/Model.hs new file mode 100644 --- /dev/null +++ b/src/Model.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +module Model + ( Step(..) + , MaybeStep(..) + , MatchAlgo(..) + , nextStep + , undo + , context + , suggest + ) where + +import Data.Function +import Data.List +import qualified Data.HashMap.Lazy as HM +import Data.Maybe +import Data.Monoid +import Data.Ord (Down(..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time hiding (parseTime) +import qualified Hledger as HL + +import AmountParser +import DateParser + +data Step = DateQuestion + | DescriptionQuestion Day + | AccountQuestion HL.Transaction + | AmountQuestion HL.AccountName HL.Transaction + | FinalQuestion HL.Transaction + deriving (Eq, Show) + + +data MaybeStep = Finished HL.Transaction + | Step Step + deriving (Eq, Show) + +data MatchAlgo = Fuzzy | Substrings + deriving (Eq, Show) + +nextStep :: HL.Journal -> DateFormat -> Either Text Text -> Step -> IO (Either Text MaybeStep) +nextStep journal dateFormat entryText current = case current of + DateQuestion -> + fmap (Step . DescriptionQuestion) <$> either (parseDateWithToday dateFormat) + parseHLDateWithToday + entryText + DescriptionQuestion day -> return $ Right $ Step $ + AccountQuestion HL.nulltransaction { HL.tdate = day + , HL.tdescription = (fromEither entryText) + } + AccountQuestion trans + | T.null (fromEither entryText) && transactionBalanced trans + -> return $ Right $ Step $ FinalQuestion trans + | T.null (fromEither entryText) -- unbalanced + -> return $ Left $ "Transaction not balanced! Please balance your transaction before adding it to the journal." + | otherwise -> return $ Right $ Step $ + AmountQuestion (fromEither entryText) trans + AmountQuestion name trans -> case parseAmount journal (fromEither entryText) of + Left err -> return $ Left (T.pack err) + Right amount -> return $ Right $ Step $ + let newPosting = post' name amount + in AccountQuestion (addPosting newPosting trans) + + FinalQuestion trans + | fromEither entryText == "y" -> return $ Right $ Finished trans + | otherwise -> return $ Right $ Step $ AccountQuestion trans + +-- | Reverses the last step. +-- +-- Returns (Left errorMessage), if the step can't be reversed +undo :: Step -> Either Text Step +undo current = case current of + DateQuestion -> Left "Already at oldest step in current transaction" + DescriptionQuestion _ -> return DateQuestion + AccountQuestion trans -> return $ case HL.tpostings trans of + [] -> DescriptionQuestion (HL.tdate trans) + ps -> AmountQuestion (HL.paccount (last ps)) trans { HL.tpostings = init ps } + AmountQuestion _ trans -> Right $ AccountQuestion trans + FinalQuestion trans -> undo (AccountQuestion trans) + +context :: HL.Journal -> MatchAlgo -> DateFormat -> Text -> Step -> IO [Text] +context _ _ dateFormat entryText DateQuestion = parseDateWithToday dateFormat entryText >>= \case + Left _ -> return [] + Right date -> return [T.pack $ HL.showDate date] +context j matchAlgo _ entryText (DescriptionQuestion _) = return $ + let descs = HL.journalDescriptions j + in sortBy (descUses j) $ filter (matches matchAlgo entryText) descs +context j matchAlgo _ entryText (AccountQuestion _) = return $ + let names = HL.journalAccountNames j + in filter (matches matchAlgo entryText) names +context journal _ _ entryText (AmountQuestion _ _) = return $ + maybeToList $ T.pack . HL.showMixedAmount <$> trySumAmount journal entryText +context _ _ _ _ (FinalQuestion _) = return [] + +-- | Suggest the initial text of the entry box for each step +-- +-- For example, it suggests today for the date prompt +suggest :: HL.Journal -> DateFormat -> Step -> IO (Maybe Text) +suggest _ dateFormat DateQuestion = + Just . printDate dateFormat . utctDay <$> getCurrentTime +suggest _ _ (DescriptionQuestion _) = return Nothing +suggest journal _ (AccountQuestion trans) = return $ + if numPostings trans /= 0 && transactionBalanced trans + then Nothing + else HL.paccount <$> (suggestAccountPosting journal trans) +suggest journal _ (AmountQuestion account trans) = return $ fmap (T.pack . HL.showMixedAmount) $ + if transactionBalanced trans + then HL.pamount <$> (findPostingByAcc account =<< findLastSimilar journal trans) + else Just $ negativeAmountSum trans +suggest _ _ (FinalQuestion _) = return $ Just "y" + +-- | Returns true if the pattern is not empty and all of its words occur in the string +-- +-- If the pattern is empty, we don't want any entries in the list, so nothing is +-- selected if the users enters an empty string. Empty inputs are special cased, +-- so this is important. +matches :: MatchAlgo -> Text -> Text -> Bool +matches algo a b + | T.null a = False + | otherwise = matches' (T.toCaseFold a) (T.toCaseFold b) + where + matches' a' b' + | algo == Fuzzy && T.any (== ':') b' = all (`fuzzyMatch` (T.splitOn ":" b')) (T.words a') + | otherwise = all (`T.isInfixOf` b') (T.words a') + +fuzzyMatch :: Text -> [Text] -> Bool +fuzzyMatch _ [] = False +fuzzyMatch query (part : partsRest) = case (T.uncons query) of + Nothing -> True + Just (c, queryRest) + | c == ':' -> fuzzyMatch queryRest partsRest + | otherwise -> fuzzyMatch query partsRest || case (T.uncons part) of + Nothing -> False + Just (c2, partRest) + | c == c2 -> fuzzyMatch queryRest (partRest : partsRest) + | otherwise -> False + +post' :: HL.AccountName -> HL.MixedAmount -> HL.Posting +post' account amount = HL.nullposting { HL.paccount = account + , HL.pamount = amount + } + +addPosting :: HL.Posting -> HL.Transaction -> HL.Transaction +addPosting p t = t { HL.tpostings = (HL.tpostings t) ++ [p] } + +trySumAmount :: HL.Journal -> Text -> Maybe HL.MixedAmount +trySumAmount ctx = either (const Nothing) Just . parseAmount ctx + + +-- | Given a previous similar transaction, suggest the next posting to enter +-- +-- This next posting is the one the user likely wants to type in next. +suggestNextPosting :: HL.Transaction -> HL.Transaction -> Maybe HL.Posting +suggestNextPosting current reference = + -- Postings that aren't already used in the new posting + let unusedPostings = filter (`notContainedIn` curPostings) refPostings + in listToMaybe $ sortBy cmpPosting unusedPostings + + where [refPostings, curPostings] = map HL.tpostings [reference, current] + notContainedIn p = not . any (((==) `on` HL.paccount) p) + -- Sort descending by amount. This way, negative amounts rank last + cmpPosting = compare `on` (Down . HL.pamount) + +-- | Given the last transaction entered, suggest the likely most comparable posting +-- +-- Since the transaction isn't necessarily the same type, we can't rely on matching the data +-- so we must use the order. This way if the user typically uses a certain order +-- like expense category and then payment method. Useful if entering many similar postings +-- in a row. For example, when entering transactions from a credit card statement +-- where the first account is usually food, and the second posting is always the credit card. +suggestCorrespondingPosting :: HL.Transaction -> HL.Transaction -> Maybe HL.Posting +suggestCorrespondingPosting current reference = + let postingsEntered = length curPostings in + if postingsEntered < (length refPostings) then + Just (refPostings !! postingsEntered) + else + suggestNextPosting current reference + where [refPostings, curPostings] = map HL.tpostings [reference, current] + +findLastSimilar :: HL.Journal -> HL.Transaction -> Maybe HL.Transaction +findLastSimilar journal desc = + maximumBy (compare `on` HL.tdate) <$> + listToMaybe' (filter (((==) `on` HL.tdescription) desc) $ HL.jtxns journal) + +suggestAccountPosting :: HL.Journal -> HL.Transaction -> Maybe HL.Posting +suggestAccountPosting journal trans = + case findLastSimilar journal trans of + Just t -> suggestNextPosting trans t + Nothing -> (last <$> listToMaybe' (HL.jtxns journal)) >>= (suggestCorrespondingPosting trans) + +-- | Return the first Posting that matches the given account name in the transaction +findPostingByAcc :: HL.AccountName -> HL.Transaction -> Maybe HL.Posting +findPostingByAcc account = find ((==account) . HL.paccount) . HL.tpostings + +listToMaybe' :: [a] -> Maybe [a] +listToMaybe' [] = Nothing +listToMaybe' ls = Just ls + +numPostings :: HL.Transaction -> Int +numPostings = length . HL.tpostings + +-- | Returns True if all postings balance and the transaction is not empty +transactionBalanced :: HL.Transaction -> Bool +transactionBalanced trans = + let (rsum, _, _) = HL.transactionPostingBalances trans + in HL.isZeroMixedAmount rsum + +-- | Computes the sum of all postings in the transaction and inverts it +negativeAmountSum :: HL.Transaction -> HL.MixedAmount +negativeAmountSum trans = + let (rsum, _, _) = HL.transactionPostingBalances trans + in HL.divideMixedAmount rsum (-1) + +-- | Compare two transaction descriptions based on their number of occurences in +-- the given journal. +descUses :: HL.Journal -> Text -> Text -> Ordering +descUses journal = compare `on` (Down . flip HM.lookup usesMap) + where usesMap = foldr (count . HL.tdescription) HM.empty $ + HL.jtxns journal + -- Add one to the current count of this element + count :: Text -> HM.HashMap Text (Sum Int) -> HM.HashMap Text (Sum Int) + count = HM.alter (<> Just 1) + +fromEither :: Either a a -> a +fromEither = either id id diff --git a/src/View.hs b/src/View.hs new file mode 100644 --- /dev/null +++ b/src/View.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +module View where + +import Brick +import Brick.Widgets.List +import Brick.Widgets.WrappedText +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time hiding (parseTime) +import qualified Hledger as HL + +import Model + +viewState :: Step -> Widget n +viewState DateQuestion = txt " " +viewState (DescriptionQuestion date) = str $ + formatTime defaultTimeLocale "%Y/%m/%d" date +viewState (AccountQuestion trans) = str $ + HL.showTransaction trans +viewState (AmountQuestion acc trans) = str $ + HL.showTransaction trans ++ " " ++ T.unpack acc +viewState (FinalQuestion trans) = str $ + HL.showTransaction trans + +viewQuestion :: Step -> Widget n +viewQuestion DateQuestion = txt "Date" +viewQuestion (DescriptionQuestion _) = txt "Description" +viewQuestion (AccountQuestion trans) = str $ + "Account " ++ show (numPostings trans + 1) +viewQuestion (AmountQuestion _ trans) = str $ + "Amount " ++ show (numPostings trans + 1) +viewQuestion (FinalQuestion trans) = txt $ + "Add this transaction to the journal? Y/n" + +viewContext :: (Ord n, Show n) => List n Text -> Widget n +viewContext = renderList renderItem True + +viewSuggestion :: Maybe Text -> Widget n +viewSuggestion Nothing = txt "" +viewSuggestion (Just t) = txt $ " (" <> t <> ")" + +renderItem :: Bool -> Text -> Widget n +renderItem True = withAttr listSelectedAttr . txt +renderItem False = txt + +numPostings :: HL.Transaction -> Int +numPostings = length . HL.tpostings + +-- TODO Adding " " to an empty message isn't required for vty >= 5.14 +-- => Remove this, once 5.14 becomes lower bound +viewMessage :: Text -> Widget n +viewMessage msg = wrappedText (if T.null msg then " " else msg) diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, LambdaCase #-} + +module Main where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.BetterDialog +import Brick.Widgets.Edit +import Brick.Widgets.List +import Brick.Widgets.List.Utils +import Graphics.Vty hiding (parseConfigFile, (<|>)) + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Text.Zipper +import qualified Data.Vector as V +import qualified Hledger as HL +import qualified Hledger.Read.JournalReader as HL +import Lens.Micro +import Options.Applicative hiding (str, option) +import qualified Options.Applicative as OA +import System.Directory +import System.Environment.XDG.BaseDir +import System.Exit +import System.IO +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Text as P + +import Brick.Widgets.HelpMessage +import DateParser +import ConfigParser hiding (parseConfigFile) +import Model +import View + +data AppState = AppState + { asEditor :: Editor Text Name + , asStep :: Step + , asJournal :: HL.Journal + , asContext :: List Name Text + , asSuggestion :: Maybe Text + , asMessage :: Text + , asFilename :: FilePath + , asDateFormat :: DateFormat + , asMatchAlgo :: MatchAlgo + , asDialog :: DialogShown + } + +data Name = HelpName | ListName | EditorName + deriving (Ord, Show, Eq) + +data DialogShown = NoDialog | HelpDialog (HelpWidget Name) | QuitDialog | AbortDialog + +myHelpDialog :: DialogShown +myHelpDialog = HelpDialog (helpWidget HelpName bindings) + +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") + ]) + , ("Acceptance", + [ ("Ret", "Accept the currently selected answer") + , ("Alt-Ret", "Accept the current answer verbatim, ignoring selection") + ])] + +draw :: AppState -> [Widget Name] +draw as = case asDialog as of + HelpDialog h -> [renderHelpWidget h, ui] + QuitDialog -> [quitDialog, ui] + AbortDialog -> [abortDialog, ui] + NoDialog -> [ui] + + where ui = viewState (asStep as) + <=> hBorder + <=> (viewQuestion (asStep as) + <+> viewSuggestion (asSuggestion as) + <+> txt ": " + <+> renderEditor True (asEditor as)) + <=> hBorder + <=> expand (viewContext (asContext as)) + <=> hBorder + <=> viewMessage (asMessage as) + + quitDialog = dialog "Quit" "Really quit without saving the current transaction? (Y/n)" + abortDialog = dialog "Abort" "Really abort this transaction (Y/n)" + +-- TODO Refactor to remove code duplication in individual case statements +event :: AppState -> BrickEvent Name Event -> EventM Name (Next AppState) +event as (VtyEvent ev) = case asDialog as of + HelpDialog helpDia -> case ev of + EvKey key [] + | key `elem` [KChar 'q', KEsc] -> continue as { asDialog = NoDialog } + | otherwise -> do + helpDia' <- handleHelpEvent helpDia ev + continue as { asDialog = HelpDialog helpDia' } + _ -> continue as + QuitDialog -> case ev of + EvKey key [] + | key `elem` [KChar 'y', KEnter] -> halt as + | otherwise -> continue as { asDialog = NoDialog } + _ -> continue as + AbortDialog -> case ev of + EvKey key [] + | key `elem` [KChar 'y', KEnter] -> + liftIO (reset as { asDialog = NoDialog }) >>= continue + | otherwise -> continue as { asDialog = NoDialog } + _ -> continue as + NoDialog -> case ev of + EvKey (KChar 'c') [MCtrl] + | asStep as == DateQuestion -> halt as + | otherwise -> continue as { asDialog = QuitDialog } + EvKey (KChar 'd') [MCtrl] + | asStep as == DateQuestion -> halt as + | otherwise -> continue as { asDialog = QuitDialog } + EvKey (KChar 'n') [MCtrl] -> continue as { asContext = listMoveDown $ asContext as + , asMessage = ""} + EvKey KDown [] -> continue as { asContext = listMoveDown $ asContext as + , asMessage = ""} + EvKey (KChar 'p') [MCtrl] -> continue as { asContext = listMoveUp $ asContext as + , asMessage = ""} + EvKey KUp [] -> continue as { asContext = listMoveUp $ asContext as + , asMessage = ""} + EvKey (KChar '\t') [] -> continue (insertSelected as) + EvKey KEsc [] + | asStep as == DateQuestion && T.null (editText as) -> halt as + | asStep as == DateQuestion -> liftIO (reset as) >>= continue + | otherwise -> continue as { asDialog = AbortDialog } + EvKey (KChar 'z') [MCtrl] -> liftIO (doUndo as) >>= continue + EvKey KEnter [MMeta] -> liftIO (doNextStep False as) >>= continue + EvKey KEnter [] -> liftIO (doNextStep True as) >>= continue + EvKey (KFun 1) [] -> continue as { asDialog = myHelpDialog } + EvKey (KChar '?') [MMeta] -> continue as { asDialog = myHelpDialog, asMessage = "Help" } + EvKey (KChar 'u') [MCtrl] -> continue as { asEditor = clearEdit (asEditor as) } + _ -> (AppState <$> handleEditorEvent ev (asEditor as) + <*> return (asStep as) + <*> return (asJournal as) + <*> return (asContext as) + <*> return (asSuggestion as) + <*> return "" + <*> return (asFilename as)) + <*> return (asDateFormat as) + <*> return (asMatchAlgo as) + <*> return NoDialog + >>= liftIO . setContext >>= continue +event as _ = continue as + +reset :: AppState -> IO AppState +reset as = do + sugg <- suggest (asJournal as) (asDateFormat as) DateQuestion + return as + { asStep = DateQuestion + , asEditor = clearEdit (asEditor as) + , asContext = ctxList V.empty + , asSuggestion = sugg + , asMessage = "Transaction aborted" + } + +setContext :: AppState -> IO AppState +setContext as = do + ctx <- flip listSimpleReplace (asContext as) . V.fromList <$> + context (asJournal as) (asMatchAlgo as) (asDateFormat as) (editText as) (asStep as) + return as { asContext = ctx } + +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 -> AppState -> IO AppState +doNextStep useSelected as = do + let name = fromMaybe (Left $ editText as) $ + msum [ Right <$> if useSelected then snd <$> listSelectedElement (asContext as) else Nothing + , Left <$> asMaybe (editText as) + , Left <$> asSuggestion as + ] + s <- nextStep (asJournal as) (asDateFormat as) name (asStep as) + case s of + Left err -> return as { asMessage = err } + Right (Finished trans) -> do + liftIO $ addToJournal trans (asFilename as) + sugg <- suggest (asJournal as) (asDateFormat as) DateQuestion + return AppState + { asStep = DateQuestion + , asJournal = addTransactionEnd trans (asJournal as) + , asEditor = clearEdit (asEditor as) + , asContext = ctxList V.empty + , asSuggestion = sugg + , asMessage = "Transaction written to journal file" + , asFilename = asFilename as + , asDateFormat = asDateFormat as + , asMatchAlgo = asMatchAlgo as + , asDialog = NoDialog + } + Right (Step s') -> do + sugg <- suggest (asJournal as) (asDateFormat as) s' + ctx' <- ctxList . V.fromList <$> context (asJournal as) (asMatchAlgo as) (asDateFormat as) "" s' + return as { asStep = s' + , asEditor = clearEdit (asEditor as) + , asContext = ctx' + , asSuggestion = sugg + , asMessage = "" + } + +doUndo :: AppState -> IO AppState +doUndo as = case undo (asStep as) of + Left msg -> return as { asMessage = "Undo failed: " <> msg } + Right step -> do + sugg <- suggest (asJournal as) (asDateFormat as) step + setContext $ as { asStep = step + , asEditor = clearEdit (asEditor as) + , asSuggestion = sugg + , asMessage = "Undo." + } + +insertSelected :: AppState -> AppState +insertSelected as = case listSelectedElement (asContext as) of + Nothing -> as + Just (_, line) -> as { asEditor = setEdit line (asEditor as) } + + +asMaybe :: Text -> Maybe Text +asMaybe t + | T.null t = Nothing + | otherwise = Just t + +attrs :: AttrMap +attrs = attrMap defAttr + [ (listSelectedAttr, black `on` white) + , (helpAttr <> "title", fg green) + ] + +clearEdit :: Editor Text n -> Editor Text n +clearEdit = setEdit "" + +setEdit :: Text -> Editor Text n -> Editor Text n +setEdit content edit = edit & editContentsL .~ zipper + where zipper = gotoEOL (textZipper [content] (Just 1)) + +addToJournal :: HL.Transaction -> FilePath -> IO () +addToJournal trans path = appendFile path (HL.showTransaction trans) + + +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 :: P.Parser 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\"" + +data Options = Options + { optLedgerFile :: FilePath + , optDateFormat :: String + , optMatchAlgo :: MatchAlgo + , optDumpConfig :: Bool + } + +confParser :: FilePath -> OptParser Options +confParser home = Options + -- TODO Convert leading tilde to home + <$> option "file" (ledgerPath home) "Path to the journal file" + <*> option "date-format" "[[%y/]%m/]%d" "Format used to parse dates" + <*> customOption "completion-engine" Substrings "substrings" + ( "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 + <*> pure False + +parseConfigFile :: IO Options +parseConfigFile = do + path <- configPath + home <- getHomeDirectory + + try (T.readFile path) >>= \case + Left (_ :: SomeException) -> return (parserDefault $ confParser home) + Right res -> case parseConfig path res (confParser home) of + Left err -> do + putStr (show err) + exitFailure + Right res' -> return res' + +optionParser :: Options -> Parser Options +optionParser def = Options + <$> strOption + ( long "file" + <> short 'f' + <> metavar "FILE" + <> value (optLedgerFile def) + <> help "Path to the journal file" + ) + <*> strOption + ( long "date-format" + <> metavar "FORMAT" + <> value (optDateFormat def) + <> help "Format used to parse dates" + ) + <*> OA.option readMatchAlgo + ( long "completion-engine" + <> metavar "ENGINE" + <> value (optMatchAlgo def) + <> 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" + ) + +main :: IO () +main = do + opts1 <- parseConfigFile + + opts <- execParser $ info (helper <*> optionParser opts1) $ + fullDesc <> header "A terminal UI as drop-in replacement for hledger add." + + when (optDumpConfig opts) $ do + home <- getHomeDirectory + path <- configPath + T.putStrLn $ "# Write this to " <> T.pack path <> "\n" + T.putStrLn (parserExample $ confParser home) + exitSuccess + + date <- case parseDateFormat (T.pack $ optDateFormat opts) of + Left err -> do + hPutStr stderr "Could not parse date format: " + T.hPutStr stderr err + exitWith (ExitFailure 1) + Right res -> return res + + let path = optLedgerFile opts + journalContents <- T.readFile path + + runExceptT (HL.parseAndFinaliseJournal HL.journalp True path journalContents) >>= \case + Left err -> hPutStrLn stderr err >> exitFailure + Right journal -> do + let edit = editor 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 = 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 diff --git a/tests/ConfigParserSpec.hs b/tests/ConfigParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ConfigParserSpec.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} +module ConfigParserSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import Control.Arrow +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T + +import ConfigParser + +spec :: Spec +spec = do + fullTest + defaultTest + syntaxTests + valueTests + commentTests + exampleTests + +data TestData = TestData + { someInt :: Int + , someInteger :: Integer + , someString :: String + , someText :: Text + } deriving (Eq, Show) + +testParser :: OptParser TestData +testParser = TestData + <$> option "someInt" 42 "Help for this" + <*> option "someInteger" 23 "Help for that" + <*> option "someString" "foobar" "Help with\nMultiple lines" + <*> option "someText" "barfoo" "And another help" + +defaultData :: TestData +defaultData = parserDefault testParser + +fullTest :: Spec +fullTest = it "parses a complete example" $ do + let inputTxt = T.unlines [ "someInt = 1" + , "someInteger = 2" + , "someString = a" + , "someText = \"b\""] + output = TestData 1 2 "a" "b" + parseConfig "" inputTxt testParser `shouldBe` Right output + +defaultTest :: Spec +defaultTest = do + it "fills in the default values" $ + parseConfig "" "" testParser `shouldBe` Right (TestData 42 23 "foobar" "barfoo") + + it "fills in the default values for random data" $ + property defaultWorksProp + +defaultWorksProp :: TestData -> Property +defaultWorksProp testData = + let parser = TestData + <$> option "someInt" (someInt testData) "Help for this" + <*> option "someInteger" (someInteger testData) "Help for that" + <*> option "someString" (someString testData) "Help with\nMultiple lines" + <*> option "someText" (someText testData) "And another help" + in parseConfig "" "" parser === Right testData + + +syntaxTests :: Spec +syntaxTests = do + context "given whitespace" whitespaceTests + context "given escaped strings" escapingTests + context "given bare strings" bareStringTests + optionNameTests + +whitespaceTests :: Spec +whitespaceTests = do + it "parses just whitespace" $ + parseConfig "" "" testParser + `shouldBe` Right (TestData 42 23 "foobar" "barfoo") + + it "parses beginning whitespace" $ + parseConfig "" "\n\n\n someInt = 13" testParser + `shouldBe` Right (TestData 13 23 "foobar" "barfoo") + + it "parses trailing whitespace" $ + parseConfig "" "someInt = 13 \n\n\n" testParser + `shouldBe` Right (TestData 13 23 "foobar" "barfoo") + + it "parses middle whitespace" $ + parseConfig "" "someInt = 13 \n\n\n someInteger = 14" testParser + `shouldBe` Right (TestData 13 14 "foobar" "barfoo") + + it "parses whitespace everywhere" $ + parseConfig "" " \n \n someInt = 13 \n \n \n someInteger = 14 \n \n " testParser + `shouldBe` Right (TestData 13 14 "foobar" "barfoo") + +escapingTests :: Spec +escapingTests = do + it "parses simple escaped strings" $ + parseConfig "" "someText = \"test\" " testParser + `shouldBe` Right (defaultData { someText = "test" }) + + it "parses escaped strings with quotes in them" $ + parseConfig "" "someText = \"te\\\"st\" " testParser + `shouldBe` Right (defaultData { someText = "te\"st" }) + + it "parses escaped strings with backslashes in them" $ + parseConfig "" "someText = \"te\\\\st\" " testParser + `shouldBe` Right (defaultData { someText = "te\\st" }) + + it "parses escaped strings with newlines in them" $ + parseConfig "" "someText = \"te\nst\" " testParser + `shouldBe` Right (defaultData { someText = "te\nst" }) + + it "fails to parse non-terminated escaped strings" $ + parseConfig "" "someText = \"test " testParser + `shouldSatisfy` isLeft + + +bareStringTests :: Spec +bareStringTests = do + it "parses a bare string correctly" $ + parseConfig "" "someText =test" testParser + `shouldBe` Right (defaultData { someText = "test" }) + + it "correctly trims bare strings" $ + parseConfig "" "someText = foo test " testParser + `shouldBe` Right (defaultData { someText = "foo test" }) + + it "fails to parse empty bare strings" $ + parseConfig "" "someText = " testParser `shouldSatisfy` isLeft + +optionNameTests :: Spec +optionNameTests = do + it "allows dashes in option names" $ do + let parser = (\x -> defaultData { someInt = x }) <$> option "test-name" 10 "" + parseConfig "" "test-name = 10" parser `shouldBe` Right defaultData { someInt = 10 } + + it "allows underscores in option names" $ do + let parser = (\x -> defaultData { someInt = x }) <$> option "test_name" 10 "" + parseConfig "" "test_name = 10" parser `shouldBe` Right defaultData { someInt = 10 } + + it "doesn't allow spaces in option names" $ do + let parser = (\x -> defaultData { someInt = x }) <$> option "test name" 10 "" + parseConfig "" "test name = 10" parser `shouldSatisfy` isLeft + + it "doesn't allow equal signs in option names" $ do + let parser = (\x -> defaultData { someInt = x }) <$> option "test=foo" 10 "" + parseConfig "" "test=foo = 10" parser `shouldSatisfy` isLeft + +valueTests :: Spec +valueTests = do + context "given integers" $ do + it "parses zero" $ + parseConfig "" "someInt = 0" testParser `shouldBe` Right defaultData { someInt = 0 } + + it "parses negative zero" $ + parseConfig "" "someInt = -0" testParser `shouldBe` Right defaultData { someInt = 0 } + + it "fails to parse integer with trailing stuff" $ + parseConfig "" "someInt = 10foo" testParser `shouldSatisfy` isLeft + + it "fails to parse empty string as integer" $ + parseConfig "" "someInt = \"\"" testParser `shouldSatisfy` isLeft + + it "fails to parse letters as integer" $ + parseConfig "" "someInt = foo" testParser `shouldSatisfy` isLeft + + + context "given strings" $ + it "parses the empty string quoted" $ + parseConfig "" "someString = \"\"" testParser `shouldBe` Right defaultData { someString = "" } + +commentTests :: Spec +commentTests = do + it "handles a file with just comments" $ + parseConfig "" "# a comment \n #another comment " testParser + `shouldBe` Right defaultData + + it "handles comments and whitespace in front" $ + parseConfig "" " \n\n#another comment " testParser + `shouldBe` Right defaultData + + it "handles comments and whitespace in front" $ + parseConfig "" " \n\n#another comment " testParser + `shouldBe` Right defaultData + + it "handles comments and whitespace after" $ + parseConfig "" "#another comment\n\n " testParser + `shouldBe` Right defaultData + + it "handles comments with whitespace between" $ + parseConfig "" "\n \n # comment \n #another comment\n\n " testParser + `shouldBe` Right defaultData + + it "handles comments after assignments" $ do + parseConfig "" "someInt = 4# a comment" testParser + `shouldBe` Right defaultData { someInt = 4 } + + parseConfig "" "someInt = 4# a comment\n" testParser + `shouldBe` Right defaultData { someInt = 4 } + + parseConfig "" "someInt = 4 # a comment" testParser + `shouldBe` Right defaultData { someInt = 4 } + + it "handles comments around assignments" $ do + parseConfig "" "someInt = 4# a comment\n # a comment\nsomeString = foo # bar" testParser + `shouldBe` Right defaultData { someInt = 4, someString = "foo" } + + +exampleTests :: Spec +exampleTests = describe "parserExample" $ do + it "works for one example" $ + let output = T.strip $ T.unlines + [ "# Help for this" + , "someInt = 42" + , "" + , "# Help for that" + , "someInteger = 23" + , "" + , "# Help with" + , "# Multiple lines" + , "someString = \"foobar\"" + , "" + , "# And another help" + , "someText = \"barfoo\"" + ] + in parserExample testParser `shouldBe` output + + it "can parse it's own example output" $ + property exampleParseableProp + +exampleParseableProp :: TestData -> Property +exampleParseableProp testData = + let parser = TestData <$> option "someInt" (someInt testData) "help" + <*> option "someInteger" (someInteger testData) "help" + <*> option "someString" (someString testData) "help" + <*> option "someText" (someText testData) "help" + in parseConfig "" (parserExample parser) parser === Right testData + +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) + +isAsciiAlnum :: Char -> Bool +isAsciiAlnum = uncurry (&&) . (isAscii &&& isAlphaNum) + +instance Arbitrary TestData where + arbitrary = TestData <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary diff --git a/tests/DateParserSpec.hs b/tests/DateParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DateParserSpec.hs @@ -0,0 +1,159 @@ + {-# LANGUAGE OverloadedStrings #-} + +module DateParserSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import Control.Monad +import Data.Either +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.Time.Calendar.WeekDate + +import DateParser + +spec :: Spec +spec = do + dateFormatTests + dateTests + dateCompletionTests + printTests + +dateFormatTests :: Spec +dateFormatTests = describe "date format parser" $ + it "parses the german format correctly" $ + parseDateFormat "%d[.[%m[.[%y]]]]" `shouldBe` Right german + +dateTests :: Spec +dateTests = describe "date parser" $ do + it "actually requires non-optional fields" $ + shouldFail "%d-%m-%y" "05" + + describe "weekDay" $ do + it "actually returns the right week day" $ property + weekDayProp + + it "is always smaller than the current date" $ property + weekDaySmallerProp + +dateCompletionTests :: Spec +dateCompletionTests = describe "date completion" $ do + it "today" $ + parseGerman 2004 7 31 "31.7.2004" `shouldBe` Right (fromGregorian 2004 7 31) + + it "today is a leap day" $ + parseGerman 2012 2 29 "29.2.2012" `shouldBe` Right (fromGregorian 2012 2 29) + + it "skips to previous month" $ + parseGerman 2016 9 20 "21" `shouldBe` Right (fromGregorian 2016 08 21) + + it "stays in month if possible" $ + parseGerman 2016 8 30 "21" `shouldBe` Right (fromGregorian 2016 08 21) + + it "skips to previous month to reach the 31st" $ + parseGerman 2016 8 30 "31" `shouldBe` Right (fromGregorian 2016 07 31) + + it "skips to an earlier month to reach the 31st" $ + parseGerman 2016 7 30 "31" `shouldBe` Right (fromGregorian 2016 05 31) + + it "skips to the previous year if necessary" $ + parseGerman 2016 9 30 "2.12." `shouldBe` Right (fromGregorian 2015 12 2) + + it "skips to the previous years if after a leap year" $ + parseGerman 2017 3 10 "29.2" `shouldBe` Right (fromGregorian 2016 02 29) + + it "even might skip to a leap year 8 years ago" $ + parseGerman 2104 2 27 "29.2" `shouldBe` Right (fromGregorian 2096 02 29) + + it "some date in the near future" $ + parseGerman 2016 2 20 "30.11.2016" `shouldBe` Right (fromGregorian 2016 11 30) + + it "some date in the far future" $ + parseGerman 2016 2 20 "30.11.3348" `shouldBe` Right (fromGregorian 3348 11 30) + + it "last october" $ + (do + monthOnly <- parseDateFormat "%m" + parseDate (fromGregorian 2016 9 15) monthOnly "10" + ) `shouldBe` Right (fromGregorian 2015 10 31) + + it "last november" $ + (do + monthOnly <- parseDateFormat "%m" + parseDate (fromGregorian 2016 9 15) monthOnly "11" + ) `shouldBe` Right (fromGregorian 2015 11 30) + + it "next november" $ + (do + yearMonth <- parseDateFormat "%y.%m" + parseDate (fromGregorian 2016 9 15) yearMonth "2016.11" + ) `shouldBe` Right (fromGregorian 2016 11 1) + + it "next january" $ + (do + yearMonth <- parseDateFormat "%y.%m" + parseDate (fromGregorian 2016 9 15) yearMonth "2017.1" + ) `shouldBe` Right (fromGregorian 2017 1 1) + + it "last january" $ + (do + yearMonth <- parseDateFormat "%y.%m" + parseDate (fromGregorian 2016 9 15) yearMonth "2016.1" + ) `shouldBe` Right (fromGregorian 2016 1 31) + + where + parseGerman :: Integer -> Int -> Int -> String -> Either Text Day + parseGerman y m d str = parseDate (fromGregorian y m d) german (T.pack str) + +printTests :: Spec +printTests = describe "date printer" $ do + it "is inverse to reading" $ property $ + printReadProp german + + it "handles short years correctly" $ do + withDateFormat ("%d-[%m-[%y]]") $ \format -> + printDate format (fromGregorian 2015 2 1) `shouldBe` "01-02-15" + + withDateFormat ("%d-[%m-[%y]]") $ \format -> + printDate format (fromGregorian 1999 2 1) `shouldBe` "01-02-1999" + + it "handles long years correctly" $ + withDateFormat ("%d-[%m-[%Y]]") $ \format -> + printDate format (fromGregorian 2015 2 1) `shouldBe` "01-02-2015" + +withDateFormat :: Text -> (DateFormat -> Expectation) -> Expectation +withDateFormat date action = case parseDateFormat date of + Left err -> expectationFailure (show err) + Right format -> action format + +shouldFail :: Text -> Text -> Expectation +shouldFail format date = withDateFormat format $ \format' -> do + res <- parseDateWithToday format' date + unless (isLeft res) $ + expectationFailure ("Should fail but parses: " ++ (T.unpack format) + ++ " / " ++ (T.unpack date) ++ " as " ++ show res) + +weekDayProp :: Property +weekDayProp = + forAll (ModifiedJulianDay <$> (arbitrary `suchThat` (>= 7))) $ \current -> + forAll (choose (1, 7)) $ \wday -> + wday === getWDay (weekDay wday current) + + where getWDay :: Day -> Int + getWDay d = let (_, _, w) = toWeekDate d in w + +weekDaySmallerProp :: Property +weekDaySmallerProp = + forAll (ModifiedJulianDay <$> (arbitrary `suchThat` (>= 7))) $ \current -> + forAll (choose (1, 7)) $ \wday -> + current >= weekDay wday current + +printReadProp :: DateFormat -> Day -> Property +printReadProp format day = case parseDate day format (printDate format day) of + Left err -> counterexample (T.unpack err) False + Right res -> res === day + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> arbitrary diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}