exchangealgebra-0.6.0.0: src/ExchangeAlgebra/IO/Input/Checked.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-}
{- |
Module : ExchangeAlgebra.IO.Input.Checked
Description : Checked construction for externally generated journal entries.
This module adds a validation layer for LLM- or runner-generated postings before
they are admitted as exchange-algebra terms. The unchecked constructor
'ExchangeAlgebra.IO.Input.Conversion.journalFromSides' deliberately preserves its historical
semantics and does not enforce balance; the functions here reject malformed
entries with structural errors instead.
-}
module ExchangeAlgebra.IO.Input.Checked
( -- $postingPolicy
ProcessingContext(..)
, EntryError(..)
, JournalError(..)
, JournalCert(..)
, SourceError(..)
, postingAllowedIn
, checkedEntryIn
, checkedEntry
, checkedEntryTextIn
, checkedEntryAccountTextIn
, checkedEntryText
, checkedJournalIn
, checkedJournal
, certifyJournalTextIn
, certifyJournalText
, reconcileSources
) where
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import qualified Data.Map.Strict as M
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import ExchangeAlgebra.Algebra.Core (Alg, Redundant((.+), norm))
import ExchangeAlgebra.Algebra.Value.Class (HatVal(..), isErrorValue)
import ExchangeAlgebra.Accounting.Exchange (Exchange(decL, balance))
import ExchangeAlgebra.Accounting.Account.PostingPolicy
( ProcessingContext(..)
, postingAllowedIn
, postingCapabilityFor
)
import ExchangeAlgebra.Accounting.Account
( AccountTitles(..), PostingCapability(..), Side(..) )
import ExchangeAlgebra.Algebra.Base.Representation (HatBase)
import ExchangeAlgebra.IO.Input.Conversion
( ConvError
, journalFromSides
, normalizeTitle
, parseAccountTitle
, parseSide
)
import ExchangeAlgebra.Journal.Core
( Journal
, Note
, (.|)
, toMap
)
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.List.NonEmpty (NonEmpty)
-- >>> import ExchangeAlgebra.Algebra (Alg, Redundant((.+), norm))
-- >>> import ExchangeAlgebra.Accounting.Exchange (Exchange(decL))
-- >>> import ExchangeAlgebra.Algebra.Base (HatBase)
-- >>> import ExchangeAlgebra.Accounting.Account (AccountTitles(..), Side(..))
-- >>> import ExchangeAlgebra.IO.Input (journalFromSides)
-- >>> import ExchangeAlgebra.Journal (Journal)
-- $postingPolicy
-- 'ProcessingContext' and 'postingAllowedIn' are defined in
-- "ExchangeAlgebra.Accounting.PostingPolicy" and re-exported here so the
-- historical import path keeps working. The gate itself is accounting-domain
-- policy, not an input-adapter concern.
-- | Validation errors for a single generated entry.
--
-- Posting positions are 0-origin indices in the input entry.
data EntryError v
= EntryParse Int ConvError
| NonPositiveAmount Int AccountTitles v
| WildcardAccount Int
| WildcardSide Int
| PostingNotAllowed Int AccountTitles PostingCapability ProcessingContext
| EmptyEntry
| Imbalanced { _debitTotal :: v, _creditTotal :: v }
deriving (Show, Eq)
-- | Validation errors for a txid-indexed journal batch.
data JournalError n v
= EntryErrors n (NonEmpty (EntryError v))
| DuplicateTxId n
deriving (Show, Eq)
-- | Staged certification of a text-originated journal batch.
--
-- A batch can be fully admitted, rejected for accounting or structural
-- reasons, or certified as structurally valid and balanced while retaining
-- account-title resolution failures for a later vocabulary pass.
--
-- The distinction that motivates the type: an externally generated journal can
-- be double-entry valid and still name accounts this chart does not carry. Folding
-- both into one 'Either' makes a correct journal in an unsupported vocabulary
-- indistinguishable from a wrong one.
--
-- Note the two totals are /batch/ totals, whereas the balance test that gates
-- 'BalancedUnresolved' is applied per entry (per txid), matching 'checkedEntry'.
-- Per-entry balance implies batch balance, so the invariant
-- @_certDebitTotal == _certCreditTotal@ holds, but the converse does not: the
-- batch totals alone would not have been a sufficient gate.
data JournalCert n v
= FullyResolved (Journal n v (HatBase AccountTitles))
| BalancedUnresolved
{ _certResolved :: [(n, [(Side, AccountTitles, v)])]
, _certUnresolved :: [(n, [(Int, Text, ConvError)])]
, _certDebitTotal :: v
, _certCreditTotal :: v
}
| Rejected (NonEmpty (JournalError n v))
deriving (Show)
instance (HatVal v, Note n) => Eq (JournalCert n v) where
FullyResolved left == FullyResolved right = toMap left == toMap right
BalancedUnresolved resolvedLeft unresolvedLeft debitLeft creditLeft
== BalancedUnresolved resolvedRight unresolvedRight debitRight creditRight =
resolvedLeft == resolvedRight
&& unresolvedLeft == unresolvedRight
&& debitLeft == debitRight
&& creditLeft == creditRight
Rejected left == Rejected right = left == right
_ == _ = False
-- | Source-coverage errors between input transactions and a checked journal.
data SourceError n v
= MissingSource n
| UnknownSource n
| AmountMismatch n v v
deriving (Show, Eq)
-- | Construct one checked entry from parsed postings in a processing context.
--
-- The success value is built with 'journalFromSides', so accepted entries keep
-- the same posting semantics as the unchecked conversion path.
--
-- >>> fmap balance (checkedEntry [(Debit, Cash, 100), (Credit, Sales, 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)))
-- Right True
-- >>> checkedEntry [] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))
-- Left (EmptyEntry :| [])
-- >>> checkedEntry [(Debit, Cash, 0), (Credit, Sales, 0)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))
-- Left (NonPositiveAmount 0 Cash 0.0 :| [NonPositiveAmount 1 Sales 0.0])
-- >>> checkedEntry [(Debit, AccountTitle, 1), (Side, Cash, 1)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))
-- Left (WildcardAccount 0 :| [WildcardSide 1,Imbalanced {_debitTotal = 1.0, _creditTotal = 0.0}])
-- >>> checkedEntry [(Debit, Cash, 100), (Credit, Sales, 90)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))
-- Left (Imbalanced {_debitTotal = 100.0, _creditTotal = 90.0} :| [])
-- >>> fmap balance (checkedEntryIn ClosingProcess [(Debit, Sales, 100), (Credit, IncomeSummary, 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)))
-- Right True
checkedEntryIn :: (HatVal v)
=> ProcessingContext
-> [(Side, AccountTitles, v)]
-> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles))
checkedEntryIn context rows =
case validateIndexed context (null rows) indexed of
[] -> Right (journalFromSides rows)
e : es -> Left (e :| es)
where
indexed = zip [0..] rows
-- | Construct one ordinary-journal entry. This compatibility API delegates
-- to 'checkedEntryIn' and therefore rejects closing-only, consolidation-only,
-- engine-generated, and non-postable coordinates.
checkedEntry :: (HatVal v)
=> [(Side, AccountTitles, v)]
-> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles))
checkedEntry = checkedEntryIn OrdinaryJournal
-- | Parse text-side runner input and then apply 'checkedEntry' validation.
--
-- Parse errors are accumulated as 'EntryParse' instead of failing fast.
--
-- >>> fmap balance (checkedEntryText [("debit", "Cash", 100), ("credit", "Sales", 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)))
-- Right True
-- >>> checkedEntryText [("left", "Cash", 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))
-- Left (EntryParse 0 (UnknownSide "left") :| [])
-- >>> checkedEntryText [("debit", "Goodwill_X", 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))
-- Left (EntryParse 0 (UnknownAccount "Goodwill_X") :| [Imbalanced {_debitTotal = 100.0, _creditTotal = 0.0}])
checkedEntryTextIn :: (HatVal v)
=> ProcessingContext
-> [(Text, Text, v)]
-> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles))
checkedEntryTextIn context rows =
checkedEntryParsedIn context
[(i, (parseSide side, parseAccountTitle account, amount))
| (i, (side, account, amount)) <- zip [0..] rows]
-- | Check typed sides and account text in the supplied processing context.
-- Account parse errors precede structural errors and imbalance. Amounts from
-- unresolved accounts still contribute to the balance check.
checkedEntryAccountTextIn
:: HatVal v
=> ProcessingContext
-> [(Side, Text, v)]
-> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles))
checkedEntryAccountTextIn context rows =
checkedEntryParsedIn context
[(i, (Right side, parseAccountTitle account, amount))
| (i, (side, account, amount)) <- zip [0..] rows]
-- | Validate all indexed parse results without dropping unresolved rows.
-- An unresolved side suppresses imbalance; an unresolved account does not.
checkedEntryParsedIn
:: forall v. HatVal v
=> ProcessingContext
-> [(Int, (Either ConvError Side, Either ConvError AccountTitles, v))]
-> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles))
checkedEntryParsedIn context rows =
case parseErrors ++ structuralErrors ++ textImbalanceErrors of
[] -> Right (journalFromSides (map snd parsedRows))
e : es -> Left (e :| es)
where
parsed = map parseIndexed rows
parseErrors = concatMap first parsed
parsedRows = mapMaybe second parsed
sideAmounts = mapMaybe third parsed
structuralErrors = filter (not . isImbalance)
(validateIndexed context (null rows) parsedRows)
-- Account vocabulary resolution and arithmetic balance are independent.
-- Retain every successfully parsed side/amount pair so an unknown account
-- does not make an otherwise balanced entry look imbalanced.
textImbalanceErrors
| null rows = []
| length sideAmounts /= length rows = []
| any invalidSideAmount sideAmounts = []
| signAccum (mergeAccum debitState (negateAccum creditState)) == Just EQ = []
| otherwise = [Imbalanced debitTotal creditTotal]
where
debitState = L.foldl' (flip addAccum) emptyAccum
[ amount | (Debit, amount) <- sideAmounts ]
creditState = L.foldl' (flip addAccum) emptyAccum
[ amount | (Credit, amount) <- sideAmounts ]
debitTotal = roundAccum debitState
creditTotal = roundAccum creditState
invalidSideAmount :: (Side, v) -> Bool
invalidSideAmount (side, amount) =
side == Side || isErrorValue amount || not (amount > 0)
isImbalance :: EntryError v -> Bool
isImbalance Imbalanced{} = True
isImbalance _ = False
first :: (a, b, c) -> a
first (x, _, _) = x
second :: (a, b, c) -> b
second (_, x, _) = x
third :: (a, b, c) -> c
third (_, _, x) = x
parseIndexed
:: (Int, (Either ConvError Side, Either ConvError AccountTitles, v))
-> ([EntryError v], Maybe (Int, (Side, AccountTitles, v)), Maybe (Side, v))
parseIndexed (i, (sideResult, accountResult, amount)) =
let errs =
(case sideResult of
Left err -> [EntryParse i err]
Right _ -> [])
++ (case accountResult of
Left err -> [EntryParse i err]
Right _ -> [])
parsedRow = case (sideResult, accountResult) of
(Right side, Right account) -> Just (i, (side, account, amount))
_ -> Nothing
sideAmount = case sideResult of
Right side -> Just (side, amount)
Left _ -> Nothing
in (errs, parsedRow, sideAmount)
-- | Parse and check an ordinary-journal entry.
checkedEntryText :: (HatVal v)
=> [(Text, Text, v)]
-> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles))
checkedEntryText = checkedEntryTextIn OrdinaryJournal
-- | Construct a checked txid-indexed journal.
--
-- Duplicate txids are detected before entry construction, because the 'Journal'
-- representation merges equal notes.
--
-- >>> fmap (norm . decL) (checkedJournal [("tx1", [(Debit, Cash, 100), (Credit, Sales, 100)])] :: Either (NonEmpty (JournalError Text Double)) (Journal Text Double (HatBase AccountTitles)))
-- Right 100.0
-- >>> checkedJournal [("tx1", [(Debit, Cash, 100), (Credit, Sales, 100)]), ("tx1", [(Debit, Cash, 5), (Credit, Sales, 5)])] :: Either (NonEmpty (JournalError Text Double)) (Journal Text Double (HatBase AccountTitles))
-- Left (DuplicateTxId "tx1" :| [])
-- >>> checkedJournal [("bad", [(Debit, Cash, 1)])] :: Either (NonEmpty (JournalError Text Double)) (Journal Text Double (HatBase AccountTitles))
-- Left (EntryErrors "bad" (Imbalanced {_debitTotal = 1.0, _creditTotal = 0.0} :| []) :| [])
checkedJournalIn :: (HatVal v, Note n, Ord n)
=> ProcessingContext
-> [(n, [(Side, AccountTitles, v)])]
-> Either (NonEmpty (JournalError n v)) (Journal n v (HatBase AccountTitles))
checkedJournalIn context entries =
case duplicateErrors ++ entryErrors of
[] -> Right (L.foldl' (.+) mempty journals)
e : es -> Left (e :| es)
where
counts = M.fromListWith (+) [ (txid, 1 :: Int) | (txid, _) <- entries ]
isDuplicate txid = M.findWithDefault 0 txid counts > 1
duplicateErrors =
[ DuplicateTxId txid
| (txid, count) <- M.toList counts
, count > 1
]
checkedUnique =
[ (txid, checkedEntryIn context rows)
| (txid, rows) <- entries
, not (isDuplicate txid)
]
entryErrors =
[ EntryErrors txid errs
| (txid, Left errs) <- checkedUnique
]
journals =
[ alg .| txid
| (txid, Right alg) <- checkedUnique
]
-- | Construct an ordinary-journal batch.
checkedJournal :: (HatVal v, Note n, Ord n)
=> [(n, [(Side, AccountTitles, v)])]
-> Either (NonEmpty (JournalError n v)) (Journal n v (HatBase AccountTitles))
checkedJournal = checkedJournalIn OrdinaryJournal
-- | Certify a text-originated journal in stages.
--
-- Duplicate txids and structural errors are rejected before balance is
-- considered. Balance is then checked using only parsed sides and amounts,
-- independently of account-title resolution. Consequently, a structurally
-- valid and balanced batch whose only remaining failures are unknown or
-- ambiguous account titles is returned as 'BalancedUnresolved'.
certifyJournalTextIn :: (HatVal v, Note n, Ord n)
=> ProcessingContext
-> [(n, [(Text, Text, v)])]
-> JournalCert n v
certifyJournalTextIn context entries =
case duplicateErrors of
e : es -> Rejected (e :| es)
[] -> case structuralErrors of
e : es -> Rejected (e :| es)
[] -> case imbalanceErrors of
e : es -> Rejected (e :| es)
[]
| null unresolvedPostings ->
FullyResolved (L.foldl' (.+) mempty journals)
| otherwise ->
BalancedUnresolved
{ _certResolved = resolvedEntries
, _certUnresolved = unresolvedEntries
, _certDebitTotal = debitTotal
, _certCreditTotal = creditTotal
}
where
counts = M.fromListWith (+) [ (txid, 1 :: Int) | (txid, _) <- entries ]
duplicateErrors =
[ DuplicateTxId txid
| (txid, count) <- M.toList counts
, count > 1
]
parsedEntries =
[ (txid, map parseCertPosting (zip [0..] rows))
| (txid, rows) <- entries
]
structuralErrors =
[ EntryErrors txid (err :| errs)
| (txid, rows) <- parsedEntries
, let entryErrors = certStructuralErrors context rows
, err : errs <- [entryErrors]
]
imbalanceErrors =
[ EntryErrors txid (Imbalanced debit credit :| [])
| (txid, rows) <- parsedEntries
, let (debitState, creditState) = certTotals rows
, let debit = roundAccum debitState
, let credit = roundAccum creditState
, signAccum (mergeAccum debitState (negateAccum creditState)) /= Just EQ
]
resolvedEntries =
[ (txid, resolved)
| (txid, rows) <- parsedEntries
, let resolved =
[ (side, account, amount)
| (_, _, amount, Right side, Right account) <- rows
]
, not (null resolved)
]
unresolvedEntries =
[ (txid, unresolved)
| (txid, rows) <- parsedEntries
, let unresolved =
[ (i, accountText, err)
| (i, accountText, _, Right _, Left err) <- rows
]
, not (null unresolved)
]
unresolvedPostings = concatMap snd unresolvedEntries
(debitTotal, creditTotal) =
let (debitState, creditState) = L.foldl' addTotals (emptyAccum, emptyAccum)
(map (certTotals . snd) parsedEntries)
in (roundAccum debitState, roundAccum creditState)
addTotals (!debits, !credits) (!entryDebits, !entryCredits) =
let !debitTotal = mergeAccum debits entryDebits
!creditTotal = mergeAccum credits entryCredits
in (debitTotal, creditTotal)
journals =
[ journalFromSides rows .| txid
| (txid, rows) <- resolvedEntries
]
-- | Certify an ordinary-journal batch in stages.
certifyJournalText :: (HatVal v, Note n, Ord n)
=> [(n, [(Text, Text, v)])]
-> JournalCert n v
certifyJournalText = certifyJournalTextIn OrdinaryJournal
-- The tuple retains the original account text so resolution failures can be
-- reported without reconstructing user input.
type CertPosting v =
(Int, Text, v, Either ConvError Side, Either ConvError AccountTitles)
-- Wildcard names have to be recognized here rather than delegated to the
-- parsers: 'parseAccountTitle' and 'parseSide' reject the wildcard
-- constructors by design (the /correct-by-construction/ guard documented in
-- "ExchangeAlgebra.IO.Input.Conversion"), so on the text path a wildcard is indistinguishable
-- from an unknown name. Certification must tell them apart, because a wildcard
-- is a structural defect ('Rejected') whereas an unknown name is a vocabulary
-- gap ('BalancedUnresolved'). Matching uses the parsers' own 'normalizeTitle',
-- so the two paths cannot drift apart.
parseCertPosting :: (Int, (Text, Text, v)) -> CertPosting v
parseCertPosting (i, (sideText, accountText, amount)) =
( i
, accountText
, amount
, if normalizeTitle sideText == T.pack "side"
then Right Side
else parseSide sideText
, if normalizeTitle accountText == T.pack "accounttitle"
then Right AccountTitle
else parseAccountTitle accountText
)
certStructuralErrors :: (HatVal v)
=> ProcessingContext
-> [CertPosting v]
-> [EntryError v]
certStructuralErrors context rows =
[ EmptyEntry | null rows ] ++ concatMap rowErrors rows
where
rowErrors (i, _, amount, sideResult, accountResult) =
[ EntryParse i err | Left err <- [sideResult] ]
++ [ NonPositiveAmount i (resolvedOrWildcard accountResult) amount
| isErrorValue amount || not (amount > 0)
]
++ [ WildcardAccount i | Right AccountTitle <- [accountResult] ]
++ [ WildcardSide i | Right Side <- [sideResult] ]
++ [ PostingNotAllowed i account capability context
| Right account <- [accountResult]
, account /= AccountTitle
, let capability = postingCapabilityFor account
, not (postingAllowedIn context capability)
]
resolvedOrWildcard (Right account) = account
resolvedOrWildcard (Left _) = AccountTitle
certTotals :: (HatVal v) => [CertPosting v] -> (Accum v, Accum v)
certTotals rows =
( L.foldl' (flip addAccum) emptyAccum
[ amount | (_, _, amount, Right Debit, _) <- rows ]
, L.foldl' (flip addAccum) emptyAccum
[ amount | (_, _, amount, Right Credit, _) <- rows ]
)
-- | Compare source transactions against the note-indexed journal coverage.
--
-- The journal side is inspected with 'toMap', giving the per-note 'Alg'. The
-- actual amount is each note's debit-side total, @norm . decL@.
--
-- >>> let Right j = checkedJournal [("tx1", [(Debit, Cash, 100), (Credit, Sales, 100)])] :: Either (NonEmpty (JournalError Text Double)) (Journal Text Double (HatBase AccountTitles))
-- >>> reconcileSources [("tx1", 100)] j
-- []
-- >>> reconcileSources [("tx1", 90)] j
-- [AmountMismatch "tx1" 90.0 100.0]
-- >>> reconcileSources [("tx1", 100), ("tx2", 5)] j
-- [MissingSource "tx2"]
-- >>> let Right j2 = checkedJournal [("tx2", [(Debit, Cash, 5), (Credit, Sales, 5)])] :: Either (NonEmpty (JournalError Text Double)) (Journal Text Double (HatBase AccountTitles))
-- >>> reconcileSources [("tx1", 100)] (j .+ j2)
-- [UnknownSource "tx2"]
reconcileSources :: (HatVal v, Note n, Ord n)
=> [(n, v)]
-> Journal n v (HatBase AccountTitles)
-> [SourceError n v]
reconcileSources sources journal =
missing ++ unknown ++ mismatched
where
expected = M.fromList sources
actual = M.fromList (HM.toList (toMap journal))
missing =
[ MissingSource txid
| (txid, _) <- sources
, M.notMember txid actual
]
unknown =
[ UnknownSource txid
| txid <- M.keys actual
, M.notMember txid expected
]
mismatched =
[ AmountMismatch txid expectedAmount actualAmount
| (txid, expectedAmount) <- sources
, Just alg <- [M.lookup txid actual]
, let actualAmount = norm (decL alg)
, expectedAmount /= actualAmount
]
validateIndexed :: (HatVal v)
=> ProcessingContext
-> Bool
-> [(Int, (Side, AccountTitles, v))]
-> [EntryError v]
validateIndexed context rawEmpty rows =
emptyErrors ++ rowErrors ++ imbalanceErrors
where
emptyErrors = [ EmptyEntry | rawEmpty ]
rowErrors = concatMap validateRow rows
validateRow (i, (side, account, amount)) =
[ NonPositiveAmount i account amount
| invalidAmount amount
]
++ [ WildcardAccount i | account == AccountTitle ]
++ [ WildcardSide i | side == Side ]
++ [ PostingNotAllowed i account capability context
| account /= AccountTitle
, let capability = postingCapabilityFor account
, not (postingAllowedIn context capability)
]
invalidAmount amount = isErrorValue amount || not (amount > 0)
imbalanceErrors
| null rows = []
| otherwise =
[ Imbalanced (roundAccum debit) (roundAccum credit)
| signAccum (mergeAccum debit (negateAccum credit)) /= Just EQ
]
where
debit = L.foldl' (flip addAccum) emptyAccum
[amount | (_, (Debit, _, amount)) <- rows]
credit = L.foldl' (flip addAccum) emptyAccum
[amount | (_, (Credit, _, amount)) <- rows]