lib/Hcompta/Filter.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE StandaloneDeriving #-}
   8 {-# LANGUAGE TupleSections #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Hcompta.Filter where
  12
  13 import           Control.Applicative (Applicative(..), Const(..))
  14 -- import           Control.Applicative (pure, (<$>), (<*>))
  15 import           Control.Arrow (second)
  16 import           Control.DeepSeq (NFData(..))
  17 import           Data.Bool
  18 import           Data.Data
  19 import           Data.Decimal ()
  20 import           Data.Either (Either(..))
  21 import           Data.Eq (Eq(..))
  22 import qualified Data.Fixed
  23 import           Data.Foldable (Foldable(..), all, any)
  24 import           Data.Functor (Functor(..), (<$>))
  25 import           Data.Functor.Compose (Compose(..))
  26 import           Data.List (reverse)
  27 import           Data.List.NonEmpty (NonEmpty(..))
  28 import qualified Data.List.NonEmpty as NonEmpty
  29 import qualified Data.Map.Strict as Data.Map
  30 import           Data.Maybe (maybe)
  31 import qualified Data.Monoid
  32 import           Data.Monoid (Monoid(..))
  33 import           Data.Ord (Ord(..), Ordering(..))
  34 import           Data.Text (Text)
  35 import           Data.Traversable (Traversable(..))
  36 import           Data.Tuple (fst, snd)
  37 import           Data.Typeable ()
  38 import           Prelude (($), (.), Int, Integer, Num(..), Show(..), const, flip, id)
  39 import           Text.Regex.Base ()
  40 import           Text.Regex.TDFA ()
  41 import           Text.Regex.TDFA.Text ()
  42
  43 import qualified Hcompta.Account as Account
  44 import qualified Hcompta.Balance as Balance
  45 import           Hcompta.Date (Date)
  46 import qualified Hcompta.Date as Date
  47 import qualified Hcompta.GL as GL
  48 import qualified Hcompta.Journal as Journal
  49 import           Hcompta.Lib.Applicative ()
  50 import           Hcompta.Lib.Consable (Consable(..))
  51 import           Hcompta.Lib.Interval (Interval)
  52 import qualified Hcompta.Lib.Interval as Interval
  53 import           Hcompta.Lib.Regex (Regex)
  54 import qualified Hcompta.Lib.Regex as Regex
  55 import           Hcompta.Polarize
  56 import qualified Hcompta.Posting as Posting
  57 import           Hcompta.Quantity (Addable(..), Zero(..))
  58 import qualified Hcompta.Stats as Stats
  59 import qualified Hcompta.Tag as Tag
  60 import           Hcompta.Unit (Unit(..))
  61
  62 -- * Requirements' interface
  63
  64 -- ** Class 'Path'
  65
  66 type Path   section
  67  = NonEmpty section
  68
  69 class Path_Section a where
  70         path_section_text :: a -> Text
  71 instance Path_Section Text where
  72         path_section_text = id
  73
  74 -- ** Class 'Account'
  75
  76 type Account_Section = Text
  77 type Account_Path = Path Account_Section
  78
  79 class Account a where
  80         account_path :: a -> Account_Path
  81         account_tags :: a -> Tag.Tags
  82
  83 instance Account (Tag.Tags, Account_Path) where
  84         account_path = snd
  85         account_tags = fst
  86
  87 -- ** Class 'Amount'
  88
  89 class
  90  ( Addable (Amount_Quantity a)
  91  , Eq      (Amount_Quantity a)
  92  , Ord     (Amount_Quantity a)
  93  , Unit    (Amount_Unit     a)
  94  ) => Amount a where
  95         type Amount_Quantity a
  96         type Amount_Unit     a
  97         amount_quantity :: a -> Polarized (Amount_Quantity a)
  98         amount_unit     :: a -> Amount_Unit a
  99
 100 instance
 101  ( Eq      quantity
 102  , Ord     quantity
 103  , Addable quantity
 104  , Zero    quantity
 105  , Unit    unit
 106  ) =>  Amount          (unit, Polarized quantity) where
 107         type Amount_Quantity (unit, Polarized quantity) = quantity
 108         type Amount_Unit     (unit, Polarized quantity) = unit
 109         amount_quantity = snd
 110         amount_unit     = fst
 111
 112 -- ** Class 'Posting'
 113
 114 class
 115  ( Posting.Posting p
 116  , Account (Posting.Posting_Account p)
 117  , Amount  (Posting.Posting_Amount  p)
 118  ) => Posting p where
 119         posting_type :: p -> Posting_Type
 120
 121 data Posting_Type
 122  =   Posting_Type_Regular
 123  |   Posting_Type_Virtual
 124  deriving (Data, Eq, Show, Typeable)
 125
 126 newtype Posting_Typed posting
 127  =      Posting_Typed (Posting_Type, posting)
 128
 129 instance
 130  ( Posting.Posting p
 131  ) =>      Posting.Posting (Posting_Typed p) where
 132         type   Posting_Account (Posting_Typed p) = Posting.Posting_Account p
 133         type   Posting_Amount  (Posting_Typed p) = Posting.Posting_Amount  p
 134         type   Posting_Amounts (Posting_Typed p) = Posting.Posting_Amounts p
 135         posting_account        (Posting_Typed p) = Posting.posting_account (snd p)
 136         posting_amounts        (Posting_Typed p) = Posting.posting_amounts (snd p)
 137 instance Posting p
 138  =>      Posting (Posting_Typed p) where
 139         posting_type   (Posting_Typed p) = fst p
 140
 141 instance Balance.Posting p
 142  =>      Balance.Posting (Posting_Typed p) where
 143         type Posting_Account   (Posting_Typed p) = Balance.Posting_Account  p
 144         type Posting_Quantity  (Posting_Typed p) = Balance.Posting_Quantity p
 145         type Posting_Unit      (Posting_Typed p) = Balance.Posting_Unit     p
 146         posting_account        (Posting_Typed p) = Balance.posting_account (snd p)
 147         posting_amounts        (Posting_Typed p) = Balance.posting_amounts (snd p)
 148         posting_set_amounts  m (Posting_Typed p) = Posting_Typed $ second (Balance.posting_set_amounts m) p
 149
 150 -- ** Class 'Transaction'
 151
 152 class
 153  ( Posting  (Transaction_Posting  t)
 154  , Foldable (Transaction_Postings t)
 155  )
 156  =>    Transaction          t where
 157         type Transaction_Posting  t
 158         type Transaction_Postings t  :: * -> *
 159         transaction_date             :: t -> Date
 160         transaction_description      :: t -> Text
 161         transaction_postings         :: t -> Transaction_Postings t (Transaction_Posting t)
 162         transaction_postings_virtual :: t -> Transaction_Postings t (Transaction_Posting t)
 163         transaction_tags             :: t -> Tag.Tags
 164
 165 -- ** Class 'Balance'
 166
 167 class
 168  ( Account (Balance_Account b)
 169  , Amount  (Balance_Amount  b)
 170  ) =>  Balance         b where
 171         type Balance_Account b
 172         type Balance_Amount  b
 173         balance_account  :: b -> Balance_Account b
 174         balance_amount   :: b -> Balance_Amount  b
 175
 176 instance
 177  ( Account acct
 178  , Amount  amt
 179  ) =>  Balance         (acct, amt) where
 180         type Balance_Account (acct, amt) = acct
 181         type Balance_Amount  (acct, amt) = amt
 182         balance_account = fst
 183         balance_amount  = snd
 184
 185 -- ** Class 'GL'
 186
 187 class
 188  ( Account (GL_Account g)
 189  , Amount  (GL_Amount  g)
 190  ) =>  GL         g where
 191         type GL_Account g
 192         type GL_Amount  g
 193         gl_account :: g -> GL_Account g
 194         gl_date    :: g -> Date
 195         gl_amount  :: g -> GL_Amount g
 196         gl_sum     :: g -> GL_Amount g
 197
 198 instance
 199  ( Account acct
 200  , Amount  amt
 201  ) =>  GL         (acct, Date, amt, amt) where
 202         type GL_Account (acct, Date, amt, amt) = acct
 203         type GL_Amount  (acct, Date, amt, amt) = amt
 204         gl_account (x, _, _, _) = x
 205         gl_date    (_, x, _, _) = x
 206         gl_amount  (_, _, x, _) = x
 207         gl_sum     (_, _, _, x) = x
 208
 209 -- * Class 'Filter'
 210
 211 class  Filter     f where
 212         type Filter_Key f
 213         test     :: f -> Filter_Key f -> Bool
 214         simplify :: f -> Simplified f
 215         -- simplify f = Simplified $ Left f
 216 -- | Type to pass an 'Interval' to 'test'.
 217 newtype With_Interval f
 218  =      With_Interval f
 219
 220 filter ::
 221  ( Foldable t
 222  , Filter f
 223  , Monoid (Filter_Key f)
 224  ) => f -> t (Filter_Key f) -> Filter_Key f
 225 filter f =
 226         foldMap
 227          (\x -> if test f x then x else mempty)
 228
 229 -- ** Type 'Simplified'
 230
 231 newtype Simplified filter
 232  =      Simplified (Either filter Bool)
 233  deriving (Eq, Show)
 234 simplified :: Simplified f -> Either f Bool
 235 simplified (Simplified e) = e
 236
 237 instance Functor Simplified where
 238         fmap _f (Simplified (Right b)) = Simplified (Right b)
 239         fmap f  (Simplified (Left x))  = Simplified (Left $ f x)
 240 instance Filter f => Filter (Simplified f) where
 241         type Filter_Key (Simplified f) = Filter_Key f
 242         test     (Simplified (Right b)) _x = b
 243         test     (Simplified (Left  f))  x = test f x
 244         simplify (Simplified (Right b)) = Simplified $ Right b
 245         simplify (Simplified (Left  f)) =
 246                 Simplified $
 247                 case simplified $ simplify f of
 248                  Right b  -> Right b
 249                  Left  sf -> Left (Simplified $ Left sf)
 250 -- | Conjonctive ('&&') 'Monoid'.
 251 instance Monoid f => Monoid (Simplified f) where
 252         mempty = Simplified (Right True)
 253         mappend (Simplified x) (Simplified y) =
 254                 Simplified $
 255                 case (x, y) of
 256                  (Right bx   , Right by   ) -> Right (bx && by)
 257                  (Right True , Left _fy   ) -> y
 258                  (Right False, Left _fy   ) -> x
 259                  (Left _fx   , Right True ) -> x
 260                  (Left _fx   , Right False) -> y
 261                  (Left fx    , Left  fy   ) -> Left $ fx `mappend` fy
 262
 263 -- ** Type 'Filter_Text'
 264
 265 data Filter_Text
 266  =   Filter_Text_Any
 267  |   Filter_Text_Exact Text
 268  |   Filter_Text_Regex Regex
 269  deriving ({-Data, -}Eq, Show, Typeable)
 270
 271 instance Filter Filter_Text where
 272         type Filter_Key Filter_Text = Text
 273         test f x =
 274                 case f of
 275                  Filter_Text_Any     -> True
 276                  Filter_Text_Exact m -> (==) m x
 277                  Filter_Text_Regex m -> Regex.match m x
 278         simplify f =
 279                 Simplified $
 280                 case f of
 281                  Filter_Text_Any -> Right True
 282                  _               -> Left f
 283
 284 -- ** Type 'Filter_Ord'
 285
 286 data Order
 287  = Lt -- ^ Lower than.
 288  | Le -- ^ Lower or equal.
 289  | Eq -- ^ Equal.
 290  | Ge -- ^ Greater or equal.
 291  | Gt -- ^ Greater than.
 292  deriving (Data, Eq, Show, Typeable)
 293
 294 data Filter_Ord o
 295  =   Filter_Ord Order o
 296  |   Filter_Ord_Any
 297  deriving (Data, Eq, Show, Typeable)
 298 instance Functor Filter_Ord where
 299         fmap f x =
 300                 case x of
 301                  Filter_Ord Lt o -> Filter_Ord Lt (f o)
 302                  Filter_Ord Le o -> Filter_Ord Le (f o)
 303                  Filter_Ord Eq o -> Filter_Ord Eq (f o)
 304                  Filter_Ord Ge o -> Filter_Ord Ge (f o)
 305                  Filter_Ord Gt o -> Filter_Ord Gt (f o)
 306                  Filter_Ord_Any  -> Filter_Ord_Any
 307 instance Ord o
 308  =>    Filter     (Filter_Ord o) where
 309         type Filter_Key (Filter_Ord o) = o
 310         test f x =
 311                 case f of
 312                  Filter_Ord Lt o -> (<)  x o
 313                  Filter_Ord Le o -> (<=) x o
 314                  Filter_Ord Eq o -> (==) x o
 315                  Filter_Ord Ge o -> (>=) x o
 316                  Filter_Ord Gt o -> (>)  x o
 317                  Filter_Ord_Any  -> True
 318         simplify f =
 319                 Simplified $
 320                 case f of
 321                  Filter_Ord_Any -> Right True
 322                  _              -> Left f
 323 instance Ord o
 324  =>    Filter     (With_Interval (Filter_Ord o)) where
 325         type Filter_Key (With_Interval (Filter_Ord o)) = Interval o
 326         test (With_Interval f) i =
 327                 let l = Interval.low  i in
 328                 let h = Interval.high i in
 329                 case f of
 330                  Filter_Ord Lt o -> case compare (Interval.limit h) o of
 331                                    LT -> True
 332                                    EQ -> Interval.adherence h == Interval.Out
 333                                    GT -> False
 334                  Filter_Ord Le o -> Interval.limit h <= o
 335                  Filter_Ord Eq o -> Interval.limit l == o && Interval.limit h == o
 336                  Filter_Ord Ge o -> Interval.limit l >= o
 337                  Filter_Ord Gt o -> case compare (Interval.limit l) o of
 338                                    LT -> False
 339                                    EQ -> Interval.adherence l == Interval.Out
 340                                    GT -> True
 341                  Filter_Ord_Any  -> True
 342         simplify f =
 343                 Simplified $
 344                 case f of
 345                  With_Interval Filter_Ord_Any -> Right True
 346                  _                            -> Left f
 347
 348 -- ** Type 'Filter_Interval'
 349
 350 data Filter_Interval x
 351  =   Filter_Interval_In (Interval (Interval.Unlimitable x))
 352  deriving (Eq, Ord, Show)
 353 --instance Functor Filter_Interval where
 354 --      fmap f (Filter_Interval_In i) = Filter_Interval_In (fmap (fmap f) i)
 355 instance Ord o
 356  =>    Filter     (Filter_Interval o) where
 357         type Filter_Key (Filter_Interval o) = Interval.Unlimitable o
 358         test (Filter_Interval_In i) x =
 359                 Interval.locate x i == EQ
 360         simplify = Simplified . Left
 361 instance Ord o
 362  =>    Filter     (With_Interval (Filter_Interval o)) where
 363         type Filter_Key (With_Interval (Filter_Interval o)) = Interval (Interval.Unlimitable o)
 364         test (With_Interval (Filter_Interval_In i)) x = Interval.into x i
 365         simplify = Simplified . Left
 366
 367 -- ** Type 'Filter_Num_Abs'
 368
 369 newtype    Num     n
 370  => Filter_Num_Abs n
 371  =  Filter_Num_Abs (Filter_Ord n)
 372  deriving (Data, Eq, Show, Typeable)
 373
 374 instance (Num x, Ord x)
 375  => Filter (Filter_Num_Abs x) where
 376         type Filter_Key (Filter_Num_Abs x) = x
 377         test (Filter_Num_Abs f) x = test f (abs x)
 378         simplify f =
 379                 case f of
 380                  Filter_Num_Abs ff -> Filter_Num_Abs <$> simplify ff
 381
 382 -- ** Type 'Filter_Bool'
 383
 384 data Filter_Bool f
 385  =   Any
 386  |   Bool f
 387  |   Not (Filter_Bool f)
 388  |   And (Filter_Bool f) (Filter_Bool f)
 389  |   Or  (Filter_Bool f) (Filter_Bool f)
 390  deriving (Data, Eq, Show, Typeable)
 391 instance Functor Filter_Bool where
 392         fmap _ Any         = Any
 393         fmap f (Bool x)    = Bool (f x)
 394         fmap f (Not t)     = Not (fmap f t)
 395         fmap f (And t0 t1) = And (fmap f t0) (fmap f t1)
 396         fmap f (Or  t0 t1) = Or  (fmap f t0) (fmap f t1)
 397 -- | Conjonctive ('And') 'Monoid'.
 398 instance Monoid (Filter_Bool f) where
 399         mempty  = Any
 400         mappend = And
 401 instance Foldable Filter_Bool where
 402         foldr _ acc Any         = acc
 403         foldr m acc (Bool f)    = m f acc
 404         foldr m acc (Not f)     = foldr m acc f
 405         foldr m acc (And f0 f1) = foldr m (foldr m acc f0) f1
 406         foldr m acc (Or  f0 f1) = foldr m (foldr m acc f0) f1
 407 instance Traversable Filter_Bool where
 408         traverse _ Any         = pure Any
 409         traverse m (Bool f)    = Bool <$> m f
 410         traverse m (Not f)     = Not  <$> traverse m f
 411         traverse m (And f0 f1) = And  <$> traverse m f0 <*> traverse m f1
 412         traverse m (Or  f0 f1) = Or   <$> traverse m f0 <*> traverse m f1
 413 instance           Filter      f
 414  =>    Filter     (Filter_Bool f) where
 415         type Filter_Key (Filter_Bool f) = Filter_Key f
 416         test Any         _ = True
 417         test (Bool f)    x = test f x
 418         test (Not f)     x = not $ test f x
 419         test (And f0 f1) x = test f0 x && test f1 x
 420         test (Or  f0 f1) x = test f0 x || test f1 x
 421
 422         simplify Any = Simplified $ Right True
 423         simplify (Bool f) = Bool <$> simplify f
 424         simplify (Not f) =
 425                 Simplified $
 426                 case simplified (simplify f) of
 427                  Left ff -> Left  $ Not ff
 428                  Right b -> Right $ not b
 429         simplify (And f0 f1) =
 430                 Simplified $
 431                 case
 432                  ( simplified $ simplify f0
 433                  , simplified $ simplify f1 ) of
 434                  (Right b0, Right  b1) -> Right $ b0 && b1
 435                  (Right b0, Left   s1) -> if b0 then Left s1 else Right False
 436                  (Left  s0, Right  b1) -> if b1 then Left s0 else Right False
 437                  (Left  s0, Left   s1) -> Left $ And s0 s1
 438         simplify (Or f0 f1) =
 439                 Simplified $
 440                 case
 441                  ( simplified $ simplify f0
 442                  , simplified $ simplify f1 ) of
 443                  (Right b0, Right b1) -> Right $ b0 || b1
 444                  (Right b0, Left  s1) -> if b0 then Right True else Left s1
 445                  (Left  s0, Right b1) -> if b1 then Right True else Left s0
 446                  (Left  s0, Left  s1) -> Left $ Or s0 s1
 447
 448 -- ** Type 'Filter_Unit'
 449
 450 newtype Filter_Unit u
 451  =      Filter_Unit Filter_Text
 452  deriving (Eq, Show, Typeable)
 453
 454 instance                  Unit u
 455  =>    Filter     (Filter_Unit u) where
 456         type Filter_Key (Filter_Unit u) = u
 457         test (Filter_Unit f) = test f . unit_text
 458         simplify f =
 459                 case f of
 460                  Filter_Unit ff -> Filter_Unit <$> simplify ff
 461
 462 -- ** Type 'Filter_Description'
 463
 464 type Filter_Description
 465  =   Filter_Text
 466
 467 -- ** Type 'Filter_Path'
 468
 469 data Filter_Path section
 470  =   Filter_Path Order [Filter_Path_Section]
 471  deriving ({-Data, -}Eq, Show, Typeable)
 472
 473 data Filter_Path_Section
 474  =   Filter_Path_Section_Any
 475  |   Filter_Path_Section_Many
 476  |   Filter_Path_Section_Text Filter_Text
 477  deriving ({-Data, -}Eq, Show, Typeable)
 478
 479 instance Path_Section s
 480  =>    Filter     (Filter_Path s) where
 481         type Filter_Key (Filter_Path s) = Path s
 482         test (Filter_Path ord flt) path =
 483                 go ord (NonEmpty.toList path) flt
 484                 where
 485                         go :: Order -> [s] -> [Filter_Path_Section] -> Bool
 486                         go o [] [] =
 487                                 case o of
 488                                  Lt -> False
 489                                  Le -> True
 490                                  Eq -> True
 491                                  Ge -> True
 492                                  Gt -> False
 493                         go o _ [Filter_Path_Section_Many] =
 494                                 case o of
 495                                  Lt -> False
 496                                  Le -> True
 497                                  Eq -> True
 498                                  Ge -> True
 499                                  Gt -> False
 500                         go o [] _ =
 501                                 case o of
 502                                  Lt -> True
 503                                  Le -> True
 504                                  Eq -> False
 505                                  Ge -> False
 506                                  Gt -> False
 507                         {-
 508                         go o (s:[]) (n:_) =
 509                                 case s of
 510                                  Filter_Path_Section_Any    -> True
 511                                  Filter_Path_Section_Many   -> True
 512                                  Filter_Path_Section_Text m -> test m n
 513                         -}
 514                         go o no@(n:ns) fo@(f:fs) =
 515                                 case f of
 516                                  Filter_Path_Section_Any    -> go o ns fs
 517                                  Filter_Path_Section_Many   -> go o no fs || go o ns fo
 518                                  Filter_Path_Section_Text m -> test m (path_section_text n) &&
 519                                                                go o ns fs
 520                         go o _ []  =
 521                                 case o of
 522                                  Lt -> False
 523                                  Le -> False
 524                                  Eq -> False
 525                                  Ge -> True
 526                                  Gt -> True
 527         simplify flt =
 528                 case flt of
 529                  Filter_Path o l | all (Filter_Path_Section_Many ==) l ->
 530                         Simplified $ Right $
 531                         case o of
 532                          Lt -> False
 533                          Le -> True
 534                          Eq -> True
 535                          Ge -> True
 536                          Gt -> False
 537                  Filter_Path o [] ->
 538                         Simplified $ Right $
 539                         case o of
 540                          Lt -> False
 541                          Le -> False
 542                          Eq -> False
 543                          Ge -> False
 544                          Gt -> True
 545                  Filter_Path _o [Filter_Path_Section_Many] ->
 546                         Simplified $ Right True
 547                  Filter_Path o fa ->
 548                         Filter_Path o <$> go fa
 549                 where
 550                         go :: [Filter_Path_Section] -> Simplified [Filter_Path_Section]
 551                         go f =
 552                                 case f of
 553                                  [] -> Simplified $ Left []
 554                                  Filter_Path_Section_Many:l@(Filter_Path_Section_Many:_) -> go l
 555                                  ff:l ->
 556                                         case simplified $ simplify_section ff of
 557                                          Left fff    -> ((fff  :) <$> go l)
 558                                          Right True  -> ((Filter_Path_Section_Any :) <$> go l)
 559                                          Right False -> Simplified $ Right False
 560                         simplify_section f =
 561                                 case f of
 562                                  Filter_Path_Section_Any     -> Simplified $ Left $ Filter_Path_Section_Any
 563                                  Filter_Path_Section_Many    -> Simplified $ Left $ Filter_Path_Section_Many
 564                                  Filter_Path_Section_Text ff -> Filter_Path_Section_Text <$> simplify ff
 565
 566 -- ** Type 'Filter_Account'
 567
 568 type Filter_Account a
 569  =   Filter_Bool
 570      (Filter_Account_Component a)
 571
 572 data Filter_Account_Component a
 573  =   Filter_Account_Path (Filter_Path Account_Section)
 574  |   Filter_Account_Tag Filter_Tags
 575 deriving instance Account a => Eq   (Filter_Account_Component a)
 576 deriving instance Account a => Show (Filter_Account_Component a)
 577
 578 instance Account a
 579  =>      Filter     (Filter_Account_Component a) where
 580         type   Filter_Key (Filter_Account_Component a) = a
 581         test (Filter_Account_Path f) a = test f $ account_path a
 582         test (Filter_Account_Tag  f) a = test f $ account_tags a
 583         simplify f =
 584                 case f of
 585                  Filter_Account_Path ff -> Filter_Account_Path <$> simplify ff
 586                  Filter_Account_Tag  ff -> Filter_Account_Tag  <$> simplify ff
 587
 588 -- ** Type 'Filter_Quantity'
 589
 590 type Filter_Quantity q
 591  =   Filter_Ord      q
 592
 593 -- ** Type 'Filter_Polarizable'
 594
 595 data Filter_Polarized q
 596  =   Filter_Polarized_Negative (Filter_Quantity q)
 597  |   Filter_Polarized_Positive (Filter_Quantity q)
 598  |   Filter_Polarized_Sum      (Filter_Quantity q)
 599  deriving (Eq, Show, Typeable)
 600
 601 instance (Ord q, Addable q)
 602  =>    Filter     (Filter_Polarized q) where
 603         type Filter_Key (Filter_Polarized q) = Polarized q
 604         test f q =
 605                 case f of
 606                  Filter_Polarized_Negative ff -> maybe False (test ff) $ polarized_negative q
 607                  Filter_Polarized_Positive ff -> maybe False (test ff) $ polarized_positive q
 608                  Filter_Polarized_Sum      ff ->              test ff  $ depolarize         q
 609         simplify f =
 610                 case f of
 611                  Filter_Polarized_Negative ff -> Filter_Polarized_Negative <$> simplify ff
 612                  Filter_Polarized_Positive ff -> Filter_Polarized_Positive <$> simplify ff
 613                  Filter_Polarized_Sum      ff -> Filter_Polarized_Sum      <$> simplify ff
 614
 615 -- ** Type 'Filter_Amount'
 616
 617 type Filter_Amount a
 618  =   Filter_Bool (Filter_Amount_Section a)
 619
 620 data       Amount         a
 621  => Filter_Amount_Section a
 622  =  Filter_Amount_Section_Quantity (Filter_Polarized (Amount_Quantity a))
 623  |  Filter_Amount_Section_Unit     (Filter_Unit      (Amount_Unit     a))
 624  deriving (Typeable)
 625 deriving instance Amount a => Eq   (Filter_Amount_Section a)
 626 deriving instance Amount a => Show (Filter_Amount_Section a)
 627
 628 instance Amount a
 629  =>    Filter     (Filter_Amount_Section a) where
 630         type Filter_Key (Filter_Amount_Section a) = a
 631         test f a =
 632                 case f of
 633                  Filter_Amount_Section_Quantity ff -> test ff $ amount_quantity a
 634                  Filter_Amount_Section_Unit     ff -> test ff $ amount_unit a
 635         simplify f =
 636                 case f of
 637                  Filter_Amount_Section_Quantity ff -> Filter_Amount_Section_Quantity <$> simplify ff
 638                  Filter_Amount_Section_Unit     ff -> Filter_Amount_Section_Unit     <$> simplify ff
 639
 640 -- ** Type 'Filter_Posting_Type'
 641
 642 data Filter_Posting_Type
 643  =   Filter_Posting_Type_Any
 644  |   Filter_Posting_Type_Exact Posting_Type
 645  deriving (Data, Eq, Show, Typeable)
 646
 647 instance Filter   Filter_Posting_Type where
 648         type Filter_Key Filter_Posting_Type = Posting_Type
 649         test f p =
 650                 case f of
 651                  Filter_Posting_Type_Any      -> True
 652                  Filter_Posting_Type_Exact ff -> ff == p
 653         simplify f =
 654                 Simplified $
 655                 case f of
 656                  Filter_Posting_Type_Any     -> Right True
 657                  Filter_Posting_Type_Exact _ -> Left f
 658
 659 -- ** Type 'Filter_Date'
 660
 661 data Filter_Date
 662  =   Filter_Date_UTC    (Filter_Ord      Date)
 663  |   Filter_Date_Year   (Filter_Interval Integer)
 664  |   Filter_Date_Month  (Filter_Interval Int)
 665  |   Filter_Date_DoM    (Filter_Interval Int)
 666  |   Filter_Date_Hour   (Filter_Interval Int)
 667  |   Filter_Date_Minute (Filter_Interval Int)
 668  |   Filter_Date_Second (Filter_Interval Data.Fixed.Pico)
 669  deriving (Eq, Show, Typeable)
 670
 671 instance Filter     Filter_Date where
 672         type   Filter_Key Filter_Date = Date
 673         test (Filter_Date_UTC    f) d = test f $ d
 674         test (Filter_Date_Year   f) d = test f $ Interval.Limited $ Date.year   d
 675         test (Filter_Date_Month  f) d = test f $ Interval.Limited $ Date.month  d
 676         test (Filter_Date_DoM    f) d = test f $ Interval.Limited $ Date.dom    d
 677         test (Filter_Date_Hour   f) d = test f $ Interval.Limited $ Date.hour   d
 678         test (Filter_Date_Minute f) d = test f $ Interval.Limited $ Date.minute d
 679         test (Filter_Date_Second f) d = test f $ Interval.Limited $ Date.second d
 680         simplify f =
 681                 case f of
 682                  Filter_Date_UTC    ff -> Filter_Date_UTC    <$> simplify ff
 683                  Filter_Date_Year   ff -> Filter_Date_Year   <$> simplify ff
 684                  Filter_Date_Month  ff -> Filter_Date_Month  <$> simplify ff
 685                  Filter_Date_DoM    ff -> Filter_Date_DoM    <$> simplify ff
 686                  Filter_Date_Hour   ff -> Filter_Date_Hour   <$> simplify ff
 687                  Filter_Date_Minute ff -> Filter_Date_Minute <$> simplify ff
 688                  Filter_Date_Second ff -> Filter_Date_Second <$> simplify ff
 689
 690 instance Filter   (With_Interval Filter_Date) where
 691         type Filter_Key (With_Interval Filter_Date) = Interval (Interval.Unlimitable Date)
 692         test (With_Interval (Filter_Date_UTC    f)) d = test (With_Interval (Interval.Limited <$> f)) d
 693         test (With_Interval (Filter_Date_Year   f)) d = maybe False (test $ With_Interval f) $ Interval.fmap (fmap Date.year)   d
 694         test (With_Interval (Filter_Date_Month  f)) d = maybe False (test $ With_Interval f) $ Interval.fmap (fmap Date.month)  d
 695         test (With_Interval (Filter_Date_DoM    f)) d = maybe False (test $ With_Interval f) $ Interval.fmap (fmap Date.dom)    d
 696         test (With_Interval (Filter_Date_Hour   f)) d = maybe False (test $ With_Interval f) $ Interval.fmap (fmap Date.hour)   d
 697         test (With_Interval (Filter_Date_Minute f)) d = maybe False (test $ With_Interval f) $ Interval.fmap (fmap Date.minute) d
 698         test (With_Interval (Filter_Date_Second f)) d = maybe False (test $ With_Interval f) $ Interval.fmap (fmap Date.second) d
 699         simplify (With_Interval f) =
 700                 case f of
 701                  Filter_Date_UTC    ff -> With_Interval . Filter_Date_UTC    <$> simplify ff
 702                  Filter_Date_Year   ff -> With_Interval . Filter_Date_Year   <$> simplify ff
 703                  Filter_Date_Month  ff -> With_Interval . Filter_Date_Month  <$> simplify ff
 704                  Filter_Date_DoM    ff -> With_Interval . Filter_Date_DoM    <$> simplify ff
 705                  Filter_Date_Hour   ff -> With_Interval . Filter_Date_Hour   <$> simplify ff
 706                  Filter_Date_Minute ff -> With_Interval . Filter_Date_Minute <$> simplify ff
 707                  Filter_Date_Second ff -> With_Interval . Filter_Date_Second <$> simplify ff
 708
 709 -- ** Type 'Filter_Tags'
 710
 711 type Filter_Tags
 712  =   Filter_Bool
 713      Filter_Tag
 714
 715 data Filter_Tag
 716  =   Filter_Tag_Path (Filter_Path Tag.Section)
 717  |   Filter_Tag_Value Filter_Tag_Value
 718  deriving ({-Data, -}Eq, Show, Typeable)
 719
 720 data Filter_Tag_Value
 721  =   Filter_Tag_Value_None
 722  |   Filter_Tag_Value_Any   Filter_Text
 723  |   Filter_Tag_Value_First Filter_Text
 724  |   Filter_Tag_Value_Last  Filter_Text
 725  deriving ({-Data, -}Eq, Show, Typeable)
 726
 727 instance Filter   Filter_Tag where
 728         type Filter_Key Filter_Tag = Tag.Tags
 729         test f (Tag.Tags ts) =
 730                 let tst =
 731                         case f of
 732                          Filter_Tag_Path  ff -> test ff . fst
 733                          Filter_Tag_Value ff -> test ff . snd in
 734                 Data.Monoid.getAny $
 735                 Data.Map.foldrWithKey
 736                  (\p -> mappend . Data.Monoid.Any . tst . (p,))
 737                  (Data.Monoid.Any False) $
 738                 ts
 739         simplify f =
 740                 case f of
 741                  Filter_Tag_Path  ff -> Filter_Tag_Path  <$> simplify ff
 742                  Filter_Tag_Value ff -> Filter_Tag_Value <$> simplify ff
 743
 744 instance Filter   Filter_Tag_Value where
 745         type Filter_Key Filter_Tag_Value = [Tag.Value]
 746         test (Filter_Tag_Value_None  ) vs = null vs
 747         test (Filter_Tag_Value_Any  f) vs = any (test f) vs
 748         test (Filter_Tag_Value_First f) vs =
 749                 case vs of
 750                  []  -> False
 751                  v:_ -> test f v
 752         test (Filter_Tag_Value_Last f) vs =
 753                 case reverse vs of
 754                  []  -> False
 755                  v:_ -> test f v
 756         simplify f =
 757                 case f of
 758                  Filter_Tag_Value_None     -> Simplified $ Right False
 759                  Filter_Tag_Value_Any   ff -> Filter_Tag_Value_Any   <$> simplify ff
 760                  Filter_Tag_Value_First ff -> Filter_Tag_Value_First <$> simplify ff
 761                  Filter_Tag_Value_Last  ff -> Filter_Tag_Value_Last  <$> simplify ff
 762
 763 -- ** Type 'Filter_Posting'
 764
 765 data       Posting p
 766  => Filter_Posting p
 767  =  Filter_Posting_Account  (Filter_Account           (Posting.Posting_Account p))
 768  |  Filter_Posting_Amount   (Filter_Amount            (Posting.Posting_Amount  p))
 769  |  Filter_Posting_Unit     (Filter_Unit (Amount_Unit (Posting.Posting_Amount  p))) -- TODO: remove: Filter_Posting_Amount should be enough
 770  |  Filter_Posting_Type     Filter_Posting_Type
 771  deriving (Typeable)
 772  -- Virtual
 773  -- Description Comp_String String
 774  -- Date Date.Span
 775  -- Account_Tag Comp_String String (Maybe (Comp_String, String))
 776  -- Account_Balance Comp_Num Comp_Num_Absolute Amount
 777  -- Depth Comp_Num Int
 778  -- None
 779  -- Real Bool
 780  -- Status Bool
 781  -- Tag Comp_String Tag.Name (Maybe (Comp_String, Tag.Value))
 782 deriving instance Posting p => Eq   (Filter_Posting p)
 783 deriving instance Posting p => Show (Filter_Posting p)
 784
 785 instance Posting p
 786  => Filter (Filter_Posting p) where
 787         type Filter_Key (Filter_Posting p) = p
 788         test (Filter_Posting_Account f) p =
 789                 test f $ Posting.posting_account p
 790         test (Filter_Posting_Amount f) p =
 791                 any (test f) $ Posting.posting_amounts p
 792         test (Filter_Posting_Type f) p =
 793                 test f $ posting_type p
 794         test (Filter_Posting_Unit f) p =
 795                 any (test f . amount_unit) $ Posting.posting_amounts p
 796         simplify f =
 797                 case f of
 798                  Filter_Posting_Account ff -> Filter_Posting_Account <$> simplify ff
 799                  Filter_Posting_Amount  ff -> Filter_Posting_Amount  <$> simplify ff
 800                  Filter_Posting_Type    ff -> Filter_Posting_Type    <$> simplify ff
 801                  Filter_Posting_Unit    ff -> Filter_Posting_Unit    <$> simplify ff
 802
 803 -- ** Type 'Filter_Transaction'
 804
 805 data        Transaction t
 806  =>  Filter_Transaction t
 807  =   Filter_Transaction_Description Filter_Description
 808  |   Filter_Transaction_Posting     (Filter_Bool (Filter_Posting (Posting_Typed (Transaction_Posting t))))
 809  |   Filter_Transaction_Date        (Filter_Bool Filter_Date)
 810  |   Filter_Transaction_Tag         Filter_Tags
 811  deriving (Typeable)
 812 deriving instance Transaction t => Eq   (Filter_Transaction t)
 813 deriving instance Transaction t => Show (Filter_Transaction t)
 814
 815 instance Transaction t
 816  =>    Filter     (Filter_Transaction t) where
 817         type Filter_Key (Filter_Transaction t) = t
 818         test (Filter_Transaction_Description f) t =
 819                 test f $ transaction_description t
 820         test (Filter_Transaction_Posting f) t =
 821                 any
 822                  (test f . Posting_Typed . (Posting_Type_Regular,))
 823                  (transaction_postings t) ||
 824                 any
 825                  (test f . Posting_Typed . (Posting_Type_Virtual,))
 826                  (transaction_postings_virtual t)
 827         test (Filter_Transaction_Date f) t =
 828                 test f $ transaction_date t
 829         test (Filter_Transaction_Tag f) t =
 830                 test f (transaction_tags t)
 831         simplify f =
 832                 case f of
 833                  Filter_Transaction_Date        ff -> Filter_Transaction_Date        <$> simplify ff
 834                  Filter_Transaction_Description ff -> Filter_Transaction_Description <$> simplify ff
 835                  Filter_Transaction_Posting     ff -> Filter_Transaction_Posting     <$> simplify ff
 836                  Filter_Transaction_Tag         ff -> Filter_Transaction_Tag         <$> simplify ff
 837
 838 instance
 839  ( Transaction t
 840  , Journal.Transaction t
 841  , Show t
 842  )
 843  => Consable
 844      (Simplified (Filter_Bool (Filter_Transaction t)))
 845      Journal.Journal t where
 846         mcons ft t !j =
 847                 if test ft t
 848                 then Journal.cons t j
 849                 else j
 850
 851 instance
 852  ( Transaction t
 853  , Stats.Transaction t
 854  )
 855  => Consable
 856      (Simplified (Filter_Bool (Filter_Transaction t)))
 857      Stats.Stats t where
 858         mcons ft t !s =
 859                 if test ft t
 860                 then Stats.cons t s
 861                 else s
 862
 863 -- ** Type 'Filter_Balance'
 864
 865 data        Balance b
 866  =>  Filter_Balance b
 867  =   Filter_Balance_Account  (Filter_Account (Balance_Account b))
 868  |   Filter_Balance_Amount   (Filter_Amount  (Balance_Amount  b))
 869  deriving (Typeable)
 870 deriving instance Balance b => Eq   (Filter_Balance b)
 871 deriving instance Balance b => Show (Filter_Balance b)
 872
 873 instance Balance b
 874  => Filter (Filter_Balance b) where
 875         type Filter_Key (Filter_Balance b) = b
 876         test (Filter_Balance_Account f) b =
 877                 test f $ balance_account b
 878         test (Filter_Balance_Amount f) b =
 879                 test f $ balance_amount b
 880         simplify f =
 881                 case f of
 882                  Filter_Balance_Account ff -> Filter_Balance_Account <$> simplify ff
 883                  Filter_Balance_Amount  ff -> Filter_Balance_Amount  <$> simplify ff
 884
 885 instance
 886  ( Balance.Posting p
 887  , Posting p
 888  , account ~ Balance.Posting_Account p
 889  , account_section ~ Account.Account_Section account
 890  , quantity  ~ Balance.Posting_Quantity p
 891  , unit      ~ Balance.Posting_Unit     p
 892  , Ord unit
 893  , Addable quantity
 894  )
 895  => Consable (Simplified (Filter_Bool (Filter_Posting p)))
 896              (Const (Balance.Balance_by_Account account_section unit quantity))
 897              p where
 898         mcons fp p (Const !bal) =
 899                 Const $
 900                 case simplified fp of
 901                  Right False -> bal
 902                  Right True -> Balance.cons_by_account p bal
 903                  Left f ->
 904                         if test f p
 905                         then Balance.cons_by_account p bal
 906                         else bal
 907 instance
 908  ( Transaction transaction
 909  , posting ~ Transaction_Posting transaction
 910  , account ~ Balance.Posting_Account posting
 911  , account_section ~ Account.Account_Section account
 912  , quantity  ~ Balance.Posting_Quantity posting
 913  , unit      ~ Balance.Posting_Unit     posting
 914  , Ord unit
 915  , Addable quantity
 916  , Balance.Posting posting
 917  , NFData account_section
 918  , NFData (Balance.Account_Sum unit quantity)
 919  )
 920  => Consable ( (Simplified (Filter_Bool (Filter_Transaction transaction)))
 921              , (Simplified (Filter_Bool (Filter_Posting posting))) )
 922              (Const (Balance.Balance_by_Account account_section unit quantity))
 923              transaction where
 924         mcons (ft, fp) t (Const !bal) =
 925                 Const $
 926                 case simplified ft of
 927                  Right False -> bal
 928                  Right True -> fold_postings bal $
 929                         Compose
 930                          [ transaction_postings t
 931                          , transaction_postings_virtual t
 932                          ]
 933                  Left f ->
 934                         if test f t
 935                         then fold_postings bal $
 936                                 Compose
 937                                  [ transaction_postings t
 938                                  , transaction_postings_virtual t
 939                                  ]
 940                         else bal
 941                 where
 942                         fold_postings ::
 943                          ( Foldable f
 944                          , account  ~ Balance.Posting_Account  posting
 945                          , quantity ~ Balance.Posting_Quantity posting
 946                          , unit     ~ Balance.Posting_Unit     posting
 947                          )
 948                          => Balance.Balance_by_Account account_section unit quantity
 949                          -> f posting
 950                          -> Balance.Balance_by_Account account_section unit quantity
 951                         fold_postings =
 952                                 case simplified fp of
 953                                  Right False -> const
 954                                  Right True -> foldl' (flip Balance.cons_by_account)
 955                                  Left ff -> foldl' $ \b p ->
 956                                         if test ff p
 957                                         then Balance.cons_by_account p b
 958                                         else b
 959 instance
 960  ( Foldable foldable
 961  , Balance.Posting posting
 962  , Posting posting
 963  , account ~ Balance.Posting_Account posting
 964  , account_section ~ Account.Account_Section account
 965  , quantity  ~ Balance.Posting_Quantity posting
 966  , unit      ~ Balance.Posting_Unit     posting
 967  , Ord unit
 968  , Addable quantity
 969  )
 970  => Consable (Simplified (Filter_Bool (Filter_Posting posting)))
 971              (Const (Balance.Balance_by_Account account_section unit quantity))
 972              (foldable posting) where
 973         mcons fp ps (Const !bal) =
 974                 Const $
 975                 case simplified fp of
 976                  Right False -> bal
 977                  Right True -> foldl' (flip Balance.cons_by_account) bal ps
 978                  Left f ->
 979                         foldl' (\b p ->
 980                                 if test f p
 981                                 then Balance.cons_by_account p b
 982                                 else b)
 983                          bal ps
 984
 985 -- ** Type 'Filter_GL'
 986
 987 data        GL g
 988  =>  Filter_GL g
 989  =   Filter_GL_Account (Filter_Account (GL_Account g))
 990  |   Filter_GL_Amount  (Filter_Amount  (GL_Amount  g))
 991  |   Filter_GL_Sum     (Filter_Amount  (GL_Amount  g))
 992  deriving (Typeable)
 993 deriving instance GL g => Eq   (Filter_GL g)
 994 deriving instance GL g => Show (Filter_GL g)
 995
 996 instance                  GL g
 997  =>    Filter     (Filter_GL g) where
 998         type Filter_Key (Filter_GL g) = g
 999         test (Filter_GL_Account f) g =
