Closing.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Module      : ExchangeAlgebra.Accounting.Closing
Description : Additional closing entries and ordered settlement pairs.

This Accounting layer selects closing accounts and constructs additional
entries using generic Algebra operations. Start with 'closingEntries' for
an existing ledger; use 'settleEntries' for signed nets already computed
by the caller. Both preserve the non-account coordinates of each source.

Import this module qualified alongside "ExchangeAlgebra.Algebra.Core":

> import qualified ExchangeAlgebra.Accounting.Closing as Closing
> import ExchangeAlgebra.Algebra.Core ((.+))

'closingEntries' returns only additional entries. For @Right entries =
Closing.closingEntries ledger@, add them with @ledger .+ entries@.
Supply only postings through the closing date, including earlier closing
entries. For a journal, first use @toAlg@ from "ExchangeAlgebra.Journal.Core",
then attach the closing note to the returned entries with @(.|)@.

The posting pairs implement Definition 9 and retain the original audit trail.

== Laws

The observation @obs@ is the map from complete bases (including Hat\/Not) to
summed values after @bar@; it does not observe the singleton versus composite
constructor or sequence order. Relative tolerance means a per-base difference
of at most @1e-9 * max (abs x) (abs y)@, treating absent bases as zero.

=== L2: closing

* Subject: 'closingEntries'.
* Preconditions: valid Hat\/Not postings; the ledger includes only entries
  through the closing date and the call returns @Right entries@.
* Relation: adding the entries closes each eligible complete base exactly.
  Each reversal has an equal retained-earnings posting on the side selected
  by 'closingSide'; non-closing bases and non-account coordinates are retained.
* Observation: exact net per complete base, including 'RetainedEarnings'.
* Tolerance: none; the 'HatVal' accumulator and 'splitAccum' preserve exact nets.
* Instances: 'Double' and @MoneyDecimal@ with 'ExBaseClass' bases.

=== L3: balance

* Subject: generated transfer and closing entries.
* Preconditions: valid postings, concrete accounts, @Relabel@ rules whose
  actual target and source have equal 'whichSide'; finite totals. The
  transfer or closing operation being observed returns @Right entries@.
* Relation: debit total equals credit total. Closing entries also satisfy
  this relation, because 'closingSide' follows the account's PIMO direction.
* Observation: @norm (decL entries)@ and @norm (decR entries)@.
* Tolerance: relative @1e-9@ for 'Double'; exact for @MoneyDecimal@.
* Instances: 'Double' and @MoneyDecimal@ with 'ExBaseClass' bases.

A relabel from @Not :< Cash@ to @Not :< Sales@ violates L3's side
precondition: its cancellation and destination are both credits.

=== L5: non-negativity

* Subject: generated transfer and closing entries.
* Preconditions: non-negative valid input values; the transfer or closing
  operation being observed returns @Right entries@.
* Relation: every generated value is greater than or equal to zero.
* Observation: posting values, before any @bar@.
* Tolerance: none.
* Instances: all lawful 'HatVal' and 'HatBaseClass' instances (closing also
  requires 'ExBaseClass'). Hat reversal is never numeric negation.

-}
module ExchangeAlgebra.Accounting.Closing ( ClosingSide(..)
                                          , closingSide
                                          , closingEntries
                                          , SettleRule
                                          , retainedEarningsRule
                                          , SettlementBatch
                                          , SignedNet
                                          , SettleError(..)
                                          , settleEntries
                                          , settlementSteps
                                          ) where

import Data.Binary (Binary(..))
import Data.Hashable (Hashable)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import GHC.Generics (Generic)
import ExchangeAlgebra.Algebra.Core ( Alg(..)
                                    , Redundant((.+))
                                    , (.@)
                                    , foldEntries
                                    )
import ExchangeAlgebra.Algebra.Base.Representation (HatBaseClass(..), Hat(..))
import ExchangeAlgebra.Algebra.Value.Class (HatVal(..), isErrorValue)
import ExchangeAlgebra.Accounting.Exchange (ExBaseClass(..))
import ExchangeAlgebra.Accounting.Account ( AccountTitles(..)
                                          , accountSpec
                                          , asClosing
                                          , ClosingRule(..)
                                          , classifyAccountDivision
                                          , classifyAccountContra
                                          , pimoFromDivision
                                          , pimoFlip
                                          , PIMO(..)
                                          )
import ExchangeAlgebra.Algebra.Transfer.Representation (TransferApplyError(..))

-- * Closing entries

-- | The retained-earnings side selected by a closing account's PIMO direction.
data ClosingSide
    = ClosingKeep -- ^ IN: retain Hat/Not (revenue or contra cost).
    | ClosingFlip -- ^ OUT: reverse Hat/Not (cost or contra revenue).
    deriving (Eq, Ord, Show, Enum, Bounded, Generic)

instance Binary ClosingSide

