Group.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-}

{- |
Module      : ExchangeAlgebra.Accounting.Statements.Group
Description : Presentation groups and the contra netting policy (Definition 7, Land 3).

A /presentation group/ is a statement block made of one or more __gross__
account titles and the __contra__ (評価勘定) titles that are deducted from
them, rendered as @gross lines → deduction lines → net line@. It is the
mechanism the Definition 7 contra amendment left open: Land 2 fixed the
classification (contra assets are @Assets@ with @isContra = True@) but kept a
display-compatibility shim so that the contra accounts still /appeared/ in the
liability column; this module supplies the real deduction presentation and
lets that shim be removed.

This module implements display grouping and deduction rules independently of
CSV writers and the financial-statement presentation pipeline. Callers can use
'presentGroups' to apply these rules in their own displays.

=== Value domain

Statement amounts are held as a @(debit gross, credit gross)@ pair and only
netted at the last moment, into a t'RelativeAmount' carrying a __non-negative__
magnitude plus a direction flag. Stored and rendered magnitudes therefore stay
in \(\mathbb{R}_0^+\), including for soft-invariant value types such as
@MoneyDecimal@. A minus sign exists only in rendered text, never in a stored
value of t'RelativeAmount'.

=== Block invariant

Within one block the exact amounts, before rounding, sum to the net line:

> Σ (gross rows) + Σ (subgroup rows) + Σ (deduction rows) = net row

A deduction row is stated /relative to the group's normal side/, so an
ordinary contra balance is already negative there and the sum above is a plain
addition, not a subtraction. A contra that exceeds its gross members simply
makes the net row negative (that is the @contra > parent@ edge case); a group
whose gross members are absent entirely nets to the negated deduction (the
@parent absent@ edge case). Both are handled by the same arithmetic. Each output is rounded once; the
sum of the displayed amounts need not equal the displayed net.
-}
module ExchangeAlgebra.Accounting.Statements.Group
    ( -- * Groups
      PresentationGroup(..)
    , PresentationGroupDef(..)
    , defaultPresentationGrouping
    , presentationGroupOf
    , lookupGroupDef
    , groupNormalSide
    , groupingForDivisions
      -- * Amounts
    , RelativeAmount(..)
    , relativeTo
    , addGross
      -- * Grouped rows
    , GroupRowKind(..)
    , GroupRow(..)
    , GroupedPresentation(..)
    , presentGroups
    ) where

import qualified Data.List as L
import qualified Data.Map.Strict as M
import           Data.Map.Strict (Map)
import qualified Data.Set as S
import           Data.Set (Set)
import           Data.Text (Text)

import           ExchangeAlgebra.Algebra.Value.Class (HatVal(..))
import           ExchangeAlgebra.Accounting.Account (defaultSide)
import           ExchangeAlgebra.Accounting.Account.Classification
                     ( AccountDivision(..), Side(..) )
import           ExchangeAlgebra.Accounting.Account.Title (AccountTitles(..))

------------------------------------------------------------------
-- Groups
------------------------------------------------------------------

-- | Identity of a statement presentation block. These are reporting
-- identities, never posting coordinates: they name a group of account titles,
-- not an account.
data PresentationGroup
    = TradeReceivablesGroup   -- ^ 売上債権 − 貸倒引当金
    | DepreciableAssetsGroup  -- ^ 償却性有形固定資産 − 減価償却累計額
    | NetSalesGroup           -- ^ 総売上高 − 売上割戻 − 売上値引
    | NetPurchasesGroup       -- ^ 総仕入高 − 仕入割戻 − 仕入値引
    | IncomeTaxesGroup        -- ^ 法人税等 − 還付法人税等
    deriving (Show, Eq, Ord, Enum, Bounded)