1000                 test f $ gl_account g
1001         test (Filter_GL_Amount f) g =
1002                 test f $ gl_amount g
1003         test (Filter_GL_Sum f) g =
1004                 test f $ gl_sum g
1005         simplify f =
1006                 case f of
1007                  Filter_GL_Account ff -> Filter_GL_Account <$> simplify ff
1008                  Filter_GL_Amount  ff -> Filter_GL_Amount  <$> simplify ff
1009                  Filter_GL_Sum     ff -> Filter_GL_Sum     <$> simplify ff
1010
1011 instance
1012  ( Transaction    transaction
1013  , Posting        posting
1014  , GL.Transaction transaction
1015  , posting ~ GL.Transaction_Posting transaction
1016  )
1017  => Consable ( (Simplified (Filter_Bool (Filter_Transaction transaction)))
1018              , (Simplified (Filter_Bool (Filter_Posting     posting    ))) )
1019              GL.GL
1020              transaction where
1021         mcons (ft, fp) t !gl =
1022                 case simplified ft of
1023                  Right False -> gl
1024                  Right True ->
1025                         case simplified fp of
1026                          Right False -> gl
1027                          Right True -> GL.cons t gl
1028                          Left f ->
1029                                 GL.cons
1030                                  (GL.transaction_postings_filter (test f) t)
1031                                  gl
1032                  Left f ->
1033                         if test f t
1034                         then
1035                                 case simplified fp of
1036                                  Right False -> gl
1037                                  Right True -> GL.cons t gl
1038                                  Left ff ->
1039                                         GL.cons
1040                                          (GL.transaction_postings_filter (test ff) t)
1041                                          gl
1042                         else gl
1043 instance
1044  ( Foldable foldable
1045  , Transaction    transaction
1046  , Posting        posting
1047  , GL.Transaction transaction
1048  , posting ~ GL.Transaction_Posting transaction
1049  )
1050  => Consable ( (Simplified (Filter_Bool (Filter_Transaction transaction)))
1051              , (Simplified (Filter_Bool (Filter_Posting     posting    ))) )
1052              (Const (GL.GL transaction))
1053              (foldable transaction) where
1054         mcons (ft, fp) ts (Const !gl) =
1055                 Const $
1056                 case simplified ft of
1057                  Right False -> gl
1058                  Right True ->
1059                         case simplified fp of
1060                          Right False -> gl
1061                          Right True -> foldr (GL.cons) gl ts
1062                          Left f ->
1063                                 foldr
1064                                  ( GL.cons
1065                                  . GL.transaction_postings_filter (test f) )
1066                                  gl ts
1067                  Left f ->
1068                         foldr
1069                          (\t ->
1070                                 if test f t
1071                                 then
1072                                         case simplified fp of
1073                                          Right False -> id
1074                                          Right True -> GL.cons t
1075                                          Left ff -> GL.cons $
1076                                                 GL.transaction_postings_filter (test ff) t
1077                                 else id
1078                          ) gl ts