lib/Hcompta/Balance/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE Rank2Types #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TupleSections #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11
  12 module Balance.Test where
  13
  14 import Control.Arrow ((***))
  15 import Data.Data ()
  16 import Data.Either (Either(..), either, isRight)
  17 import Data.Eq (Eq(..))
  18 import Data.Function (($), (.), id, const)
  19 import Data.Functor ((<$>))
  20 import Data.Map.Strict (Map)
  21 import Data.Maybe (Maybe(..))
  22 import Data.Ord (Ord(..))
  23 import Data.String (String)
  24 import Data.Text (Text)
  25 import Data.Tuple (snd)
  26 import Prelude (Integer, error)
  27 import Test.Tasty
  28 import Test.Tasty.HUnit
  29 import Text.Show (Show(..))
  30 import qualified Data.List as List
  31 import qualified Data.Map.Strict as Map
  32 import qualified Data.NonNull as NonNull
  33 import qualified Data.Text as Text
  34
  35 import qualified Data.TreeMap.Strict as TreeMap
  36 import qualified Hcompta as H
  37 import qualified Hcompta.Lib.Strict as Strict
  38
  39 elide :: String -> String
  40 elide s | List.length s > 42 = List.take 42 s List.++ ['…']
  41 elide s = s
  42
  43 type Unit = Text
  44 type Quantity = Integer
  45 amounts :: (H.Addable q, Ord u) => [(u, q)] -> Map u q
  46 amounts = Map.fromListWith (H.+)
  47 pol :: H.Polarizable t => (forall q. q -> (Unit, q)) -> (t -> (Unit, H.Polarized t))
  48 pol u = u . H.polarize
  49 usd :: t -> (Unit, t)
  50 usd = ("$",)
  51 eur :: t -> (Unit, t)
  52 eur = ("€",)
  53 gbp :: t -> (Unit, t)
  54 gbp = ("£",)
  55
  56 type Account = Text
  57 account :: Text -> TreeMap.Path Text
  58 account txt = case go txt of
  59          [] -> error "account"
  60          a:as -> NonNull.ncons a as
  61         where
  62         sep = '/'
  63         go t =
  64                 case Text.uncons t of
  65                  Nothing -> []
  66                  Just (x, xs) ->
  67                         if x == sep
  68                         then go xs
  69                         else
  70                                 let (chunk, rest) = Text.break (== sep) t in
  71                                 chunk:go rest
  72
  73 type Posting = (Account, [(Unit, Quantity)])
  74 instance H.To (TreeMap.Path a) (TreeMap.Path a) where to = id
  75
  76 tests :: TestTree
  77 tests = testGroup "Balance"
  78  [ testGroup "balanceOf" $
  79         let (==>) (input::[Posting])
  80                  ( byAccount::[(Account, [(Unit, H.Polarized Quantity)])]
  81                  , byUnit::[(Unit, (H.Polarized Quantity, [Account]))] ) =
  82                 testCase (elide $ show input) $
  83                 List.foldl (H.+=) H.zero
  84                  ((account *** Map.map H.polarize . amounts) <$> input) @?=
  85                 H.Balance
  86                  { H.balByAccount = TreeMap.from_List const $
  87                         (account *** amounts) <$> byAccount
  88                  , H.balByUnit = Map.fromList $
  89                         (id *** (\(q, as) -> H.SumByUnit q $ Map.fromList $ ((,()) . account <$> as))) <$> byUnit
  90                  }
  91         in
  92          [ [ ("/A", [usd 1]) ] ==> (,)
  93                 [ ("/A", [pol usd 1]) ]
  94                 [ usd (H.polarize 1, ["/A"]) ]
  95          , [ ("/A", [usd 1])
  96                  , ("/A", [usd (-1)]) ] ==> (,)
  97                 [ ("/A", [usd $ H.PolBoth (-1) 1]) ]
  98                 [ usd (H.PolBoth (-1) 1, ["/A"]) ]
  99          , [ ("/A", [usd 1])
 100                  , ("/A", [eur (-1)]) ] ==> (,)
 101                 [ ("/A", [ pol usd 1
 102                          , pol eur (-1) ]) ]
 103                 [ usd (H.polarize 1, ["/A"])
 104                 , eur (H.polarize (-1), ["/A"]) ]
 105          , [ ("/A", [usd 1])
 106                  , ("/B", [usd (-1)]) ] ==> (,)
 107                 [ ("/A", [pol usd 1])
 108                 , ("/B", [pol usd (-1)]) ]
 109                 [ usd (H.PolBoth (-1) 1, ["/A", "/B"]) ]
 110          , [ ("/A", [usd 1])
 111                  , ("/B", [eur (-1)]) ] ==> (,)
 112                 [ ("/A", [pol usd 1])
 113                 , ("/B", [pol eur (-1)]) ]
 114                 [ usd (H.polarize 1, ["/A"])
 115                 , eur (H.polarize (-1), ["/B"]) ]
 116          , [ ("/A", [usd 1])
 117                  , ("/B", [usd 1]) ] ==> (,)
 118                 [ ("/A", [pol usd 1])
 119                 , ("/B", [pol usd 1]) ]
 120                 [ usd (H.polarize 2, ["/A", "/B"]) ]
 121          , [ ("/A", [usd 1, eur 2])
 122                  , ("/A", [usd (-1), eur (-2)]) ] ==> (,)
 123                 [ ("/A", [ usd $ H.PolBoth (-1) 1
 124                          , eur $ H.PolBoth (-2) 2 ]) ]
 125                 [ usd (H.PolBoth (-1) 1, ["/A"])
 126                 , eur (H.PolBoth (-2) 2, ["/A"]) ]
 127          , [ ("/A", [usd 1, eur 2, gbp 3])
 128                  , ("/B", [usd (-1), eur (-2), gbp (-3)]) ] ==> (,)
 129                 [ ("/A", [ pol usd 1
 130                          , pol eur 2
 131                          , pol gbp 3 ])
 132                 , ("/B", [ pol usd (-1)
 133                          , pol eur (-2)
 134                          , pol gbp (-3) ]) ]
 135                 [ usd (H.PolBoth (-1) 1, ["/A", "/B"])
 136                 , eur (H.PolBoth (-2) 2, ["/A", "/B"])
 137                 , gbp (H.PolBoth (-3) 3, ["/A", "/B"]) ]
 138          ]
 139  , testGroup "unionBal" $
 140         let (==>)
 141                  (input::
 142                  [( [(Account, [(Unit, H.Polarized Quantity)])]
 143                   , [(Unit, (H.Polarized Quantity, [Account]))] )])
 144                  (expected::
 145                  ( [(Account, [(Unit, H.Polarized Quantity)])]
 146                  , [(Unit, (H.Polarized Quantity, [Account]))] )) =
 147                 testCase (elide $ show input) $
 148                 List.foldl (H.+) H.zero (bal <$> input) @?= bal expected
 149                 where
 150                 bal (byAccount, byUnit) =
 151                         H.Balance
 152                          { H.balByAccount = TreeMap.from_List const $
 153                                 (account *** amounts) <$> byAccount
 154                          , H.balByUnit = Map.fromList $
 155                                 (id *** (\(q, as) -> H.SumByUnit q $ Map.fromList $ ((,()) . account <$> as))) <$> byUnit
 156                          }
 157         in
 158          [ [ (,)
 159                         [ ("/A", [pol usd 1]) ]
 160                         [ usd (H.polarize 1, ["/A"]) ]
 161                  , (,)
 162                         [ ("/A", [pol usd 1]) ]
 163                         [ usd (H.polarize 1, ["/A"]) ]
 164                  ] ==> (,)
 165                         [ ("/A", [pol usd 2]) ]
 166                         [ usd (H.polarize 2, ["/A"]) ]
 167          , [ (,)
 168                         [ ("/A", [pol usd 1]) ]
 169                         [ usd (H.polarize 1, ["/A"]) ]
 170                  , (,)
 171                         [ ("/B", [pol usd 1]) ]
 172                         [ usd (H.polarize 1, ["/B"]) ]
 173                  ] ==> (,)
 174                         [ ("/A", [pol usd 1])
 175                         , ("/B", [pol usd 1]) ]
 176                         [ usd (H.polarize 2, ["/A", "/B"]) ]
 177          , [ (,)
 178                         [ ("/A", [pol usd 1]) ]
 179                         [ usd (H.polarize 1, ["/A"]) ]
 180                  , (,)
 181                         [ ("/B", [pol eur 1]) ]
 182                         [ eur (H.polarize 1, ["/B"]) ]
 183                  ] ==> (,)
 184                         [ ("/A", [pol usd 1])
 185                         , ("/B", [pol eur 1]) ]
 186                         [ usd (H.polarize 1, ["/A"])
 187                         , eur (H.polarize 1, ["/B"]) ]
 188          , [ (,)
 189                         [ ("/A", [pol usd 1, pol eur 2]) ]
 190                         [ usd (H.polarize 1, ["/A"])
 191                         , eur (H.polarize 2, ["/A"]) ]
 192                  , (,)
 193                         [ ("/B", [pol usd (-1), pol eur (-2)]) ]
 194                         [ usd (H.polarize (-1), ["/B"])
 195                         , eur (H.polarize (-2), ["/B"]) ]
 196                  ] ==> (,)
 197                         [ ("/A", [pol usd 1   , pol eur 2])
 198                         , ("/B", [pol usd (-1), pol eur (-2)]) ]
 199                         [ usd (H.PolBoth (-1) 1, ["/A", "/B"])
 200                         , eur (H.PolBoth (-2) 2, ["/A", "/B"]) ]
 201          , [ (,)
 202                         [ ("/A", [pol usd 1, pol eur 2]) ]
 203                         [ usd (H.polarize 1, ["/A"])
 204                         , eur (H.polarize 2, ["/A"]) ]
 205                  , (,)
 206                         [ ("/B", [pol usd (-1), pol eur (-2)]) ]
 207                         [ usd (H.polarize (-1), ["/B"])
 208                         , eur (H.polarize (-2), ["/B"]) ]
 209                  , (,)
 210                         [ ("/C", [pol gbp 3]) ]
 211                         [ gbp (H.polarize 3, ["/C"]) ]
 212                  ] ==> (,)
 213                         [ ("/A", [pol usd 1   , pol eur 2])
 214                         , ("/B", [pol usd (-1), pol eur (-2)])
 215                         , ("/C", [pol gbp 3]) ]
 216                         [ usd (H.PolBoth (-1) 1, ["/A", "/B"])
 217                         , eur (H.PolBoth (-2) 2, ["/A", "/B"])
 218                         , gbp (H.polarize 3, ["/C"]) ]
 219          ]
 220  , testGroup "clusiveBalByAccount" $
 221         let (==>)
 222                  (input::[(Account, [(Unit, H.Polarized Quantity)])])
 223                  (expected::[(Account, ( [(Unit, H.Polarized Quantity)]
 224                                        , [(Unit, H.Polarized Quantity)] ))]) =
 225                 testCase (elide $ show input) $
 226                 H.clusiveBalByAccount (bal input) @?= exbal expected
 227                 where
 228                 bal byAccount =
 229                         TreeMap.from_List const $
 230                         (account *** amounts) <$> byAccount
 231                 exbal byAccount =
 232                         TreeMap.from_List const $
 233                         (account *** (\(e, i) -> Strict.Clusive (amounts e) (amounts i) )) <$> byAccount
 234         in
 235          [ [] ==> []
 236          , [ ("/A", [pol usd 1]) ] ==>
 237                 [ ("/A", (,) [pol usd 1] [pol usd 1]) ]
 238          , [ ("/A/A", [pol usd 1]) ] ==>
 239                 [ ("/A",   (,) []          [pol usd 1])
 240                 , ("/A/A", (,) [pol usd 1] [pol usd 1]) ]
 241          , [ ("/A/B", [pol usd 1]) ] ==>
 242                 [ ("/A",   (,) []          [pol usd 1])
 243                 , ("/A/B", (,) [pol usd 1] [pol usd 1]) ]
 244          , [ ("/A/B/C", [pol usd 1]) ] ==>
 245                 [ ("/A",     (,) []          [pol usd 1])
 246                 , ("/A/B",   (,) []          [pol usd 1])
 247                 , ("/A/B/C", (,) [pol usd 1] [pol usd 1]) ]
 248          , [ ("/A/B",   [pol usd (-1)])
 249                  , ("/A/B/C", [pol usd 1])
 250                  ] ==>
 251                 [ ("/A",     (,) []             [usd $ H.PolBoth (-1) 1])
 252                 , ("/A/B",   (,) [pol usd (-1)] [usd $ H.PolBoth (-1) 1])
 253                 , ("/A/B/C", (,) [pol usd 1]    [pol usd 1]) ]
 254          , [ ("/A/B",   [pol usd 1])
 255                  , ("/A/B/C", [pol usd 1])
 256                  , ("/A/B/D", [pol usd 1])
 257                  ] ==>
 258                 [ ("/A",     (,) []          [pol usd 3])
 259                 , ("/A/B",   (,) [pol usd 1] [pol usd 3])
 260                 , ("/A/B/C", (,) [pol usd 1] [pol usd 1])
 261                 , ("/A/B/D", (,) [pol usd 1] [pol usd 1]) ]
 262          , [ ("/A/B", [pol usd 1])
 263                  , ("/A/C", [pol usd 1])
 264                  , ("/D/B", [pol usd 1])
 265                  ] ==>
 266                 [ ("/A",   (,) []          [pol usd 2])
 267                 , ("/A/B", (,) [pol usd 1] [pol usd 1])
 268                 , ("/A/C", (,) [pol usd 1] [pol usd 1])
 269                 , ("/D",   (,) []          [pol usd 1])
 270                 , ("/D/B", (,) [pol usd 1] [pol usd 1]) ]
 271          ]
 272  , testGroup "deviationByUnit" $
 273         let (==>) (input::[Posting])
 274                  (expected::[(Unit, (H.Polarized Quantity, [Account]))]) =
 275                 testCase (elide $ show input) $
 276                 H.deviationByUnit
 277                  H.Balance
 278                          { H.balByAccount
 279                          , H.balByUnit
 280                          } @?=
 281                 H.DeviationByUnit balDev
 282                 where
 283                 balByAccount =
 284                         TreeMap.from_List const $
 285                         (account *** (H.polarize <$>) . amounts) <$> input
 286                 balByUnit = H.sum balByAccount
 287                 balDev =
 288                         Map.fromList $
 289                         (id *** (\(q, as) ->
 290                                 H.SumByUnit q $ Map.fromList $
 291                                 ((,()) . account <$> as))
 292                         ) <$> expected
 293         in
 294          [ [] ==> []
 295          , [ ("/A", [usd 1]) ] ==>
 296                 [usd (H.polarize 1, [])]
 297          , [ ("/A", [usd 1])
 298                  , ("/B", []) ] ==>
 299                 [usd (H.polarize 1, ["/B"])]
 300          , [ ("/A",   [usd 1])
 301                  , ("/A/B", []) ] ==>
 302                 [usd (H.polarize 1, ["/A/B"])]
 303          , [ ("/A",   [usd 1])
 304                  , ("/A/B", [usd (-1)]) ] ==>
 305                 []
 306          , [ ("/A",   [usd 1])
 307                  , ("/A/B", [eur (-1)]) ] ==>
 308                 [ usd (H.polarize 1, ["/A/B"])
 309                 , eur (H.polarize (-1), ["/A"])
 310                 ]
 311          , [ ("/A", [usd 1])
 312                  , ("/B", [usd 1]) ] ==>
 313                 [usd (H.polarize 2, [])]
 314          , [ ("/A", [usd 1])
 315                  , ("/B", [eur 2]) ] ==>
 316                 [ usd (H.polarize 1, ["/B"])
 317                 , eur (H.polarize 2, ["/A"])
 318                 ]
 319          , [ ("/A", [usd 1, eur 2])
 320                  , ("/B", [usd (-1), eur 2]) ] ==>
 321                 [ eur (H.polarize 4, []) ]
 322          , [ ("/A", [usd 1, eur 2])
 323                  , ("/B", [usd (-1), eur 2])
 324                  , ("/C", [gbp 3]) ] ==>
 325                 [ eur (H.polarize 4, ["/C"])
 326                 , gbp (H.polarize 3, ["/A", "/B"]) ]
 327          ]
 328  , testGroup "equilibrium" $
 329         let (==>) (input::[Posting])
 330                  (expected::Either [(Unit, (H.Polarized Quantity, [Account]))] [Posting]) =
 331                 testCase (elide $ show input) $
 332                 let o = snd (H.equilibrium $ postings input) in
 333                 let e = either (Left . units) (Right . postings) expected in
 334                 let is = H.isEquilibriumInferrable $
 335                         H.deviationByUnit
 336                          H.Balance
 337                                  { H.balByAccount
 338                                  , H.balByUnit
 339                                  } in
 340                 (isRight o, o) @?= (is, e)
 341                 where
 342                 postings
 343                  :: [Posting]
 344                  -> Map (TreeMap.Path Text)
 345                         [( TreeMap.Path Text
 346                          , Map Unit (H.Polarized Quantity) )]
 347                 postings =
 348                         Map.fromList .
 349                         ((\(acct, amts) ->
 350                                 let a = account acct in (a,)
 351                                 [(a, H.polarize <$> amounts amts)] ) <$>)
 352                 units
 353                  :: [(Unit, (H.Polarized Quantity, [Account]))]
 354                  -> [(Unit, H.SumByUnit (TreeMap.Path Text) (H.Polarized Quantity))]
 355                 units =
 356                         ((id *** (\(q, as) ->
 357                                 H.SumByUnit q $ Map.fromList $
 358                                 ((,()) . account <$> as))) <$>)
 359                 balByAccount =
 360                         TreeMap.from_List const $
 361                         (account *** (H.polarize <$>) . amounts) <$> input
 362                 balByUnit = H.sum balByAccount
 363         in
 364          [ [] ==> Right []
 365          , [ ("/A", [usd 1]) ] ==> Left
 366                  [ usd (H.polarize 1, []) ]
 367          , [ ("/A", [usd 1])
 368                  , ("/B", []) ] ==> Right
 369                  [ ("/A", [usd 1])
 370                  , ("/B", [usd (-1)]) ]
 371          , [ ("/A",   [usd 1])
 372                  , ("/A/B", []) ] ==> Right
 373                  [ ("/A",   [usd 1])
 374                  , ("/A/B", [usd (-1)]) ]
 375          , [ ("/A",   [usd 1])
 376                  , ("/A/B", [usd (-1)]) ] ==> Right
 377                  [ ("/A",   [usd 1])
 378                  , ("/A/B", [usd (-1)]) ]
 379          , [ ("/A",   [usd 1])
 380                  , ("/A/B", [eur (-1)]) ] ==> Right
 381                  [ ("/A",   [usd 1, eur 1])
 382                  , ("/A/B", [usd (-1), eur (-1)]) ]
 383          , [ ("/A", [usd 1])
 384                  , ("/B", [usd 1]) ] ==> Left
 385                  [ usd (H.polarize 2, []) ]
 386          , [ ("/A", [usd 1])
 387                  , ("/B", [eur 2]) ] ==> Right
 388                  [ ("/A", [usd 1, eur (-2)])
 389                  , ("/B", [usd (-1), eur 2]) ]
 390          , [ ("/A", [usd 1, eur 2])
 391                  , ("/B", [usd (-1), eur 2]) ] ==> Left
 392                  [ eur (H.polarize 4, []) ]
 393          , [ ("/A", [usd 1, eur 2])
 394                  , ("/B", [usd (-1), eur 2])
 395                  , ("/C", [gbp 3]) ] ==> Left
 396                  [ gbp (H.polarize 3, ["/A", "/B"]) ]
 397          ]
 398  ]