-- | One block of a statement: the gross titles, the contra titles deducted
-- from them, and (optionally) the group this block rolls up into.
--
-- @pgGross@ and @pgDeductions@ are ordered; rows are emitted in that order so
-- that the output is deterministic. Every @pgDeductions@ member is expected to
-- be a registry contra account of the same division as @pgDivision@, and no
-- @pgGross@ member is; the test-suite pins both, together with the disjointness
-- of the membership sets and the fact that every registry contra account
-- belongs to exactly one group.
data PresentationGroupDef = PresentationGroupDef
    { pgKey        :: PresentationGroup
    , pgDivision   :: AccountDivision
      -- ^ Statement column the block belongs to. Fixes the group's normal
      -- side via 'groupNormalSide'.
    , pgLabel      :: Text
      -- ^ Label of the net line (and of the carried subtotal when this block
      -- rolls up into another one).
    , pgGross      :: [AccountTitles]
    , pgDeductions :: [AccountTitles]
    , pgParent     :: Maybe PresentationGroup
      -- ^ When set, this block's net is carried into the named block as a
      -- 'SubgroupRow' and only the outermost block contributes to the column
      -- total. The default grouping is flat; nesting exists so that a caller
      -- can state a multi-level statement without a second netting rule.
    }
    deriving (Show, Eq)

-- | Normal (deduction-free) side of a group, i.e. the side its net line is
-- stated against.
groupNormalSide :: PresentationGroupDef -> Side
groupNormalSide = defaultSide . pgDivision

-- | Default display groups for callers using 'presentGroups'.
--
-- The membership lists are presentation policy, not algebra: they say which
-- gross titles a single undifferentiated valuation account is deducted from
-- under JGAAP's indirect method (間接控除法). Tests verify that each registry
-- contra account occurs exactly once among the default blocks' deductions.
-- A block can deduct multiple contra accounts: net sales deducts both sales
-- rebates and sales allowances. All blocks are flat — a nested default would
-- assert a subtotal structure that the chart does not yet carry.
defaultPresentationGrouping :: [PresentationGroupDef]
defaultPresentationGrouping =
    [ PresentationGroupDef
        { pgKey = TradeReceivablesGroup
        , pgDivision = Assets
        , pgLabel = "TradeReceivablesNet"
        , pgGross =
            [ NotesReceivable
            , AccountsReceivable
            , ElectronicallyRecordedReceivable
            , CreditCardReceivable
            ]
        , pgDeductions = [AllowanceForDoubtfulAccounts]
        , pgParent = Nothing
        }
    , PresentationGroupDef
        { pgKey = DepreciableAssetsGroup
        , pgDivision = Assets
        , pgLabel = "DepreciableAssetsNet"
        , pgGross =
            [ Building
            , Structures
            , Machinery
            , Vehicle
            , ToolsAndInstruments
            , Fixtures
            ]
        , pgDeductions = [AccumulatedDepreciation]
        , pgParent = Nothing
        }
    , PresentationGroupDef
        { pgKey = NetSalesGroup
        , pgDivision = Revenue
        , pgLabel = "NetSales"
        , pgGross = [Sales]
        , pgDeductions = [SalesRebates, SalesAllowances]
        , pgParent = Nothing
        }
    , PresentationGroupDef
        { pgKey = NetPurchasesGroup
        , pgDivision = Cost
        , pgLabel = "NetPurchases"
        , pgGross = [Purchases]
        , pgDeductions = [PurchaseRebates, PurchaseAllowances]
        , pgParent = Nothing
        }
    , PresentationGroupDef
        { pgKey = IncomeTaxesGroup
        , pgDivision = Cost
        , pgLabel = "IncomeTaxesNet"
        , pgGross = [CorporateIncomeTaxes, AdditionalIncomeTaxesForPriorPeriods]
        , pgDeductions = [RefundOfIncomeTaxes]
        , pgParent = Nothing
        }
    ]

-- | Block a title belongs to under 'defaultPresentationGrouping', if any.
presentationGroupOf :: AccountTitles -> Maybe PresentationGroup
presentationGroupOf title = fmap pgKey (L.find member defaultPresentationGrouping)
  where
    member def = title `elem` pgGross def || title `elem` pgDeductions def

-- | Look one block up in the grouping in force.
lookupGroupDef :: [PresentationGroupDef] -> PresentationGroup -> Maybe PresentationGroupDef
lookupGroupDef defs key = L.find ((== key) . pgKey) defs

-- | Restrict a grouping to the statement columns a writer renders. A balance
-- sheet must not net revenue accounts, and a profit and loss statement must
-- not net asset accounts.
groupingForDivisions :: [AccountDivision] -> [PresentationGroupDef] -> [PresentationGroupDef]
groupingForDivisions divisions = filter ((`elem` divisions) . pgDivision)

