From bb1c79b9a45af83d08e5d38566fafb3dfcfa9eb1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 27 Jan 2023 21:05:25 -0500
Subject: [PATCH] ENH make income balance errors more sane

---
 lib/Internal/Insert.hs | 15 +++++++--------
 lib/Internal/Types.hs  | 14 +++++++++++++-
 lib/Internal/Utils.hs  |  8 +++++++-
 3 files changed, 27 insertions(+), 10 deletions(-)

diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index fbcc0fa..e89bd7c 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -179,19 +179,17 @@ sumAllocations = sum . concatMap (fmap amtValue . alloAmts)
 sumTaxes :: [Tax] -> Rational
 sumTaxes = sum . fmap (dec2Rat . taxValue)
 
--- TODO these errors could be more descriptive by including an indicator
--- of the budget itself
-balancePostTax :: Rational -> [RawAllocation] -> EitherErr [BalAllocation]
-balancePostTax bal as
-  | null as = Left $ AllocationError NoAllocations
+balancePostTax :: DatePat -> Rational -> [RawAllocation] -> EitherErr [BalAllocation]
+balancePostTax dp bal as
+  | null as = err NoAllocations
   | otherwise = case partitionEithers $ fmap hasVal as of
       ([([empty], nonmissing)], bs) ->
         let s = bal - sumAllocations (nonmissing : bs)
          in if s < 0
-              then Left $ AllocationError ExceededTotal
+              then err ExceededTotal
               else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
-      ([], _) -> Left $ AllocationError MissingBlank
-      _ -> Left $ AllocationError TooManyBlanks
+      ([], _) -> err MissingBlank
+      _ -> err TooManyBlanks
   where
     hasVal a@Allocation {alloAmts = xs} =
       case partitionEithers $ fmap maybeAmt xs of
@@ -199,6 +197,7 @@ balancePostTax bal as
         (unbal, bs) -> Left (unbal, a {alloAmts = bs})
     maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
     maybeAmt a = Left a
+    err t = Left $ AllocationError t dp
 
 -- TODO lens reinvention
 mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index 8918b01..43bc70f 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -140,14 +140,20 @@ type AcntID = T.Text
 
 deriving instance Eq TimeUnit
 
+deriving instance Show TimeUnit
+
 deriving instance Hashable TimeUnit
 
 deriving instance Eq Weekday
 
+deriving instance Show Weekday
+
 deriving instance Hashable Weekday
 
 deriving instance Eq WeekdayPat
 
+deriving instance Show WeekdayPat
+
 deriving instance Hashable WeekdayPat
 
 deriving instance Show RepeatPat
@@ -190,14 +196,20 @@ instance Ord GregorianM where
 
 deriving instance Eq ModPat
 
+deriving instance Show ModPat
+
 deriving instance Hashable ModPat
 
 deriving instance Eq CronPat
 
+deriving instance Show CronPat
+
 deriving instance Hashable CronPat
 
 deriving instance Eq DatePat
 
+deriving instance Show DatePat
+
 deriving instance Hashable DatePat
 
 --------------------------------------------------------------------------------
@@ -526,7 +538,7 @@ data InsertError
   | ConversionError T.Text
   | LookupError LookupField T.Text
   | BalanceError BalanceType CurID [RawSplit]
-  | AllocationError AllocationSuberr
+  | AllocationError AllocationSuberr DatePat
   | StatementError [TxRecord] [Match]
   deriving (Show)
 
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index b0ade06..3960467 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -293,7 +293,13 @@ showError other = (: []) $ case other of
   (ConversionError x) -> T.append "Could not convert to rational number: " x
   -- TODO use the field indicator
   (LookupError _ f) -> T.append "Could not find field: " f
-  (AllocationError _) -> "Could not balance allocation"
+  (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
+    where
+      msg = case t of
+        NoAllocations -> "No post-tax allocations present"
+        ExceededTotal -> "Allocations exceed total income"
+        MissingBlank -> "No blank allocation to balance"
+        TooManyBlanks -> "Cannot balance multiple blank allocations"
   (BalanceError t cur rss) ->
     T.concat
       [ msg