lib: fix some transaction balancing cases

I needed to be more careful about ordering, as johannesgerer's original
code was, and the tests missed it. I think I have it now.
Found the PR whose code I have been reworking, it was #438.

hledger-lib/Hledger/Data/Journal.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
 
 {-|
 
@@ -667,23 +668,24 @@ journalBalanceTransactions assrt j' =
       -- and check balance assertions. This is done in two passes:
       runExceptT $ do
 
-        -- 1. Balance the transactions which don't have balance assignments.
+        -- 1. Step through the transactions, balancing the ones which don't have balance assignments
-        let (noassignmenttxns, withassignmenttxns) = partition (null . assignmentPostings) ts
+        -- and leaving the others for later. The balanced ones are split into their postings.
-        noassignmenttxns' <- forM noassignmenttxns $ \t ->
+        -- The postings and not-yet-balanced transactions remain in the same relative order.
-          either throwError (\t -> lift (writeArray balancedtxns (tindex t) t) >> return t) $ 
+        psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case
-            balanceTransaction styles t 
+          t | null $ assignmentPostings t -> case balanceTransaction styles t of
+              Left  e  -> throwError e 
+              Right t' -> do
+                lift $ writeArray balancedtxns (tindex t') t'
+                return $ map Left $ tpostings t'
+          t -> return [Right t]
 
-        -- 2. Step through the postings of those transactions, and the remaining transactions, in date order,
+        -- 2. Sort these items by date, preserving the order of same-day items,
-        let sortedpsandts :: [Either Posting Transaction] = 
+        -- and step through them while keeping running account balances, 
-              sortOn (either postingDate tdate) $ 
-                map Left (concatMap tpostings noassignmenttxns') ++ 
-                map Right withassignmenttxns
-        -- keeping running account balances, 
         runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)
         flip runReaderT (BalancingState styles txnmodifieraccts assrt runningbals balancedtxns) $ do
           -- performing balance assignments in, and balancing, the remaining transactions,
           -- and checking balance assertions as each posting is processed.
-          void $ mapM' balanceTransactionAndCheckAssertionsB sortedpsandts
+          void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts
 
         ts' <- lift $ getElems balancedtxns
         return j{jtxns=ts'} 
@@ -1248,24 +1250,59 @@ tests_Journal = tests "Journal" [
       ,test "expenses"    $ expectEq (namesfrom journalExpenseAccountQuery)   ["expenses","expenses:food","expenses:supplies"]
     ]
 
-  ,test "journalBalanceTransactions" $ do
+  ,tests "journalBalanceTransactions" [
-    let ej = journalBalanceTransactions True $
+
-              nulljournal{ jtxns = [
+     test "balance-assignment" $ do
-                txnTieKnot $ nulltransaction{
+      let ej = journalBalanceTransactions True $
-                  tdate=parsedate "2019/01/01",
+            --2019/01/01
-                  tpostings=[
+            --  (a)            = 1
-                     nullposting{
+            nulljournal{ jtxns = [
-                       ptype=VirtualPosting
+              transaction "2019/01/01" [ vpost' "a" missingamt (balassert (num 1)) ]
-                      ,paccount="a"
+            ]}
-                      ,pamount=missingmixedamt
+      expectRight ej
-                      ,pbalanceassertion=Just nullassertion{baamount=num 1}
+      let Right j = ej
-                      }
+      (jtxns j & head & tpostings & head & pamount) `is` Mixed [num 1]
-                    ],
+
-                  tprecedingcomment=""
+    ,test "same-day-1" $ do
-                  }
+      expectRight $ journalBalanceTransactions True $
-                ]
+            --2019/01/01
-              }
+            --  (a)            = 1
-    expectRight ej
+            --2019/01/01
-    let Right j = ej
+            --  (a)          1 = 2
-    (jtxns j & head & tpostings & head & pamount) `is` Mixed [num 1]
+            nulljournal{ jtxns = [
+               transaction "2019/01/01" [ vpost' "a" missingamt (balassert (num 1)) ]
+              ,transaction "2019/01/01" [ vpost' "a" (num 1)    (balassert (num 2)) ]
+            ]}
+
+    ,test "same-day-2" $ do
+      expectRight $ journalBalanceTransactions True $
+            --2019/01/01
+            --    (a)                  2 = 2
+            --2019/01/01
+            --    b                    1
+            --    a
+            --2019/01/01
+            --    a                    0 = 1
+            nulljournal{ jtxns = [
+               transaction "2019/01/01" [ vpost' "a" (num 2)    (balassert (num 2)) ]
+              ,transaction "2019/01/01" [
+                 post' "b" (num 1)     Nothing  
+                ,post' "a"  missingamt Nothing  
+              ]
+              ,transaction "2019/01/01" [ post' "a" (num 0)     (balassert (num 1)) ]
+            ]}
+
+    ,test "out-of-order" $ do
+      expectRight $ journalBalanceTransactions True $
+            --2019/1/2
+            --  (a)    1 = 2
+            --2019/1/1
+            --  (a)    1 = 1
+            nulljournal{ jtxns = [
+               transaction "2019/01/02" [ vpost' "a" (num 1)    (balassert (num 2)) ]
+              ,transaction "2019/01/01" [ vpost' "a" (num 1)    (balassert (num 1)) ]
+            ]}
+
+    ]
+
   ]