------------------------------------------------------------------
-- Amounts
------------------------------------------------------------------

-- | An amount stated relative to a group's normal side. @raMagnitude@ is
-- always non-negative; @raBelowZero@ says whether the amount sits on the
-- opposite side (a deduction, or a net that its deductions pushed past zero).
-- Callers render the direction — as a leading @-@, a triangle (△), or a move
-- to the other column — and never negate the value itself.
data RelativeAmount v = RelativeAmount
    { raBelowZero :: !Bool
    , raMagnitude :: !v
    }
    deriving (Show, Eq)

-- | Orient a directional net balance, such as the output of @diffRL@,
-- against a group's normal side. The magnitude is already netted; this
-- function never subtracts rounded gross totals or applies a tolerance.
relativeTo :: HatVal v => Side -> (Side, v) -> RelativeAmount v
relativeTo side (direction, magnitude) =
    RelativeAmount (direction /= Side && direction /= normal) magnitude
  where
    normal = case side of
        Side -> Debit
        _ -> side

-- | Accumulate @(debit gross, credit gross)@ pairs.
addGross :: Num v => (v, v) -> (v, v) -> (v, v)
addGross (leftDebit, leftCredit) (rightDebit, rightCredit) =
    (leftDebit + rightDebit, leftCredit + rightCredit)

------------------------------------------------------------------
-- Grouped rows
------------------------------------------------------------------

-- | What one row of a block states.
data GroupRowKind
    = GrossRow AccountTitles
      -- ^ A constituent account, before deduction.
    | SubgroupRow PresentationGroup
      -- ^ The net of a nested block, carried into this one.
    | DeductionRow AccountTitles
      -- ^ A contra account. Its amount is already stated relative to the
      -- group's normal side, so it is normally 'raBelowZero'.
    | NetRow PresentationGroup
      -- ^ The block's net, rounded after combining the exact member amounts.
    deriving (Show, Eq)

-- | A group row kind paired with its relative amount.
data GroupRow v = GroupRow
    { grKind   :: GroupRowKind
    , grAmount :: RelativeAmount v
    }
    deriving (Show, Eq)

-- | Result of applying a grouping to a set of per-title balances.
data GroupedPresentation v = GroupedPresentation
    { gpBlocks     :: [(PresentationGroupDef, [GroupRow v])]
      -- ^ Blocks in render order: nested blocks precede the block they roll
      -- up into, roots follow the order of the grouping list.
    , gpRootTotals :: Map AccountDivision (v, v)
      -- ^ Per-division @(debit, credit)@ contribution of the __outermost__
      -- blocks only. A caller adds this to the ungrouped part of the column;
      -- adding nested blocks as well would double count.
    , gpConsumed   :: Set AccountTitles
      -- ^ Titles the blocks have taken over. The caller must not render these
      -- again through its ordinary per-entry path.
    }
    deriving (Show, Eq)

-- | Apply a grouping to per-title @(debit gross, credit gross)@ totals.
--
-- A block is /active/ when one of its own contra titles carries non-zero gross
-- activity, or when a nested block is active: a group with nothing to deduct is
-- not a group, and leaving it inactive is what keeps output identical to the
-- pre-amendment behavior for charts that contain no contra posting. Testing
-- gross activity rather than the net balance also keeps a fully offset contra
-- title inside its group instead of leaking one side into the ordinary rows.
--
-- An indeterminate (NaN) net is oriented as @(Side, NaN)@, like @diffRL@.
--
-- Complexity: O(g · m + g²) for @g@ blocks of @m@ members (the grouping is a
-- fixed, small table).
presentGroups
    :: HatVal v
    => [PresentationGroupDef]
    -> Map AccountTitles (v, v)
    -> GroupedPresentation v
