Add hledger-check script.
This commit is contained in:
Michael Walker
Simon Michael
parent
0a8212bda3
commit
66e33e0b0a
475
bin/hledger-check.hs
Executable file
475
bin/hledger-check.hs
Executable file
@ -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: `<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.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
|
||||
Loading…
Reference in New Issue
Block a user