instance Hashable ClosingSide

-- | Select the retained-earnings direction for an account eligible for closing.
-- Registry NoClose accounts, including NetIncome and NetLoss, are excluded.
closingSide :: AccountTitles -> Maybe ClosingSide
closingSide title = case accountSpec title of
    Nothing -> Nothing
    Just spec -> case asClosing spec of
        NoClose -> Nothing
        CloseByDivision -> case direction of
            IN -> Just ClosingKeep
            OUT -> Just ClosingFlip
            _ -> Nothing
  where
    direction
        | classifyAccountContra title = pimoFlip ordinaryDirection
        | otherwise = ordinaryDirection
    ordinaryDirection = pimoFromDivision (classifyAccountDivision title)

-- | Generate closing entries that close each eligible base exactly.
-- Supply only postings through the closing date. For each base whose account
-- has a 'closingSide', the Hat and Not values are accumulated without
-- rounding ('HatVal' accumulator); the exact net (Not minus Hat) decides the
-- winning side. A zero net generates nothing. Otherwise 'splitAccum' splits
-- the exact magnitude into finite positive values @d1 >= d2 >= ... >= dk@
-- whose exact sum is the net, and each @di@ becomes one pair: the reversal of
-- the base and the posting to 'RetainedEarnings'. @k = 1@ whenever the net is
-- representable in the value type. The pairs are not compressed back into one
-- pair, so the exact net of every closed base after the entries is zero.
-- This folds the source sequences (audit detail) per base, but preserves
-- separate target postings from distinct source accounts. It does not call
-- @bar@. All non-account axes are retained, and no note is attached.
--
-- 'NonFiniteBalance' is returned when an eligible base has a posting value
-- for which 'valueError' is 'Just' (non-finite or negative), or when its net
-- cannot be split ('splitAccum' returns 'Nothing': the rounded net is not
-- finite). Side sums beyond the value type's range succeed when the exact
-- net is in range. The reported base is the first in ascending 'Ord' order
-- after normalizing Hat/Not to Not. No partial result is returned.
--
-- Laws (exact arithmetic; observed with 'exactAccum'): for every closed base
-- the exact net of @x .+ c@ is zero, where @Right c = closingEntries x@;
-- the entries of @c@ have equal exact debit and credit sums; and
-- @closingEntries (x .+ c) == Right Zero@.
-- Balance collection is O(s log b), for s postings and b eligible bases.
closingEntries :: forall v b. (HatVal v, ExBaseClass b)
               => Alg v b -> Either (TransferApplyError v b) (Alg v b)
closingEntries = Map.foldlWithKey' close (Right Zero) . foldEntries collect Map.empty
  where
    collect :: Map b (Bool, Accum v, Accum v) -> v -> b
            -> Map b (Bool, Accum v, Accum v)
    collect balances value source = case (hat source, closingSide (getAccountTitle source)) of
        (Hat, Just _) -> Map.insertWith addTotals (toNot source)
            (isErrorValue value, addAccum value emptyAccum, emptyAccum) balances
        (Not, Just _) -> Map.insertWith addTotals source
            (isErrorValue value, emptyAccum, addAccum value emptyAccum) balances
        _ -> balances

    addTotals :: (Bool, Accum v, Accum v) -> (Bool, Accum v, Accum v)
              -> (Bool, Accum v, Accum v)
    addTotals (invalid, hatValue, notValue) (failed, hatTotal, notTotal) =
        (invalid || failed, mergeAccum hatValue hatTotal, mergeAccum notValue notTotal)

    close :: Either (TransferApplyError v b) (Alg v b)
          -> b
          -> (Bool, Accum v, Accum v)
          -> Either (TransferApplyError v b) (Alg v b)
    close result source (invalid, hatTotal, notTotal) = do
        entries   <- result
        additions <- netEntries source invalid (mergeAccum notTotal (negateAccum hatTotal))
        pure (entries .+ additions)

    netEntries :: b -> Bool -> Accum v -> Either (TransferApplyError v b) (Alg v b)
    netEntries source invalid amount
        | invalid = Left (NonFiniteBalance source)
        | otherwise = case signAccum amount of
            Just EQ -> Right Zero
            Just LT -> splitPairs source (toHat source) (negateAccum amount)
            Just GT -> splitPairs source source amount
            Nothing -> Left (NonFiniteBalance source)

    splitPairs :: b -> b -> Accum v -> Either (TransferApplyError v b) (Alg v b)
    splitPairs source balanceBase amount = case splitAccum amount of
        Nothing -> Left (NonFiniteBalance source)
        Just values -> case closingSide (getAccountTitle balanceBase) of
            Nothing   -> Right Zero
            Just side -> Right $ mconcat
                [ closingPairBy (targetSide side) RetainedEarnings value balanceBase
                | value <- values ]

    targetSide :: ClosingSide -> b -> b
    targetSide side = case side of
        ClosingKeep -> id
        ClosingFlip -> revHat