presentGroups defs balances = GroupedPresentation
    { gpBlocks = blocks
    , gpRootTotals = rootTotals
    , gpConsumed = consumed
    }
  where
    grossOf title = M.findWithDefault (zeroValue, zeroValue) title balances
    hasBalance title = uncurry (/=) (grossOf title)
    hasActivity title = case M.lookup title balances of
        Nothing -> False
        Just (debit, credit) ->
            debit /= zeroValue
            || credit /= zeroValue

    memberTitles def = pgGross def ++ pgDeductions def

    -- Children of a block, in grouping order. 'pgParent' is followed with a
    -- visited set so that a malformed (cyclic) grouping is truncated instead
    -- of diverging.
    childrenOf visited key =
        [ def
        | def <- defs
        , pgParent def == Just key
        , not (S.member (pgKey def) visited)
        ]

    ownPair def = L.foldl' mergePair (emptyAccum, emptyAccum)
        [ (addAccum debit emptyAccum, addAccum credit emptyAccum)
        | title <- memberTitles def, let (debit, credit) = grossOf title ]

    mergePair (debit, credit) (otherDebit, otherCredit) =
        (mergeAccum debit otherDebit, mergeAccum credit otherCredit)

    subtreePair visited def = L.foldl' mergePair (ownPair def)
        (map (subtreePair visited') (activeChildrenOf visited' def))
      where
        visited' = S.insert (pgKey def) visited

    ownActive def = any hasActivity (pgDeductions def)

    isActive visited def = ownActive def
        || any (isActive visited') (childrenOf visited' (pgKey def))
      where
        visited' = S.insert (pgKey def) visited

    activeChildrenOf visited def =
        [ child
        | child <- childrenOf visited (pgKey def)
        , pgDivision child == pgDivision def
        , isActive visited child
        ]

    -- A block is a root when it has no usable parent, or when it is the stable
    -- representative of a malformed parent cycle. Cross-division parents are
    -- unusable because a carried subtotal and its root total must share a
    -- statement column.
    isRoot def = case pgParent def of
        Nothing -> True
        Just parent -> case lookupGroupDef defs parent of
            Nothing -> True
            Just parentDef
                | pgDivision parentDef /= pgDivision def -> True
                | otherwise -> case parentCycle def of
                    Nothing -> False
                    Just keys -> pgKey def == minimum keys

    parentCycle def = follow [] (pgKey def)
      where
        follow path key
            | key `elem` path = Just (dropWhile (/= key) path)
            | otherwise = case lookupGroupDef defs key >>= pgParent of
                Nothing -> Nothing
                Just parent -> follow (path ++ [key]) parent

    activeRoots = [def | def <- defs, isRoot def, isActive S.empty def]

    -- Depth-first: nested blocks are rendered before the block that carries
    -- their net, so a reader meets a subtotal only after its constituents.
    blocksOf visited def =
        concatMap (blocksOf visited') activeChildren
        ++ [(def, rowsOf visited' def activeChildren)]
      where
        visited' = S.insert (pgKey def) visited
        activeChildren = activeChildrenOf visited' def

    rowsOf visited def activeChildren =
        [ GroupRow (GrossRow title) (relativeScalar (grossOf title))
        | title <- pgGross def, hasBalance title ]
        ++
        [ GroupRow (SubgroupRow (pgKey child)) (relative (subtreePair visited child))
        | child <- activeChildren ]
        ++
        [ GroupRow (DeductionRow title) (relativeScalar (grossOf title))
        | title <- pgDeductions def, hasBalance title ]
        ++
        [ GroupRow (NetRow (pgKey def)) (relative (subtreePair visited def)) ]
      where
        relativeScalar (debit, credit) = relative
            (addAccum debit emptyAccum, addAccum credit emptyAccum)
        relative (debit, credit) = case signAccum difference of
            Just EQ -> relativeTo normal (Side, zeroValue)
            Just GT -> relativeTo normal (Debit, roundAccum difference)
            Just LT -> relativeTo normal (Credit, roundAccum (negateAccum difference))
            Nothing -> relativeTo normal (Side, roundAccum difference)
          where
            normal = groupNormalSide def
            difference = mergeAccum debit (negateAccum credit)

    blocks = concatMap (blocksOf S.empty) activeRoots

    rootTotals = M.map (\(debit, credit) -> (roundAccum debit, roundAccum credit))
        (M.fromListWith mergePair
            [ (pgDivision def, subtreePair S.empty def) | def <- activeRoots ])

    consumed = S.fromList
        [ title | (def, _) <- blocks, title <- memberTitles def ]