ProjWildcardSpec.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

-- | The @proj@ family matches wildcards one way: only the query's wildcards
-- act as a pattern, and a wildcard stored in a ledger base is an ordinary
-- value. The result must not depend on the shape of the ledger (a single
-- element or a 'Liner').
module Algebra.ProjWildcardSpec (runTests) where

import           Control.Monad (unless)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import           Data.Text (Text)
import           System.Exit (exitFailure)
import           Test.QuickCheck hiding (label)
import           ExchangeAlgebra.Algebra hiding (map, filter)
import qualified ExchangeAlgebra.Algebra as Algebra
import           ExchangeAlgebra.Algebra.Transfer.Rule (collapseEntries)

-- | Account and unit coordinates; either axis may hold a ledger wildcard.
type TestBase = HatBase (AccountTitles, CountUnit)

type TestAlg = Alg Double TestBase

-- | Generated postings (ledger wildcards allowed) and a query set. Values are
-- small whole numbers, so every 'Double' sum below is exact.
data ProjCase = ProjCase [(Double, TestBase)] [TestBase]
    deriving (Show)

genTitle :: Gen AccountTitles
genTitle = frequency [(1, pure wildcard), (4, elements [Cash, Products, Sales])]

genUnit :: Gen CountUnit
genUnit = frequency [(1, pure wildcard), (4, elements [Yen, Amount, Dollar])]

genEntryBase :: Gen TestBase
genEntryBase = (:<) <$> elements [Hat, Not] <*> ((,) <$> genTitle <*> genUnit)

genQueryBase :: Gen TestBase
genQueryBase = (:<) <$> elements [Hat, Not, HatNot] <*> ((,) <$> genTitle <*> genUnit)

genProjCase :: Gen ProjCase
genProjCase = do
    count <- chooseInt (0, 12)
    entries <- vectorOf count ((,) <$> (fromIntegral <$> chooseInt (1, 1000)) <*> genEntryBase)
    queryCount <- chooseInt (1, 4)
    ProjCase entries <$> vectorOf queryCount genQueryBase

-- | The same generator restricted to concrete ledger bases.
genConcreteCase :: Gen ProjCase
genConcreteCase = do
    ProjCase entries queries <- genProjCase
    pure (ProjCase (filter (not . haveWildcard . snd) entries) queries)

-- | Reference predicate, written per axis and independent of the library's
-- 'ignoreWildcard': a query axis matches when it is a wildcard or equals the
-- entry axis. A ledger wildcard is matched only by a query wildcard.
oneWay :: TestBase -> TestBase -> Bool
oneWay (queryHat :< (queryTitle, queryUnit)) (entryHat :< (entryTitle, entryUnit)) =
    axis queryHat entryHat && axis queryTitle entryTitle && axis queryUnit entryUnit
  where
    axis :: Element a => a -> a -> Bool
    axis query entry = isWildcard query || query == entry

-- | The old symmetric predicate, for the concrete-ledger regression.
symmetric :: TestBase -> TestBase -> Bool
symmetric = (.==)

build :: [(Double, TestBase)] -> TestAlg
build entries = fromList [value :@ postingBase | (value, postingBase) <- entries]

-- | Raw postings keyed by the rendered base. 'HatBase' orders wildcards as
-- equal to anything, so the base itself cannot be the key here.
observe :: TestAlg -> Map.Map String [Double]
observe = Map.map List.sort
        . foldEntries (\result value postingBase ->
              Map.insertWith (++) (show postingBase) [value] result) Map.empty

selected :: (TestBase -> TestBase -> Bool) -> ProjCase -> [(Double, TestBase)]
selected match (ProjCase entries queries) =
    [entry | entry@(_, postingBase) <- entries, any (`match` postingBase) queries]

-- | Bar-netted norm of the selected entries, per base.
netNorm :: [(Double, TestBase)] -> Double
netNorm entries = sum (Map.elems (Map.map abs perBase))
  where
    perBase = Map.fromListWith (+)
        [ (show (base postingBase), if hat postingBase == Hat then negate value else value)
        | (value, postingBase) <- entries ]

propLedger :: ProjCase -> Bool
propLedger testCase@(ProjCase entries queries) =
    observe (proj queries (build entries)) == observe (build (selected oneWay testCase))

propSingle :: ProjCase -> Bool
propSingle (ProjCase entries queries) = all agrees entries
  where
    agrees entry@(value, postingBase) =
        observe (proj queries (value :@ postingBase))
            == observe (build (selected oneWay (ProjCase [entry] queries)))

