477 lines
		
	
	
		
			20 KiB
		
	
	
	
		
			Haskell
		
	
	
		
			Executable File
		
	
	
	
	
			
		
		
	
	
			477 lines
		
	
	
		
			20 KiB
		
	
	
	
		
			Haskell
		
	
	
		
			Executable File
		
	
	
	
	
#!/usr/bin/env stack
 | 
						|
{- stack runghc --verbosity info
 | 
						|
  --package filepath
 | 
						|
  --package hledger-lib
 | 
						|
  --package optparse-applicative
 | 
						|
  --package megaparsec
 | 
						|
  --package text
 | 
						|
  --package time
 | 
						|
  --package transformers
 | 
						|
-}
 | 
						|
{-
 | 
						|
 | 
						|
```
 | 
						|
Usage: hledger-check [-f|--file FILE] [--alias OLD=NEW] [--ignore-assertions]
 | 
						|
                     [-b|--begin DATE] [-e|--end DATE] [-C|--cleared]
 | 
						|
                     [--pending] [-U|--uncleared] [-R|--real] [--sunday]
 | 
						|
                     [-D|--daily ASSERT] [-W|--weekly ASSERT]
 | 
						|
                     [-M|--monthly ASSERT] [-Q|--quarterly ASSERT]
 | 
						|
                     [-Y|--yearly ASSERT] [ASSERT]
 | 
						|
  Complex account balance assertions for hledger journals.
 | 
						|
 | 
						|
Available options:
 | 
						|
  -h,--help                Show this help text
 | 
						|
  -f,--file FILE           use a different input file. For stdin, use -
 | 
						|
  --alias OLD=NEW          display accounts named OLD as NEW
 | 
						|
  --ignore-assertions      ignore any balance assertions in the journal
 | 
						|
  -b,--begin DATE          include postings/txns on or after this date
 | 
						|
  -e,--end DATE            include postings/txns before this date
 | 
						|
  -C,--cleared             include only cleared postings/txns
 | 
						|
  --pending                include only pending postings/txns
 | 
						|
  -U,--uncleared           include only uncleared (and pending) postings/txns
 | 
						|
  -R,--real                include only non-virtual postings
 | 
						|
  --sunday                 weeks start on Sunday
 | 
						|
  -D,--daily ASSERT        assertions that must hold at the end of the day
 | 
						|
  -W,--weekly ASSERT       assertions that must hold at the end of the week
 | 
						|
  -M,--monthly ASSERT      assertions that must hold at the end of the month
 | 
						|
  -Q,--quarterly ASSERT    assertions that must hold at the end of the quarter
 | 
						|
  -Y,--yearly ASSERT       assertions that must hold at the end of the year
 | 
						|
  ASSERT                   assertions that must hold after every transaction
 | 
						|
```
 | 
						|
 | 
						|
Comparison: `<value OR account name>  cmp  <value OR account name>`
 | 
						|
-------------------------------------------------------------------
 | 
						|
 | 
						|
In the simplest form, an assertion is just a comparison between
 | 
						|
values. A value is either an amount or an account name (both as
 | 
						|
defined by hledger). The comparison operators are `<`, `<=`, `==`,
 | 
						|
`>=`, `>`, and `!=` (with the obvious meanings).
 | 
						|
 | 
						|
Normally, the name of an account refers to the balance of that account
 | 
						|
only, without including subaccounts. The syntax `* AccountName` refers
 | 
						|
to the sum of the values in both that account and its subaccounts.
 | 
						|
 | 
						|
**Example:**
 | 
						|
```
 | 
						|
hledger-invariant -D "budget:books  >= £0"
 | 
						|
```
 | 
						|
 | 
						|
"At the end of every day, the books budget is greater than or equal to
 | 
						|
£0", implying that if I overspend, I need to take the money out of
 | 
						|
some other account. Note the double space after `budget:books`, this
 | 
						|
is because account names can contain single spaces.
 | 
						|
 | 
						|
Combination: `<assertion>  op  <assertion>`
 | 
						|
-------------------------------------------
 | 
						|
 | 
						|
Assertions can be combined with logical connectives. The connectives
 | 
						|
are `&&`, `||`, `==>`, and `<==>` (with the obvious meanings).
 | 
						|
Assertions can also be wrapped inside parentheses.
 | 
						|
 | 
						|
**Example:**
 | 
						|
```
 | 
						|
hledger-invariant "(assets:overdraft  < £2000) ==> (*assets:checking  == £0)"
 | 
						|
```
 | 
						|
 | 
						|
"If I have taken money from my overdraft, then I must have no money in
 | 
						|
my checking account (including subaccounts)."
 | 
						|
-}
 | 
						|
