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 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10
  11 module Balance.Test where
  12 import           Control.Arrow ((***))
  13 import           Data.Data ()
  14 import           Data.Either (Either(..), either, isRight)
  15 import           Data.Maybe (Maybe(..))
  16 import           Data.Monoid (Monoid(..))
  17 import           Data.Function (($), (.), id, const, flip)
  18 import           Data.Functor ((<$>))
  19 import           Data.Eq (Eq(..))
  20 import qualified Data.List as List
  21 import           Data.List.NonEmpty (NonEmpty(..))
  22 import qualified Data.Map.Strict as Map
  23 import           Data.Ord (Ord(..))
  24 import           Data.String (String)
  25 import           Data.Text (Text)
  26 import qualified Data.Text as Text
  27 import           Data.Tuple (snd)
  28 import           Prelude (Integer, error)
  29 import           Text.Show (Show(..))
  30 import           Test.Tasty
  31 import           Test.Tasty.HUnit
  32
  33 import qualified Data.TreeMap.Strict as TreeMap
  34 import qualified Hcompta as H
  35 import qualified Hcompta.Lib.Strict as Strict
  36
  37 elide :: String -> String
  38 elide s | List.length s > 42 = List.take 42 s List.++ ['…']
  39 elide s = s
  40
  41 type Unit = Text
  42 type Quantity = Integer
  43 amounts :: (H.Addable q, Ord u) => [(u, q)] -> Map.Map u q
  44 amounts = Map.fromListWith H.quantity_add
  45 pol :: H.Polarizable t => (forall q. q -> (Unit, q)) -> (t -> (Unit, H.Polarized t))
  46 pol u = u . H.polarize
  47 usd :: t -> (Unit, t)
  48 usd = ("$",)
  49 eur :: t -> (Unit, t)
  50 eur = ("€",)
  51 gbp :: t -> (Unit, t)
  52 gbp = ("£",)
  53
  54 type Account = Text
  55 account :: Text -> H.Balance_Account Text
  56 account txt = case go txt of
  57          [] -> error "account"
  58          a:as -> a:|as
  59         where
  60         sep = '/'
  61         go t =
  62                 case Text.uncons t of
  63                  Nothing -> []
  64                  Just (x, xs) ->
  65                         if x == sep
  66                         then go xs
  67                         else
  68                                 let (chunk, rest) = Text.break (== sep) t in
  69                                 chunk:go rest
  70
  71 type Posting = (Account, [(Unit, Quantity)])
  72 instance H.Get (H.Balance_Account a) (H.Balance_Account a) where get = id
  73
  74 tests :: TestTree
  75 tests = testGroup "Balance"
  76  [ testGroup "balance_cons" $
  77         let (==>) (input::[Posting])
  78                  ( byAccount::[(Account, [(Unit, H.Polarized Quantity)])]
  79                  , byUnit::[(Unit, (H.Polarized Quantity, [Account]))] ) =
  80                 testCase (elide $ show input) $
  81                 List.foldl (flip H.balance_cons) H.balance_empty
  82                  ((account *** Map.map H.polarize . amounts) <$> input) @?=
  83                 H.Balance
  84                  { H.balByAccount = TreeMap.from_List const $
  85                         (account *** H.SumByAccount . amounts) <$> byAccount
  86                  , H.balByUnit = H.BalByUnit $ Map.fromList $
  87                         (id *** (\(q, as) -> H.SumByUnit q $ Map.fromList $ ((,()) . account <$> as))) <$> byUnit
  88                  }
  89         in
  90          [ [ ("/A", [usd 1]) ] ==> (,)
  91                 [ ("/A", [pol usd 1]) ]
  92                 [ usd (H.polarize 1, ["/A"]) ]
  93          , [ ("/A", [usd 1])
  94                  , ("/A", [usd (-1)]) ] ==> (,)
  95                 [ ("/A", [usd $ H.Polarized_Both (-1) 1]) ]
  96                 [ usd (H.Polarized_Both (-1) 1, ["/A"]) ]
  97          , [ ("/A", [usd 1])
  98                  , ("/A", [eur (-1)]) ] ==> (,)
  99                 [ ("/A", [ pol usd 1
 100                          , pol eur (-1) ]) ]
 101                 [ usd (H.polarize 1, ["/A"])
 102                 , eur (H.polarize (-1), ["/A"]) ]
 103          , [ ("/A", [usd 1])
 104                  , ("/B", [usd (-1)]) ] ==> (,)
 105                 [ ("/A", [pol usd 1])
 106                 , ("/B", [pol usd (-1)]) ]
 107                 [ usd (H.Polarized_Both (-1) 1, ["/A", "/B"]) ]
 108          , [ ("/A", [usd 1])
 109                  , ("/B", [eur (-1)]) ] ==> (,)
 110                 [ ("/A", [pol usd 1])
 111                 , ("/B", [pol eur (-1)]) ]
 112                 [ usd (H.polarize 1, ["/A"])
 113                 , eur (H.polarize (-1), ["/B"]) ]
 114          , [ ("/A", [usd 1])
 115                  , ("/B", [usd 1]) ] ==> (,)
 116                 [ ("/A", [pol usd 1])
 117                 , ("/B", [pol usd 1]) ]
 118                 [ usd (H.polarize 2, ["/A", "/B"]) ]
 119          , [ ("/A", [usd 1, eur 2])
 120                  , ("/A", [usd (-1), eur (-2)]) ] ==> (,)
 121                 [ ("/A", [ usd $ H.Polarized_Both (-1) 1
 122                          , eur $ H.Polarized_Both (-2) 2 ]) ]
 123                 [ usd (H.Polarized_Both (-1) 1, ["/A"])
 124                 , eur (H.Polarized_Both (-2) 2, ["/A"]) ]
 125          , [ ("/A", [usd 1, eur 2, gbp 3])
 126                  , ("/B", [usd (-1), eur (-2), gbp (-3)]) ] ==> (,)
 127                 [ ("/A", [ pol usd 1
 128                          , pol eur 2
 129                          , pol gbp 3 ])
 130                 , ("/B", [ pol usd (-1)
 131                          , pol eur (-2)
 132                          , pol gbp (-3) ]) ]
 133                 [ usd (H.Polarized_Both (-1) 1, ["/A", "/B"])
 134                 , eur (H.Polarized_Both (-2) 2, ["/A", "/B"])
 135                 , gbp (H.Polarized_Both (-3) 3, ["/A", "/B"]) ]
 136          ]
 137  , testGroup "balance_union" $
 138         let (==>)
 139                  (input::
 140                  [( [(Account, [(Unit, H.Polarized Quantity)])]
 141                   , [(Unit, (H.Polarized Quantity, [Account]))] )])
 142                  (expected::
 143                  ( [(Account, [(Unit, H.Polarized Quantity)])]
 144                  , [(Unit, (H.Polarized Quantity, [Account]))] )) =
 145                 testCase (elide $ show input) $
 146                 List.foldl H.balance_union H.balance_empty (bal <$> input) @?= bal expected
 147                 where
 148                 bal (byAccount, byUnit) =
 149                         H.Balance
 150                          { H.balByAccount = TreeMap.from_List const $
 151                                 (account *** H.SumByAccount . amounts) <$> byAccount
 152                          , H.balByUnit = H.BalByUnit $ Map.fromList $
 153                                 (id *** (\(q, as) -> H.SumByUnit q $ Map.fromList $ ((,()) . account <$> as))) <$> byUnit
 154                          }
 155         in
 156          [ [ (,)
 157                         [ ("/A", [pol usd 1]) ]
 158                         [ usd (H.polarize 1, ["/A"]) ]
 159                  , (,)
 160                         [ ("/A", [pol usd 1]) ]
 161                         [ usd (H.polarize 1, ["/A"]) ]
 162                  ] ==> (,)
 163                         [ ("/A", [pol usd 2]) ]
 164                         [ usd (H.polarize 2, ["/A"]) ]
 165          , [ (,)
 166                         [ ("/A", [pol usd 1]) ]
 167                         [ usd (H.polarize 1, ["/A"]) ]
 168                  , (,)
 169                         [ ("/B", [pol usd 1]) ]
 170                         [ usd (H.polarize 1, ["/B"]) ]
 171                  ] ==> (,)
 172                         [ ("/A", [pol usd 1])
 173                         , ("/B", [pol usd 1]) ]
 174                         [ usd (H.polarize 2, ["/A", "/B"]) ]
 175          , [ (,)
 176                         [ ("/A", [pol usd 1]) ]
 177                         [ usd (H.polarize 1, ["/A"]) ]
 178                  , (,)
 179                         [ ("/B", [pol eur 1]) ]
 180                         [ eur (H.polarize 1, ["/B"]) ]
 181                  ] ==> (,)
 182                         [ ("/A", [pol usd 1])
 183                         , ("/B", [pol eur 1]) ]
 184                         [ usd (H.polarize 1, ["/A"])
 185                         , eur (H.polarize 1, ["/B"]) ]
 186          , [ (,)
 187                         [ ("/A", [pol usd 1, pol eur 2]) ]
 188                         [ usd (H.polarize 1, ["/A"])
 189                         , eur (H.polarize 2, ["/A"]) ]
 190                  , (,)
 191                         [ ("/B", [pol usd (-1), pol eur (-2)]) ]
 192                         [ usd (H.polarize (-1), ["/B"])
 193                         , eur (H.polarize (-2), ["/B"]) ]
 194                  ] ==> (,)
 195                         [ ("/A", [pol usd 1   , pol eur 2])
 196                         , ("/B", [pol usd (-1), pol eur (-2)]) ]
 197                         [ usd (H.Polarized_Both (-1) 1, ["/A", "/B"])
 198                         , eur (H.Polarized_Both (-2) 2, ["/A", "/B"]) ]
 199          , [ (,)
 200                         [ ("/A", [pol usd 1, pol eur 2]) ]
 201                         [ usd (H.polarize 1, ["/A"])
 202                         , eur (H.polarize 2, ["/A"]) ]
 203                  , (,)
 204                         [ ("/B", [pol usd (-1), pol eur (-2)]) ]
 205                         [ usd (H.polarize (-1), ["/B"])
 206                         , eur (H.polarize (-2), ["/B"]) ]
 207                  , (,)
 208                         [ ("/C", [pol gbp 3]) ]
 209                         [ gbp (H.polarize 3, ["/C"]) ]
 210                  ] ==> (,)
 211                         [ ("/A", [pol usd 1   , pol eur 2])
 212                         , ("/B", [pol usd (-1), pol eur (-2)])
 213                         , ("/C", [pol gbp 3]) ]
 214                         [ usd (H.Polarized_Both (-1) 1, ["/A", "/B"])
 215                         , eur (H.Polarized_Both (-2) 2, ["/A", "/B"])
 216                         , gbp (H.polarize 3, ["/C"]) ]
 217          ]
 218  , testGroup "clusiveBalByAccount" $
 219         let (==>)
 220                  (input::[(Account, [(Unit, H.Polarized Quantity)])])
 221                  (expected::[(Account, ( [(Unit, H.Polarized Quantity)]
 222                                        , [(Unit, H.Polarized Quantity)] ))]) =
 223                 testCase (elide $ show input) $
 224                 H.clusiveBalByAccount (bal input) @?= exbal expected
 225                 where
 226                 bal byAccount =
 227                         TreeMap.from_List const $
 228                         (account *** H.SumByAccount . amounts) <$> byAccount
 229                 exbal byAccount =
 230                         TreeMap.from_List const $
 231                         (account *** (\(e, i) -> Strict.Clusive
 232                          (H.SumByAccount (amounts e))
 233                          (H.SumByAccount (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.Polarized_Both (-1) 1])
 252                 , ("/A/B",   (,) [pol usd (-1)] [usd $ H.Polarized_Both (-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.SumByAccount . (H.polarize <$>) . amounts) <$> input
 286                 balByUnit = H.balByUnit_of_BalByAccount balByAccount mempty
 287                 balDev =
 288                         H.BalByUnit $ 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.is_equilibrium_inferrable $
 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.Map (H.Balance_Account Text)
 345                             [( H.Balance_Account Text
 346                              , Map.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 (H.Balance_Account 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.SumByAccount . (H.polarize <$>) . amounts) <$> input
 362                 balByUnit = H.balByUnit_of_BalByAccount balByAccount mempty
 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  ]