propNetNorm :: ProjCase -> Bool
propNetNorm testCase@(ProjCase entries queries) =
    projNetNorm queries (build entries) == netNorm (selected oneWay testCase)
        && all single entries
  where
    single entry@(value, postingBase) =
        projNetNorm queries (value :@ postingBase)
            == netNorm (selected oneWay (ProjCase [entry] queries))

propConcreteRegression :: ProjCase -> Bool
propConcreteRegression testCase =
    selected oneWay testCase == selected symmetric testCase && propLedger testCase

assertTest :: String -> Bool -> IO ()
assertTest label success = do
    unless success $ do
        putStrLn ("[FAIL] " ++ label)
        exitFailure
    putStrLn ("[PASS] " ++ label)

quickProperty :: Testable property => String -> property -> IO ()
quickProperty label proposition = do
    result <- quickCheckWithResult stdArgs { maxSuccess = 500, chatty = False } proposition
    unless (isSuccess result) $ do
        putStrLn ("[FAIL] " ++ label ++ ": " ++ output result)
        exitFailure
    putStrLn ("[PASS] " ++ label)

-- | The reported table: cash carries no unit axis in the ledger.
testReportedTable :: IO ()
testReportedTable = do
    let cash = 10 :@ Not :< (Cash, wildcard) :: TestAlg
        both = cash .+ 3 :@ Not :< (Products, Yen)
        anyTitleYen = [Not :< (wildcard, Yen)]
        cashYen = [Not :< (Cash, Yen)]
        cashAny = [Not :< (Cash, wildcard)]
        products = 3 :@ Not :< (Products, Yen) :: TestAlg
    assertTest "proj: wildcard-title query skips ledger-wildcard unit (single)"
        (Algebra.isZero (proj anyTitleYen cash))
    assertTest "proj: wildcard-title query skips ledger-wildcard unit (Liner)"
        (observe (proj anyTitleYen both) == observe products)
    assertTest "proj: concrete query does not match a ledger wildcard (single)"
        (Algebra.isZero (proj cashYen cash))
    assertTest "proj: concrete query does not match a ledger wildcard (Liner)"
        (Algebra.isZero (proj cashYen both))
    assertTest "proj: query wildcard picks up the ledger wildcard (single)"
        (observe (proj cashAny cash) == observe cash)
    assertTest "proj: query wildcard picks up the ledger wildcard (Liner)"
        (observe (proj cashAny both) == observe cash)
    assertTest "projNetNorm: single element and Liner agree on a ledger wildcard"
        (projNetNorm cashYen cash == 0 && projNetNorm cashYen both == 0
            && projNetNorm cashAny cash == 10 && projNetNorm cashAny both == 10)
    assertTest "proj: projecting a projection is stable"
        (observe (proj cashYen (proj cashAny both)) == Map.empty)

-- | 'projByAccountTitle' follows the same one-way rule on the title axis.
testProjByAccountTitle :: IO ()
testProjByAccountTitle = do
    let noTitle = 7 :@ Not :< wildcard :: Alg Double (HatBase AccountTitles)
        cash = 10 :@ Not :< Cash
        ledger = noTitle .+ cash
        postings = List.sort . foldEntries (\result value postingBase ->
            (show postingBase, value) : result) []
    assertTest "projByAccountTitle: concrete title skips a ledger wildcard (single)"
        (Algebra.isZero (projByAccountTitle Cash noTitle))
    assertTest "projByAccountTitle: concrete title skips a ledger wildcard (Liner)"
        (postings (projByAccountTitle Cash ledger) == postings cash)
    assertTest "projByAccountTitle: wildcard title selects every entry"
        (postings (projByAccountTitle wildcard ledger) == postings ledger)

-- | 'Algebra.map' keeps a rewrite between a wildcard and a concrete coordinate
-- in both directions and in both ledger shapes.
testMapRewritesWildcardAxis :: IO ()
testMapRewritesWildcardAxis = do
    let cash = 10 :@ Not :< (Cash, wildcard) :: TestAlg
        cashYen = 10 :@ Not :< (Cash, Yen) :: TestAlg
        products = 3 :@ Not :< (Products, Amount) :: TestAlg
        setCashUnit unit entry@(value :@ (h :< (title, _)))
            | title == Cash = value :@ (h :< (title, unit))
            | otherwise     = entry
        setCashUnit _ entry = entry
    assertTest "map: wildcard axis rewritten to a concrete value (single)"
        (observe (Algebra.map (setCashUnit Yen) cash) == observe cashYen)
    assertTest "map: wildcard axis rewritten to a concrete value (Liner)"
        (observe (Algebra.map (setCashUnit Yen) (cash .+ products))
            == observe (cashYen .+ products))
    assertTest "map: concrete axis rewritten to the wildcard (Liner)"
        (observe (Algebra.map (setCashUnit wildcard) (cashYen .+ products))
            == observe (cash .+ products))

