├── cabal.project ├── Setup.hs ├── tests ├── Spec.hs ├── AmountParserSpec.hs ├── DateParserSpec.hs ├── ConfigParserSpec.hs └── ModelSpec.hs ├── doc └── screencast.gif ├── .gitignore ├── stack.yaml ├── stack-8.4.yaml ├── src ├── Data │ └── Time │ │ └── Ext.hs ├── Brick │ └── Widgets │ │ ├── Border │ │ └── Utils.hs │ │ ├── WrappedText.hs │ │ ├── List │ │ └── Utils.hs │ │ ├── BetterDialog.hs │ │ ├── CommentDialog.hs │ │ ├── HelpMessage.hs │ │ └── Edit │ │ └── EmacsBindings.hs ├── AmountParser.hs ├── View.hs ├── DateParser.hs ├── ConfigParser.hs ├── Model.hs └── main │ └── Main.hs ├── release ├── arch │ ├── Dockerfile │ ├── README.org │ └── build_release.sh └── release.sh ├── stack-8.2.yaml ├── LICENSE ├── .github └── workflows │ └── ci.yml ├── hledger-iadd.cabal ├── ChangeLog.md └── README.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /doc/screencast.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hpdeifel/hledger-iadd/HEAD/doc/screencast.gif -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work 2 | /.cabal-sandbox 3 | /cabal.config 4 | /dist 5 | /dist-newstyle 6 | /.hspec-failures 7 | /.ghc.environment* 8 | .dir-locals.el 9 | /cabal.project.local 10 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - . 3 | extra-deps: 4 | - brick-2.1.1 5 | - vty-6.1 6 | - vty-crossplatform-0.4.0.0 7 | - vty-unix-0.2.0.0 8 | - vty-windows-0.2.0.1 9 | - hledger-lib-1.32.2 10 | resolver: lts-21.25 11 | -------------------------------------------------------------------------------- /stack-8.4.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - . 5 | extra-deps: 6 | - hledger-lib-1.14 7 | - megaparsec-7.0.4 8 | - cassava-megaparsec-2.0.0 9 | - config-ini-0.2.4.0 10 | resolver: lts-12.26 11 | -------------------------------------------------------------------------------- /src/Data/Time/Ext.hs: -------------------------------------------------------------------------------- 1 | -- | Some helper functions for "Data.Time" 2 | module Data.Time.Ext 3 | ( module Data.Time 4 | , getLocalTime 5 | , getLocalDay 6 | ) where 7 | 8 | import Data.Time 9 | 10 | -- | Return the current time in the system time zone. 11 | getLocalTime :: IO LocalTime 12 | getLocalTime = zonedTimeToLocalTime <$> getZonedTime 13 | 14 | -- | Return the current day in the system time zone. 15 | getLocalDay :: IO Day 16 | getLocalDay = localDay <$> getLocalTime 17 | -------------------------------------------------------------------------------- /release/arch/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM archlinux 2 | 3 | RUN pacman -Suy --noconfirm 4 | RUN pacman -S --noconfirm curl base-devel 5 | ENV BOOTSTRAP_HASKELL_NONINTERACTIVE=1 6 | RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh 7 | ENV PATH="/root/.cabal/bin/:/root/.ghcup/bin:${PATH}" 8 | 9 | RUN mkdir /build/ 10 | 11 | WORKDIR /build/ 12 | CMD cp -r /home/hledger-iadd/* /build/ && cabal new-update && cabal new-build && \ 13 | cp `cabal list-bin exe:hledger-iadd` /home/hledger-iadd/ && \ 14 | strip /home/hledger-iadd/hledger-iadd 15 | -------------------------------------------------------------------------------- /stack-8.2.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - . 5 | extra-deps: 6 | - hledger-lib-1.14 7 | - megaparsec-7.0.4 8 | - cassava-megaparsec-2.0.0 9 | - config-ini-0.2.4.0 10 | - base-compat-batteries-0.10.5@sha256:480e82200ededcb1cb71ce5dd3b215b8eeb5728ae62f5ab026e2db39f76cf5f3 11 | - easytest-0.2.1@sha256:b819be42963118f61d955b5554fa83ce53442f942e322a4b8a75412d71ff9ed1 12 | - parser-combinators-1.0.0@sha256:7374d14cd3b38af0c7f7333049d6af1ccbbe6009deaa66e18701c2194e48f253 13 | - base-compat-0.10.5@sha256:d49e174ed0daecd059c52d13d4f4de87b5609c81212a22adbb92431f9cd58fff 14 | - contravariant-1.5@sha256:83f4d20073414561f2352aeb8f48207def31cc933eb058c141968fbbefaeb0d5 15 | resolver: lts-11.22 16 | -------------------------------------------------------------------------------- /src/Brick/Widgets/Border/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | Extensions to "Brick.Widgets.Border" 2 | module Brick.Widgets.Border.Utils (borderLeft) where 3 | 4 | import Brick 5 | import Brick.Widgets.Border 6 | import Graphics.Vty 7 | 8 | import Lens.Micro 9 | 10 | -- | Draw a vertical border on the left side of a widget. 11 | borderLeft :: Widget n -> Widget n 12 | borderLeft wrapped = Widget (hSize wrapped) (vSize wrapped) $ do 13 | c <- getContext 14 | 15 | wrappedRes <- render $ hLimit (c^.availWidthL - 1) 16 | $ wrapped 17 | 18 | let withBorder = vBorder <+> (Widget Fixed Fixed $ return wrappedRes) 19 | width = wrappedRes^.imageL.to imageWidth + 1 20 | height = wrappedRes^.imageL.to imageHeight 21 | 22 | render $ hLimit width $ vLimit height $ withBorder 23 | -------------------------------------------------------------------------------- /src/Brick/Widgets/WrappedText.hs: -------------------------------------------------------------------------------- 1 | -- | TODO Use the built-in wrapping feature in brick-0.20 2 | module Brick.Widgets.WrappedText (wrappedText) where 3 | 4 | import Brick 5 | import Data.Text (Text) 6 | import qualified Data.Text as T 7 | import Lens.Micro 8 | 9 | -- | Widget like 'txt', but wrap all lines to fit on the screen. 10 | -- 11 | -- Doesn't do word wrap, just breaks the line whenever the maximum width is 12 | -- exceeded. 13 | wrappedText :: Text -> Widget n 14 | wrappedText theText = Widget Fixed Fixed $ do 15 | ctx <- getContext 16 | let newText = wrapLines (ctx^.availWidthL) theText 17 | render $ txt newText 18 | 19 | -- | Wrap all lines in input to fit into maximum width. 20 | -- 21 | -- Doesn't do word wrap, just breaks the line whenever the maximum width is 22 | -- exceeded. 23 | wrapLines :: Int -> Text -> Text 24 | wrapLines width = T.unlines . concat . map wrap . T.lines 25 | where 26 | wrap = T.chunksOf width 27 | -------------------------------------------------------------------------------- /src/Brick/Widgets/List/Utils.hs: -------------------------------------------------------------------------------- 1 | module Brick.Widgets.List.Utils where 2 | 3 | import Brick.Widgets.List 4 | import Data.Maybe 5 | import qualified Data.Vector as V 6 | import Lens.Micro 7 | 8 | -- | Replace the contents of a list with a new set of elements but preserve the 9 | -- currently selected index. 10 | -- 11 | -- This is a version of listReplace that doesn't try to be smart, but assumes 12 | -- that all the elements in one list are distinct. 13 | -- 14 | -- listReplace itself is broken as of brick-0.2 due to a bogus implementation of 15 | -- the `merge` function. 16 | listSimpleReplace :: Eq e => V.Vector e -> List n e -> List n e 17 | listSimpleReplace elems oldList = 18 | let selected = flip V.elemIndex elems . snd =<< listSelectedElement oldList 19 | newSelected = if V.null elems 20 | then Nothing 21 | else Just $ fromMaybe 0 selected 22 | in oldList & listElementsL .~ elems & listSelectedL .~ newSelected 23 | -------------------------------------------------------------------------------- /src/AmountParser.hs: -------------------------------------------------------------------------------- 1 | module AmountParser (parseAmount) where 2 | 3 | import Data.Text (Text) 4 | import qualified Hledger as HL 5 | import Data.Functor.Identity 6 | import Control.Monad.Trans.State.Strict 7 | import Text.Megaparsec 8 | import Text.Megaparsec.Char 9 | 10 | type Parser a = HL.JournalParser Identity a 11 | 12 | parseAmount :: HL.Journal -> Text -> Either String HL.MixedAmount 13 | parseAmount journal t = case runIdentity $ runParserT (evalStateT (mixed <* optional space <* eof) journal) "" t of 14 | Left err -> Left (errorBundlePretty err) 15 | Right res -> Right res 16 | 17 | mixed :: Parser HL.MixedAmount 18 | mixed = HL.mixed <$> expr 19 | 20 | expr :: Parser [HL.Amount] 21 | expr = some (try $ lexeme factor) 22 | 23 | factor :: Parser HL.Amount 24 | factor = (char '+' >> lexeme HL.amountp) 25 | <|> (char '-' >> HL.divideAmount (-1) <$> lexeme HL.amountp) 26 | <|> HL.amountp 27 | 28 | lexeme :: Parser a -> Parser a 29 | lexeme p = space >> p 30 | -------------------------------------------------------------------------------- /release/arch/README.org: -------------------------------------------------------------------------------- 1 | This Dockerfile is used to produce the [[https://aur.archlinux.org/packages/hledger-iadd-bin/][binary AUR package]] for Archlinux. 2 | 3 | * Building the Image 4 | 5 | Execute in this directory 6 | 7 | #+BEGIN_SRC sh 8 | podman build -t hledger-iadd . 9 | #+END_SRC 10 | 11 | * Building the binary from a release tarball 12 | 13 | From the toplevel directory of the repo: 14 | 15 | #+BEGIN_SRC sh 16 | ./release/arch/build_release.sh VERSION 17 | #+END_SRC 18 | 19 | This creates tarball and signature in the current directory. 20 | 21 | * Uploading to Github release 22 | 23 | 1. Go to the github release in question 24 | 2. Click /Edit release/ 25 | 3. Drag and drop tarball and signature file into the area below the input box 26 | 4. Click /Update release/ 27 | 28 | * Updating the AUR package 29 | 30 | Last but not least, bump the version number in the AUR PKGBUILD, update 31 | the checksums (from local files, not github) and run: 32 | 33 | #+BEGIN_SRC sh 34 | makepkg 35 | makepkg --printsrcinfo > .SRCINFO 36 | git commit -m "Bump for new release" 37 | git push 38 | #+END_SRC 39 | -------------------------------------------------------------------------------- /src/Brick/Widgets/BetterDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Brick.Widgets.BetterDialog ( dialog )where 4 | 5 | import Brick 6 | import Brick.Widgets.Border 7 | import Graphics.Vty 8 | import Data.Text (Text) 9 | import Lens.Micro 10 | 11 | dialog :: Text -> Text -> Widget n 12 | dialog title = center . dialog' title 13 | 14 | -- TODO Remove duplication from HelpMessage 15 | center :: Widget n -> Widget n 16 | center w = Widget Fixed Fixed $ do 17 | c <- getContext 18 | res <- render w 19 | let rWidth = res^.imageL.to imageWidth 20 | rHeight = res^.imageL.to imageHeight 21 | x = (c^.availWidthL `div` 2) - (rWidth `div` 2) 22 | y = (c^.availHeightL `div` 2) - (rHeight `div` 2) 23 | 24 | render $ translateBy (Location (x,y)) $ raw (res^.imageL) 25 | 26 | dialog' :: Text -> Text -> Widget n 27 | dialog' title content = Widget Fixed Fixed $ do 28 | c <- getContext 29 | 30 | render $ 31 | hLimit (min 80 $ c^.availWidthL) $ 32 | vLimit (min 30 $ c^.availHeightL) $ 33 | borderWithLabel (txt title) $ 34 | txt " " 35 | <=> (txt " " <+> txt content <+> txt " ") 36 | <=> txt " " 37 | -------------------------------------------------------------------------------- /tests/AmountParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module AmountParserSpec (spec) where 4 | 5 | import Test.Hspec 6 | 7 | import Control.Monad.Trans.State.Strict 8 | import Data.Either (isLeft) 9 | import Data.Functor.Identity 10 | import Data.Text (Text) 11 | import qualified Hledger as HL 12 | import Text.Megaparsec 13 | 14 | import AmountParser 15 | 16 | spec :: Spec 17 | spec = describe "parseAmount" $ do 18 | it "parses single amount" $ 19 | parseAmount HL.nulljournal "42" `shouldBe` Right (amount "42") 20 | 21 | it "parses a positive number" $ 22 | parseAmount HL.nulljournal "+42" `shouldBe` Right (amount "42") 23 | 24 | it "parses a negative number" $ 25 | parseAmount HL.nulljournal "-42" `shouldBe` Right (amount "-42") 26 | 27 | it "parses a simple sum" $ 28 | parseAmount HL.nulljournal "23 + 23 + 42 + 1" `shouldBe` Right (amount "89") 29 | 30 | it "parses a sum with negative values" $ 31 | parseAmount HL.nulljournal "-42 + 23 + 42 - 23 + 1" `shouldBe` Right (amount "1") 32 | 33 | it "fails to parse a trailing plus" $ 34 | parseAmount HL.nulljournal "23 +" `shouldSatisfy` isLeft 35 | 36 | amount :: Text -> HL.MixedAmount 37 | amount = HL.mixed . Just . fromRight . runIdentity . runParserT (evalStateT HL.amountp HL.nulljournal) "" 38 | 39 | fromRight :: Either a b -> b 40 | fromRight = either (error "fromRight: Left value encountered") id 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Hans-Peter Deifel (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Hans-Peter Deifel nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | 3 | on: [push, pull_request, workflow_dispatch] 4 | 5 | permissions: 6 | contents: read 7 | 8 | jobs: 9 | build: 10 | 11 | runs-on: ubuntu-latest 12 | 13 | steps: 14 | - uses: actions/checkout@v4 15 | 16 | - name: Setup GHC 17 | uses: haskell-actions/setup@v2 18 | id: setup 19 | with: 20 | ghc-version: '9.6.7' 21 | cabal-version: '3.12' 22 | cabal-update: true 23 | 24 | # Generate plan.json for the cache key 25 | - name: Configure the build 26 | run: | 27 | cabal configure --enable-tests --enable-benchmarks --disable-documentation 28 | cabal build all --dry-run 29 | 30 | - name: Restore cached dependencies 31 | uses: actions/cache/restore@v4 32 | id: cache 33 | env: 34 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} 35 | with: 36 | path: ${{ steps.setup.outputs.cabal-store }} 37 | key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} 38 | restore-keys: ${{ env.key }}- 39 | 40 | - name: Install dependencies 41 | if: steps.cache.outputs.cache-hit != 'true' 42 | run: cabal build all --only-dependencies 43 | 44 | - name: Save cached dependencies 45 | uses: actions/cache/save@v4 46 | if: steps.cache.outputs.cache-hit != 'true' 47 | with: 48 | path: ${{ steps.setup.outputs.cabal-store }} 49 | key: ${{ steps.cache.outputs.cache-primary-key }} 50 | 51 | - name: Build 52 | run: cabal build all 53 | 54 | - name: Run tests 55 | run: cabal test all -------------------------------------------------------------------------------- /release/arch/build_release.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # This script build a binary release tarball for Archlinux. 4 | # 5 | # It must be executed in the toplevel directory of the hledger-iadd repo: 6 | # 7 | # ./release/arch/build_release.sh VERSION 8 | # 9 | # This assumes that a container image called hledger-iadd that is built from the 10 | # Dockerfile in this directory is available. 11 | # 12 | # The repo must be in unmodified state and the release in question must be 13 | # checked out. 14 | 15 | set -euo pipefail 16 | IFS=$'\n\t' 17 | 18 | if [ $# -lt 1 ]; then 19 | echo "Usage: $0 VERSION" 20 | exit 1 21 | fi 22 | 23 | if [ \! -e hledger-iadd.cabal ]; then 24 | echo "This script must be executed from the toplevel directory of the hledger-iadd repo." 25 | echo "(The one with the cabal file)." 26 | exit 1 27 | fi 28 | 29 | VERSION=$1 30 | TMPDIR=$(mktemp -d) 31 | CURDIR=$(pwd) 32 | 33 | set -x 34 | 35 | # Create a source distribution tarball from the repo and copy it to a temporary 36 | # directory. 37 | cabal new-sdist 38 | cp "./dist-newstyle/sdist/hledger-iadd-${VERSION}.tar.gz" "${TMPDIR}" 39 | 40 | # Go to the temporary directory 41 | pushd "${TMPDIR}" 42 | 43 | # Unpack the source tarball 44 | tar xf "hledger-iadd-${VERSION}.tar.gz" 45 | cd hledger-iadd-${VERSION} 46 | 47 | # Build the binary in a container 48 | podman run --rm -v $(pwd):/home/hledger-iadd:z hledger-iadd 49 | 50 | # Pack the whole thing up 51 | tar -cJf "hledger-iadd-${VERSION}-archlinux.tar.xz" hledger-iadd 52 | 53 | # Sign it 54 | gpg --armor --detach-sign "hledger-iadd-${VERSION}-archlinux.tar.xz" 55 | 56 | # And copy the artifacts back to our original working directory 57 | cp "hledger-iadd-${VERSION}-archlinux.tar.xz" "hledger-iadd-${VERSION}-archlinux.tar.xz.asc" "${CURDIR}/" 58 | 59 | # Delete the temporary directory 60 | popd 61 | rm -r "${TMPDIR}" 62 | -------------------------------------------------------------------------------- /src/Brick/Widgets/CommentDialog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Brick.Widgets.CommentDialog 5 | ( CommentWidget 6 | , commentWidget 7 | , renderCommentWidget 8 | , commentDialogComment 9 | , CommentAction(..) 10 | , handleCommentEvent 11 | ) where 12 | 13 | import Brick 14 | import Brick.Widgets.Dialog 15 | import Brick.Widgets.Center 16 | import Data.Text.Zipper 17 | import Graphics.Vty.Input 18 | import qualified Data.Text as T 19 | import Data.Text (Text) 20 | 21 | import Lens.Micro 22 | import Lens.Micro.TH 23 | import Lens.Micro.Mtl 24 | 25 | import Brick.Widgets.Edit.EmacsBindings 26 | 27 | data CommentWidget n = CommentWidget 28 | { _origComment :: Text 29 | , _textArea :: Editor n 30 | , _dialogWidget :: Dialog () n 31 | , _promptPrefix :: Text 32 | } 33 | 34 | makeLenses ''CommentWidget 35 | 36 | commentWidget :: Eq n => n -> Text -> Text -> CommentWidget n 37 | commentWidget name prompt comment = 38 | let 39 | title = txt "ESC: cancel, RET: accept, Alt-RET: New line" 40 | maxWidth = 80 41 | diag = dialog (Just title) Nothing maxWidth 42 | edit = editorText name (txt . T.unlines) Nothing comment 43 | in 44 | CommentWidget 45 | { _origComment = comment 46 | , _textArea = applyEdit gotoEnd edit 47 | , _dialogWidget = diag 48 | , _promptPrefix = prompt 49 | } 50 | 51 | data CommentAction = CommentContinue | CommentFinished Text 52 | 53 | handleCommentEvent :: Eq n => Event -> EventM n (CommentWidget n) CommentAction 54 | handleCommentEvent ev = case ev of 55 | EvKey KEsc [] -> CommentFinished <$> use origComment 56 | EvKey KEnter [] -> CommentFinished <$> gets commentDialogComment 57 | EvKey KEnter [MMeta] -> do 58 | zoom textArea $ applyEditM breakLine 59 | return CommentContinue 60 | _ -> do 61 | zoom textArea $ handleEditorEvent ev 62 | return CommentContinue 63 | 64 | renderCommentWidget :: (Ord n, Show n) => CommentWidget n -> Widget n 65 | renderCommentWidget widget = 66 | let 67 | height = min (length (getEditContents (widget^.textArea)) + 4) 24 68 | textArea' = padTop (Pad 1) $ 69 | txt (widget^.promptPrefix <> ": ") <+> renderEditor True (widget^.textArea) 70 | in 71 | vCenterLayer $ vLimit height $ renderDialog (widget^.dialogWidget) textArea' 72 | 73 | commentDialogComment :: CommentWidget n -> Text 74 | commentDialogComment = T.intercalate "\n" . getEditContents . _textArea 75 | 76 | gotoEnd :: Monoid a => TextZipper a -> TextZipper a 77 | gotoEnd zipper = 78 | let 79 | lengths = lineLengths zipper 80 | (row, col) = (length lengths, last lengths) 81 | in 82 | moveCursor (row-1, col) zipper 83 | -------------------------------------------------------------------------------- /release/release.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This script is for maintainers only! It creates a new release. 4 | # 5 | # Usage: release.sh VERSION 6 | 7 | set -e 8 | 9 | if [ -z "$1" ] || [ "$1" = -h ]; then 10 | echo "$0 VERSION" 11 | exit 0 12 | fi 13 | 14 | version="$1" 15 | 16 | if git status --porcelain | grep '^ M' ; then 17 | echo "You have unstaged changes!" >&2 18 | exit 1 19 | fi 20 | 21 | if [ ! -e .git/ ]; then 22 | echo "Please run this script from the top-level directory." >&2 23 | exit 1 24 | fi 25 | 26 | ######################## 27 | # Function definitions # 28 | ######################## 29 | 30 | function run_tests { 31 | echo "### Running Tests" 32 | cabal test -O0 -v0 33 | } 34 | 35 | function update_changelog { 36 | echo "### Updating version in ChangeLog.md" 37 | local headline="# $version [$(date +%Y-%m-%d)]" 38 | sed -i "s/^# NEXT VERSION/$headline/" ChangeLog.md 39 | } 40 | 41 | function update_cabal_file { 42 | echo "### Updating version in cabal file" 43 | local line="^version:\(\W\+\).*" 44 | sed -i "s/${line}/version:\1${version}/" hledger-iadd.cabal 45 | } 46 | 47 | function make_commit { 48 | echo "### Comitting" 49 | git add hledger-iadd.cabal 50 | git add ChangeLog.md 51 | git commit -m "Bump version and update ChangeLog" 52 | git tag -s -m "Version $version" v${version} 53 | } 54 | 55 | function push_changes { 56 | echo -e "### Pushing\n" 57 | echo -n "really push? (return to confirm) " 58 | read 59 | git push 60 | git push --tags 61 | } 62 | 63 | function make_hackage_tarball { 64 | echo "### Creating the hackage tarball" 65 | cabal sdist -o . hledger-iadd.cabal 66 | } 67 | 68 | function check_hackage_tarball { 69 | echo "### Testing the hackage tarball" 70 | local tmpdir="$(mktemp -d)" 71 | 72 | tar xf "hledger-iadd-${version}.tar.gz" --directory=${tmpdir} 73 | 74 | pushd "$tmpdir/hledger-iadd-${version}/" 75 | cabal test -O0 -v0 76 | popd 77 | } 78 | 79 | function upload_hackage_tarball { 80 | echo -e "### Uploading the hackage tarball\n" 81 | echo -n "Really upload? (return to confirm) " 82 | read 83 | cabal upload "hledger-iadd-${version}.tar.gz" 84 | } 85 | 86 | function next_steps { 87 | echo -e "### Manual steps required:\n" 88 | echo " - [ ] Create github release from tag" 89 | echo " - [ ] Publish the hackage release" 90 | echo " - [ ] Make static binary" 91 | echo " - [ ] Update AUR Package" 92 | echo " - [ ] Announce release" 93 | } 94 | 95 | ############### 96 | # Main script # 97 | ############### 98 | 99 | run_tests; echo 100 | update_changelog; echo 101 | update_cabal_file; echo 102 | run_tests; echo 103 | make_commit; echo 104 | push_changes; echo 105 | make_hackage_tarball; echo 106 | check_hackage_tarball; echo 107 | upload_hackage_tarball; echo 108 | next_steps 109 | -------------------------------------------------------------------------------- /src/View.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module View 5 | ( viewState 6 | , viewQuestion 7 | , viewContext 8 | , viewSuggestion 9 | , viewMessage 10 | ) where 11 | 12 | import Brick 13 | import Brick.Widgets.List 14 | import Brick.Widgets.WrappedText 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | import qualified Hledger as HL 18 | 19 | -- hledger-lib 1.17 will switch showTransaction to ISO date format, which means 20 | -- that ISO dates yyyy-mm-dd will be added to the journal instead of yyyy/mm/dd. 21 | -- 22 | -- Thus, for hledger-lib >=1.17, we also show the ISO format in the UI 23 | #if !MIN_VERSION_hledger_lib(1,16,99) 24 | import Data.Time hiding (parseTime) 25 | #endif 26 | 27 | import Model 28 | 29 | viewState :: Step -> Widget n 30 | viewState (DateQuestion comment) = txt $ 31 | if T.null comment then " " else viewComment comment 32 | viewState (DescriptionQuestion date comment) = txt $ 33 | #if MIN_VERSION_hledger_lib(1,16,99) 34 | T.pack (show date) 35 | #else 36 | T.pack (formatTime defaultTimeLocale "%Y/%m/%d" date) 37 | #endif 38 | <> viewComment comment 39 | viewState (AccountQuestion trans comment) = txt $ 40 | showTransaction trans <> viewComment comment 41 | viewState (AmountQuestion acc trans comment) = txt $ 42 | showTransaction trans <> "\n " <> acc <> viewComment comment 43 | viewState (FinalQuestion trans _) = txt $ 44 | showTransaction trans 45 | 46 | viewQuestion :: Step -> Widget n 47 | viewQuestion (DateQuestion _) = txt "Date" 48 | viewQuestion (DescriptionQuestion _ _) = txt "Description" 49 | viewQuestion (AccountQuestion trans _) = str $ 50 | "Account " ++ show (numPostings trans + 1) 51 | viewQuestion (AmountQuestion _ trans _) = str $ 52 | "Amount " ++ show (numPostings trans + 1) 53 | viewQuestion (FinalQuestion _ duplicate) = txt $ 54 | "Add this transaction to the journal?" 55 | <> (if duplicate then " (warning: duplicate)" else "") -- TODO Add better UI for duplicates 56 | <> " Y/n" 57 | 58 | viewContext :: (Ord n, Show n) => List n Text -> Widget n 59 | viewContext = renderList renderItem True 60 | 61 | viewSuggestion :: Maybe Text -> Widget n 62 | viewSuggestion Nothing = txt "" 63 | viewSuggestion (Just t) = txt $ " (" <> t <> ")" 64 | 65 | renderItem :: Bool -> Text -> Widget n 66 | renderItem True = withAttr listSelectedAttr . padRight Max . txt 67 | renderItem False = txt 68 | 69 | numPostings :: HL.Transaction -> Int 70 | numPostings = length . HL.tpostings 71 | 72 | -- TODO Adding " " to an empty message isn't required for vty >= 5.14 73 | -- => Remove this, once 5.14 becomes lower bound 74 | viewMessage :: Text -> Widget n 75 | viewMessage msg = wrappedText (if T.null msg then " " else msg) 76 | 77 | viewComment :: Text -> Text 78 | viewComment comment 79 | | T.null comment = "" 80 | | otherwise = T.unlines $ map (" ; " <>) $ T.lines comment 81 | 82 | 83 | showTransaction :: HL.Transaction -> Text 84 | showTransaction = T.stripEnd . HL.showTransaction 85 | -------------------------------------------------------------------------------- /src/Brick/Widgets/HelpMessage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, NamedFieldPuns, ConstraintKinds #-} 2 | module Brick.Widgets.HelpMessage 3 | ( HelpWidget 4 | , Title 5 | , KeyBindings(..) 6 | , helpWidget 7 | , renderHelpWidget 8 | , helpAttr 9 | , resetHelpWidget 10 | , handleHelpEvent 11 | ) where 12 | 13 | import Brick 14 | import Brick.Widgets.Border 15 | import Graphics.Vty 16 | import Data.Text (Text) 17 | import Data.List 18 | import Lens.Micro 19 | 20 | type Title = Text 21 | 22 | -- [(Title, [(Key, Description)])] 23 | newtype KeyBindings = KeyBindings [(Title, [(Text, Text)])] 24 | 25 | data HelpWidget n = HelpWidget 26 | { keyBindings :: KeyBindings 27 | , name :: n 28 | } 29 | 30 | type Name n = (Ord n, Show n) 31 | 32 | helpWidget :: n -> KeyBindings -> HelpWidget n 33 | helpWidget = flip HelpWidget 34 | 35 | renderHelpWidget :: Name n => HelpWidget n -> Widget n 36 | renderHelpWidget HelpWidget{keyBindings, name} = 37 | center $ renderHelpWidget' name keyBindings 38 | 39 | center :: Widget n -> Widget n 40 | center w = Widget Fixed Fixed $ do 41 | c <- getContext 42 | res <- render w 43 | let rWidth = res^.imageL.to imageWidth 44 | rHeight = res^.imageL.to imageHeight 45 | x = (c^.availWidthL `div` 2) - (rWidth `div` 2) 46 | y = (c^.availHeightL `div` 2) - (rHeight `div` 2) 47 | 48 | render $ translateBy (Location (x,y)) $ raw (res^.imageL) 49 | 50 | renderHelpWidget' :: Name n => n -> KeyBindings -> Widget n 51 | renderHelpWidget' name (KeyBindings bindings) = Widget Fixed Fixed $ do 52 | c <- getContext 53 | 54 | render $ 55 | hLimit (min 80 $ c^.availWidthL) $ 56 | vLimit (min 30 $ c^.availHeightL) $ 57 | borderWithLabel (txt "Help") $ 58 | viewport name Vertical $ 59 | vBox $ intersperse (txt " ") $ 60 | map (uncurry section) bindings 61 | 62 | scroller :: HelpWidget n -> ViewportScroll n 63 | scroller HelpWidget{name} = viewportScroll name 64 | 65 | handleHelpEvent :: Event -> EventM n (HelpWidget n) () 66 | handleHelpEvent (EvKey k _) = case k of 67 | KChar 'j' -> gets scroller >>= \s -> vScrollBy s 1 68 | KDown -> gets scroller >>= \s -> vScrollBy s 1 69 | KChar 'k' -> gets scroller >>= \s -> vScrollBy s (-1) 70 | KUp -> gets scroller >>= \s -> vScrollBy s (-1) 71 | KChar 'g' -> gets scroller >>= \s -> vScrollToBeginning s 72 | KHome -> gets scroller >>= \s -> vScrollToBeginning s 73 | KChar 'G' -> gets scroller >>= \s -> vScrollToEnd s 74 | KEnd -> gets scroller >>= \s -> vScrollToEnd s 75 | KPageUp -> gets scroller >>= \s -> vScrollPage s Up 76 | KPageDown -> gets scroller >>= \s -> vScrollPage s Down 77 | _ -> return () 78 | handleHelpEvent _ = return () 79 | 80 | 81 | resetHelpWidget :: HelpWidget n -> EventM n s () 82 | resetHelpWidget x = vScrollToBeginning (scroller x) 83 | 84 | key :: Text -> Text -> Widget n 85 | key k h = withAttr (helpAttr <> attrName "key") (txt (" " <> k)) 86 | <+> padLeft Max (withAttr (helpAttr <> attrName "description") (txt h)) 87 | 88 | helpAttr :: AttrName 89 | helpAttr = attrName "help" 90 | 91 | section :: Title -> [(Text, Text)] -> Widget n 92 | section title keys = withAttr (helpAttr <> attrName "title") (txt (title <> ":")) 93 | <=> vBox (map (uncurry key) keys) 94 | -------------------------------------------------------------------------------- /src/Brick/Widgets/Edit/EmacsBindings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, CPP #-} 2 | 3 | -- | Widget like "Brick.Widgets.Edit", but with more emacs style keybindings. 4 | -- 5 | -- This is also a complete wrapper around the "Brick.Widgets.Edit" API to retain 6 | -- compatability with older brick versions. 7 | -- 8 | -- See 'handleEditorEvent' for a list of added keybindings. 9 | module Brick.Widgets.Edit.EmacsBindings 10 | ( Editor 11 | , editorText 12 | , getEditContents 13 | , applyEditM 14 | , applyEdit 15 | , editContentsL 16 | , handleEditorEvent 17 | , renderEditor 18 | ) where 19 | 20 | import Brick 21 | import Graphics.Vty 22 | import qualified Brick.Widgets.Edit as E 23 | import Data.Text.Zipper 24 | import Data.Text (Text) 25 | import Lens.Micro.TH 26 | import Lens.Micro 27 | import Lens.Micro.Mtl 28 | 29 | import Data.Text.Zipper.Generic.Words 30 | 31 | -- | Wrapper around 'E.Editor', but specialized to 'Text' 32 | data Editor n = Editor { 33 | _origEditor :: E.Editor Text n, 34 | _drawingFunction :: [Text] -> Widget n 35 | } 36 | 37 | makeLenses ''Editor 38 | 39 | -- | Wrapper for 'E.editorText' specialized to 'Text' 40 | editorText :: n -> ([Text] -> Widget n)-> Maybe Int -> Text -> Editor n 41 | editorText name draw linum content = 42 | #if MIN_VERSION_brick(0,19,0) 43 | Editor (E.editorText name linum content) draw 44 | #else 45 | Editor (E.editorText name draw linum content) draw 46 | #endif 47 | 48 | -- | Wrapper for 'E.getEditContents' specialized to 'Text' 49 | getEditContents :: Editor n -> [Text] 50 | getEditContents edit = edit ^. origEditor . to E.getEditContents 51 | 52 | -- | Wrapper for 'E.applyEdit' specialized to 'Text' 53 | applyEdit :: (TextZipper Text -> TextZipper Text) -> Editor n -> Editor n 54 | applyEdit f edit = edit & origEditor %~ E.applyEdit f 55 | 56 | applyEditM :: (TextZipper Text -> TextZipper Text) -> EventM n (Editor n) () 57 | applyEditM f = origEditor %= E.applyEdit f 58 | 59 | -- | Wrapper for 'E.editContentsL' specialized to 'Text' 60 | editContentsL :: Lens (Editor n) (Editor n) (TextZipper Text) (TextZipper Text) 61 | editContentsL = origEditor . E.editContentsL 62 | 63 | -- | Same as 'E.handleEditorEvent', but with more emacs-style keybindings and 64 | -- specialized to 'Text' 65 | -- 66 | -- Specifically: 67 | -- 68 | -- - Ctrl-f: Move forward one character 69 | -- - Ctrl-b: Move backward one character 70 | -- - Alt-f: Move forward one word 71 | -- - Alt-b: Move backward one word 72 | -- - Alt-Backspace: Delete the previous word 73 | -- - Ctrl-w: Delete the previous word 74 | -- - Alt-d: Delete the next word 75 | handleEditorEvent :: Eq n => Event -> EventM n (Editor n) () 76 | handleEditorEvent event = case event of 77 | EvKey (KChar 'f') [MCtrl] -> applyEditM moveRight 78 | EvKey (KChar 'b') [MCtrl] -> applyEditM moveLeft 79 | 80 | EvKey (KChar 'f') [MMeta] -> applyEditM moveWordRight 81 | EvKey (KChar 'b') [MMeta] -> applyEditM moveWordLeft 82 | 83 | EvKey KBS [MMeta] -> applyEditM deletePrevWord 84 | EvKey (KChar 'w') [MCtrl] -> applyEditM deletePrevWord 85 | EvKey (KChar 'd') [MMeta] -> applyEditM deleteWord 86 | 87 | EvKey KHome [] -> applyEditM gotoBOL 88 | EvKey KEnd [] -> applyEditM gotoEOL 89 | 90 | _ -> zoom origEditor $ E.handleEditorEvent (VtyEvent event) 91 | 92 | 93 | -- | Wrapper for 'E.renderEditor' specialized to 'Text' 94 | renderEditor :: (Ord n, Show n) => Bool -> Editor n -> Widget n 95 | renderEditor focus edit = 96 | #if MIN_VERSION_brick(0,19,0) 97 | E.renderEditor (edit^.drawingFunction) focus (edit^.origEditor) 98 | #else 99 | E.renderEditor focus (edit^.origEditor) 100 | #endif 101 | -------------------------------------------------------------------------------- /hledger-iadd.cabal: -------------------------------------------------------------------------------- 1 | name: hledger-iadd 2 | version: 1.3.23 3 | synopsis: A terminal UI as drop-in replacement for hledger add 4 | description: This is a terminal UI as drop-in replacement for hledger add. 5 | . 6 | It improves in the following ways on hledger's add command: 7 | . 8 | * Interactive as-you-type completion for 9 | account names and descriptions with optional 10 | fuzzy matching. 11 | . 12 | * Integrated calculator: Amounts can be written 13 | as simple sums with real-time feedback on the 14 | result. 15 | . 16 | * All actions while entering a transaction can 17 | be undone 18 | . 19 | * Configurable format for date input. Instead 20 | of @y\/m\/d@ it is also possible to use other 21 | formats like the german @d.m.y@. 22 | 23 | homepage: https://github.com/hpdeifel/hledger-iadd#readme 24 | bug-reports: https://github.com/hpdeifel/hledger-iadd/issues 25 | license: BSD3 26 | license-file: LICENSE 27 | author: Hans-Peter Deifel 28 | maintainer: Hans-Peter Deifel 29 | copyright: 2018 Hans-Peter Deifel 30 | category: Finance, Console 31 | build-type: Simple 32 | cabal-version: >=1.10 33 | tested-with: GHC ==8.10.7 34 | , GHC ==9.0.2 35 | , GHC ==9.2.8 36 | , GHC ==9.4.8 37 | , GHC ==9.6.3 38 | 39 | extra-source-files: 40 | doc/screencast.gif 41 | README.md 42 | ChangeLog.md 43 | 44 | source-repository head 45 | type: git 46 | location: https://github.com/hpdeifel/hledger-iadd.git 47 | 48 | library 49 | hs-source-dirs: src 50 | exposed-modules: Model 51 | , View 52 | , AmountParser 53 | , DateParser 54 | , ConfigParser 55 | , Brick.Widgets.List.Utils 56 | , Brick.Widgets.HelpMessage 57 | , Brick.Widgets.CommentDialog 58 | , Brick.Widgets.BetterDialog 59 | , Brick.Widgets.WrappedText 60 | , Brick.Widgets.Edit.EmacsBindings 61 | , Brick.Widgets.Border.Utils 62 | , Data.Time.Ext 63 | default-language: Haskell2010 64 | build-depends: base >= 4.14 && < 5 65 | , hledger-lib >= 1.50 && < 1.52 66 | , brick >= 2.1 && < 2.11 67 | , vty >= 6.1 && < 6.6 68 | , text 69 | , microlens 70 | , microlens-th 71 | , microlens-mtl 72 | , text-zipper >= 0.10 73 | , transformers >= 0.3 74 | , time >= 1.5 75 | , vector 76 | , megaparsec >= 7.0 && <9.8 77 | , containers 78 | , optparse-applicative 79 | , directory 80 | , xdg-basedir 81 | , unordered-containers 82 | , free >= 4.12.4 83 | ghc-options: -Wall -fdefer-typed-holes -fno-warn-name-shadowing 84 | 85 | executable hledger-iadd 86 | hs-source-dirs: src/main 87 | main-is: Main.hs 88 | other-modules: Paths_hledger_iadd 89 | default-language: Haskell2010 90 | build-depends: base >= 4.14 && < 5 91 | , hledger-iadd 92 | , hledger-lib >= 1.50 && <1.52 93 | , brick >= 2.1 && < 2.11 94 | , vty >= 6.1 && < 6.6 95 | , text 96 | , microlens 97 | , microlens-th 98 | , microlens-mtl 99 | , text-zipper >= 0.10 100 | , transformers >= 0.3 101 | , time >= 1.5 102 | , vector 103 | , optparse-applicative 104 | , directory 105 | , xdg-basedir 106 | , unordered-containers 107 | , free >= 4.12.4 108 | , megaparsec >= 7.0 && <9.8 109 | ghc-options: -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing 110 | 111 | test-suite spec 112 | type: exitcode-stdio-1.0 113 | hs-source-dirs: tests 114 | main-is: Spec.hs 115 | other-modules: DateParserSpec 116 | , ConfigParserSpec 117 | , AmountParserSpec 118 | , ModelSpec 119 | default-language: Haskell2010 120 | build-depends: base >= 4.14 && < 5 121 | , hledger-iadd 122 | , hledger-lib >= 1.50 && <1.52 123 | , text 124 | , transformers >= 0.3 125 | , time >= 1.5 126 | , vector 127 | , hspec 128 | , QuickCheck 129 | , quickcheck-instances 130 | , free >= 4.12.4 131 | , megaparsec >= 7.0 && <9.8 132 | , text-zipper >= 0.10 133 | build-tool-depends: hspec-discover:hspec-discover ==2.* 134 | ghc-options: -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing 135 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # NEXT RELEASE 2 | 3 | - dependencies: Bump brick and vty 4 | 5 | # 1.3.22 [2025-09-17] 6 | 7 | - feature: Add more abbreviations for weekdays ("m", "mo", ...) 8 | - dependencies: Require hledger-lib 1.50 9 | - dependencies: Bump brick, vty and megaparsec 10 | 11 | # 1.3.21 [2024-04-20] 12 | 13 | - dependencies: Bump brick and vty versions 14 | - Update to hledger-lib 1.33 15 | 16 | # 1.3.20 [2024-01-10] 17 | 18 | - feature: Make 'Y/n' prompts case-insensitive 19 | - dependencies: Update to hledger-lib 1.32 20 | - dependencies: Allow megaparsec 9.6 21 | 22 | # 1.3.19 [2023-09-15] 23 | 24 | - dependencies: Update to hledger-lib 1.31 25 | - dependencies: Allow megaparsec 9.5 26 | 27 | # 1.3.18 [2023-04-05] 28 | 29 | - dependencies: Update to hledger-lib 1.29 30 | - dependencies: Update to brick 1.5 31 | 32 | # 1.3.17 [2022-03-15] 33 | 34 | - dependencies: Support brick 0.68 35 | - dependencies: Allow hledger-lib 1.25 36 | - dependencies: Allow megaparsec 9.2 37 | 38 | # 1.3.16 [2021-09-22] 39 | 40 | - dependencies: Support (and require) hledger-lib-1.23 41 | - dependencies: Allow megaparsec 9.1 42 | 43 | # 1.3.15 [2021-07-08] 44 | 45 | - dependencies: Support (and require) hledger-lib-1.22 46 | - dependencies: Drop support for GHC <8.6 completely 47 | 48 | # 1.3.14 [2021-03-13] 49 | 50 | - bugfix: Fix test failures 51 | - bugfix: Fix amount suggestion in some circumstances 52 | - dependencies: Remove GHC 8.0, 8.2 and 8.4 from list of officially supported 53 | compilers. They might still work 54 | 55 | # 1.3.13 [2021-03-10] 56 | 57 | - dependencies: Support (and require) hledger-lib-1.21 58 | - dependencies: Support megaparsec-9 59 | 60 | # 1.3.12 [2020-08-31] 61 | 62 | - dependencies: Fix tests build with hledger-lib-1.19 63 | 64 | # 1.3.11 [2020-06-04] 65 | 66 | - bugfix: Fix check for balanced transactions in the presence of commodities. 67 | - dependencies: Fix build with hledger-lib-1.18 68 | 69 | # 1.3.10 [2020-01-14] 70 | 71 | - dependencies: Support megaparsec-8 72 | 73 | # 1.3.9 [2019-03-02] 74 | 75 | - dependencies: Port to hledger-lib-1.14 76 | - Add AUR packaging 77 | 78 | # 1.3.8 79 | 80 | - dependencies: Port to hledger-lib-1.13 81 | 82 | # 1.3.7 83 | 84 | - feature: Add abbreviated days of the week to date completion (e.g. `mon`, 85 | `tue`, etc) 86 | - dependencies: Port to hledger-lib-1.12 and megaparsec-7 87 | - dependencies: Support GHC-8.6 88 | - dependencies: Switch stack builds to ghc 8.4 by default 89 | 90 | # 1.3.6 91 | 92 | - bugfix: Use local time instead of UTC everywhere 93 | 94 | # 1.3.5 95 | 96 | - Fix build with hledger-lib 1.9.1 97 | 98 | # 1.3.4 99 | 100 | - Fix test suite build with hledger-lib 1.9 101 | 102 | # 1.3.3 103 | 104 | - Support new dependencies 105 | - Raise lower bound on hledger-lib to 1.5 106 | 107 | # 1.3.2 108 | 109 | - Highlight currently constructed transaction 110 | - Fix build with GHC 8.4 111 | - Support new dependencies 112 | - Drop dependency on text-format 113 | 114 | # 1.3.1 115 | 116 | - Support brick <= 0.32 117 | - Support megaparsec <= 6.4 118 | 119 | # 1.3.0 120 | 121 | - Detect duplicate transactions and warn about them 122 | - Add empty line before transactions when writing to journal 123 | - Don't elide the last amount in transactions 124 | - Support account directive for account completion 125 | - Bugfixes and dependency bumps 126 | 127 | # 1.2.6 128 | 129 | - Fix build with hledger-lib >= 1.3.1 130 | - Support for megaparsec-6.1 131 | - Support for brick <= 0.24 132 | - Fix test suite with ghc 8.2 133 | 134 | # 1.2.5 135 | 136 | - Fix broken release tarball 137 | 138 | # 1.2.4 139 | 140 | - Support for megaparsec-6.0 141 | 142 | # 1.2.3 143 | 144 | - Support for brick-0.20 145 | - Restore compatibility with brick-0.17 146 | - Support for hledger-lib-1.3 147 | 148 | # 1.2.2 149 | 150 | - Support for megaparsec-5.3.0 151 | - Bump brick dependency to 0.19 152 | 153 | # 1.2.1 154 | 155 | - Support for hledger-lib-1.2 156 | - Minor documentation fixes 157 | 158 | # 1.2 159 | 160 | - Add support for comments (bound to `;`) 161 | - Restore previous text input on undo 162 | - Bump text-zipper dependency to 0.10 163 | 164 | # 1.1.4 165 | 166 | - Sort account names by frequency for completion 167 | - Bind Home/End im entry field 168 | - Bump brick and vty dependencies 169 | 170 | # 1.1.3 171 | 172 | - Add more emacs/readline like keybindings in entry field (`C-f`/`C-b`, 173 | `M-f`/`M-b`, `M-Del`/`C-w`, `M-d`) 174 | - Fix account suggestion order to be more like `hledger add` 175 | 176 | # 1.1.2 177 | 178 | - Respect ${LEDGER_FILE} environment variable 179 | - Add --version command 180 | - Bump brick dependency to 0.15.2 181 | - Bump hledger-lib dependency to 1.1 182 | - Bind C-u to 'delete to beginning of line' 183 | 184 | # 1.1.1 185 | 186 | - bugfix: Show cursor in empty entry widget 187 | - bugfix: Correctly execute `--help` and `--dump-default-config` in 188 | the presence of syntax errors in the config file 189 | 190 | # 1.1 191 | 192 | - Add a configuration file for persistent settings 193 | - Disallow unbalanced transactions 194 | - Order postings naturally and omit balancing amounts in transaction preview (thanks Tristan Hume) 195 | - Suggest account based on last transaction if no similar transaction is found (thanks Tristan Hume) 196 | - Make completed dates as recent as possible (thanks Thorsten Wißmann) 197 | - Optional fuzzy matching via config option "completion-engine" (thanks Tristan Hume) 198 | - Add Ctrl-d as new keybinding for 'quit' 199 | - Make ESC quit at the toplevel 200 | - Various bug fixes 201 | 202 | # 1.0 203 | 204 | - Initial release 205 | 206 | 207 | 208 | 209 | -------------------------------------------------------------------------------- /tests/DateParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module DateParserSpec (spec) where 5 | 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | import Test.QuickCheck.Instances() 9 | 10 | import Control.Monad 11 | import Data.Either 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Data.Time 15 | import Data.Time.Calendar.WeekDate 16 | 17 | import DateParser 18 | 19 | spec :: Spec 20 | spec = do 21 | dateFormatTests 22 | dateTests 23 | dateCompletionTests 24 | printTests 25 | 26 | dateFormatTests :: Spec 27 | dateFormatTests = describe "date format parser" $ 28 | it "parses the german format correctly" $ 29 | parseDateFormat "%d[.[%m[.[%y]]]]" `shouldBe` Right german 30 | 31 | dateTests :: Spec 32 | dateTests = describe "date parser" $ do 33 | it "actually requires non-optional fields" $ 34 | shouldFail "%d-%m-%y" "05" 35 | 36 | describe "weekDay" $ do 37 | it "actually returns the right week day" $ property 38 | weekDayProp 39 | 40 | it "is always smaller than the current date" $ property 41 | weekDaySmallerProp 42 | 43 | dateCompletionTests :: Spec 44 | dateCompletionTests = describe "date completion" $ do 45 | it "today" $ 46 | parseGerman 2004 7 31 "31.7.2004" `shouldBe` Right (fromGregorian 2004 7 31) 47 | 48 | it "today is a leap day" $ 49 | parseGerman 2012 2 29 "29.2.2012" `shouldBe` Right (fromGregorian 2012 2 29) 50 | 51 | it "skips to previous month" $ 52 | parseGerman 2016 9 20 "21" `shouldBe` Right (fromGregorian 2016 08 21) 53 | 54 | it "stays in month if possible" $ 55 | parseGerman 2016 8 30 "21" `shouldBe` Right (fromGregorian 2016 08 21) 56 | 57 | it "skips to previous month to reach the 31st" $ 58 | parseGerman 2016 8 30 "31" `shouldBe` Right (fromGregorian 2016 07 31) 59 | 60 | it "skips to an earlier month to reach the 31st" $ 61 | parseGerman 2016 7 30 "31" `shouldBe` Right (fromGregorian 2016 05 31) 62 | 63 | it "skips to the previous year if necessary" $ 64 | parseGerman 2016 9 30 "2.12." `shouldBe` Right (fromGregorian 2015 12 2) 65 | 66 | it "skips to the previous years if after a leap year" $ 67 | parseGerman 2017 3 10 "29.2" `shouldBe` Right (fromGregorian 2016 02 29) 68 | 69 | it "even might skip to a leap year 8 years ago" $ 70 | parseGerman 2104 2 27 "29.2" `shouldBe` Right (fromGregorian 2096 02 29) 71 | 72 | it "some date in the near future" $ 73 | parseGerman 2016 2 20 "30.11.2016" `shouldBe` Right (fromGregorian 2016 11 30) 74 | 75 | it "some date in the far future" $ 76 | parseGerman 2016 2 20 "30.11.3348" `shouldBe` Right (fromGregorian 3348 11 30) 77 | 78 | it "last october" $ 79 | (do 80 | monthOnly <- parseDateFormat "%m" 81 | parseDate (fromGregorian 2016 9 15) monthOnly "10" 82 | ) `shouldBe` Right (fromGregorian 2015 10 31) 83 | 84 | it "last november" $ 85 | (do 86 | monthOnly <- parseDateFormat "%m" 87 | parseDate (fromGregorian 2016 9 15) monthOnly "11" 88 | ) `shouldBe` Right (fromGregorian 2015 11 30) 89 | 90 | it "next november" $ 91 | (do 92 | yearMonth <- parseDateFormat "%y.%m" 93 | parseDate (fromGregorian 2016 9 15) yearMonth "2016.11" 94 | ) `shouldBe` Right (fromGregorian 2016 11 1) 95 | 96 | it "next january" $ 97 | (do 98 | yearMonth <- parseDateFormat "%y.%m" 99 | parseDate (fromGregorian 2016 9 15) yearMonth "2017.1" 100 | ) `shouldBe` Right (fromGregorian 2017 1 1) 101 | 102 | it "last january" $ 103 | (do 104 | yearMonth <- parseDateFormat "%y.%m" 105 | parseDate (fromGregorian 2016 9 15) yearMonth "2016.1" 106 | ) `shouldBe` Right (fromGregorian 2016 1 31) 107 | 108 | it "literally yesterday" $ do 109 | parseGerman 2018 10 18 "yesterday" `shouldBe` Right (fromGregorian 2018 10 17) 110 | parseGerman 2018 10 18 "yest" `shouldBe` Right (fromGregorian 2018 10 17) 111 | parseGerman 2018 10 18 "yes" `shouldBe` Right (fromGregorian 2018 10 17) 112 | 113 | it "literally today" $ do 114 | parseGerman 2018 10 18 "today" `shouldBe` Right (fromGregorian 2018 10 18) 115 | 116 | it "literally tomorrow" $ do 117 | parseGerman 2018 10 18 "tomorrow" `shouldBe` Right (fromGregorian 2018 10 19) 118 | 119 | it "literally monday" $ do 120 | parseGerman 2018 10 18 "monday" `shouldBe` Right (fromGregorian 2018 10 15) 121 | parseGerman 2018 10 18 "mon" `shouldBe` Right (fromGregorian 2018 10 15) 122 | parseGerman 2018 10 18 "mo" `shouldBe` Right (fromGregorian 2018 10 15) 123 | parseGerman 2018 10 18 "m" `shouldBe` Right (fromGregorian 2018 10 15) 124 | 125 | it "literally tuesday" $ do 126 | parseGerman 2018 10 18 "tuesday" `shouldBe` Right (fromGregorian 2018 10 16) 127 | parseGerman 2018 10 18 "tues" `shouldBe` Right (fromGregorian 2018 10 16) 128 | parseGerman 2018 10 18 "tue" `shouldBe` Right (fromGregorian 2018 10 16) 129 | 130 | it "literally wednesday" $ do 131 | parseGerman 2018 10 18 "wednesday" `shouldBe` Right (fromGregorian 2018 10 17) 132 | parseGerman 2018 10 18 "wed" `shouldBe` Right (fromGregorian 2018 10 17) 133 | 134 | it "literally thursday" $ do 135 | parseGerman 2018 10 18 "thursday" `shouldBe` Right (fromGregorian 2018 10 18) 136 | parseGerman 2018 10 18 "thur" `shouldBe` Right (fromGregorian 2018 10 18) 137 | 138 | it "literally friday" $ do 139 | parseGerman 2018 10 18 "friday" `shouldBe` Right (fromGregorian 2018 10 12) 140 | parseGerman 2018 10 18 "fri" `shouldBe` Right (fromGregorian 2018 10 12) 141 | 142 | it "literally saturday" $ do 143 | parseGerman 2018 10 18 "saturday" `shouldBe` Right (fromGregorian 2018 10 13) 144 | parseGerman 2018 10 18 "sat" `shouldBe` Right (fromGregorian 2018 10 13) 145 | 146 | it "literally sunday" $ do 147 | parseGerman 2018 10 18 "sunday" `shouldBe` Right (fromGregorian 2018 10 14) 148 | parseGerman 2018 10 18 "sun" `shouldBe` Right (fromGregorian 2018 10 14) 149 | 150 | it "literally satan" $ do 151 | parseGerman 2018 10 18 "satan" `shouldSatisfy` isLeft 152 | 153 | where 154 | parseGerman :: Integer -> Int -> Int -> String -> Either Text Day 155 | parseGerman y m d str = parseDate (fromGregorian y m d) german (T.pack str) 156 | 157 | printTests :: Spec 158 | printTests = describe "date printer" $ do 159 | it "is inverse to reading" $ property $ 160 | printReadProp german 161 | 162 | it "handles short years correctly" $ do 163 | withDateFormat ("%d-[%m-[%y]]") $ \format -> 164 | printDate format (fromGregorian 2015 2 1) `shouldBe` "01-02-15" 165 | 166 | withDateFormat ("%d-[%m-[%y]]") $ \format -> 167 | printDate format (fromGregorian 1999 2 1) `shouldBe` "01-02-1999" 168 | 169 | it "handles long years correctly" $ 170 | withDateFormat ("%d-[%m-[%Y]]") $ \format -> 171 | printDate format (fromGregorian 2015 2 1) `shouldBe` "01-02-2015" 172 | 173 | withDateFormat :: Text -> (DateFormat -> Expectation) -> Expectation 174 | withDateFormat date action = case parseDateFormat date of 175 | Left err -> expectationFailure (show err) 176 | Right format -> action format 177 | 178 | shouldFail :: Text -> Text -> Expectation 179 | shouldFail format date = withDateFormat format $ \format' -> do 180 | res <- parseDateWithToday format' date 181 | unless (isLeft res) $ 182 | expectationFailure ("Should fail but parses: " ++ (T.unpack format) 183 | ++ " / " ++ (T.unpack date) ++ " as " ++ show res) 184 | 185 | weekDayProp :: Property 186 | weekDayProp = 187 | forAll (ModifiedJulianDay <$> (arbitrary `suchThat` (>= 7))) $ \current -> 188 | forAll (choose (1, 7)) $ \wday -> 189 | wday === getWDay (weekDay wday current) 190 | 191 | where getWDay :: Day -> Int 192 | getWDay d = let (_, _, w) = toWeekDate d in w 193 | 194 | weekDaySmallerProp :: Property 195 | weekDaySmallerProp = 196 | forAll (ModifiedJulianDay <$> (arbitrary `suchThat` (>= 7))) $ \current -> 197 | forAll (choose (1, 7)) $ \wday -> 198 | current >= weekDay wday current 199 | 200 | printReadProp :: DateFormat -> Day -> Property 201 | printReadProp format day = case parseDate day format (printDate format day) of 202 | Left err -> counterexample (T.unpack err) False 203 | Right res -> res === day 204 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hledger-iadd 2 | 3 | An interactive terminal UI as drop-in replacement for `hledger add`. 4 | 5 | ![Screencast](doc/screencast.gif) 6 | 7 | ## Features 8 | 9 | This project improves in the following ways on hledger's `add` command: 10 | 11 | - Interactive as-you-type completion for account names and 12 | descriptions with optional fuzzy matching (see [below](#configuration-file)). 13 | 14 | - Integrated calculator: Amounts can be written as simple sums with 15 | real-time feedback on the result. 16 | 17 | - All actions while entering a transaction can be undone 18 | 19 | - Configurable format for date input. Instead of `y/m/d` it is also 20 | possible to use other formats like the german `d.m.y`. 21 | 22 | Also see the user guide under [Usage](#usage). 23 | 24 | ## Installation 25 | ### Latest release 26 | #### Archlinux 27 | 28 | For Archlinux users, an [AUR package](https://aur.archlinux.org/packages/hledger-iadd-bin) with a binary built by me (@hpdeifel) 29 | is available. If you want to compile `hledger-iadd` yourself, use one of the 30 | following installation methods. 31 | 32 | #### stack 33 | 34 | The easiest method would be [stack]: Install the [stack] program and 35 | type: 36 | 37 | stack install --resolver=lts hledger-iadd-1.3.21 38 | 39 | This downloads and builds `hledger-iadd` and all it's Haskell 40 | dependencies. After that, it copys the resulting binary to 41 | `~/.local/bin`. See `stack --help` for more options. You may get asked 42 | to install the GHC Haskell compiler locally. To do that, type `stack 43 | setup`. 44 | 45 | #### cabal 46 | 47 | First, install the GHC Haskell compiler and the `cabal install`, 48 | `alex` and `happy` build tools, possibly from your distribution or the 49 | [haskell platform]. Type 50 | 51 | cabal install --bindir ~/bin hledger-iadd 52 | 53 | to install the binary in `~/bin`. 54 | 55 | ### Development version 56 | 57 | To install the development version, clone the git repository first: 58 | 59 | git clone https://github.com/hpdeifel/hledger-iadd.git 60 | cd hledger-iadd 61 | 62 | #### stack 63 | 64 | The easiest method would be [stack]: Install the [stack] program and 65 | type: 66 | 67 | stack install 68 | 69 | To build and install all Haskell dependencies locally and install 70 | `hledger-iadd` to `~/.local/bin`. See `stack --help` for more options. 71 | You may get asked to install the GHC Haskell compiler locally. To do 72 | that, type `stack setup`. 73 | 74 | #### Cabal 75 | 76 | First, install the GHC Haskell compiler and the `cabal install`, 77 | `alex` and `happy` build tools, possibly from your distribution or the 78 | [haskell platform]. 79 | 80 | Since `cabal` builds regularly break in non-isolated environments, the 81 | recommended next step is to create a cabal sandbox where all 82 | dependencies will be installed in: 83 | 84 | cd hledger-iadd 85 | cabal sandbox init 86 | 87 | You can now download and install all dependencies locally with 88 | 89 | cabal install --only-dependencies 90 | 91 | And finally you're ready to build and install `hledger-iadd`: 92 | 93 | cabal configure --bindir ~/bin 94 | cabal build 95 | cabal copy 96 | 97 | ## Usage 98 | 99 | *[YouTube video demonstrating basic interactions](https://www.youtube.com/watch?v=ZuCT9EzryaI)* 100 | 101 | You can start the program either with 102 | 103 | hledger iadd 104 | 105 | or simply `hledger-iadd`. 106 | 107 | The following command line options are available: 108 | 109 | - `-f/--file/`: Path to the journal file. (Default: `~/.hledger.journal`) 110 | - `--date-format`: Format for parsing dates. (Default: 111 | `[[%y/]%m/]%d`, the usual ledger date format). Brackets can be 112 | used to specify optional parts. E.g the german date format would 113 | be `%d[.[%m[.[%y]]]]`. (Dates are written as `y/m/d` to the 114 | journal regardless of this option). 115 | - `--completion-engine`: Algorithm for account name completion. Can 116 | be `substrings` or `fuzzy`. 117 | - `--dump-default-config`: Print the example config file to stdout 118 | and exit 119 | 120 | The UI is partitioned in 4 regions: 121 | 122 | Current Transaction (view of your work in progress) 123 | --------------------------------------------------- 124 | Question: [ text area ] 125 | --------------------------------------------------- 126 | Context information (e.g. list of accounts) 127 | 128 | 129 | 130 | 131 | --------------------------------------------------- 132 | Message area 133 | 134 | For each transaction, you will get asked the following questions in 135 | order: 136 | 137 | 1. Date? 138 | 2. Description? 139 | 3. Account name? 140 | 4. Amount? 141 | 5. The last two questions are repeated until you enter the empty account 142 | 6. Do you want to add this transaction to the journal? 143 | 144 | To accept the default answer, immediately press Return at a 145 | promt. 146 | 147 | While you type, the context area shows possible completions. Pressing 148 | Return answers the question with the currently selected 149 | completion. You can select differnt completions with C-n 150 | and C-p. 151 | 152 | The following keyboard shortcuts are available: 153 | 154 | | Key | Function | 155 | | ------------------------------- | ----------------------------------------------------------------------------- | 156 | | C-c, C-d | Quit the program without saving the current transaction | 157 | | Esc | Abort the current transaction or exit when at toplevel | 158 | | Ret | Accept the currently selected answer | 159 | | Alt-Ret | Accept the current answer verbatim from the text area, ignoring the selection | 160 | | C-z | Undo the last action | 161 | | Tab | Insert the currently selected answer into the text area | 162 | | C-n,↓ | Select the next context item | 163 | | C-p,↑ | Select the previous context item | 164 | | ; | Edit comment for current prompt | 165 | | Alt-; | Edit transaction comment | 166 | | F1,Alt-? | Show help dialog | 167 | 168 | ## Default Currency 169 | 170 | To make entry easier it is recommended that you set a [default commodity](https://hledger.org/journal.html#default-commodity) 171 | in your ledger file if you haven't already done so. 172 | That way when entering amounts, `hledger-iadd` will add the symbols for you. 173 | You can do this by adding a line like below to the top of your ledger file: 174 | 175 | ```lisp 176 | ; sets the default commodity symbol and placement, thousands separator, and decimal symbol 177 | D $1,000.00 178 | ``` 179 | 180 | ## Configuration File 181 | 182 | `hledger-iadd` is optionally configurable through a configuration file 183 | in `${XDG_CONFIG_HOME}/hledger-iadd/config.conf`. This file consists 184 | of simple 185 | 186 | key = value 187 | 188 | assignments on individual lines with whitespace or comments starting 189 | with `#` between them. The default config can be obtained by 190 | passing `--dump-default-config` to `hledger-iadd`. 191 | 192 | The following options are currently available: 193 | 194 | - `file`: Path to the journal file. 195 | - `date-format`: The date format. See the documentation for 196 | `--date-format` for details. 197 | - `completion-engine`: Algorithm used to find completions for 198 | account names. Possible values are: 199 | - `substrings`: Every word in the search string has to occur 200 | somewhere in the account name 201 | - `fuzzy`: All letters from the search string have to appear in 202 | the name in the same order 203 | 204 | ## License 205 | 206 | The code of `hledger-iadd` is released under the [BSD3] license, but 207 | since `hledger-lib` -- the library that `hledger-iadd` uses -- is 208 | licensed under the [GPLv3], the terms of the GPL apply to the compiled 209 | and linked binary. 210 | 211 | [stack]: https://github.com/commercialhaskell/stack 212 | [haskell platform]: https://www.haskell.org/platform/ 213 | [BSD3]: https://opensource.org/licenses/BSD-3-Clause 214 | [GPLv3]: https://www.gnu.org/licenses/gpl-3.0.en.html 215 | -------------------------------------------------------------------------------- /tests/ConfigParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module ConfigParserSpec (spec) where 5 | 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | 12 | import ConfigParser 13 | 14 | spec :: Spec 15 | spec = do 16 | fullTest 17 | defaultTest 18 | syntaxTests 19 | valueTests 20 | commentTests 21 | exampleTests 22 | 23 | data TestData = TestData 24 | { someInt :: Int 25 | , someInteger :: Integer 26 | , someString :: String 27 | , someText :: Text 28 | } deriving (Eq, Show) 29 | 30 | testParser :: OptParser TestData 31 | testParser = TestData 32 | <$> option "someInt" 42 "Help for this" 33 | <*> option "someInteger" 23 "Help for that" 34 | <*> option "someString" "foobar" "Help with\nMultiple lines" 35 | <*> option "someText" "barfoo" "And another help" 36 | 37 | defaultData :: TestData 38 | defaultData = parserDefault testParser 39 | 40 | fullTest :: Spec 41 | fullTest = it "parses a complete example" $ do 42 | let inputTxt = T.unlines [ "someInt = 1" 43 | , "someInteger = 2" 44 | , "someString = a" 45 | , "someText = \"b\""] 46 | output = TestData 1 2 "a" "b" 47 | parseConfig "" inputTxt testParser `shouldBe` Right output 48 | 49 | defaultTest :: Spec 50 | defaultTest = do 51 | it "fills in the default values" $ 52 | parseConfig "" "" testParser `shouldBe` Right (TestData 42 23 "foobar" "barfoo") 53 | 54 | it "fills in the default values for random data" $ 55 | property defaultWorksProp 56 | 57 | defaultWorksProp :: TestData -> Property 58 | defaultWorksProp testData = 59 | let parser = TestData 60 | <$> option "someInt" (someInt testData) "Help for this" 61 | <*> option "someInteger" (someInteger testData) "Help for that" 62 | <*> option "someString" (someString testData) "Help with\nMultiple lines" 63 | <*> option "someText" (someText testData) "And another help" 64 | in parseConfig "" "" parser === Right testData 65 | 66 | 67 | syntaxTests :: Spec 68 | syntaxTests = do 69 | context "given whitespace" whitespaceTests 70 | context "given escaped strings" escapingTests 71 | context "given bare strings" bareStringTests 72 | optionNameTests 73 | 74 | whitespaceTests :: Spec 75 | whitespaceTests = do 76 | it "parses just whitespace" $ 77 | parseConfig "" "" testParser 78 | `shouldBe` Right (TestData 42 23 "foobar" "barfoo") 79 | 80 | it "parses beginning whitespace" $ 81 | parseConfig "" "\n\n\n someInt = 13" testParser 82 | `shouldBe` Right (TestData 13 23 "foobar" "barfoo") 83 | 84 | it "parses trailing whitespace" $ 85 | parseConfig "" "someInt = 13 \n\n\n" testParser 86 | `shouldBe` Right (TestData 13 23 "foobar" "barfoo") 87 | 88 | it "parses middle whitespace" $ 89 | parseConfig "" "someInt = 13 \n\n\n someInteger = 14" testParser 90 | `shouldBe` Right (TestData 13 14 "foobar" "barfoo") 91 | 92 | it "parses whitespace everywhere" $ 93 | parseConfig "" " \n \n someInt = 13 \n \n \n someInteger = 14 \n \n " testParser 94 | `shouldBe` Right (TestData 13 14 "foobar" "barfoo") 95 | 96 | escapingTests :: Spec 97 | escapingTests = do 98 | it "parses simple escaped strings" $ 99 | parseConfig "" "someText = \"test\" " testParser 100 | `shouldBe` Right (defaultData { someText = "test" }) 101 | 102 | it "parses escaped strings with quotes in them" $ 103 | parseConfig "" "someText = \"te\\\"st\" " testParser 104 | `shouldBe` Right (defaultData { someText = "te\"st" }) 105 | 106 | it "parses escaped strings with backslashes in them" $ 107 | parseConfig "" "someText = \"te\\\\st\" " testParser 108 | `shouldBe` Right (defaultData { someText = "te\\st" }) 109 | 110 | it "parses escaped strings with newlines in them" $ 111 | parseConfig "" "someText = \"te\nst\" " testParser 112 | `shouldBe` Right (defaultData { someText = "te\nst" }) 113 | 114 | it "fails to parse non-terminated escaped strings" $ 115 | parseConfig "" "someText = \"test " testParser 116 | `shouldSatisfy` isLeft 117 | 118 | 119 | bareStringTests :: Spec 120 | bareStringTests = do 121 | it "parses a bare string correctly" $ 122 | parseConfig "" "someText =test" testParser 123 | `shouldBe` Right (defaultData { someText = "test" }) 124 | 125 | it "correctly trims bare strings" $ 126 | parseConfig "" "someText = foo test " testParser 127 | `shouldBe` Right (defaultData { someText = "foo test" }) 128 | 129 | it "fails to parse empty bare strings" $ 130 | parseConfig "" "someText = " testParser `shouldSatisfy` isLeft 131 | 132 | optionNameTests :: Spec 133 | optionNameTests = do 134 | it "allows dashes in option names" $ do 135 | let parser = (\x -> defaultData { someInt = x }) <$> option "test-name" 10 "" 136 | parseConfig "" "test-name = 10" parser `shouldBe` Right defaultData { someInt = 10 } 137 | 138 | it "allows underscores in option names" $ do 139 | let parser = (\x -> defaultData { someInt = x }) <$> option "test_name" 10 "" 140 | parseConfig "" "test_name = 10" parser `shouldBe` Right defaultData { someInt = 10 } 141 | 142 | it "doesn't allow spaces in option names" $ do 143 | let parser = (\x -> defaultData { someInt = x }) <$> option "test name" 10 "" 144 | parseConfig "" "test name = 10" parser `shouldSatisfy` isLeft 145 | 146 | it "doesn't allow equal signs in option names" $ do 147 | let parser = (\x -> defaultData { someInt = x }) <$> option "test=foo" 10 "" 148 | parseConfig "" "test=foo = 10" parser `shouldSatisfy` isLeft 149 | 150 | valueTests :: Spec 151 | valueTests = do 152 | context "given integers" $ do 153 | it "parses zero" $ 154 | parseConfig "" "someInt = 0" testParser `shouldBe` Right defaultData { someInt = 0 } 155 | 156 | it "parses negative zero" $ 157 | parseConfig "" "someInt = -0" testParser `shouldBe` Right defaultData { someInt = 0 } 158 | 159 | it "fails to parse integer with trailing stuff" $ 160 | parseConfig "" "someInt = 10foo" testParser `shouldSatisfy` isLeft 161 | 162 | it "fails to parse empty string as integer" $ 163 | parseConfig "" "someInt = \"\"" testParser `shouldSatisfy` isLeft 164 | 165 | it "fails to parse letters as integer" $ 166 | parseConfig "" "someInt = foo" testParser `shouldSatisfy` isLeft 167 | 168 | 169 | context "given strings" $ 170 | it "parses the empty string quoted" $ 171 | parseConfig "" "someString = \"\"" testParser `shouldBe` Right defaultData { someString = "" } 172 | 173 | commentTests :: Spec 174 | commentTests = do 175 | it "handles a file with just comments" $ 176 | parseConfig "" "# a comment \n #another comment " testParser 177 | `shouldBe` Right defaultData 178 | 179 | it "handles comments and whitespace in front" $ 180 | parseConfig "" " \n\n#another comment " testParser 181 | `shouldBe` Right defaultData 182 | 183 | it "handles comments and whitespace in front" $ 184 | parseConfig "" " \n\n#another comment " testParser 185 | `shouldBe` Right defaultData 186 | 187 | it "handles comments and whitespace after" $ 188 | parseConfig "" "#another comment\n\n " testParser 189 | `shouldBe` Right defaultData 190 | 191 | it "handles comments with whitespace between" $ 192 | parseConfig "" "\n \n # comment \n #another comment\n\n " testParser 193 | `shouldBe` Right defaultData 194 | 195 | it "handles comments after assignments" $ do 196 | parseConfig "" "someInt = 4# a comment" testParser 197 | `shouldBe` Right defaultData { someInt = 4 } 198 | 199 | parseConfig "" "someInt = 4# a comment\n" testParser 200 | `shouldBe` Right defaultData { someInt = 4 } 201 | 202 | parseConfig "" "someInt = 4 # a comment" testParser 203 | `shouldBe` Right defaultData { someInt = 4 } 204 | 205 | it "handles comments around assignments" $ do 206 | parseConfig "" "someInt = 4# a comment\n # a comment\nsomeString = foo # bar" testParser 207 | `shouldBe` Right defaultData { someInt = 4, someString = "foo" } 208 | 209 | 210 | exampleTests :: Spec 211 | exampleTests = describe "parserExample" $ do 212 | it "works for one example" $ 213 | let output = T.strip $ T.unlines 214 | [ "# Help for this" 215 | , "someInt = 42" 216 | , "" 217 | , "# Help for that" 218 | , "someInteger = 23" 219 | , "" 220 | , "# Help with" 221 | , "# Multiple lines" 222 | , "someString = \"foobar\"" 223 | , "" 224 | , "# And another help" 225 | , "someText = \"barfoo\"" 226 | ] 227 | in parserExample testParser `shouldBe` output 228 | 229 | it "can parse it's own example output" $ 230 | property exampleParseableProp 231 | 232 | exampleParseableProp :: TestData -> Property 233 | exampleParseableProp testData = 234 | let parser = TestData <$> option "someInt" (someInt testData) "help" 235 | <*> option "someInteger" (someInteger testData) "help" 236 | <*> option "someString" (someString testData) "help" 237 | <*> option "someText" (someText testData) "help" 238 | in parseConfig "" (parserExample parser) parser === Right testData 239 | 240 | isLeft :: Either a b -> Bool 241 | isLeft = either (const True) (const False) 242 | 243 | instance Arbitrary TestData where 244 | arbitrary = TestData <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 245 | 246 | instance Arbitrary Text where 247 | arbitrary = T.pack <$> arbitrary 248 | -------------------------------------------------------------------------------- /src/DateParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TupleSections #-} 2 | {-# LANGUAGE DeriveFunctor, LambdaCase, ViewPatterns #-} 3 | 4 | module DateParser 5 | ( DateFormat 6 | , parseDateFormat 7 | , german 8 | 9 | , parseDate 10 | , parseDateWithToday 11 | 12 | , parseHLDate 13 | , parseHLDateWithToday 14 | 15 | , printDate 16 | 17 | -- * Utilities 18 | , weekDay 19 | ) where 20 | 21 | import Control.Applicative hiding (many, some) 22 | import Data.List 23 | import Data.Maybe 24 | import Data.Monoid 25 | import Data.Ord 26 | import qualified Data.Semigroup as Sem 27 | import Data.Void 28 | 29 | import Data.Text (Text) 30 | import qualified Data.Text as T 31 | import qualified Data.Text.Lazy as TL 32 | import Data.Text.Lazy.Builder (Builder, toLazyText) 33 | import qualified Data.Text.Lazy.Builder as Build 34 | import qualified Data.Text.Lazy.Builder.Int as Build 35 | import Data.Time.Ext 36 | import Data.Time.Calendar.WeekDate 37 | import qualified Hledger.Data.Dates as HL 38 | import qualified Hledger.Data.Types as HL 39 | import Text.Megaparsec 40 | import Text.Megaparsec.Char 41 | import Text.Printf (printf, PrintfArg) 42 | 43 | newtype DateFormat = DateFormat [DateSpec] 44 | deriving (Eq, Show) 45 | 46 | -- TODO Add show instance that corresponds to parsed expression 47 | 48 | data DateSpec = DateYear 49 | | DateYearShort 50 | | DateMonth 51 | | DateDay 52 | | DateString Text 53 | | DateOptional [DateSpec] 54 | deriving (Show, Eq) 55 | 56 | 57 | parseHLDate :: Day -> Text -> Either Text Day 58 | parseHLDate current text = case parse HL.smartdate "date" text of 59 | Right res -> case HL.fixSmartDate current res of 60 | HL.Exact day -> Right day 61 | HL.Flex day -> Left $ "Date " <> T.pack (show day) <> " not specified exactly." 62 | Left err -> Left $ T.pack $ errorBundlePretty err 63 | 64 | parseHLDateWithToday :: Text -> IO (Either Text Day) 65 | parseHLDateWithToday text = flip parseHLDate text <$> getLocalDay 66 | 67 | -- | Corresponds to %d[.[%m[.[%y]]]] 68 | german :: DateFormat 69 | german = DateFormat 70 | [ DateDay 71 | , DateOptional [DateString "." 72 | ,DateOptional [DateMonth 73 | ,DateOptional [DateString "." 74 | ,DateOptional [DateYearShort]]]]] 75 | 76 | parseDateFormat :: Text -> Either Text DateFormat 77 | parseDateFormat text = case parse dateSpec "date-format" text of 78 | Left err -> Left $ T.pack $ errorBundlePretty err 79 | Right res -> Right res 80 | 81 | 82 | type Parser = Parsec Void Text 83 | 84 | dateSpec :: Parser DateFormat 85 | dateSpec = DateFormat <$> (many oneTok <* eof) 86 | 87 | oneTok :: Parser DateSpec 88 | oneTok = char '%' *> percent 89 | <|> char '\\' *> escape 90 | <|> DateOptional <$> between (char '[') (char ']') (many oneTok) 91 | <|> DateString . T.pack <$> some (noneOf ("\\[]%" :: String)) 92 | 93 | percent :: Parser DateSpec 94 | percent = char 'y' *> pure DateYearShort 95 | <|> char 'Y' *> pure DateYear 96 | <|> char 'm' *> pure DateMonth 97 | <|> char 'd' *> pure DateDay 98 | <|> char '%' *> pure (DateString "%") 99 | 100 | escape :: Parser DateSpec 101 | escape = char '\\' *> pure (DateString "\\") 102 | <|> char '[' *> pure (DateString "[") 103 | <|> char ']' *> pure (DateString "]") 104 | 105 | -- | Parse text with given format and fill in missing fields with todays date. 106 | parseDateWithToday :: DateFormat -> Text -> IO (Either Text Day) 107 | parseDateWithToday spec text = do 108 | today <- getLocalDay 109 | return (parseDate today spec text) 110 | 111 | parseDate :: Day -> DateFormat -> Text -> Either Text Day 112 | parseDate current (DateFormat spec) text = 113 | let en = Just <$> parseEnglish current 114 | completeIDate :: IncompleteDate (Maybe Int) -> Maybe Day 115 | completeIDate d = 116 | completeNearDate Past current d 117 | <|> completeNearDate Future current d 118 | num = completeIDate . fmap getFirst <$> parseDate' spec <* eof 119 | 120 | in case parse ((try en <|> num) <* eof) "date" text of 121 | Left err -> Left $ T.pack $ errorBundlePretty err 122 | Right Nothing -> Left "Invalid Date" 123 | Right (Just d) -> Right d 124 | 125 | -- (y, m, d) 126 | newtype IncompleteDate a = IDate (a, a, a) 127 | deriving (Sem.Semigroup, Monoid, Functor, Show) 128 | 129 | data Direction = Future | Past deriving (Eq,Show) 130 | -- find a date that matches the incomplete date and is as near as possible to 131 | -- the current date in the given direction (Future means only today and in the 132 | -- future; Past means only today and in the past). 133 | completeNearDate :: Direction -> Day -> IncompleteDate (Maybe Int) -> Maybe Day 134 | completeNearDate dir current (IDate (i_year,i_month,i_day)) = 135 | let 136 | sign = if dir == Past then -1 else 1 137 | (currentYear, _, _) = toGregorian current 138 | singleton a = [a] 139 | withDefaultRange :: Maybe a -> [a] -> [a] 140 | withDefaultRange maybe_value range = 141 | fromMaybe 142 | (if dir == Past then reverse range else range) 143 | (singleton <$> maybe_value) 144 | in listToMaybe $ do 145 | -- every date occours at least once in 8 years 146 | -- That is because the years divisible by 100 but not by 400 are no leap 147 | -- years. Depending on dir, choose the past or the next 8 years 148 | y <- (toInteger <$> i_year) `withDefaultRange` 149 | [currentYear + sign*4 - 4 .. currentYear + sign*4 + 4] 150 | m <- i_month `withDefaultRange` [1..12] 151 | d <- i_day `withDefaultRange` [1..31] 152 | completed <- maybeToList (fromGregorianValid y m d) 153 | if ((completed `diffDays` current) * sign >= 0) 154 | then return completed 155 | else fail $ "Completed day not the " ++ show dir ++ "." 156 | 157 | 158 | parseDate' :: [DateSpec] -> Parser (IncompleteDate (First Int)) 159 | parseDate' [] = return mempty 160 | parseDate' (d:ds) = case d of 161 | DateOptional sub -> try ((<>) <$> parseDate' sub <*> parseDate' ds) 162 | <|> parseDate' ds 163 | 164 | _ -> (<>) <$> parseDate1 d <*> parseDate' ds 165 | 166 | 167 | parseDate1 :: DateSpec -> Parser (IncompleteDate (First Int)) 168 | parseDate1 ds = case ds of 169 | DateYear -> part (,mempty,mempty) 170 | DateYearShort -> part $ (,mempty,mempty) . fmap completeYear 171 | DateMonth -> part (mempty,,mempty) 172 | DateDay -> part (mempty,mempty,) 173 | DateString s -> string s >> pure mempty 174 | DateOptional ds' -> option mempty (try $ parseDate' ds') 175 | 176 | where digits = some digitChar 177 | part f = IDate . f . First . Just . (read :: String -> Int) <$> digits 178 | completeYear year 179 | | year < 100 = year + 2000 180 | | otherwise = year 181 | 182 | 183 | -- Parses an english word such as 'yesterday' or 'monday' 184 | parseEnglish :: Day -> Parser Day 185 | parseEnglish current = ($ current) <$> choice (relativeDays ++ weekDays) 186 | 187 | relativeDays :: [Parser (Day -> Day)] 188 | relativeDays = map try 189 | [ addDays 1 <$ string "tomorrow" 190 | , addDays 1 <$ string "tom" 191 | , id <$ string "today" 192 | , id <$ string "tod" 193 | , addDays (-1) <$ string "yesterday" 194 | , addDays (-1) <$ string "yest" 195 | , addDays (-1) <$ string "yes" 196 | , addDays (-1) <$ string "ye" 197 | , addDays (-1) <$ string "y" 198 | ] 199 | 200 | weekDays :: [Parser (Day -> Day)] 201 | weekDays = map (\(i, name) -> weekDay i <$ try (string name)) sortedDays 202 | where -- sort the days so that the parser finds the longest match 203 | sortedDays :: [(Int, Text)] 204 | sortedDays = sortOn (Down . T.length . snd) flattenedDays 205 | flattenedDays :: [(Int, Text)] 206 | flattenedDays = concatMap (\(i, xs) -> fmap (i,) xs) days 207 | days :: [(Int, [Text])] 208 | days = [ (1, ["monday", "m", "mo", "mon"]) 209 | , (2, ["tuesday", "tu", "tue", "tues"]) 210 | , (3, ["wednesday", "w", "we", "wed"]) 211 | , (4, ["thursday", "th", "thu", "thur"]) 212 | , (5, ["friday", "f", "fr", "fri"]) 213 | , (6, ["saturday", "sa", "sat"]) 214 | , (7, ["sunday", "su", "sun"]) 215 | ] 216 | 217 | -- | Computes a relative date by the given weekday 218 | -- 219 | -- Returns the first weekday with index wday, that's before the current date. 220 | weekDay :: Int -> Day -> Day 221 | weekDay wday current = 222 | let (_, _, wday') = toWeekDate current 223 | difference = negate $ (wday' - wday) `mod` 7 224 | in addDays (toInteger difference) current 225 | 226 | 227 | printDate :: DateFormat -> Day -> Text 228 | printDate (DateFormat spec) day = TL.toStrict $ toLazyText $ printDate' spec day 229 | 230 | printDate' :: [DateSpec] -> Day -> Builder 231 | printDate' [] _ = "" 232 | printDate' (DateYear:ds) day@(toGregorian -> (y,_,_)) = 233 | Build.decimal y <> printDate' ds day 234 | printDate' (DateYearShort:ds) day@(toGregorian -> (y,_,_)) 235 | | y > 2000 = twoDigits (y-2000) <> printDate' ds day 236 | | otherwise = twoDigits y <> printDate' ds day 237 | printDate' (DateMonth:ds) day@(toGregorian -> (_,m,_)) = 238 | twoDigits m <> printDate' ds day 239 | printDate' (DateDay:ds) day@(toGregorian -> (_,_,d)) = 240 | twoDigits d <> printDate' ds day 241 | printDate' (DateString s:ds) day = 242 | Build.fromText s <> printDate' ds day 243 | printDate' (DateOptional opt:ds) day = 244 | printDate' opt day <> printDate' ds day 245 | 246 | twoDigits :: (Integral a, PrintfArg a) => a -> Builder 247 | twoDigits = Build.fromString . printf "%02d" 248 | -------------------------------------------------------------------------------- /tests/ModelSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ModelSpec (spec) where 4 | 5 | import Test.Hspec 6 | 7 | import Control.Monad 8 | import Data.List 9 | 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import Data.Time.Calendar 13 | import qualified Hledger as HL 14 | 15 | import DateParser 16 | import Model hiding (context) 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "suggest" suggestSpec 21 | describe "accountsByFrequency" accByFreqSpec 22 | describe "setCurrentComment" setCurrentCommentSpec 23 | describe "setTransactionComment" setTransactionCommentSpec 24 | describe "isDuplicateTransaction" isDuplicateTransactionSpec 25 | describe "isSubsetTransaction" isSubsetTransactionSpec 26 | 27 | suggestSpec :: Spec 28 | suggestSpec = do 29 | context "at the account prompt" $ do 30 | 31 | it "suggests nothing for an empty journal" $ 32 | suggest HL.nulljournal german (AccountQuestion HL.nulltransaction "") 33 | `shouldReturn` Nothing 34 | 35 | it "suggests the accounts in order" $ do 36 | let postings = [("x", 1), ("y", 2), ("z", 3)] 37 | j = mkJournal [ ((2017, 1, 1), "Foo", postings) ] 38 | 39 | forM_ (zip (inits postings) postings) $ \(posts, next) -> do 40 | let t = mkTransaction ((2016, 1, 1), "Foo", map (\(x,y) -> (x, y+1)) posts) 41 | suggest j german (AccountQuestion t "") `shouldReturn` Just (fst next) 42 | 43 | 44 | context "at the amount prompt" $ do 45 | 46 | it "suggests amounts from the similar transaction" $ do 47 | let postings = [("x", 1), ("y", 2), ("z", 3)] 48 | j = mkJournal [ ((2017, 1, 1), "Foo", postings) ] 49 | 50 | forM_ (zip (inits postings) postings) $ \(posts, next) -> do 51 | let t = mkTransaction ((2016, 1, 1), "Foo", posts) 52 | suggest j german (AmountQuestion (fst next) t "") 53 | `shouldReturn` Just ("€" <> T.pack (show $ snd next) <> ".00") 54 | 55 | it "suggests the balancing amount if accounts don't match with similar transaction" $ do 56 | let postings = [("x", 1), ("y", 2), ("z", 3)] 57 | j = mkJournal [ ((2017, 1, 1), "Foo", postings) ] 58 | t = mkTransaction ((2016, 1, 1), "Foo", [("foo", 3)]) 59 | 60 | suggest j german (AmountQuestion "y" t "") `shouldReturn` Just "€-3.00" 61 | 62 | it "initially doesn't suggest an amount if there is no similar transaction" $ do 63 | let j = mkJournal [ ((2017, 1, 1), "Foo", [("x", 2), ("y", 3)]) ] 64 | t = mkTransaction ((2016, 1, 1), "Bar", []) 65 | 66 | suggest j german (AmountQuestion "y" t "") `shouldReturn` Nothing 67 | 68 | it "suggests the balancing amount if there is no similar transaction for the second account" $ do 69 | let j = mkJournal [ ((2017, 1, 1), "Foo", [("x", 2), ("y", 3)]) ] 70 | t = mkTransaction ((2016, 1, 1), "Bar", [("foo", 3)]) 71 | 72 | suggest j german (AmountQuestion "y" t "") `shouldReturn` Just "€-3.00" 73 | 74 | 75 | accByFreqSpec :: Spec 76 | accByFreqSpec = do 77 | it "sorts according to frequency" $ do 78 | let postings = [("x", 1), ("y", 2), ("y", 3)] 79 | j = mkJournal [ ((2017, 1, 1), "Foo", postings) ] 80 | 81 | accountsByFrequency j `shouldBe` ["y", "x"] 82 | 83 | it "includes subaccounts" $ do 84 | let j = mkJournal [ ((2017, 1, 1), "Foo", [("x:y", 2)]) ] 85 | accountsByFrequency j `shouldContain` ["x"] 86 | 87 | it "only counts explicit occurences for sorting" $ do 88 | let j = mkJournal [ ((2017, 1, 1), "Foo", [("x:y", 2), ("x:y", 3), ("x:z", 4)]) ] 89 | accountsByFrequency j `shouldBe` ["x:y", "x:z", "x"] 90 | 91 | it "includes accounts from the 'account directive'" $ do 92 | let j = (mkJournal [ ((2017, 1, 1), "Foo", [("x:y", 2)]) ]) { HL.jdeclaredaccounts = [("foo:bar", HL.nullaccountdeclarationinfo)]} 93 | accountsByFrequency j `shouldContain` ["foo:bar"] 94 | accountsByFrequency j `shouldContain` ["foo"] 95 | 96 | 97 | setCurrentCommentSpec :: Spec 98 | setCurrentCommentSpec = do 99 | it "works at the date prompt" $ 100 | worksOn (DateQuestion "") 101 | 102 | it "works at the description prompt" $ 103 | worksOn (DescriptionQuestion (fromGregorian 2017 2 3) "") 104 | 105 | it "works at the account prompt" $ 106 | worksOn (AccountQuestion HL.nulltransaction "") 107 | 108 | it "works at the amount prompt" $ 109 | worksOn (AmountQuestion "foo" HL.nulltransaction "") 110 | 111 | it "works at the final prompt" $ 112 | worksOn (FinalQuestion HL.nulltransaction False) 113 | 114 | where 115 | worksOn :: Step -> Expectation 116 | worksOn step = 117 | let comment = "a fancy comment" 118 | in getCurrentComment (setCurrentComment comment step) `shouldBe` comment 119 | 120 | setTransactionCommentSpec :: Spec 121 | setTransactionCommentSpec = do 122 | it "works at the date prompt" $ 123 | worksOn (DateQuestion "") 124 | 125 | it "works at the description prompt" $ 126 | worksOn (DescriptionQuestion (fromGregorian 2017 2 3) "") 127 | 128 | it "works at the account prompt" $ 129 | worksOn (AccountQuestion HL.nulltransaction "") 130 | 131 | it "works at the amount prompt" $ 132 | worksOn (AmountQuestion "foo" HL.nulltransaction "") 133 | 134 | it "works at the final prompt" $ 135 | worksOn (FinalQuestion HL.nulltransaction False) 136 | 137 | where 138 | worksOn :: Step -> Expectation 139 | worksOn step = 140 | let comment = "a fancy comment" 141 | in getTransactionComment (setTransactionComment comment step) `shouldBe` comment 142 | 143 | isDuplicateTransactionSpec :: Spec 144 | isDuplicateTransactionSpec = do 145 | it "considers exact copies as duplicates" $ 146 | let trans = ((2017,9,23), "Test", [("Test", 1), ("Toast", -1)]) 147 | in 148 | isDuplicateTransaction (mkJournal [trans]) (mkTransaction trans) 149 | 150 | it "ignores the order of postings" $ 151 | let 152 | t1 = ((2017,9,23), "Test", [("Test", 1), ("Toast", -1)]) 153 | t2 = ((2017,9,23), "Test", [("Toast", -1), ("Test", 1)]) 154 | in 155 | isDuplicateTransaction (mkJournal [t1]) (mkTransaction t2) 156 | 157 | it "ignores comments and tags" $ do 158 | let 159 | t1 = mkTransaction ((2017,9,23), "Test", [("Test", 1), ("Toast", -1)]) 160 | t2 = t1 { HL.tcomment = "Foo" } 161 | t3 = t1 { HL.ttags = [("Foo", "Bar")] } 162 | 163 | isDuplicateTransaction (HL.addTransaction t2 HL.nulljournal) t1 `shouldBe` True 164 | isDuplicateTransaction (HL.addTransaction t3 HL.nulljournal) t1 `shouldBe` True 165 | 166 | it "considers date and description" $ do 167 | let 168 | t1 = ((2017,9,23), "Test", [("Test", 1), ("Toast", -1)]) 169 | t2 = ((2017,9,24), "Test", [("Test", 1), ("Toast", -1)]) 170 | t3 = ((2017,9,23), "Foo", [("Test", 1), ("Toast", -1)]) 171 | 172 | isDuplicateTransaction (mkJournal [t1]) (mkTransaction t2) `shouldBe` False 173 | isDuplicateTransaction (mkJournal [t1]) (mkTransaction t3) `shouldBe` False 174 | 175 | 176 | it "considers date, amount and account of postings" $ do 177 | let 178 | t1 = ((2017,9,23), "Test", [("Test", 1), ("Toast", -1)]) 179 | t2 = ((2017,9,23), "Test", [("Foo", 1), ("Toast", -1)]) 180 | t3 = ((2017,9,23), "Test", [("Test", 2), ("Toast", -1)]) 181 | t4 = ((2017,9,23), "Test", [("Test", 1), ("Toast", -1), ("Foo", 2), ("Bar", -2)]) 182 | 183 | t5p1 = (mkPosting ("Test", 1)) { HL.pdate = Just (fromGregorian 2017 9 23 )} 184 | t5 = (mkTransaction t1) { HL.tpostings = [t5p1, mkPosting ("Toast", -1)]} 185 | 186 | isDuplicateTransaction (mkJournal [t1]) (mkTransaction t2) `shouldBe` False 187 | isDuplicateTransaction (mkJournal [t1]) (mkTransaction t3) `shouldBe` False 188 | isDuplicateTransaction (mkJournal [t1]) (mkTransaction t4) `shouldBe` False 189 | isDuplicateTransaction (mkJournal [t1]) t5 `shouldBe` False 190 | 191 | it "ignores amount presentation" $ do 192 | let a1 = (HL.eur 0.5) { HL.astyle = HL.amountstyle} 193 | -- We use 'read' in the following because hledger-lib 1.19 changed the 194 | -- type of 'asprecision' from Int to 'AmountPrecision'. 'read' works in 195 | -- both cases. 196 | a2 = (HL.eur 0.5) { HL.astyle = HL.amountstyle { HL.asprecision = HL.Precision 15 } } 197 | 198 | p1 = mkPosting ("Test", -1) 199 | p2 = HL.nullposting { HL.paccount = "Toast", HL.pamount = HL.mixedAmount a1 } 200 | p3 = HL.nullposting { HL.paccount = "Toast", HL.pamount = HL.mixedAmount a2 } 201 | 202 | t0 = mkTransaction ((2017,9,23), "Test", []) 203 | t1 = t0 { HL.tpostings = [p1,p2,p2] } 204 | t2 = t0 { HL.tpostings = [p1,p3,p3] } 205 | 206 | isDuplicateTransaction (HL.addTransaction t1 HL.nulljournal) t2 `shouldBe` True 207 | 208 | isSubsetTransactionSpec :: Spec 209 | isSubsetTransactionSpec = 210 | it "ignores amount presentation" $ do 211 | let t1 = mkTransaction ((2021,3,12), "Test", [("Test", 1)]) 212 | t2' = mkTransaction ((2021,3,12), "Test", [("Toast", -1)]) 213 | testPosting = HL.nullposting 214 | { HL.paccount = "Test" 215 | , HL.pamount = HL.mixed [ (HL.eur 1) { HL.astyle = HL.amountstyle { HL.asdecimalmark = Just ';' }}]} 216 | t2 = t2' { HL.tpostings = testPosting : HL.tpostings t2' } 217 | isSubsetTransaction t1 t2 `shouldBe` True 218 | 219 | -- Helpers 220 | 221 | type Date = (Integer,Int,Int) -- y, d, m 222 | 223 | -- | Creates a mock-journal from a list of transactions 224 | -- 225 | -- Transactions consists of the date, a description and a list of postings in 226 | -- for form of (account, amount) 227 | mkJournal :: [(Date, Text, [(Text, Int)])] -> HL.Journal 228 | mkJournal = 229 | foldl (\j t -> HL.addTransaction (mkTransaction t) j) HL.nulljournal 230 | 231 | mkTransaction :: (Date, Text, [(Text, Int)]) -> HL.Transaction 232 | mkTransaction ((year,month,day), desc, postings) = HL.nulltransaction 233 | { HL.tdate = fromGregorian year month day 234 | , HL.tdescription = desc 235 | , HL.tpostings = map mkPosting postings 236 | } 237 | 238 | mkPosting :: (Text, Int) -> HL.Posting 239 | mkPosting (account, amount) = HL.nullposting 240 | { HL.paccount = account 241 | , HL.pamount = HL.mixed [HL.eur (fromIntegral amount)] 242 | } 243 | -------------------------------------------------------------------------------- /src/ConfigParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE GADTs, DeriveFunctor, ScopedTypeVariables #-} 7 | {-# LANGUAGE CPP #-} 8 | 9 | -- | Applicative config parser. 10 | -- 11 | -- This parses config files in the style of optparse-applicative. It supports 12 | -- automatic generation of a default config both as datatype and in printed 13 | -- form. 14 | -- 15 | -- Example: 16 | -- 17 | -- @ 18 | -- data Config = Config 19 | -- { test :: Text 20 | -- , foobar :: Int 21 | -- } 22 | -- 23 | -- confParser :: ConfParser Config 24 | -- confParser = Config 25 | -- \<$\> option "test" "default value" "Help for test" 26 | -- \<*\> option "foobar" 42 "Help for foobar" 27 | -- @ 28 | -- 29 | -- This parses a config file like the following: 30 | -- 31 | -- > # This is a comment 32 | -- > test = "something" 33 | -- > foobar = 23 34 | module ConfigParser 35 | ( OptParser 36 | , parseConfig 37 | , parseConfigFile 38 | , option 39 | , customOption 40 | , parserDefault 41 | , parserExample 42 | , ConfParseError 43 | , OParser 44 | , Option 45 | , OptionArgument() 46 | ) where 47 | 48 | import Control.Applicative hiding (many, some) 49 | import Control.Applicative.Free 50 | import Control.Monad 51 | import Data.Functor.Identity 52 | import qualified Data.List.NonEmpty as NE 53 | 54 | import qualified Data.Set as S 55 | -- import Data.Set (Set) 56 | import Data.Text (Text) 57 | import qualified Data.Text as T 58 | import qualified Data.Text.IO as T 59 | import Text.Megaparsec hiding (option) 60 | import Text.Megaparsec.Char 61 | import Data.Maybe 62 | -- import Text.Megaparsec.Text 63 | 64 | -- | Errors that can occur during parsing. Use the 'Show' instance for printing. 65 | data ConfParseError = UnknownOption Text 66 | | TypeError Text Text -- Type and Option name 67 | deriving (Eq, Ord, Show) 68 | 69 | instance ShowErrorComponent ConfParseError where 70 | showErrorComponent (UnknownOption name) = "Unknown option " ++ T.unpack name 71 | showErrorComponent (TypeError typ name) = 72 | "in " ++ T.unpack typ ++ " argument for option " ++ T.unpack name 73 | 74 | type OParser = Parsec ConfParseError Text 75 | 76 | type CustomParseError = ParseErrorBundle Text ConfParseError 77 | 78 | -- | Parse a config file from a 'Text'. 79 | parseConfig :: FilePath -- ^ File path to use in error messages 80 | -> Text -- ^ The input test 81 | -> OptParser a -- ^ The parser to use 82 | -> Either CustomParseError a 83 | parseConfig path input parser = case parse (assignmentList <* eof) path input of 84 | Left err -> Left err 85 | Right res -> runOptionParser res parser 86 | 87 | -- | Parse a config file from an actual file in the filesystem. 88 | parseConfigFile :: FilePath -- ^ Path to the file 89 | -> OptParser a -- ^ The parser to use 90 | -> IO (Either CustomParseError a) 91 | parseConfigFile path parser = do 92 | input <- T.readFile path 93 | return $ parseConfig path input parser 94 | 95 | -- | An option in the config file. Use 'option' as a smart constructor. 96 | data Option a = Option 97 | { optParser :: OParser a 98 | , optType :: Text -- Something like "string" or "integer" 99 | , optName :: Text 100 | , optHelp :: Text 101 | , optDefault :: a 102 | , optDefaultTxt :: Text -- printed version of optDefault 103 | } deriving (Functor) 104 | 105 | -- | The main parser type. Use 'option' and the 'Applicative' instance to create those. 106 | type OptParser a = Ap Option a 107 | 108 | -- | Class for supported option types. 109 | -- 110 | -- At the moment, orphan instances are not supported 111 | class OptionArgument a where 112 | mkParser :: (Text, OParser a) 113 | printArgument :: a -> Text 114 | 115 | -- | 'OptParser' that parses one option. 116 | -- 117 | -- Can be combined with the 'Applicative' instance for 'OptParser'. See the 118 | -- module documentation for an example. 119 | option :: OptionArgument a 120 | => Text -- ^ The option name 121 | -> a -- ^ The default value 122 | -> Text 123 | -- ^ A help string for the option. Will be used by 'parserExample' to 124 | -- create helpful comments. 125 | -> OptParser a 126 | option name def help = liftAp $ Option parser typename name help def (printArgument def) 127 | where (typename, parser) = mkParser 128 | 129 | customOption :: Text -- ^ The option name 130 | -> a -- ^ The default Value 131 | -> Text -- ^ A textual representation of the default value 132 | -> Text -- ^ A help string for the option 133 | -> Text -- ^ A description of the expected type such sas "string" or "integer" 134 | -> OParser a -- ^ Parser for the option 135 | -> OptParser a 136 | customOption optName optDefault optDefaultTxt optHelp optType optParser = liftAp $ Option {..} 137 | 138 | instance OptionArgument Int where 139 | mkParser = ("integer", parseNumber) 140 | printArgument = T.pack . show 141 | 142 | instance OptionArgument Integer where 143 | mkParser = ("integer", parseNumber) 144 | printArgument = T.pack . show 145 | 146 | instance OptionArgument String where 147 | mkParser = ("string", many anySingle) 148 | printArgument = quote . T.pack 149 | 150 | instance OptionArgument Text where 151 | mkParser = ("string", T.pack <$> many anySingle) 152 | printArgument = quote 153 | 154 | quote :: Text -> Text 155 | quote x = "\"" <> escape x <> "\"" 156 | where 157 | escape = T.replace "\"" "\\\"" . T.replace "\\" "\\\\" 158 | 159 | runOptionParser :: [Assignment] -> OptParser a -> Either CustomParseError a 160 | runOptionParser (a:as) parser = parseOption parser a >>= runOptionParser as 161 | runOptionParser [] parser = Right $ parserDefault parser 162 | 163 | -- | Returns the default value of a given parser. 164 | -- 165 | -- This default value is computed from the default arguments of the 'option' 166 | -- constructor. For the parser from the module description, the default value 167 | -- would be: 168 | -- 169 | -- > Config { test = "default value" 170 | -- > , foobar :: 42 171 | -- > } 172 | parserDefault :: OptParser a -> a 173 | parserDefault = runIdentity . runAp (Identity . optDefault) 174 | 175 | -- | Generate the default config file. 176 | -- 177 | -- This returns a valid config file, filled with the default values of every 178 | -- option and using the help string of these options as comments. 179 | parserExample :: OptParser a -> Text 180 | parserExample = T.strip . runAp_ example1 181 | where example1 a = commentify (optHelp a) <> optName a <> " = " <> optDefaultTxt a <> "\n\n" 182 | commentify = T.unlines . map ("# " <>) . T.lines 183 | 184 | parseOption :: OptParser a -> Assignment -> Either CustomParseError (OptParser a) 185 | parseOption (Pure _) ass = 186 | Left $ mkCustomError (assignmentPosition ass) (UnknownOption (assignmentKey ass)) 187 | parseOption (Ap opt rest) ass 188 | | optName opt == assignmentKey ass = 189 | let content = (valueContent $ assignmentValue ass) 190 | pos = (valuePosition $ assignmentValue ass) 191 | in case parseWithStart (optParser opt <* eof) pos content of 192 | Left e -> Left $ addCustomError e $ TypeError (optType opt) (assignmentKey ass) 193 | Right res -> Right $ fmap ($ res) rest 194 | | otherwise = fmap (Ap opt) $ parseOption rest ass 195 | 196 | mkCustomError :: SourcePos -> e -> ParseErrorBundle Text e 197 | mkCustomError pos e = ParseErrorBundle 198 | { bundleErrors = NE.fromList [FancyError 0 (S.singleton (ErrorCustom e))] 199 | , bundlePosState = PosState 200 | { pstateInput = "" 201 | , pstateOffset = 0 202 | , pstateSourcePos = pos 203 | , pstateTabWidth = mkPos 1 204 | , pstateLinePrefix = "" 205 | } 206 | } 207 | addCustomError :: ParseErrorBundle Text e -> e -> ParseErrorBundle Text e 208 | addCustomError e customE = 209 | e { bundleErrors = NE.cons 210 | (FancyError 0 (S.singleton (ErrorCustom customE))) 211 | (bundleErrors e)} 212 | 213 | -- Low level assignment parser 214 | 215 | data Assignment = Assignment 216 | { assignmentPosition :: SourcePos 217 | , assignmentKey :: Text 218 | , assignmentValue :: AssignmentValue 219 | } deriving (Show) 220 | 221 | data AssignmentValue = AssignmentValue 222 | { valuePosition :: SourcePos 223 | , valueContent :: Text 224 | } deriving (Show) 225 | 226 | assignmentList :: OParser [Assignment] 227 | assignmentList = whitespace *> many (assignment <* whitespace) 228 | 229 | assignment :: OParser Assignment 230 | assignment = do 231 | Assignment 232 | <$> getSourcePos <*> key <* whitespaceNoComment 233 | <* char '=' <* whitespaceNoComment 234 | <*> value 235 | 236 | key :: OParser Text 237 | key = T.pack <$> some (alphaNumChar <|> char '_' <|> char '-') 238 | 239 | value :: OParser AssignmentValue 240 | value = AssignmentValue <$> getSourcePos <*> content <* whitespaceNoEOL <* (void eol <|> eof) 241 | 242 | content :: OParser Text 243 | content = escapedString 244 | <|> bareString 245 | 246 | bareString :: OParser Text 247 | bareString = (T.strip . T.pack <$> some (noneOf ("#\n" :: String))) 248 | "bare string" 249 | 250 | escapedString :: OParser Text 251 | escapedString = (T.pack <$> (char '"' *> many escapedChar <* char '"')) 252 | "quoted string" 253 | where escapedChar = char '\\' *> anySingle 254 | <|> noneOf ("\"" :: String) 255 | 256 | whitespace :: OParser () 257 | whitespace = skipMany $ (void $ oneOf (" \t\n" :: String)) <|> comment 258 | 259 | whitespaceNoEOL :: OParser () 260 | whitespaceNoEOL = skipMany $ (void $ oneOf (" \t" :: String)) <|> comment 261 | 262 | whitespaceNoComment :: OParser () 263 | whitespaceNoComment = skipMany $ oneOf (" \t" :: String) 264 | 265 | comment :: OParser () 266 | comment = char '#' >> skipMany (noneOf ("\n" :: String)) 267 | 268 | parseNumber :: Read a => OParser a 269 | parseNumber = read <$> ((<>) <$> (maybeToList <$> optional (char '-')) <*> some digitChar) 270 | 271 | 272 | -- | Like 'parse', but start at a specific source position instead of 0. 273 | parseWithStart :: (Stream s, Ord e) 274 | => Parsec e s a -> SourcePos -> s -> Either (ParseErrorBundle s e) a 275 | parseWithStart p pos s = snd (runParser' p state) 276 | where state = State 277 | { stateInput = s 278 | , stateOffset = 0 279 | , statePosState =PosState 280 | { pstateInput = s 281 | , pstateOffset = 0 282 | , pstateSourcePos = pos 283 | , pstateTabWidth = mkPos 1 284 | , pstateLinePrefix = "" 285 | } 286 | #if MIN_VERSION_megaparsec(8,0,0) 287 | , stateParseErrors = [] 288 | #endif 289 | } 290 | -------------------------------------------------------------------------------- /src/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE LambdaCase, OverloadedStrings #-} 3 | 4 | module Model 5 | ( Step(..) 6 | , MaybeStep(..) 7 | , MatchAlgo(..) 8 | , nextStep 9 | , undo 10 | , context 11 | , suggest 12 | , setCurrentComment 13 | , getCurrentComment 14 | , setTransactionComment 15 | , getTransactionComment 16 | 17 | -- * Helpers exported for easier testing 18 | , accountsByFrequency 19 | , isDuplicateTransaction 20 | , isSubsetTransaction 21 | ) where 22 | 23 | import Data.Function 24 | import Data.List 25 | import qualified Data.HashMap.Lazy as HM 26 | import Data.Maybe 27 | import Data.Monoid 28 | import Data.Ord (Down(..)) 29 | import Data.Text (Text) 30 | import qualified Data.Text as T 31 | import Data.Time.Ext 32 | import qualified Hledger as HL 33 | import Data.Foldable 34 | import Control.Applicative 35 | import Control.Arrow ((&&&)) 36 | 37 | import AmountParser 38 | import DateParser 39 | 40 | 41 | type Comment = Text 42 | type Duplicate = Bool 43 | 44 | data Step = DateQuestion Comment 45 | | DescriptionQuestion Day Comment 46 | | AccountQuestion HL.Transaction Comment 47 | | AmountQuestion HL.AccountName HL.Transaction Comment 48 | | FinalQuestion HL.Transaction Duplicate 49 | deriving (Eq, Show) 50 | 51 | 52 | data MaybeStep = Finished HL.Transaction 53 | | Step Step 54 | deriving (Eq, Show) 55 | 56 | data MatchAlgo = Fuzzy | Substrings 57 | deriving (Eq, Show) 58 | 59 | nextStep :: HL.Journal -> DateFormat -> Either Text Text -> Step -> IO (Either Text MaybeStep) 60 | nextStep journal dateFormat entryText current = case current of 61 | DateQuestion comment -> 62 | fmap (Step . flip DescriptionQuestion comment) 63 | <$> either (parseDateWithToday dateFormat) parseHLDateWithToday entryText 64 | 65 | DescriptionQuestion day comment -> return $ Right $ Step $ 66 | AccountQuestion HL.nulltransaction { HL.tdate = day 67 | , HL.tdescription = fromEither entryText 68 | , HL.tcomment = comment 69 | } 70 | "" -- empty comment 71 | AccountQuestion trans comment 72 | | T.null (fromEither entryText) && transactionBalanced trans 73 | -> return $ Right $ Step $ FinalQuestion trans (isDuplicateTransaction journal trans) 74 | | T.null (fromEither entryText) -- unbalanced 75 | -> return $ Left "Transaction not balanced! Please balance your transaction before adding it to the journal." 76 | | otherwise -> return $ Right $ Step $ 77 | AmountQuestion (fromEither entryText) trans comment 78 | AmountQuestion name trans comment -> case parseAmount journal (fromEither entryText) of 79 | Left err -> return $ Left (T.pack err) 80 | Right amount -> return $ Right $ Step $ 81 | let newPosting = post' name amount comment 82 | in AccountQuestion (addPosting newPosting trans) "" 83 | 84 | FinalQuestion trans _ 85 | | fromEither entryText `elem` ["y", "Y"] -> return $ Right $ Finished trans 86 | | otherwise -> return $ Right $ Step $ AccountQuestion trans "" 87 | 88 | -- | Reverses the last step. 89 | -- 90 | -- Returns (Left errorMessage), if the step can't be reversed 91 | undo :: Step -> Either Text Step 92 | undo current = case current of 93 | DateQuestion _ -> Left "Already at oldest step in current transaction" 94 | DescriptionQuestion _ comment -> return (DateQuestion comment) 95 | AccountQuestion trans _ -> return $ case HL.tpostings trans of 96 | [] -> DescriptionQuestion (HL.tdate trans) (HL.tcomment trans) 97 | ps -> AmountQuestion (HL.paccount (last ps)) trans { HL.tpostings = init ps } (HL.pcomment (last ps)) 98 | AmountQuestion _ trans comment -> Right $ AccountQuestion trans comment 99 | FinalQuestion trans _ -> undo (AccountQuestion trans "") 100 | 101 | context :: HL.Journal -> MatchAlgo -> DateFormat -> Text -> Step -> IO [Text] 102 | context _ _ dateFormat entryText (DateQuestion _) = parseDateWithToday dateFormat entryText >>= \case 103 | Left _ -> return [] 104 | Right date -> return [HL.showDate date] 105 | context j matchAlgo _ entryText (DescriptionQuestion _ _) = return $ 106 | let descs = HL.journalDescriptions j 107 | in sortBy (descUses j) $ filter (matches matchAlgo entryText) descs 108 | context j matchAlgo _ entryText (AccountQuestion _ _) = return $ 109 | let names = accountsByFrequency j 110 | in filter (matches matchAlgo entryText) names 111 | context journal _ _ entryText (AmountQuestion {}) = return $ 112 | maybeToList $ T.pack . HL.showMixedAmount <$> trySumAmount journal entryText 113 | context _ _ _ _ (FinalQuestion _ _) = return [] 114 | 115 | -- | Suggest the initial text of the entry box for each step 116 | -- 117 | -- For example, it suggests today for the date prompt 118 | suggest :: HL.Journal -> DateFormat -> Step -> IO (Maybe Text) 119 | suggest _ dateFormat (DateQuestion _) = 120 | Just . printDate dateFormat <$> getLocalDay 121 | suggest _ _ (DescriptionQuestion _ _) = return Nothing 122 | suggest journal _ (AccountQuestion trans _) = return $ 123 | if numPostings trans /= 0 && transactionBalanced trans 124 | then Nothing 125 | else HL.paccount <$> suggestAccountPosting journal trans 126 | suggest journal _ (AmountQuestion account trans _) = return $ fmap (T.pack . HL.showMixedAmount) $ 127 | case findLastSimilar journal trans of 128 | Nothing 129 | -- no similar transaction, first posting => nothing to suggest 130 | | null (HL.tpostings trans) 131 | -> Nothing 132 | -- no similar transaction, so just try to balance the new one 133 | | otherwise 134 | -> Just $ negativeAmountSum trans 135 | Just last 136 | -- current transaction already balanced => see we have a posting with the 137 | -- current account in the reference transaction 138 | | transactionBalanced trans 139 | -> HL.pamount <$> findPostingByAcc account last 140 | -- transaction not balanced, but we're following the reference 141 | -- transaction. => Try to find a matching posting for the current account. 142 | -- Otherwise, just balance the current transaction. 143 | | trans `isSubsetTransaction` last 144 | -> (HL.pamount <$> findPostingByAcc account last) 145 | <|> Just (negativeAmountSum trans) 146 | -- we're not balanced and the reference transaction doesn't match anymore 147 | -- => Just balance the current transaction. 148 | | otherwise 149 | -> Just $ negativeAmountSum trans 150 | suggest _ _ (FinalQuestion _ _) = return $ Just "y" 151 | 152 | getCurrentComment :: Step -> Comment 153 | getCurrentComment step = case step of 154 | DateQuestion c -> c 155 | DescriptionQuestion _ c -> c 156 | AccountQuestion _ c -> c 157 | AmountQuestion _ _ c -> c 158 | FinalQuestion trans _ -> HL.tcomment trans 159 | 160 | setCurrentComment :: Comment -> Step -> Step 161 | setCurrentComment comment step = case step of 162 | DateQuestion _ -> DateQuestion comment 163 | DescriptionQuestion date _ -> DescriptionQuestion date comment 164 | AccountQuestion trans _ -> AccountQuestion trans comment 165 | AmountQuestion trans name _ -> AmountQuestion trans name comment 166 | FinalQuestion trans duplicate -> FinalQuestion trans { HL.tcomment = comment } duplicate 167 | 168 | getTransactionComment :: Step -> Comment 169 | getTransactionComment step = case step of 170 | DateQuestion c -> c 171 | DescriptionQuestion _ c -> c 172 | AccountQuestion trans _ -> HL.tcomment trans 173 | AmountQuestion _ trans _ -> HL.tcomment trans 174 | FinalQuestion trans _ -> HL.tcomment trans 175 | 176 | setTransactionComment :: Comment -> Step -> Step 177 | setTransactionComment comment step = case step of 178 | DateQuestion _ -> DateQuestion comment 179 | DescriptionQuestion date _ -> DescriptionQuestion date comment 180 | AccountQuestion trans comment' -> 181 | AccountQuestion (trans { HL.tcomment = comment }) comment' 182 | AmountQuestion name trans comment' -> 183 | AmountQuestion name (trans { HL.tcomment = comment }) comment' 184 | FinalQuestion trans duplicate -> FinalQuestion trans { HL.tcomment = comment } duplicate 185 | 186 | -- | Returns true if the pattern is not empty and all of its words occur in the string 187 | -- 188 | -- If the pattern is empty, we don't want any entries in the list, so nothing is 189 | -- selected if the users enters an empty string. Empty inputs are special cased, 190 | -- so this is important. 191 | matches :: MatchAlgo -> Text -> Text -> Bool 192 | matches algo a b 193 | | T.null a = False 194 | | otherwise = matches' (T.toCaseFold a) (T.toCaseFold b) 195 | where 196 | matches' a' b' 197 | | algo == Fuzzy && T.any (== ':') b' = all (`fuzzyMatch` T.splitOn ":" b') (T.words a') 198 | | otherwise = all (`T.isInfixOf` b') (T.words a') 199 | 200 | fuzzyMatch :: Text -> [Text] -> Bool 201 | fuzzyMatch _ [] = False 202 | fuzzyMatch query (part : partsRest) = case T.uncons query of 203 | Nothing -> True 204 | Just (c, queryRest) 205 | | c == ':' -> fuzzyMatch queryRest partsRest 206 | | otherwise -> fuzzyMatch query partsRest || case T.uncons part of 207 | Nothing -> False 208 | Just (c2, partRest) 209 | | c == c2 -> fuzzyMatch queryRest (partRest : partsRest) 210 | | otherwise -> False 211 | 212 | post' :: HL.AccountName -> HL.MixedAmount -> Comment -> HL.Posting 213 | post' account amount comment = HL.nullposting 214 | { HL.paccount = account 215 | , HL.pamount = amount 216 | , HL.pcomment = comment 217 | } 218 | 219 | addPosting :: HL.Posting -> HL.Transaction -> HL.Transaction 220 | addPosting p t = t { HL.tpostings = HL.tpostings t ++ [p] } 221 | 222 | trySumAmount :: HL.Journal -> Text -> Maybe HL.MixedAmount 223 | trySumAmount ctx = either (const Nothing) Just . parseAmount ctx 224 | 225 | 226 | -- | Given a previous similar transaction, suggest the next posting to enter 227 | -- 228 | -- This next posting is the one the user likely wants to type in next. 229 | suggestNextPosting :: HL.Transaction -> HL.Transaction -> Maybe HL.Posting 230 | suggestNextPosting current reference = 231 | -- Postings that aren't already used in the new posting 232 | let unusedPostings = filter (`notContainedIn` curPostings) refPostings 233 | in listToMaybe unusedPostings 234 | 235 | where (refPostings, curPostings) = (HL.tpostings reference, HL.tpostings current) 236 | notContainedIn p = not . any (((==) `on` HL.paccount) p) 237 | 238 | -- | Given the last transaction entered, suggest the likely most comparable posting 239 | -- 240 | -- Since the transaction isn't necessarily the same type, we can't rely on matching the data 241 | -- so we must use the order. This way if the user typically uses a certain order 242 | -- like expense category and then payment method. Useful if entering many similar postings 243 | -- in a row. For example, when entering transactions from a credit card statement 244 | -- where the first account is usually food, and the second posting is always the credit card. 245 | suggestCorrespondingPosting :: HL.Transaction -> HL.Transaction -> Maybe HL.Posting 246 | suggestCorrespondingPosting current reference = 247 | let postingsEntered = length curPostings in 248 | if postingsEntered < length refPostings then 249 | Just (refPostings !! postingsEntered) 250 | else 251 | suggestNextPosting current reference 252 | where (refPostings, curPostings) = (HL.tpostings reference, HL.tpostings current) 253 | 254 | findLastSimilar :: HL.Journal -> HL.Transaction -> Maybe HL.Transaction 255 | findLastSimilar journal desc = 256 | maximumBy (compare `on` HL.tdate) <$> 257 | listToMaybe' (filter (((==) `on` HL.tdescription) desc) $ HL.jtxns journal) 258 | 259 | suggestAccountPosting :: HL.Journal -> HL.Transaction -> Maybe HL.Posting 260 | suggestAccountPosting journal trans = 261 | case findLastSimilar journal trans of 262 | Just t -> suggestNextPosting trans t 263 | Nothing -> listToMaybe' (HL.jtxns journal) >>= suggestCorrespondingPosting trans . last 264 | 265 | -- | Return the first Posting that matches the given account name in the transaction 266 | findPostingByAcc :: HL.AccountName -> HL.Transaction -> Maybe HL.Posting 267 | findPostingByAcc account = find ((==account) . HL.paccount) . HL.tpostings 268 | 269 | -- | Returns True if the first transaction is a subset of the second one. 270 | -- 271 | -- That means, all postings from the first transaction are present in the 272 | -- second one. 273 | isSubsetTransaction :: HL.Transaction -> HL.Transaction -> Bool 274 | isSubsetTransaction current origin = 275 | let 276 | origPostings = HL.tpostings origin 277 | currPostings = HL.tpostings current 278 | in 279 | null (deleteFirstsBy cmpPosting currPostings origPostings) 280 | where 281 | cmpPosting a b = HL.paccount a == HL.paccount b 282 | && cmpAmount (HL.pamount a) (HL.pamount b) 283 | 284 | cmpAmount a b = ((==) `on` map (HL.acommodity &&& HL.aquantity)) (HL.amounts a) (HL.amounts b) 285 | 286 | listToMaybe' :: [a] -> Maybe [a] 287 | listToMaybe' [] = Nothing 288 | listToMaybe' ls = Just ls 289 | 290 | numPostings :: HL.Transaction -> Int 291 | numPostings = length . HL.tpostings 292 | 293 | -- | Returns True if all postings balance and the transaction is not empty 294 | transactionBalanced :: HL.Transaction -> Bool 295 | transactionBalanced = HL.isTransactionBalanced HL.defbalancingopts 296 | 297 | -- | Computes the sum of all postings in the transaction and inverts it 298 | negativeAmountSum :: HL.Transaction -> HL.MixedAmount 299 | negativeAmountSum trans = 300 | let rsum = HL.sumPostings $ HL.realPostings trans 301 | in HL.divideMixedAmount (-1) rsum 302 | 303 | -- | Compare two transaction descriptions based on their number of occurences in 304 | -- the given journal. 305 | descUses :: HL.Journal -> Text -> Text -> Ordering 306 | descUses journal = compare `on` Down . flip HM.lookup usesMap 307 | where usesMap = foldr (count . HL.tdescription) HM.empty $ 308 | HL.jtxns journal 309 | -- Add one to the current count of this element 310 | count :: Text -> HM.HashMap Text (Sum Int) -> HM.HashMap Text (Sum Int) 311 | count = HM.alter (<> Just 1) 312 | 313 | -- | All accounts occuring in the journal sorted in descending order of 314 | -- appearance. 315 | accountsByFrequency :: HL.Journal -> [HL.AccountName] 316 | accountsByFrequency journal = 317 | let 318 | usedAccounts = map HL.paccount (HL.journalPostings journal) 319 | frequencyMap :: HM.HashMap HL.AccountName Int = foldr insertOrPlusOne HM.empty usedAccounts 320 | mapWithSubaccounts = foldr insertIfNotPresent frequencyMap (subaccounts frequencyMap) 321 | declaredAccounts = HL.expandAccountNames (HL.journalAccountNamesDeclared journal) 322 | mapWithDeclared = foldr insertIfNotPresent mapWithSubaccounts declaredAccounts 323 | in 324 | map fst (sortBy (compare `on` Down . snd) (HM.toList mapWithDeclared)) 325 | 326 | 327 | where 328 | insertOrPlusOne = HM.alter (Just . maybe 1 (+1)) 329 | insertIfNotPresent account = HM.insertWith (\ _ x -> x) account 0 330 | subaccounts m = HL.expandAccountNames (HM.keys m) 331 | 332 | -- | Deterimine if a given transaction already occurs in the journal 333 | -- 334 | -- This function ignores certain attributes of transactions, postings and 335 | -- amounts that are either artifacts of knot-tying or are purely for 336 | -- presentation. 337 | -- 338 | -- See the various ...attributes functions in the where clause for details. 339 | isDuplicateTransaction :: HL.Journal -> HL.Transaction -> Bool 340 | isDuplicateTransaction journal trans = any ((==EQ) . cmpTransaction trans) (HL.jtxns journal) 341 | where 342 | -- | Transaction attributes that are compared to determine duplicates 343 | transactionAttributes = 344 | [ cmp HL.tdate, cmp HL.tdate2, cmp HL.tdescription, cmp HL.tstatus 345 | , cmp HL.tcode, cmpPostings `on` HL.tpostings 346 | ] 347 | 348 | -- | Posting attributes that are compared to determine duplicates 349 | postingAttributes = 350 | [ cmp HL.pdate, cmp HL.pdate2, cmp HL.pstatus, cmp HL.paccount 351 | , cmpMixedAmount `on` HL.pamount, cmpPType `on` HL.ptype 352 | , fmap fold . liftA2 cmpBalanceAssertion `on` HL.pbalanceassertion 353 | ] 354 | 355 | -- | Ammount attributes that are compared to determine duplicates 356 | amountAttributes = 357 | [ cmp HL.acommodity, cmp HL.acost, cmp HL.aquantity ] 358 | 359 | -- | Compare two transactions but ignore unimportant details 360 | cmpTransaction :: HL.Transaction -> HL.Transaction -> Ordering 361 | cmpTransaction = lexical transactionAttributes 362 | 363 | 364 | -- | Compare two posting lists of postings by sorting them deterministically 365 | -- and then compare correspondings list elements 366 | cmpPostings :: [HL.Posting] -> [HL.Posting] -> Ordering 367 | cmpPostings ps1 ps2 = 368 | mconcat (zipWith (lexical postingAttributes) (sortPostings ps1) (sortPostings ps2)) 369 | 370 | -- | Compare two posting styles (this should really be an Eq instance) 371 | cmpPType :: HL.PostingType -> HL.PostingType -> Ordering 372 | cmpPType = compare `on` pTypeToInt 373 | where 374 | pTypeToInt :: HL.PostingType -> Int 375 | pTypeToInt HL.RegularPosting = 0 376 | pTypeToInt HL.VirtualPosting = 1 377 | pTypeToInt HL.BalancedVirtualPosting = 2 378 | 379 | -- | Compare two amounts ignoring unimportant details 380 | cmpAmount :: HL.Amount -> HL.Amount -> Ordering 381 | cmpAmount = lexical amountAttributes 382 | 383 | -- | Compare two mixed amounts by first sorting the individual amounts 384 | -- deterministically and then comparing them one-by-one. 385 | cmpMixedAmount :: HL.MixedAmount -> HL.MixedAmount -> Ordering 386 | cmpMixedAmount as1 as2 = 387 | let 388 | sortedAs1 = sortBy cmpAmount $ HL.amounts as1 389 | sortedAs2 = sortBy cmpAmount $ HL.amounts as2 390 | in 391 | mconcat $ 392 | compare (length $ HL.amounts as1) (length $ HL.amounts as2) : zipWith cmpAmount sortedAs1 sortedAs2 393 | 394 | cmpBalanceAssertion :: HL.BalanceAssertion -> HL.BalanceAssertion -> Ordering 395 | cmpBalanceAssertion = lexical [cmp HL.baamount, cmp HL.batotal] 396 | 397 | sortPostings :: [HL.Posting] -> [HL.Posting] 398 | sortPostings = sortBy (lexical postingAttributes) 399 | 400 | -- | Shortcut for 'compare `on`' 401 | cmp :: Ord b => (a -> b) -> a -> a -> Ordering 402 | cmp f = compare `on` f 403 | 404 | -- | Apply two things with multiple predicats and combine the results lexicographically 405 | lexical :: [a -> b -> Ordering] -> a -> b -> Ordering 406 | lexical = fold -- hehe 407 | 408 | fromEither :: Either a a -> a 409 | fromEither = either id id 410 | -------------------------------------------------------------------------------- /src/main/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE OverloadedStrings, LambdaCase #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Main where 8 | 9 | import Brick 10 | ( Widget, App(..), AttrMap, BrickEvent(..), EventM 11 | , (<=>), (<+>), txt, halt, attrMap, on, fg 12 | , defaultMain, showFirstCursor, padBottom, Padding(Max,Pad) 13 | , padAll, padLeft, nestEventM', nestEventM, modify, gets, get, attrName 14 | ) 15 | import Brick.Widgets.BetterDialog (dialog) 16 | import Brick.Widgets.Border (hBorder) 17 | import Brick.Widgets.Edit.EmacsBindings 18 | ( Editor, renderEditor, handleEditorEvent, getEditContents, editContentsL 19 | , editorText 20 | ) 21 | import Brick.Widgets.List 22 | ( List, listMoveDown, listMoveUp, listMoveTo, listSelectedElement 23 | , listSelectedAttr, list 24 | ) 25 | import Brick.Widgets.List.Utils (listSimpleReplace) 26 | import Graphics.Vty 27 | (Event(EvKey), Modifier(MCtrl,MMeta), Key(..), defAttr, black, white, green) 28 | 29 | import Control.Exception (SomeException, try) 30 | import Control.Monad (msum, when, void) 31 | import Control.Monad.IO.Class (liftIO) 32 | import Control.Monad.Trans.Except (runExceptT) 33 | import Data.Functor.Identity (Identity(..), runIdentity) 34 | import Data.Maybe (fromMaybe, fromJust) 35 | import Data.Monoid (First(..), getFirst) 36 | import qualified Data.Semigroup as Sem 37 | import Data.Text (Text) 38 | import qualified Data.Text as T 39 | import qualified Data.Text.IO as T 40 | import Data.Text.Zipper (gotoEOL, textZipper) 41 | import qualified Data.Vector as V 42 | import qualified Hledger as HL 43 | import qualified Hledger.Read.JournalReader as HL 44 | import Lens.Micro ((&), (.~), (^.), (%~)) 45 | import Lens.Micro.Mtl 46 | import qualified Options.Applicative as OA 47 | import Options.Applicative 48 | ( ReadM, Parser, value, help, long, metavar, switch, helper, fullDesc, info 49 | , header, short, (<|>), eitherReader, execParser 50 | ) 51 | import System.Directory (getHomeDirectory) 52 | import System.Environment (lookupEnv) 53 | import System.Environment.XDG.BaseDir (getUserConfigFile) 54 | import System.Exit (exitFailure, exitSuccess) 55 | import System.IO (hPutStr, hPutStrLn, stderr) 56 | import qualified Text.Megaparsec as P 57 | import qualified Text.Megaparsec.Char as P 58 | 59 | import Brick.Widgets.CommentDialog 60 | import Brick.Widgets.HelpMessage 61 | import Brick.Widgets.Border.Utils (borderLeft) 62 | import ConfigParser hiding (parseConfigFile) 63 | import DateParser 64 | import Model 65 | import View 66 | 67 | import Lens.Micro.TH 68 | 69 | import Data.Version (showVersion) 70 | import qualified Paths_hledger_iadd as Paths 71 | 72 | 73 | data Name = HelpName | ListName | EditorName | CommentName 74 | deriving (Ord, Show, Eq) 75 | 76 | data CommentType = TransactionComment | CurrentComment 77 | 78 | instance Show CommentType where 79 | show TransactionComment = "Transaction comment" 80 | show CurrentComment = "Comment" 81 | 82 | data DialogShown = NoDialog 83 | | HelpDialog (HelpWidget Name) 84 | | QuitDialog 85 | | AbortDialog 86 | | CommentDialog CommentType (CommentWidget Name) 87 | 88 | 89 | 90 | data AppState = AppState 91 | { _asEditor :: Editor Name 92 | , _asStep :: Step 93 | , _asJournal :: HL.Journal 94 | , _asContext :: List Name Text 95 | , _asSuggestion :: Maybe Text 96 | , _asMessage :: Text 97 | , _asFilename :: FilePath 98 | , _asDateFormat :: DateFormat 99 | , _asMatchAlgo :: MatchAlgo 100 | , _asDialog :: DialogShown 101 | , _asInputHistory :: [Text] 102 | } 103 | 104 | makeLenses ''AppState 105 | 106 | 107 | myHelpDialog :: DialogShown 108 | myHelpDialog = HelpDialog (helpWidget HelpName bindings) 109 | 110 | myCommentDialog :: CommentType -> Text -> DialogShown 111 | myCommentDialog typ comment = 112 | CommentDialog typ (commentWidget CommentName (T.pack $ show typ) comment) 113 | 114 | bindings :: KeyBindings 115 | bindings = KeyBindings 116 | [ ("Denial", 117 | [ ("C-c, C-d", "Quit without saving the current transaction") 118 | , ("Esc", "Abort the current transaction or exit when at toplevel") 119 | ]) 120 | , ("Anger", 121 | [ ("F1, Alt-?", "Show help screen")]) 122 | , ("Bargaining", 123 | [ ("C-n", "Select the next context item") 124 | , ("C-p", "Select the previous context item") 125 | , ("Tab", "Insert currently selected answer into text area") 126 | , ("C-z", "Undo") 127 | , (";", "Edit comment for current prompt") 128 | , ("Alt-;", "Edit transaction comment") 129 | ]) 130 | , ("Acceptance", 131 | [ ("Ret", "Accept the currently selected answer") 132 | , ("Alt-Ret", "Accept the current answer verbatim, ignoring selection") 133 | ])] 134 | 135 | draw :: AppState -> [Widget Name] 136 | draw as = case as^.asDialog of 137 | HelpDialog h -> [renderHelpWidget h, ui] 138 | QuitDialog -> [quitDialog, ui] 139 | AbortDialog -> [abortDialog, ui] 140 | CommentDialog _ c -> [renderCommentWidget c, ui] 141 | NoDialog -> [ui] 142 | 143 | where ui = txt "New Transaction:" 144 | <=> padAll 1 (borderLeft $ padLeft (Pad 1) $ viewState (as^.asStep)) 145 | <=> hBorder 146 | <=> (viewQuestion (as^.asStep) 147 | <+> viewSuggestion (as^.asSuggestion) 148 | <+> txt ": " 149 | <+> renderEditor True (as^.asEditor)) 150 | <=> hBorder 151 | <=> expand (viewContext (as^.asContext)) 152 | <=> hBorder 153 | <=> viewMessage (as^.asMessage) 154 | 155 | quitDialog = dialog "Quit" "Really quit without saving the current transaction? (Y/n)" 156 | abortDialog = dialog "Abort" "Really abort this transaction (Y/n)" 157 | 158 | setComment :: CommentType -> Text -> Step -> Step 159 | setComment TransactionComment = setTransactionComment 160 | setComment CurrentComment = setCurrentComment 161 | 162 | -- TODO Refactor to remove code duplication in individual case statements 163 | event :: BrickEvent Name Event -> EventM Name AppState () 164 | event (VtyEvent ev) = use asDialog >>= \case 165 | HelpDialog helpDia -> case ev of 166 | EvKey key [] 167 | | key `elem` [KChar 'q', KEsc] -> asDialog .= NoDialog 168 | | otherwise -> do 169 | nestEventM' helpDia (handleHelpEvent ev) >>= assign asDialog . HelpDialog 170 | _ -> return () 171 | QuitDialog -> case ev of 172 | EvKey key [] 173 | | key `elem` [KChar 'y', KChar 'Y', KEnter] -> halt 174 | | otherwise -> asDialog .= NoDialog 175 | _ -> return () 176 | AbortDialog -> case ev of 177 | EvKey key [] 178 | | key `elem` [KChar 'y', KChar 'Y', KEnter] -> do 179 | asDialog .= NoDialog 180 | reset 181 | | otherwise -> asDialog .= NoDialog 182 | _ -> return () 183 | CommentDialog typ dia -> nestEventM dia (handleCommentEvent ev) >>= \case 184 | (dia', CommentContinue) -> do 185 | asDialog .= CommentDialog typ dia' 186 | asStep %= setComment typ (commentDialogComment dia') 187 | (_, CommentFinished comment) -> do 188 | asDialog .= NoDialog 189 | asStep %= setComment typ comment 190 | 191 | NoDialog -> case ev of 192 | EvKey (KChar 'c') [MCtrl] -> use asStep >>= \case 193 | DateQuestion _ -> halt 194 | _ -> asDialog .= QuitDialog 195 | EvKey (KChar 'd') [MCtrl] -> use asStep >>= \case 196 | DateQuestion _ -> halt 197 | _ -> asDialog .= QuitDialog 198 | EvKey (KChar 'n') [MCtrl] -> do 199 | asContext %= listMoveDown 200 | asMessage .= "" 201 | EvKey KDown [] -> do 202 | asContext %= listMoveDown 203 | asMessage .= "" 204 | EvKey (KChar 'p') [MCtrl] -> do 205 | asContext %= listMoveUp 206 | asMessage .= "" 207 | EvKey KUp [] -> do 208 | asContext %= listMoveUp 209 | asMessage .= "" 210 | EvKey (KChar '\t') [] -> modify insertSelected 211 | EvKey (KChar ';') [] -> do 212 | step <- use asStep 213 | asDialog .= myCommentDialog CurrentComment (getCurrentComment step) 214 | EvKey (KChar ';') [MMeta] -> do 215 | step <- use asStep 216 | asDialog .= myCommentDialog TransactionComment (getTransactionComment step) 217 | EvKey KEsc [] -> use asStep >>= \case 218 | DateQuestion _ -> do 219 | t <- gets editText 220 | if T.null t then halt else reset 221 | _ -> asDialog .= AbortDialog 222 | EvKey (KChar 'z') [MCtrl] -> doUndo 223 | EvKey KEnter [MMeta] -> doNextStep False 224 | EvKey KEnter [] -> doNextStep True 225 | EvKey (KFun 1) [] -> asDialog .= myHelpDialog 226 | EvKey (KChar '?') [MMeta] -> asDialog .= myHelpDialog >> asMessage .= "Help" 227 | _ -> do 228 | zoom asEditor $ handleEditorEvent ev 229 | setContext 230 | event _ = return () 231 | 232 | reset :: EventM n AppState () 233 | reset = do 234 | as <- get 235 | sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) (DateQuestion "") 236 | 237 | asStep .= DateQuestion "" 238 | asEditor %= clearEdit 239 | asContext .= ctxList V.empty 240 | asSuggestion .= sugg 241 | asMessage .= "Transaction aborted" 242 | 243 | 244 | setContext :: EventM n AppState () 245 | setContext = do 246 | as <- get 247 | newCtx <- liftIO $ context (as^.asJournal) (as^.asMatchAlgo) (as^.asDateFormat) (editText as) (as^.asStep) 248 | asContext %= listSimpleReplace (V.fromList newCtx) 249 | 250 | 251 | editText :: AppState -> Text 252 | editText = T.concat . getEditContents . _asEditor 253 | 254 | -- | Add a tranaction at the end of a journal 255 | -- 256 | -- Hledgers `HL.addTransaction` adds it to the beginning, but our suggestion 257 | -- system expects newer transactions to be at the end. 258 | addTransactionEnd :: HL.Transaction -> HL.Journal -> HL.Journal 259 | addTransactionEnd t j = j { HL.jtxns = HL.jtxns j ++ [t] } 260 | 261 | doNextStep :: Bool -> EventM n AppState () 262 | doNextStep useSelected = do 263 | as <- get 264 | let inputText = editText as 265 | name = fromMaybe (Left inputText) $ 266 | msum [ Right <$> if useSelected then snd <$> listSelectedElement (as^.asContext) else Nothing 267 | , Left <$> asMaybe (editText as) 268 | , Left <$> as^.asSuggestion 269 | ] 270 | s <- liftIO $ nextStep (as^.asJournal) (as^.asDateFormat) name (as^.asStep) 271 | case s of 272 | Left err -> asMessage .= err 273 | Right (Finished trans) -> do 274 | liftIO $ addToJournal trans (as^.asFilename) 275 | sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) (DateQuestion "") 276 | asStep .= DateQuestion "" 277 | asJournal %= addTransactionEnd trans 278 | asEditor %= clearEdit 279 | asContext .= ctxList V.empty 280 | asSuggestion .= sugg 281 | asMessage .= "Transaction written to journal file" 282 | asDialog .= NoDialog 283 | asInputHistory .= [] 284 | Right (Step s') -> do 285 | sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) s' 286 | ctx' <- ctxList . V.fromList <$> liftIO (context (as^.asJournal) (as^.asMatchAlgo) (as^.asDateFormat) "" s') 287 | asStep .= s' 288 | asEditor %= clearEdit 289 | asContext .= ctx' 290 | asSuggestion .= sugg 291 | asMessage .= "" 292 | -- Adhere to the 'undo' behaviour: when in the final 293 | -- confirmation question, 'undo' jumps back to the last amount 294 | -- question instead of to the last account question. So do not 295 | -- save the last empty account answer which indicates the end 296 | -- of the transaction. 297 | -- Furthermore, don't save the input if the FinalQuestion is 298 | -- answered by 'n' (for no). 299 | case (as^.asStep, s') of 300 | (FinalQuestion _ _, _) -> return () 301 | (_, FinalQuestion _ _) -> return () 302 | _ -> asInputHistory %= (inputText :) 303 | 304 | doUndo :: EventM n AppState () 305 | doUndo = use asStep >>= \s -> case undo s of 306 | Left msg -> asMessage .= "Undo failed: " <> msg 307 | Right step -> do 308 | as <- get 309 | let (lastInput,historyTail) = 310 | case as^.asInputHistory of 311 | x:t -> (x,t) 312 | [] -> ("",[]) 313 | 314 | sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) step 315 | asStep .= step 316 | asEditor %= setEdit lastInput 317 | asSuggestion .= sugg 318 | asMessage .= "Undo." 319 | asInputHistory .= historyTail 320 | setContext 321 | 322 | insertSelected :: AppState -> AppState 323 | insertSelected as = case listSelectedElement (as^.asContext) of 324 | Nothing -> as 325 | Just (_, line) -> as & asEditor %~ setEdit line 326 | 327 | 328 | asMaybe :: Text -> Maybe Text 329 | asMaybe t 330 | | T.null t = Nothing 331 | | otherwise = Just t 332 | 333 | attrs :: AttrMap 334 | attrs = attrMap defAttr 335 | [ (listSelectedAttr, black `on` white) 336 | , (helpAttr <> attrName "title", fg green) 337 | ] 338 | 339 | clearEdit :: Editor n -> Editor n 340 | clearEdit = setEdit "" 341 | 342 | setEdit :: Text -> Editor n -> Editor n 343 | setEdit content edit = edit & editContentsL .~ zipper 344 | where zipper = gotoEOL (textZipper [content] (Just 1)) 345 | 346 | addToJournal :: HL.Transaction -> FilePath -> IO () 347 | addToJournal trans path = appendFile path (T.unpack $ moveEmptyLine $ HL.showTransaction trans) 348 | where 349 | -- showTransactionUnelided adds an empty line to the end of the transaction. We want 350 | -- the empty line to be at the start instead, to allow it to be added to a 351 | -- journal that doesn't end with a newline. 352 | moveEmptyLine :: Text -> Text 353 | moveEmptyLine = T.unlines . ("":) . init . T.lines 354 | 355 | -------------------------------------------------------------------------------- 356 | -- Command line and config parsing 357 | -------------------------------------------------------------------------------- 358 | 359 | data CommonOptions f = CommonOptions 360 | { optLedgerFile :: f FilePath 361 | , optDateFormat :: f String 362 | , optMatchAlgo :: f MatchAlgo 363 | } 364 | 365 | instance Sem.Semigroup (CommonOptions Maybe) where 366 | (<>) opt1 opt2 = 367 | let opt1' = optNatTrans First opt1 368 | opt2' = optNatTrans First opt2 369 | in optNatTrans getFirst $ CommonOptions 370 | { optLedgerFile = optLedgerFile opt1' <> optLedgerFile opt2' 371 | , optDateFormat = optDateFormat opt1' <> optDateFormat opt2' 372 | , optMatchAlgo = optMatchAlgo opt1' <> optMatchAlgo opt2' 373 | } 374 | 375 | instance Monoid (CommonOptions Maybe) where 376 | mappend = (Sem.<>) 377 | mempty = CommonOptions Nothing Nothing Nothing 378 | 379 | optNatTrans :: (forall a. f a -> g a) -> CommonOptions f -> CommonOptions g 380 | optNatTrans nat opts = CommonOptions 381 | { optLedgerFile = nat $ optLedgerFile opts 382 | , optDateFormat = nat $ optDateFormat opts 383 | , optMatchAlgo = nat $ optMatchAlgo opts 384 | } 385 | 386 | optFromJust :: CommonOptions Identity -> CommonOptions Maybe -> CommonOptions Identity 387 | optFromJust def opts = 388 | optNatTrans (Identity . fromJust) ( opts <> optNatTrans (Just . runIdentity) def) 389 | 390 | data CmdLineOptions = CmdLineOptions 391 | { cmdCommon :: CommonOptions Maybe 392 | , cmdDumpConfig :: Bool 393 | , cmdVersion :: Bool 394 | } 395 | 396 | data ConfOptions = ConfOptions { confCommon :: CommonOptions Maybe } 397 | 398 | defaultOptions :: FilePath -> CommonOptions Identity 399 | defaultOptions home = CommonOptions 400 | { optLedgerFile = Identity (ledgerPath home) 401 | , optDateFormat = Identity "[[%y/]%m/]%d" 402 | , optMatchAlgo = Identity Substrings 403 | } 404 | 405 | ledgerPath :: FilePath -> FilePath 406 | ledgerPath home = home <> "/.hledger.journal" 407 | 408 | configPath :: IO FilePath 409 | configPath = getUserConfigFile "hledger-iadd" "config.conf" 410 | 411 | -- | Megaparsec parser for MatchAlgo, used for config file parsing 412 | parseMatchAlgo :: OParser MatchAlgo 413 | parseMatchAlgo = (P.string "fuzzy" *> pure Fuzzy) 414 | <|> (P.string "substrings" *> pure Substrings) 415 | 416 | -- | ReadM parser for MatchAlgo, used for command line option parsing 417 | readMatchAlgo :: ReadM MatchAlgo 418 | readMatchAlgo = eitherReader reader 419 | where 420 | reader str 421 | | str == "fuzzy" = return Fuzzy 422 | | str == "substrings" = return Substrings 423 | | otherwise = Left "Expected \"fuzzy\" or \"substrings\"" 424 | 425 | -- | Parser for our config file 426 | confParser :: CommonOptions Identity -> OptParser ConfOptions 427 | confParser def = fmap ConfOptions $ CommonOptions 428 | -- TODO Convert leading tilde to home 429 | <$> (Just <$> option "file" (runIdentity $ optLedgerFile def) "Path to the journal file") 430 | <*> (Just <$> option "date-format" (runIdentity $ optDateFormat def) "Format used to parse dates") 431 | <*> (Just <$> customOption "completion-engine" matchAlgo (T.toLower $ T.pack $ show matchAlgo) 432 | ( "Algorithm used to find completions for account names. Possible values are:\n" 433 | <> " - substrings: Every word in the search string has to occur somewhere in the account name\n" 434 | <> " - fuzzy: All letters from the search string have to appear in the name in the same order" 435 | ) 436 | "string" 437 | parseMatchAlgo 438 | ) 439 | 440 | where matchAlgo = runIdentity (optMatchAlgo def) 441 | 442 | -- | IO Action to read and parse config file 443 | parseConfigFile :: IO ConfOptions 444 | parseConfigFile = do 445 | path <- configPath 446 | home <- getHomeDirectory 447 | let def = defaultOptions home 448 | 449 | try (T.readFile path) >>= \case 450 | Left (_ :: SomeException) -> return (parserDefault $ confParser def) 451 | Right res -> case parseConfig path res (confParser def) of 452 | Left err -> do 453 | putStr (P.errorBundlePretty err) 454 | exitFailure 455 | Right res' -> return res' 456 | 457 | -- | command line option parser 458 | cmdOptionParser :: Parser CmdLineOptions 459 | cmdOptionParser = CmdLineOptions 460 | <$> (CommonOptions 461 | <$> OA.option (Just <$> OA.str) 462 | ( long "file" 463 | <> short 'f' 464 | <> metavar "FILE" 465 | <> value Nothing 466 | <> help "Path to the journal file" 467 | ) 468 | <*> OA.option (Just <$> OA.str) 469 | ( long "date-format" 470 | <> metavar "FORMAT" 471 | <> value Nothing 472 | <> help "Format used to parse dates" 473 | ) 474 | <*> OA.option (Just <$> readMatchAlgo) 475 | ( long "completion-engine" 476 | <> metavar "ENGINE" 477 | <> value Nothing 478 | <> help "Algorithm for account name completion. Possible values: \"fuzzy\", \"substrings\"") 479 | ) 480 | <*> switch 481 | ( long "dump-default-config" 482 | <> help "Print an example configuration file to stdout and exit" 483 | ) 484 | <*> switch 485 | ( long "version" 486 | <> help "Print version number and exit" 487 | ) 488 | 489 | parseEnvVariables :: IO (CommonOptions Maybe) 490 | parseEnvVariables = do 491 | maybeFilePath <- lookupEnv "LEDGER_FILE" 492 | return mempty 493 | { optLedgerFile = maybeFilePath } 494 | 495 | main :: IO () 496 | main = do 497 | home <- getHomeDirectory 498 | path <- configPath 499 | let defOpts = defaultOptions home 500 | 501 | cmdOpts <- execParser $ info (helper <*> cmdOptionParser) $ 502 | fullDesc <> header "A terminal UI as drop-in replacement for hledger add." 503 | 504 | when (cmdVersion cmdOpts) $ do 505 | putStrLn $ "This is hledger-iadd version " <> showVersion Paths.version 506 | exitSuccess 507 | 508 | when (cmdDumpConfig cmdOpts) $ do 509 | T.putStrLn $ "# Write this to " <> T.pack path <> "\n" 510 | T.putStrLn (parserExample $ confParser defOpts) 511 | exitSuccess 512 | 513 | confOpts <- parseConfigFile 514 | 515 | envOpts <- parseEnvVariables 516 | 517 | -- The order of precedence here is: 518 | -- arguments > environment > config file 519 | let opts = optFromJust defOpts $ cmdCommon cmdOpts <> envOpts <> confCommon confOpts 520 | 521 | date <- case parseDateFormat (T.pack $ runIdentity $ optDateFormat opts) of 522 | Left err -> do 523 | hPutStr stderr "Could not parse date format: " 524 | T.hPutStr stderr err 525 | exitFailure 526 | Right res -> return res 527 | 528 | let path = runIdentity $ optLedgerFile opts 529 | journalContents <- T.readFile path 530 | 531 | let hlIopts = HL.definputopts 532 | 533 | runExceptT (HL.parseAndFinaliseJournal (HL.journalp hlIopts) hlIopts path journalContents) >>= \case 534 | Left err -> hPutStrLn stderr err >> exitFailure 535 | Right journal -> do 536 | let edit = editorText EditorName (txt . T.concat) (Just 1) "" 537 | 538 | sugg <- suggest journal date (DateQuestion "") 539 | 540 | let welcome = "Welcome! Press F1 (or Alt-?) for help. Exit with Ctrl-d." 541 | matchAlgo = runIdentity $ optMatchAlgo opts 542 | as = AppState edit (DateQuestion "") journal (ctxList V.empty) sugg welcome path date matchAlgo NoDialog [] 543 | 544 | void $ defaultMain app as 545 | 546 | where app = App { appDraw = draw 547 | , appChooseCursor = showFirstCursor 548 | , appHandleEvent = event 549 | , appAttrMap = const attrs 550 | , appStartEvent = return () 551 | } :: App AppState Event Name 552 | 553 | expand :: Widget n -> Widget n 554 | expand = padBottom Max 555 | 556 | ctxList :: V.Vector e -> List Name e 557 | ctxList v = (if V.null v then id else listMoveTo 0) $ list ListName v 1 558 | --------------------------------------------------------------------------------