lib/Hcompta/Filter.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE TupleSections #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 module Hcompta.Filter where
   9
  10 import           Prelude hiding (filter)
  11 import           Control.Applicative (pure, (<$>), (<*>))
  12 import           Data.Data
  13 import qualified Data.Fixed
  14 import qualified Data.Foldable
  15 import           Data.Foldable (Foldable(..))
  16 import qualified Data.Functor.Compose
  17 import           Data.Traversable (Traversable(..))
  18 import qualified Data.Monoid
  19 import           Data.Monoid (Monoid(..))
  20 import           Data.Typeable ()
  21 import           Data.Text (Text)
  22 -- import qualified Data.Text as Text
  23 import qualified Data.Map.Strict as Data.Map
  24 import           Data.Map.Strict (Map)
  25 import           Text.Regex.TDFA ()
  26 import           Text.Regex.Base ()
  27 import           Text.Regex.TDFA.Text ()
  28
  29 import qualified Data.List.NonEmpty as NonEmpty
  30 -- import           Data.List.NonEmpty (NonEmpty(..))
  31 import qualified Hcompta.Lib.Regex as Regex
  32 import           Hcompta.Lib.Regex (Regex)
  33 import qualified Hcompta.Amount as Amount
  34 import qualified Hcompta.Amount.Unit as Amount.Unit
  35 import qualified Hcompta.Date as Date
  36 import           Hcompta.Date (Date)
  37 import qualified Hcompta.Account as Account
  38 import           Hcompta.Account (Account)
  39 -- import qualified Hcompta.Date as Date
  40 import qualified Hcompta.Balance as Balance
  41 import qualified Hcompta.GL as GL
  42
  43 -- * Requirements' interface
  44
  45 -- ** Class 'Unit'
  46
  47 class Unit a where
  48         unit_text :: a -> Text
  49
  50 instance Unit Amount.Unit where
  51         unit_text = Amount.Unit.text
  52
  53 instance Unit Text where
  54         unit_text = id
  55
  56 -- ** Class 'Amount'
  57
  58 class
  59  ( Ord  (Amount_Quantity a)
  60  , Show (Amount_Quantity a)
  61  , Show (Amount_Unit a)
  62  , Unit (Amount_Unit a)
  63  )
  64  =>  Amount a where
  65         type Amount_Unit     a
  66         type Amount_Quantity a
  67         amount_unit     :: a -> Amount_Unit a
  68         amount_quantity :: a -> Amount_Quantity a
  69
  70 instance Amount Amount.Amount where
  71         type Amount_Unit     Amount.Amount = Amount.Unit
  72         type Amount_Quantity Amount.Amount = Amount.Quantity
  73         amount_quantity = Amount.quantity
  74         amount_unit     = Amount.unit
  75
  76 instance (Amount a, GL.Amount a)
  77  => Amount (Amount.Sum a) where
  78         type Amount_Unit     (Amount.Sum a) = Amount_Unit a
  79         type Amount_Quantity (Amount.Sum a) = Amount_Quantity a
  80         amount_quantity = amount_quantity . Amount.sum_balance
  81         amount_unit     = amount_unit     . Amount.sum_balance
  82
  83 -- ** Class 'Posting'
  84
  85 class Amount (Posting_Amount p)
  86  => Posting p where
  87         type Posting_Amount p
  88         posting_account :: p -> Account
  89         posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
  90
  91 -- ** Class 'Transaction'
  92
  93 class Posting (Transaction_Posting t)
  94  => Transaction t where
  95         type Transaction_Posting t
  96         transaction_date        :: t -> Date
  97         transaction_description :: t -> Text
  98         transaction_postings    :: t -> Map Account [Transaction_Posting t]
  99         transaction_tags        :: t -> Map Text [Text]
 100
 101 -- ** Class 'Balance'
 102
 103 class Amount (Balance_Amount b)
 104  => Balance b where
 105         type Balance_Amount b
 106         balance_account  :: b -> Account
 107         balance_amount   :: b -> Balance_Amount b
 108         balance_positive :: b -> Maybe (Balance_Amount b)
 109         balance_negative :: b -> Maybe (Balance_Amount b)
 110
 111 instance (Amount a, Balance.Amount a)
 112  => Balance (Account, Amount.Sum a) where
 113         type Balance_Amount (Account, Amount.Sum a) = a
 114         balance_account = fst
 115         balance_amount (_, amt) =
 116                 case amt of
 117                  Amount.Sum_Negative n -> n
 118                  Amount.Sum_Positive p -> p
 119                  Amount.Sum_Both n p   -> Balance.amount_add n p
 120         balance_positive = Amount.sum_positive . snd
 121         balance_negative = Amount.sum_negative . snd
 122
 123 -- ** Class 'GL'
 124
 125 class Amount (GL_Amount r)
 126  => GL r where
 127         type GL_Amount r
 128         register_account         :: r -> Account
 129         register_date            :: r -> Date
 130         register_amount_positive :: r -> Maybe (GL_Amount r)
 131         register_amount_negative :: r -> Maybe (GL_Amount r)
 132         register_amount_balance  :: r ->        GL_Amount r
 133         register_sum_positive    :: r -> Maybe (GL_Amount r)
 134         register_sum_negative    :: r -> Maybe (GL_Amount r)
 135         register_sum_balance     :: r ->        GL_Amount r
 136
 137 instance (Amount a, GL.Amount a)
 138  => GL (Account, Date, Amount.Sum a, Amount.Sum a) where
 139         type GL_Amount (Account, Date, Amount.Sum a, Amount.Sum a) = a
 140         register_account         (x, _, _, _) = x
 141         register_date            (_, x, _, _) = x
 142         register_amount_positive (_, _, x, _) = Amount.sum_positive x
 143         register_amount_negative (_, _, x, _) = Amount.sum_negative x
 144         register_amount_balance  (_, _, x, _) = Amount.sum_balance  x
 145         register_sum_positive    (_, _, _, x) = Amount.sum_positive x
 146         register_sum_negative    (_, _, _, x) = Amount.sum_negative x
 147         register_sum_balance     (_, _, _, x) = Amount.sum_balance  x
 148
 149 -- * Class 'Test'
 150
 151 class Test p x where
 152         test :: p -> x -> Bool
 153
 154 filter
 155  :: (Foldable t, Test p x, Monoid x)
 156  => p -> t x -> x
 157 filter p =
 158         Data.Foldable.foldMap
 159          (\x -> if test p x then x else mempty)
 160
 161 -- ** Type 'Test_Text'
 162
 163 data Test_Text
 164  =   Test_Text_Any
 165  |   Test_Text_Exact Text
 166  |   Test_Text_Regex Regex
 167  deriving (Eq, Show, Typeable)
 168
 169 instance Test Test_Text Text where
 170         test p x =
 171                 case p of
 172                  Test_Text_Any     -> True
 173                  Test_Text_Exact m -> (==) m x
 174                  Test_Text_Regex m -> Regex.match m x
 175
 176 -- ** Type 'Test_Ord'
 177
 178 data     Ord    o
 179  => Test_Ord    o
 180  =  Test_Ord_Lt o
 181  |  Test_Ord_Le o
 182  |  Test_Ord_Gt o
 183  |  Test_Ord_Ge o
 184  |  Test_Ord_Eq o
 185  deriving (Data, Eq, Show, Typeable)
 186
 187 instance (Ord o, o ~ x)
 188  => Test (Test_Ord o) x where
 189         test p x =
 190                 case p of
 191                  Test_Ord_Lt o -> (<)  x o
 192                  Test_Ord_Le o -> (<=) x o
 193                  Test_Ord_Gt o -> (>)  x o
 194                  Test_Ord_Ge o -> (>=) x o
 195                  Test_Ord_Eq o -> (==) x o
 196
 197 -- ** Type 'Test_Range'
 198
 199 data Test_Range a
 200  =   Test_Range_Eq a
 201  |   Test_Range_In (Maybe a) (Maybe a)
 202  deriving (Show)
 203
 204 test_range_all :: Test_Range a
 205 test_range_all =
 206         Test_Range_In Nothing Nothing
 207
 208 instance (Ord o, o ~ x)
 209  => Test (Test_Range o) x where
 210         test p x =
 211                 case p of
 212                  Test_Range_Eq o                   -> (==)  x o
 213                  Test_Range_In (Just a0) (Just a1) -> (<=) a0 x && (<=) x a1
 214                  Test_Range_In Nothing   (Just a1) ->              (<=) x a1
 215                  Test_Range_In (Just a0) Nothing   -> (<=) a0 x
 216                  Test_Range_In Nothing   Nothing   -> True
 217 instance Functor Test_Range where
 218         fmap f (Test_Range_Eq a)     = Test_Range_Eq (f a)
 219         fmap f (Test_Range_In a0 a1) = Test_Range_In (fmap f a0) (fmap f a1)
 220
 221 -- ** Type 'Test_Num_Abs'
 222
 223 newtype Num n
 224  => Test_Num_Abs n
 225  =  Test_Num_Abs (Test_Ord n)
 226  deriving (Data, Eq, Show, Typeable)
 227
 228 instance (Num n, Ord x, n ~ x)
 229  => Test (Test_Num_Abs n) x where
 230         test (Test_Num_Abs f) x = test f (abs x)
 231
 232 -- ** Type 'Test_Bool'
 233
 234 data Test_Bool p
 235  =   Any
 236  |   Bool p
 237  |   Not (Test_Bool p)
 238  |   And (Test_Bool p) (Test_Bool p)
 239  |   Or  (Test_Bool p) (Test_Bool p)
 240  deriving (Show)
 241 deriving instance Eq p => Eq (Test_Bool p)
 242 instance Functor Test_Bool where
 243         fmap _ Any         = Any
 244         fmap f (Bool x)    = Bool (f x)
 245         fmap f (Not t)     = Not (fmap f t)
 246         fmap f (And t0 t1) = And (fmap f t0) (fmap f t1)
 247         fmap f (Or  t0 t1) = Or  (fmap f t0) (fmap f t1)
 248 instance Foldable Test_Bool where
 249         foldr _ acc Any         = acc
 250         foldr f acc (Bool p)    = f p acc
 251         foldr f acc (Not t)     = Data.Foldable.foldr f acc t
 252         foldr f acc (And t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
 253         foldr f acc (Or  t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
 254 instance Traversable Test_Bool where
 255         traverse _ Any         = pure Any
 256         traverse f (Bool x)    = Bool <$> f x
 257         traverse f (Not t)     = Not  <$> traverse f t
 258         traverse f (And t0 t1) = And  <$> traverse f t0 <*> traverse f t1
 259         traverse f (Or  t0 t1) = Or   <$> traverse f t0 <*> traverse f t1
 260 instance Test p x => Test (Test_Bool p) x where
 261         test Any         _ = True
 262         test (Bool p)    x = test p x
 263         test (Not t)     x = not $ test t x
 264         test (And t0 t1) x = test t0 x && test t1 x
 265         test (Or  t0 t1) x = test t0 x || test t1 x
 266
 267 bool :: Test p x => Test_Bool p -> x -> Bool
 268 bool Any         _ = True
 269 bool (Bool p)    x = test p x
 270 bool (Not t)     x = not $ test t x
 271 bool (And t0 t1) x = test t0 x && test t1 x
 272 bool (Or  t0 t1) x = test t0 x || test t1 x
 273
 274 -- ** Type 'Test_Unit'
 275
 276 newtype Test_Unit
 277  =      Test_Unit Test_Text
 278  deriving (Eq, Show, Typeable)
 279
 280 instance Unit u => Test Test_Unit u where
 281         test (Test_Unit f) = test f . unit_text
 282
 283 -- ** Type 'Test_Account'
 284
 285 type Test_Account
 286  =  [Test_Account_Section]
 287
 288 data Test_Account_Section
 289  =   Test_Account_Section_Any
 290  |   Test_Account_Section_Many
 291  |   Test_Account_Section_Text Test_Text
 292  deriving (Eq, Show, Typeable)
 293
 294 instance Test Test_Account Account where
 295         test f acct =
 296                 comp f (NonEmpty.toList acct)
 297                 where
 298                         comp :: [Test_Account_Section] -> [Account.Name] -> Bool
 299                         comp [] [] = True
 300                         comp [Test_Account_Section_Many] _  = True
 301                         comp [] _ = False
 302                         {-
 303                         comp (s:[]) (n:_) =
 304                                 case s of
 305                                  Test_Account_Section_Any    -> True
 306                                  Test_Account_Section_Many   -> True
 307                                  Test_Account_Section_Text m -> test m n
 308                         -}
 309                         comp so@(s:ss) no@(n:ns) =
 310                                 case s of
 311                                  Test_Account_Section_Any    -> comp ss ns
 312                                  Test_Account_Section_Many   -> comp ss no || comp so ns
 313                                  Test_Account_Section_Text m -> test m n && comp ss ns
 314                         comp _ []  = False
 315
 316 -- ** Type 'Test_Amount'
 317
 318 type Test_Quantity q
 319  =   Test_Ord q
 320
 321 data     Amount a
 322  => Test_Amount a
 323  =  Test_Amount
 324  {  test_amount_quantity :: Test_Quantity (Amount_Quantity a)
 325  ,  test_amount_unit     :: Test_Unit
 326  } deriving (Typeable)
 327 deriving instance Amount a => Eq   (Test_Amount a)
 328 deriving instance Amount a => Show (Test_Amount a)
 329
 330 instance Amount a
 331  => Test (Test_Amount a) a where
 332         test (Test_Amount fq fu) amt =
 333                 test fu (amount_unit amt) &&
 334                 test fq (amount_quantity amt)
 335
 336 -- ** Type 'Test_Date'
 337
 338 data Test_Date
 339  =   Test_Date_UTC    (Test_Ord   Date)
 340  |   Test_Date_Year   (Test_Range Integer)
 341  |   Test_Date_Month  (Test_Range Int)
 342  |   Test_Date_DoM    (Test_Range Int)
 343  |   Test_Date_Hour   (Test_Range Int)
 344  |   Test_Date_Minute (Test_Range Int)
 345  |   Test_Date_Second (Test_Range Data.Fixed.Pico)
 346  deriving (Typeable)
 347 deriving instance Show (Test_Date)
 348
 349 instance Test Test_Date Date where
 350         test (Test_Date_UTC    f) d = test f d
 351         test (Test_Date_Year   f) d = test f $ Date.year   d
 352         test (Test_Date_Month  f) d = test f $ Date.month  d
 353         test (Test_Date_DoM    f) d = test f $ Date.dom    d
 354         test (Test_Date_Hour   f) d = test f $ Date.hour   d
 355         test (Test_Date_Minute f) d = test f $ Date.minute d
 356         test (Test_Date_Second f) d = test f $ Date.second d
 357
 358 -- ** Type 'Test_Tag'
 359
 360 data Test_Tag
 361  =   Test_Tag_Name  Test_Text
 362  |   Test_Tag_Value Test_Text
 363  deriving (Typeable)
 364 deriving instance Show (Test_Tag)
 365
 366 instance Test Test_Tag (Text, Text) where
 367         test (Test_Tag_Name  f) (x, _) = test f x
 368         test (Test_Tag_Value f) (_, x) = test f x
 369
 370 -- ** Type 'Test_Posting'
 371
 372 data     Posting posting
 373  => Test_Posting posting
 374  =  Test_Posting_Account Test_Account
 375  |  Test_Posting_Amount (Test_Amount (Posting_Amount posting))
 376  |  Test_Posting_Unit Test_Unit
 377  deriving (Typeable)
 378  -- Virtual
 379  -- Description Comp_String String
 380  -- Date Date.Span
 381  -- Account_Tag Comp_String String (Maybe (Comp_String, String))
 382  -- Account_Balance Comp_Num Comp_Num_Absolute Amount
 383  -- Depth Comp_Num Int
 384  -- None
 385  -- Real Bool
 386  -- Status Bool
 387  -- Tag Comp_String Tag.Name (Maybe (Comp_String, Tag.Value))
 388 deriving instance Posting p => Eq   (Test_Posting p)
 389 deriving instance Posting p => Show (Test_Posting p)
 390
 391 instance Posting p
 392  => Test (Test_Posting p) p where
 393         test (Test_Posting_Account f) p =
 394                 test f $ posting_account p
 395         test (Test_Posting_Amount  f) p =
 396                 Data.Foldable.any (test f) $ posting_amounts p
 397         test (Test_Posting_Unit    f) p =
 398                 Data.Foldable.any (test f . amount_unit) $ posting_amounts p
 399
 400 newtype Cross t = Cross t
 401 instance (Transaction t, Transaction_Posting t ~ p, Posting p)
 402  => Test (Test_Transaction t) (Cross p) where
 403         test pr (Cross p) =
 404                 case pr of
 405                  (Test_Transaction_Description _) -> True
 406                  (Test_Transaction_Posting     f) -> test f p
 407                  (Test_Transaction_Date        _) -> True  -- TODO: use posting_date
 408                  (Test_Transaction_Tag         _) -> False -- TODO: use posting_tags
 409
 410 -- ** Type 'Test_Transaction'
 411
 412 data      Transaction t
 413  =>  Test_Transaction t
 414  =   Test_Transaction_Description Test_Text
 415  |   Test_Transaction_Posting (Test_Posting (Transaction_Posting t))
 416  |   Test_Transaction_Date (Test_Bool Test_Date)
 417  |   Test_Transaction_Tag (Test_Bool Test_Tag)
 418  deriving (Typeable)
 419 deriving instance Transaction t => Show (Test_Transaction t)
 420
 421 instance Transaction t
 422  => Test (Test_Transaction t) t where
 423         test (Test_Transaction_Description f) t =
 424                 test f $ transaction_description t
 425         test (Test_Transaction_Posting f) t =
 426                 Data.Foldable.any (test f) $
 427                 Data.Functor.Compose.Compose $
 428                 transaction_postings t
 429         test (Test_Transaction_Date f) t =
 430                 test f $ transaction_date t
 431         test (Test_Transaction_Tag f) t =
 432                 Data.Monoid.getAny $
 433                 Data.Map.foldrWithKey
 434                  (\n -> mappend . Data.Monoid.Any .
 435                         Data.Foldable.any (test f . (n,)))
 436                  (Data.Monoid.Any False) $
 437                 transaction_tags t
 438
 439 -- ** Type 'Test_Balance'
 440
 441 data      Balance b
 442  =>  Test_Balance b
 443  =   Test_Balance_Account Test_Account
 444  |   Test_Balance_Amount   (Test_Amount (Balance_Amount b))
 445  |   Test_Balance_Positive (Test_Amount (Balance_Amount b))
 446  |   Test_Balance_Negative (Test_Amount (Balance_Amount b))
 447  deriving (Typeable)
 448 deriving instance Balance b => Eq   (Test_Balance b)
 449 deriving instance Balance b => Show (Test_Balance b)
 450
 451 instance Balance b
 452  => Test (Test_Balance b) b where
 453         test (Test_Balance_Account f) b =
 454                 test f $ balance_account b
 455         test (Test_Balance_Amount f) b =
 456                 test f $ balance_amount b
 457         test (Test_Balance_Positive f) b =
 458                 Data.Foldable.any (test f) $
 459                 balance_positive b
 460         test (Test_Balance_Negative f) b =
 461                 Data.Foldable.any (test f) $
 462                 balance_negative b
 463
 464 -- ** Type 'Test_GL'
 465
 466 data      GL r
 467  =>  Test_GL r
 468  =   Test_GL_Account Test_Account
 469  |   Test_GL_Amount_Positive (Test_Amount (GL_Amount r))
 470  |   Test_GL_Amount_Negative (Test_Amount (GL_Amount r))
 471  |   Test_GL_Amount_Balance  (Test_Amount (GL_Amount r))
 472  |   Test_GL_Sum_Positive    (Test_Amount (GL_Amount r))
 473  |   Test_GL_Sum_Negative    (Test_Amount (GL_Amount r))
 474  |   Test_GL_Sum_Balance     (Test_Amount (GL_Amount r))
 475  deriving (Typeable)
 476 deriving instance GL r => Eq   (Test_GL r)
 477 deriving instance GL r => Show (Test_GL r)
 478
 479 instance GL r
 480  => Test (Test_GL r) r where
 481         test (Test_GL_Account f) r =
 482                 test f $ register_account r
 483         test (Test_GL_Amount_Positive f) r =
 484                 Data.Foldable.any (test f) $
 485                 register_amount_positive r
 486         test (Test_GL_Amount_Negative f) r =
 487                 Data.Foldable.any (test f) $
 488                 register_amount_negative r
 489         test (Test_GL_Amount_Balance f) r =
 490                 test f $ register_amount_balance r
 491         test (Test_GL_Sum_Positive f) r =
 492                 Data.Foldable.any (test f) $
 493                 register_sum_positive r
 494         test (Test_GL_Sum_Negative f) r =
 495                 Data.Foldable.any (test f) $
 496                 register_sum_negative r
 497         test (Test_GL_Sum_Balance f) r =
 498                 test f $ register_sum_balance r