-- | Flattening Text coordinates preserves projection norms, net norms,
-- collapse postings, and symmetric matching. Small non-negative whole values
-- make the Double observations exact; either inner query axis may be a wildcard.
propNestedFlattening :: (Text, Text, Text) -> (Double, Double, Double) -> Bool
propNestedFlattening (queryFirst, querySecond, queryThird) (notValue, hatValue, otherValue) =
    norm (proj [nestedQuery] nestedLedger) == norm (proj [flatQuery] flatLedger)
        && projNetNorm [nestedQuery] nestedLedger == projNetNorm [flatQuery] flatLedger
        && List.sort nestedCollapsed == List.sort flatCollapsed
        && (nestedStored .== nestedCoordinates) == (flatStored .== flatCoordinates)
        && ((Not :< nestedStored) .== (Not :< nestedCoordinates))
            == ((Not :< flatStored) .== (Not :< flatCoordinates))
  where
    nestedStored      = (("a", "b"), "c") :: ((Text, Text), Text)
    flatStored        = ("a", "b", "c") :: (Text, Text, Text)
    nestedCoordinates = ((queryFirst, querySecond), queryThird)
    flatCoordinates   = (queryFirst, querySecond, queryThird)
    nestedQuery       = HatNot :< nestedCoordinates
    flatQuery         = HatNot :< flatCoordinates
    nestedLedger :: Alg Double (HatBase ((Text, Text), Text))
    nestedLedger = notValue   .@ Not :< nestedStored
                .+ hatValue   .@ Hat :< nestedStored
                .+ otherValue .@ Not :< (("x", "y"), "z")
    flatLedger :: Alg Double (HatBase (Text, Text, Text))
    flatLedger = notValue   .@ Not :< flatStored
              .+ hatValue   .@ Hat :< flatStored
              .+ otherValue .@ Not :< ("x", "y", "z")
    nestedCollapsed :: [(Double, Hat, (Text, Text, Text))]
    nestedCollapsed = foldEntries
        (\result value (side :< ((first, second), third)) ->
            (value, side, (first, second, third)) : result) []
        (collapseEntries [nestedQuery] (const (("a", "b"), "d")) nestedLedger)
    flatCollapsed :: [(Double, Hat, (Text, Text, Text))]
    flatCollapsed = foldEntries
        (\result value (side :< coordinates) -> (value, side, coordinates) : result) []
        (collapseEntries [flatQuery] (const ("a", "b", "d")) flatLedger)

-- | The reported inner-only wildcard selects gross 13 and net 7, and
-- collapseEntries adds reversal and replacement postings with total norm 26.
testNestedWildcard :: IO ()
testNestedWildcard = do
    let ledger = 10 .@ Not :< (("a", "b"), "c")
              .+  3 .@ Hat :< (("a", "b"), "c")
              .+  2 .@ Not :< (("x", "y"), "z")
              :: Alg Double (HatBase ((Text, Text), Text))
        query = HatNot :< (("a", ""), "c")
    assertTest "nested wildcard: reported projection and collapse values"
        (norm (proj [query] ledger) == 13
            && projNetNorm [query] ledger == 7
            && norm (collapseEntries [query] (const (("a", "b"), "d")) ledger) == 26)
    assertTest "nested wildcard: reported case agrees with flat coordinates"
        (propNestedFlattening ("a", "", "c") (10, 3, 2))

runTests :: IO ()
runTests = do
    testReportedTable
    testProjByAccountTitle
    testMapRewritesWildcardAxis
    testNestedWildcard
    quickProperty "nested wildcard: flattening preserves projection, collapse, and matching"
        (forAll ((,,) <$> elements ["a", ""] <*> elements ["b", ""]
                      <*> elements ["c", ""]) $ \coordinates ->
            forAll ((,,) <$> (fromIntegral <$> chooseInt (0, 1000))
                         <*> (fromIntegral <$> chooseInt (0, 1000))
                         <*> (fromIntegral <$> chooseInt (0, 1000)))
                (propNestedFlattening coordinates))
    quickProperty "proj: Liner result equals the one-way reference (ledger wildcards)"
        (forAll genProjCase propLedger)
    quickProperty "proj: single-element result equals the one-way reference"
        (forAll genProjCase propSingle)
    quickProperty "projNetNorm: equals the one-way reference for both shapes"
        (forAll genProjCase propNetNorm)
    quickProperty "proj: concrete ledgers keep the old symmetric result"
        (forAll genConcreteCase propConcreteRegression)