diff --git a/bin/hledger-check.hs b/bin/hledger-check.hs new file mode 100755 index 000000000..73e517230 --- /dev/null +++ b/bin/hledger-check.hs @@ -0,0 +1,475 @@ +#!/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: ` cmp ` +------------------------------------------------------------------- + +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: ` op ` +------------------------------------------- + +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.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