hledger-iadd (empty) → 1.1
raw patch · 16 files changed
+1900/−0 lines, 16 filesdep +QuickCheckdep +basedep +bricksetup-changed
Dependencies added: QuickCheck, base, brick, containers, directory, free, hledger-iadd, hledger-lib, hspec, megaparsec, microlens, optparse-applicative, text, text-format, text-zipper, time, transformers, unordered-containers, vector, vty, xdg-basedir
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hledger-iadd.cabal +94/−0
- src/AmountParser.hs +29/−0
- src/Brick/Widgets/BetterDialog.hs +36/−0
- src/Brick/Widgets/HelpMessage.hs +95/−0
- src/Brick/Widgets/List/Utils.hs +22/−0
- src/Brick/Widgets/WrappedText.hs +25/−0
- src/ConfigParser.hs +262/−0
- src/DateParser.hs +223/−0
- src/Model.hs +226/−0
- src/View.hs +54/−0
- src/main/Main.hs +392/−0
- tests/ConfigParserSpec.hs +250/−0
- tests/DateParserSpec.hs +159/−0
- tests/Spec.hs +1/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hledger-iadd.cabal view
@@ -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
+ src/AmountParser.hs view
@@ -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
+ src/Brick/Widgets/BetterDialog.hs view
@@ -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 " "
+ src/Brick/Widgets/HelpMessage.hs view
@@ -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)
+ src/Brick/Widgets/List/Utils.hs view
@@ -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
+ src/Brick/Widgets/WrappedText.hs view
@@ -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
+ src/ConfigParser.hs view
@@ -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) }
+ src/DateParser.hs view
@@ -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'
+ src/Model.hs view
@@ -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
+ src/View.hs view
@@ -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)
+ src/main/Main.hs view
@@ -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
+ tests/ConfigParserSpec.hs view
@@ -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
+ tests/DateParserSpec.hs view
@@ -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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}