-- | A closing rule containing only its destination account title.
-- The private constructor restricts destinations to accounts compatible with
-- the closing directions.
newtype SettleRule = SettleRule AccountTitles

-- | Close eligible accounts into 'RetainedEarnings', preserving all other axes.
retainedEarningsRule :: SettleRule
retainedEarningsRule = SettleRule RetainedEarnings

-- | Settlement pairs in strictly ascending source-base order.
-- A model returns only @Posting@ built with @entry@ and 'Monoid'. Settlement
-- magnitudes can exceed the @Posted@ bound, so this type has no conversion to
-- @Posting@ and no 'Semigroup' or 'Monoid' instance.
--
-- Record each pair separately in source-base order. Combining all pairs first
-- can change the order of additions to a shared destination. For example,
-- sequential increments @T, 1, -T@ with @T = 2^53@ give 0 in 'Double', whereas
-- adding @T, -T, 1@ gives 1.
newtype SettlementBatch b = SettlementBatch [(BasePart b, Alg Double b)]

-- | A signed Not-minus-Hat net. This is not a non-negative posting magnitude.
-- As a type synonym, it does not enforce finiteness or any numeric range.
type SignedNet = Double

-- | The first non-finite input net, identified by its complete base coordinates.
data SettleError b = NonFiniteNet (BasePart b)

deriving instance Eq (BasePart b) => Eq (SettleError b)
deriving instance Show (BasePart b) => Show (SettleError b)

-- | Construct one reversal and destination pair per eligible source base.
-- Input values are signed Not-minus-Hat nets. Zero nets, accounts without a
-- closing side, and destination bases produce no pair. Every pair has two
-- finite, non-negative magnitudes equal to the absolute input net; the source
-- reversal cancels that net exactly. Other base axes are preserved.
--
-- A non-finite input, including at an excluded key, returns 'Left' with the
-- first key in ascending order. Finite magnitudes above
-- 'ExchangeAlgebra.Algebra.Value.postingUpperBound' are accepted, without passing
-- through 'ExchangeAlgebra.Algebra.Posting.posted'. No implicit @bar@ or @compress@ is
-- applied. Complexity: O(b) for b input bases.
-- Law: subject: each generated settlement pair; preconditions: all nets finite.
-- Relation: each reversal cancels its source net. For each destination base,
-- its increment is the sum of @direction * net@ over the source bases, where
-- @direction@ is +1 for 'ClosingKeep' and -1 for 'ClosingFlip'.
-- Observation: sums of @decL@ and @decR@ lifted to Rational for each pair.
-- Tolerance: exact. Instances: 'ExBaseClass' bases with Double posting values.
settleEntries :: forall b. ExBaseClass b
              => SettleRule
              -> Map (BasePart b) SignedNet
              -> Either (SettleError b) (SettlementBatch b)
settleEntries (SettleRule destination) amounts
    = case mapMaybe nonFinite (Map.toAscList amounts) of
        first : _ -> Left (NonFiniteNet first)
        []        -> Right (SettlementBatch (mapMaybe close (Map.toAscList amounts)))
  where
    finite amount = not (isNaN amount || isInfinite amount)
    nonFinite (coordinates, amount)
        | finite amount = Nothing
        | otherwise     = Just coordinates
    close (coordinates, amount)
        | amount == 0 = Nothing
        | coordinates == base (setAccountTitle source destination) = Nothing
        | otherwise = case closingSide (getAccountTitle source) of
            Nothing   -> Nothing
            Just side -> Just
                (coordinates, closingPairBy (targetSide side) destination (abs amount) source)
      where
        source = merge (sourceSide amount) coordinates :: b
    sourceSide amount
        | amount < 0 = Hat
        | otherwise  = Not
    targetSide side = case side of
        ClosingKeep -> id
        ClosingFlip -> revHat

-- | Read the pairs in strictly ascending source-base order, without constraints
-- on the base type. Record each pair before proceeding to the next source.
-- Complexity: O(1) to expose the list; O(b) to consume b pairs.
settlementSteps :: SettlementBatch b -> [(BasePart b, Alg Double b)]
settlementSteps (SettlementBatch steps) = steps

-- | Reverse a closing balance and post it to the given destination account.
-- The first argument transforms the source to the target side: @id@ retains
-- Hat/Not, and 'revHat' reverses it. The caller must classify the source,
-- and the value must satisfy the non-negative,
-- finite posting contract of '.@'.
closingPairBy :: (HatVal v, ExBaseClass b)
              => (b -> b)
              -> AccountTitles
              -> v
              -> b
              -> Alg v b
closingPairBy targetSide targetAccount value source
    =  (value .@ revHat source)
    .+ (value .@ setAccountTitle (targetSide source) targetAccount)