module Main where
 | 
						|
 | 
						|
import Control.Arrow (first)
 | 
						|
import Control.Monad (mplus, mzero, unless, void)
 | 
						|
import Control.Monad.Trans.Class (lift)
 | 
						|
import Control.Monad.Trans.State.Strict (runStateT)
 | 
						|
import Data.Function (on)
 | 
						|
import Data.Functor.Identity (Identity(..))
 | 
						|
import Data.List (foldl', groupBy, intercalate, nub, sortOn)
 | 
						|
import Data.List.NonEmpty (NonEmpty(..), nonEmpty, toList)
 | 
						|
import Data.Maybe (fromMaybe, mapMaybe)
 | 
						|
import Data.Monoid ((<>))
 | 
						|
import Data.Time.Calendar (toGregorian)
 | 
						|
import Data.Time.Calendar.OrdinalDate (mondayStartWeek, sundayStartWeek, toOrdinalDate)
 | 
						|
import Data.Text (isPrefixOf, pack, unpack)
 | 
						|
import qualified Hledger.Data as H
 | 
						|
import qualified Hledger.Query as H
 | 
						|
import qualified Hledger.Read as H
 | 
						|
import qualified Hledger.Utils.Parse as H
 | 
						|
import Options.Applicative
 | 
						|
import System.Exit (exitFailure)
 | 
						|
import System.FilePath (FilePath)
 | 
						|
import qualified Text.Megaparsec as P
 | 
						|
import qualified Text.Megaparsec.Text as P
 | 
						|
 | 
						|
main :: IO ()
 | 
						|
main = do
 | 
						|
    opts <- execParser args
 | 
						|
    journalFile <- maybe H.defaultJournalPath pure (file opts)
 | 
						|
    ejournal    <- H.readJournalFile Nothing Nothing (not $ ignoreAssertions opts) journalFile
 | 
						|
    case ejournal of
 | 
						|
      Right j -> do
 | 
						|
        (journal, starting) <- fixupJournal opts j
 | 
						|
        let postings = H.journalPostings journal
 | 
						|
        b1 <- checkAssertions starting (assertionsAlways    opts) (groupByNE ((==) `on` H.ptransaction) postings)
 | 
						|
        b2 <- checkAssertions starting (assertionsDaily     opts) (groupByNE sameDay     postings)
 | 
						|
        b3 <- checkAssertions starting (assertionsWeekly    opts) (groupByNE (sameWeek (sunday opts))   postings)
 | 
						|
        b4 <- checkAssertions starting (assertionsMonthly   opts) (groupByNE sameMonth   postings)
 | 
						|
        b5 <- checkAssertions starting (assertionsQuarterly opts) (groupByNE sameQuarter postings)
 | 
						|
        b6 <- checkAssertions starting (assertionsYearly    opts) (groupByNE sameYear    postings)
 | 
						|
        unless (b1 && b2 && b3 && b4 && b5 && b6)
 | 
						|
          exitFailure
 | 
						|
      Left err -> putStrLn err >> exitFailure
 | 
						|
 | 
						|
 | 
						|
-------------------------------------------------------------------------------
 | 
						|
-- Assertions
 | 
						|
 | 
						|
-- | Check assertions against a collection of grouped postings:
 | 
						|
-- assertions must hold when all postings in the group have been
 | 
						|
-- applied. Print out errors as they are found.
 | 
						|
checkAssertions :: [(H.AccountName, H.MixedAmount)] -> [(String, Predicate)] -> [NonEmpty H.Posting] -> IO Bool
 | 
						|
checkAssertions balances0 asserts0 postingss
 | 
						|
    | null failed = pure True
 | 
						|
    | otherwise = putStrLn (intercalate "\n\n" failed) >> pure False
 | 
						|
  where
 | 
						|
    (_, _, failed) = foldl' applyAndCheck (balances0, asserts0, []) postingss
 | 
						|
 | 
						|
    -- Apply a collection of postings and check the assertions.
 | 
						|
    applyAndCheck :: ([(H.AccountName, H.MixedAmount)], [(String, Predicate)], [String])
 | 
						|
                  -> NonEmpty H.Posting
 | 
						|
                  -> ([(H.AccountName, H.MixedAmount)], [(String, Predicate)], [String])
 | 
						|
    applyAndCheck (starting, asserts, errs) ps =
 | 
						|
      let ps' = toList ps
 | 
						|
          closing  = starting `addAccounts` closingBalances' ps'
 | 
						|
          checked  = map (\a -> (a, check (last ps') closing a)) asserts
 | 
						|
          asserts' = [a | (a, Nothing) <- checked]
 | 
						|
          errs'    = [e | (_, Just e)  <- checked]
 | 
						|
      in (closing, asserts', errs ++ errs')
 | 
						|
 | 
						|
    -- Check an assertion against a collection of account balances,
 | 
						|
    -- and return an error on failure.
 | 
						|
    check :: H.Posting -> [(H.AccountName, H.MixedAmount)] -> (String, Predicate) -> Maybe String
 | 
						|
    check lastp balances (pstr, p)
 | 
						|
      | checkAssertion balances p = Nothing
 | 
						|
      | otherwise = Just . unlines $
 | 
						|
          let after = case H.ptransaction lastp of
 | 
						|
                Just t  ->
 | 
						|
                  "after transaction:\n" ++ H.showTransaction t ++
 | 
						|
                  "(after posting: " ++ init (H.showPosting lastp) ++ ")\n\n"
 | 
						|
                Nothing ->
 | 
						|
                  "after posting:\n" ++ H.showPosting lastp
 | 
						|
 | 
						|
              -- Restrict to accounts mentioned in the predicate, and pretty-print balances
 | 
						|
              balances' = map (first unpack) $ filter (flip inAssertion p . fst) balances
 | 
						|
              maxalen   = maximum $ map (length . fst) balances'
 | 
						|
              accounts = [ a <> padding <> show m
 | 
						|
                         | (a,m) <- balances'
 | 
						|
                         , let padding = replicate (2 + maxalen - length a) ' '
 | 
						|
                         ]
 | 
						|
          in [ "assertion '" ++ pstr ++ "' violated", after ++ "relevant balances:"] ++ map ("    "++) accounts
 | 
						|
 | 
						|
-- | Check an assertion holds for a collection of account balances.
 | 
						|
checkAssertion :: [(H.AccountName, H.MixedAmount)] -> Predicate -> Bool
 | 
						|
checkAssertion accounts = checkAssertion'
 | 
						|
  where
 | 
						|
    checkAssertion' (Not p) = not (checkAssertion' p)
 | 
						|
    checkAssertion' (Connect p1 c p2) =
 | 
						|
      let p1' = checkAssertion' p1
 | 
						|
          p2' = checkAssertion' p2
 | 
						|
      in case c of
 | 
						|
          AND     -> p1' && p2'
 | 
						|
          OR      -> p1' || p2'
 | 
						|
          IMPLIES -> not p1' || p2'
 | 
						|
          IFF     -> p1' == p2'
 | 
						|
    checkAssertion' (Compare v1 c v2) =
 | 
						|
      let v1e = evaluate v1
 | 
						|
          v2e = evaluate v2
 | 
						|
          v1' = fixup v1e v2e
 | 
						|
          v2' = fixup v2e v1e
 | 
						|
      in case c of
 | 
						|
          LLT -> v1' <  v2'
 | 
						|
          EEQ -> v1' == v2'
 | 
						|
          GGT -> v1' >  v2'
 | 
						|
          LTE -> v1' <= v2'
 | 
						|
          NEQ -> v1' /= v2'
 | 
						|
          GTE -> v1' >= v2'
 | 
						|
 | 
						|
    evaluate (Account account) =
 | 
						|
      fromMaybe H.nullmixedamt $ lookup account accounts
 | 
						|
    evaluate (AccountNested account) =
 | 
						|
      sum [m | (a,m) <- accounts, account == a || (a <> pack ":") `isPrefixOf` account]
 | 
						|
    evaluate (Amount amount) = H.mixed [amount]
 | 
						|
 | 
						|
    -- Add missing amounts (with 0 value), normalise, throw away style
 | 
						|
    -- information, and sort by commodity name.
 | 
						|
    fixup (H.Mixed m1) (H.Mixed m2) = H.Mixed $
 | 
						|
      let m = H.Mixed (m1 ++ [m_ { H.aquantity = 0 } | m_ <- m2])
 | 
						|
          (H.Mixed as) = H.normaliseMixedAmount m
 | 
						|
      in sortOn H.acommodity . map (\a -> a { H.astyle = H.amountstyle }) $ as
 | 
						|
 | 
						|
-- | Check if an account name is mentioned in an assertion.
 | 
						|
inAssertion :: H.AccountName -> Predicate -> Bool
 | 
						|
inAssertion account = inAssertion'
 | 
						|
  where
 | 
						|
    inAssertion' (Not p) = not (inAssertion' p)
 | 
						|
    inAssertion' (Connect p1 _ p2) = inAssertion' p1 || inAssertion' p2
 | 
						|
    inAssertion' (Compare v1 _ v2) = inValue v1 || inValue v2
 | 
						|
 | 
						|
    inValue (Account a) = account == a
 | 
						|
    inValue (AccountNested a) = account == a || (a <> pack ":") `isPrefixOf` account
 | 
						|
    inValue (Amount _) = False
 | 
						|
 | 
						|
 | 
						|
-------------------------------------------------------------------------------
 | 
						|
-- Journals
 | 
						|
 | 
						|
-- | Apply account aliases and restrict to the date range, return the
 | 
						|
-- starting balance of every account.
 | 
						|
fixupJournal :: Opts -> H.Journal -> IO (H.Journal, [(H.AccountName, H.MixedAmount)])
 | 
						|
fixupJournal opts j = do
 | 
						|
    today <- H.getCurrentDay
 | 
						|
    let j' = (if cleared   opts then H.filterJournalTransactions (H.Status H.Cleared)   else id)
 | 
						|
           . (if pending   opts then H.filterJournalTransactions (H.Status H.Pending)   else id)
 | 
						|
           . (if uncleared opts then H.filterJournalTransactions (H.Status H.Uncleared) else id)
 | 
						|
           . (if real      opts then H.filterJournalTransactions (H.Real   True)        else id)
 | 
						|
           $ H.journalApplyAliases (aliases opts) j
 | 
						|
    let starting = case begin opts of
 | 
						|
          Just _  ->
 | 
						|
              let dateSpan = H.DateSpan Nothing (fixDay today begin)
 | 
						|
              in closingBalances (H.filterJournalPostings (H.Date dateSpan) j')
 | 
						|
          Nothing -> []
 | 
						|
    let dateSpan = H.DateSpan (fixDay today begin) (fixDay today end)
 | 
						|
    pure (H.filterJournalTransactions (H.Date dateSpan) j', starting)
 | 
						|
 | 
						|
  where
 | 
						|
    fixDay today dayf = H.fixSmartDate today <$> dayf opts
 | 
						|
 | 
						|
-- | Get the closing balances of every account in the journal.
 | 
						|
closingBalances :: H.Journal -> [(H.AccountName, H.MixedAmount)]
 | 
						|
closingBalances = closingBalances' . H.journalPostings
 | 
						|
 | 
						|
-- | Get the closing balances of every account referenced by a group
 | 
						|
-- of postings.
 | 
						|
closingBalances' :: [H.Posting] -> [(H.AccountName, H.MixedAmount)]
 | 
						|
closingBalances' postings =
 | 
						|
  let postingsByAccount =
 | 
						|
        groupBy ((==) `on` H.paccount) . sortOn H.paccount $ postings
 | 
						|
  in map (\ps@(p:_) -> (H.paccount p, H.sumPostings ps)) postingsByAccount
 | 
						|
 | 
						|
-- | Add balances in matching accounts.
 | 
						|
addAccounts :: [(H.AccountName, H.MixedAmount)] -> [(H.AccountName, H.MixedAmount)] -> [(H.AccountName, H.MixedAmount)]
 | 
						|
addAccounts as1 as2 = [ (a, a1 + a2)
 | 
						|
                      | a <- nub (map fst as1 ++ map fst as2)
 | 
						|
                      , let a1 = fromMaybe H.nullmixedamt $ lookup a as1
 | 
						|
                      , let a2 = fromMaybe H.nullmixedamt $ lookup a as2
 | 
						|
                      ]
 | 
						|
 | 
						|
-------------------------------------------------------------------------------
 | 
						|
-- Dates
 | 
						|
 | 
						|
-- | Check if two postings are in the same day.
 | 
						|
sameDay :: H.Posting -> H.Posting -> Bool
 | 
						|
sameDay = sameish id
 | 
						|
 | 
						|
-- | Check if two postings are in the same week.
 | 
						|
sameWeek :: Bool -> H.Posting -> H.Posting -> Bool
 | 
						|
sameWeek startSunday p1 p2 =
 | 
						|
  let startWeek = if startSunday then sundayStartWeek else mondayStartWeek
 | 
						|
      d1 = H.postingDate p1
 | 
						|
      d2 = H.postingDate p2
 | 
						|
      y1 = fst (toOrdinalDate d1)
 | 
						|
      y2 = fst (toOrdinalDate d2)
 | 
						|
      w1 = fst (startWeek d1)
 | 
						|
      w2 = fst (startWeek d2)
 | 
						|
      sameYearSameWeek =   y1 == y2   && w1 == w2
 | 
						|
      week0Week52      =   y1 == y2+1 && w1 == 0  && w2 == 52
 | 
						|
      week52Week0      = 1+y1 == y2   && w1 == 52 && w2 == 0
 | 
						|
  in sameYearSameWeek || week0Week52 || week52Week0
 | 
						|
 | 
						|
-- | Check if two postings are in the same month.
 | 
						|
sameMonth :: H.Posting -> H.Posting -> Bool
 | 
						|
sameMonth = sameish (\(y,m,_) -> (y,m))
 | 
						|
 | 
						|
-- | Check if two postings are in the same quarter.
 | 
						|
sameQuarter :: H.Posting -> H.Posting -> Bool
 | 
						|
sameQuarter = sameish (\(y,m,_) -> (y, m `div` 4))
 | 
						|
 | 
						|
-- | Check if two postings are in the same year.
 | 
						|
sameYear :: H.Posting -> H.Posting -> Bool
 | 
						|
sameYear = sameish (\(y,_,_) -> y)
 | 
						|
 | 
						|
 | 
						|
-------------------------------------------------------------------------------
 | 
						|
-- Command-line Arguments
 | 
						|
 | 
						|
-- | Parsed command-line arguments.
 | 
						|
data Opts = Opts
 | 
						|
    { file :: Maybe FilePath
 | 
						|
    -- ^ Path to journal file.
 | 
						|
    , aliases :: [H.AccountAlias]
 | 
						|
    -- ^ Account name aliases: (OLD, NEW).
 | 
						|
    , ignoreAssertions :: Bool
 | 
						|
    -- ^ Ignore balance assertions while reading the journal file (but
 | 
						|
    -- still apply any given to this tool.
 | 
						|
    , begin :: Maybe H.SmartDate
 | 
						|
    -- ^ Exclude postings/txns before this date.
 | 
						|
    , end :: Maybe H.SmartDate
 | 
						|
    -- ^ Exclude postings/txns on or after this date.
 | 
						|
    , cleared :: Bool
 | 
						|
    -- ^ Include only cleared postings/txns.
 | 
						|
    , pending :: Bool
 | 
						|
    -- ^ Include only pending postings/txns.
 | 
						|
    , uncleared :: Bool
 | 
						|
    -- ^ Include only uncleared (and pending) postings/txns.
 | 
						|
    , real :: Bool
 | 
						|
    -- ^ Include only non-virtual postings.
 | 
						|
    , sunday :: Bool
 | 
						|
    -- ^ Week starts on Sunday.
 | 
						|
    , assertionsDaily :: [(String, Predicate)]
 | 
						|
    -- ^ Account assertions that must hold at the end of each day.
 | 
						|
    , assertionsWeekly :: [(String, Predicate)]
 | 
						|
    -- ^ Account assertions that must hold at the end of each week.
 | 
						|
    , assertionsMonthly :: [(String, Predicate)]
 | 
						|
    -- ^ Account assertions that must hold at the end of each month.
 | 
						|
    , assertionsQuarterly :: [(String, Predicate)]
 | 
						|
    -- ^ Account assertions that must hold at the end of each quarter.
 | 
						|
    , assertionsYearly :: [(String, Predicate)]
 | 
						|
    -- ^ Account assertions that must hold at the end of each year.
 | 
						|
    , assertionsAlways :: [(String, Predicate)]
 | 
						|
    -- ^ Account assertions that must hold after each txn.
 | 
						|
    }
 | 
						|
  deriving (Eq, Ord, Show)
 | 
						|
 | 
						|
-- | Command-line arguments.
 | 
						|
args :: ParserInfo Opts
 | 
						|
args = info (helper <*> parser) $ mconcat
 | 
						|
    [ fullDesc
 | 
						|
    , progDesc "Complex account balance assertions for hledger journals."
 | 
						|
    ]
 | 
						|
  where
 | 
						|
    parser = Opts <$> (optional . strOption)
 | 
						|
                        (arg 'f' "file" "use a different input file. For stdin, use -"             <> metavar "FILE")
 | 
						|
                  <*> (many . fmap snd . popt (lift H.accountaliasp))
 | 
						|
                        (arg' "alias" "display accounts named OLD as NEW"                          <> metavar "OLD=NEW")
 | 
						|
                  <*> switch
 | 
						|
                        (arg' "ignore-assertions" "ignore any balance assertions in the journal")
 | 
						|
                  <*> (optional . fmap snd . popt' H.smartdate)
 | 
						|
                        (arg 'b' "begin" "include postings/txns on or after this date"             <> metavar "DATE")
 | 
						|
                  <*> (optional . fmap snd . popt' H.smartdate)
 | 
						|
                        (arg 'e' "end" "include postings/txns before this date"                    <> metavar "DATE")
 | 
						|
                  <*> switch
 | 
						|
                        (arg 'C' "cleared" "include only cleared postings/txns")
 | 
						|
                  <*> switch
 | 
						|
                        (arg' "pending" "include only pending postings/txns")
 | 
						|
                  <*> switch
 | 
						|
                        (arg 'U' "uncleared" "include only uncleared (and pending) postings/txns")
 | 
						|
                  <*> switch
 | 
						|
                        (arg 'R' "real" "include only non-virtual postings")
 | 
						|
                  <*> switch
 | 
						|
                        (arg' "sunday" "weeks start on Sunday")
 | 
						|
                  <*> (many . popt predicatep)
 | 
						|
                        (arg 'D' "daily" "assertions that must hold at the end of the day"         <> metavar "ASSERT")
 | 
						|
                  <*> (many . popt predicatep)
 | 
						|
                        (arg 'W' "weekly" "assertions that must hold at the end of the week"       <> metavar "ASSERT")
 | 
						|
                  <*> (many . popt predicatep)
 | 
						|
                        (arg 'M' "monthly" "assertions that must hold at the end of the month"     <> metavar "ASSERT")
 | 
						|
                  <*> (many . popt predicatep)
 | 
						|
                        (arg 'Q' "quarterly" "assertions that must hold at the end of the quarter" <> metavar "ASSERT")
 | 
						|
                  <*> (many . popt predicatep)
 | 
						|
                        (arg 'Y' "yearly" "assertions that must hold at the end of the year"       <> metavar "ASSERT")
 | 
						|
                  <*> (many . parg predicatep)
 | 
						|
                        (help "assertions that must hold after every transaction"                  <> metavar "ASSERT")
 | 
						|
 | 
						|
    -- Shorthand for options
 | 
						|
    arg s l h = arg' l h <> short s
 | 
						|
    arg'  l h = long l <> help h
 | 
						|
 | 
						|
    -- Arguments and options from a Megaparsec parser.
 | 
						|
    parg = argument . readParsec
 | 
						|
    popt = option . readParsec
 | 
						|
    popt' = option . readParsec'
 | 
						|
 | 
						|
    -- Turn a Parsec parser into a ReadM parser that also returns the
 | 
						|
    -- input.
 | 
						|
    readParsec :: H.JournalStateParser ReadM a -> ReadM (String, a)
 | 
						|
    readParsec p = do
 | 
						|
      s <- str
 | 
						|
      parsed <- P.runParserT (runStateT p H.nulljournal) "" (pack s)
 | 
						|
      case parsed of
 | 
						|
        Right (a, _) -> pure (s, a)
 | 
						|
        Left err -> fail ("failed to parse input '" ++ s ++ "': " ++ show err)
 | 
						|
 | 
						|
    readParsec' :: P.Parser a -> ReadM (String, a)
 | 
						|
    readParsec' p = do
 | 
						|
      s <- str
 | 
						|
      let parsed = runIdentity $ P.runParserT p "" (pack s)
 | 
						|
      case parsed of
 | 
						|
        Right a -> pure (s, a)
 | 
						|
        Left err -> fail ("failed to parse input '" ++ s ++ "': " ++ show err)
 | 
						|
 | 
						|
 | 
						|
-------------------------------------------------------------------------------
 | 
						|
-- Predicates & Parsers
 | 
						|
 | 
						|
data Predicate
 | 
						|
    = Compare Value Compare Value
 | 
						|
    | Connect Predicate Connect Predicate
 | 
						|
    | Not Predicate
 | 
						|
  deriving (Eq, Ord, Show)
 | 
						|
 | 
						|
-- | Parse a 'Predicate'.
 | 
						|
predicatep :: Monad m => H.JournalStateParser m Predicate
 | 
						|
predicatep = wrap predparensp <|> wrap predcomparep <|> wrap prednotp where
 | 
						|
    predparensp  = P.char '(' *> spaces *> predicatep <* spaces <* P.char ')'
 | 
						|
    predcomparep = Compare <$> valuep <*> (spaces *> lift comparep <* spaces) <*> valuep
 | 
						|
    prednotp     = void (P.char '!') *> (Not <$> predicatep)
 | 
						|
    spaces = void . many $ P.char ' '
 | 
						|
 | 
						|
    wrap p = do
 | 
						|
        a <- P.try p
 | 
						|
        spaces
 | 
						|
        P.try (wrap $ do c <- lift connectp; spaces; a2 <- p; pure $ Connect a c a2) <|> pure a
 | 
						|
 | 
						|
data Value = Account H.AccountName | AccountNested H.AccountName | Amount H.Amount
 | 
						|
  deriving (Eq, Ord, Show)
 | 
						|
 | 
						|
-- | Parse a 'Value'.
 | 
						|
valuep :: Monad m => H.JournalStateParser m Value
 | 
						|
-- Account name parser has to come last because they eat everything.
 | 
						|
valuep = valueamountp <|> valueaccountnestedp <|> valueaccountp where
 | 
						|
    valueamountp  = Amount  <$> H.amountp
 | 
						|
    valueaccountp = Account <$> lift H.accountnamep
 | 
						|
    valueaccountnestedp = AccountNested <$> (P.char '*' *> spaces *> lift H.accountnamep)
 | 
						|
    spaces = void . many $ P.char ' '
 | 
						|
 | 
						|
data Compare = LLT | EEQ | GGT | LTE | NEQ | GTE
 | 
						|
  deriving (Eq, Ord, Read, Show, Bounded, Enum)
 | 
						|
 | 
						|
-- | Parse a 'Compare'.
 | 
						|
comparep :: Monad m => H.TextParser m Compare
 | 
						|
comparep = gostringsp [("<=", LTE), ("<", LLT), ("==", EEQ), (">=", GTE), (">", GGT), ("!=", NEQ)]
 | 
						|
 | 
						|
data Connect = AND | OR | IMPLIES | IFF
 | 
						|
  deriving (Eq, Ord, Read, Show, Bounded, Enum)
 | 
						|
 | 
						|
-- | Parse a 'Connect'.
 | 
						|
connectp :: Monad m => H.TextParser m Connect
 | 
						|
connectp = gostringsp [("&&", AND), ("||", OR), ("==>", IMPLIES), ("<==>", IFF)]
 | 
						|
 | 
						|
 | 
						|
-------------------------------------------------------------------------------
 | 
						|
-- Utilities
 | 
						|
 | 
						|
-- | Group values in a list into nonempty subsequences.
 | 
						|
groupByNE :: (a -> a -> Bool) -> [a] -> [NonEmpty a]
 | 
						|
groupByNE f = mapMaybe nonEmpty . groupBy f
 | 
						|
 | 
						|
-- | Check if two postings are on the sameish date, given a function
 | 
						|
-- to convert the posting date (in (Y,M,D) format) to some comparable
 | 
						|
-- value.
 | 
						|
sameish :: Eq a => ((Integer, Int, Int) -> a) -> H.Posting -> H.Posting -> Bool
 | 
						|
sameish f = (==) `on` f . toGregorian . H.postingDate
 | 
						|
 | 
						|
-- | Helper for 'Compare' and 'Connect' parsers.
 | 
						|
gostringsp :: Monad m => [(String, a)] -> H.TextParser m a
 | 
						|
gostringsp ((s,a):rest) = P.try (P.string s *> pure a) `mplus` gostringsp rest
 | 
						|
gostringsp [] = mzero
 |