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 module Hcompta.Filter where
  11
  12 -- import           Control.Applicative (pure, (<$>), (<*>))
  13 import           Control.Applicative (Const(..))
  14 import           Data.Data
  15 import qualified Data.Fixed
  16 import qualified Data.Foldable
  17 -- import           Data.Foldable (Foldable(..))
  18 -- import           Data.Functor.Compose (Compose(..))
  19 -- import qualified Data.List
  20 import           Data.Map.Strict (Map)
  21 import qualified Data.Map.Strict as Data.Map
  22 import qualified Data.Monoid
  23 -- import           Data.Monoid (Monoid(..))
  24 import           Data.Text (Text)
  25 -- import qualified Data.Text as Text
  26 -- import qualified Data.Time.Calendar as Time
  27 -- import           Data.Traversable (Traversable(..))
  28 import           Data.Typeable ()
  29 import           Prelude hiding (filter)
  30 import           Text.Regex.Base ()
  31 import           Text.Regex.TDFA ()
  32 import           Text.Regex.TDFA.Text ()
  33
  34 import qualified Data.List.NonEmpty as NonEmpty
  35 -- import           Data.List.NonEmpty (NonEmpty(..))
  36 import           Hcompta.Lib.Consable (Consable(..))
  37 import           Hcompta.Lib.Interval (Interval)
  38 import qualified Hcompta.Lib.Interval as Interval
  39 import qualified Hcompta.Lib.Regex as Regex
  40 import           Hcompta.Lib.Regex (Regex)
  41 -- import qualified Hcompta.Lib.TreeMap as TreeMap
  42 -- import           Hcompta.Lib.TreeMap (TreeMap)
  43 import qualified Hcompta.Amount as Amount
  44 import qualified Hcompta.Amount.Unit as Amount.Unit
  45 import qualified Hcompta.Date as Date
  46 import           Hcompta.Date (Date)
  47 import qualified Hcompta.Account as Account
  48 import           Hcompta.Account (Account)
  49 -- import qualified Hcompta.Date as Date
  50 import qualified Hcompta.Balance as Balance
  51 import qualified Hcompta.GL as GL
  52 import qualified Hcompta.Journal as Journal
  53
  54 -- * Requirements' interface
  55
  56 -- ** Class 'Unit'
  57
  58 class Unit a where
  59         unit_text :: a -> Text
  60
  61 instance Unit Amount.Unit where
  62         unit_text = Amount.Unit.text
  63
  64 instance Unit Text where
  65         unit_text = id
  66
  67 -- ** Class 'Amount'
  68
  69 class
  70  ( Ord  (Amount_Quantity a)
  71  , Show (Amount_Quantity a)
  72  , Show (Amount_Unit a)
  73  , Unit (Amount_Unit a)
  74  )
  75  =>    Amount          a where
  76         type Amount_Unit     a
  77         type Amount_Quantity a
  78         amount_unit     :: a -> Amount_Unit a
  79         amount_quantity :: a -> Amount_Quantity a
  80
  81 instance Amount Amount.Amount where
  82         type Amount_Unit     Amount.Amount = Amount.Unit
  83         type Amount_Quantity Amount.Amount = Amount.Quantity
  84         amount_quantity = Amount.quantity
  85         amount_unit     = Amount.unit
  86
  87 instance (Amount a, GL.Amount a)
  88  => Amount (Amount.Sum a) where
  89         type Amount_Unit     (Amount.Sum a) = Amount_Unit a
  90         type Amount_Quantity (Amount.Sum a) = Amount_Quantity a
  91         amount_quantity = amount_quantity . Amount.sum_balance
  92         amount_unit     = amount_unit     . Amount.sum_balance
  93
  94 -- ** Class 'Posting'
  95
  96 class Amount (Posting_Amount p)
  97  =>    Posting        p where
  98         type Posting_Amount p
  99         posting_account :: p -> Account
 100         posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
 101
 102 -- ** Class 'Transaction'
 103
 104 class
 105  ( Posting  (Transaction_Posting  t)
 106  , Foldable (Transaction_Postings t)
 107  )
 108  =>    Transaction          t where
 109         type Transaction_Posting  t
 110         type Transaction_Postings t :: * -> *
 111         transaction_date        :: t -> Date
 112         transaction_description :: t -> Text
 113         transaction_postings    :: t -> Transaction_Postings t (Transaction_Posting t)
 114         transaction_tags        :: t -> Map Text [Text]
 115
 116 -- ** Class 'Balance'
 117
 118 class Amount (Balance_Amount b)
 119  =>    Balance        b where
 120         type Balance_Amount b
 121         balance_account  :: b -> Account
 122         balance_amount   :: b -> Balance_Amount b
 123         balance_positive :: b -> Maybe (Balance_Amount b)
 124         balance_negative :: b -> Maybe (Balance_Amount b)
 125
 126 instance (Amount a, Balance.Amount a)
 127  =>    Balance        (Account, Amount.Sum a) where
 128         type Balance_Amount (Account, Amount.Sum a) = a
 129         balance_account = fst
 130         balance_amount (_, amt) =
 131                 case amt of
 132                  Amount.Sum_Negative n -> n
 133                  Amount.Sum_Positive p -> p
 134                  Amount.Sum_Both n p   -> Balance.amount_add n p
 135         balance_positive = Amount.sum_positive . snd
 136         balance_negative = Amount.sum_negative . snd
 137
 138 -- ** Class 'GL'
 139
 140 class Amount (GL_Amount r)
 141  =>    GL        r where
 142         type GL_Amount r
 143         gl_account         :: r -> Account
 144         gl_date            :: r -> Date
 145         gl_amount_positive :: r -> Maybe (GL_Amount r)
 146         gl_amount_negative :: r -> Maybe (GL_Amount r)
 147         gl_amount_balance  :: r ->        GL_Amount r
 148         gl_sum_positive    :: r -> Maybe (GL_Amount r)
 149         gl_sum_negative    :: r -> Maybe (GL_Amount r)
 150         gl_sum_balance     :: r ->        GL_Amount r
 151
 152 instance (Amount a, GL.Amount a)
 153  =>    GL        (Account, Date, Amount.Sum a, Amount.Sum a) where
 154         type GL_Amount (Account, Date, Amount.Sum a, Amount.Sum a) = a
 155         gl_account         (x, _, _, _) = x
 156         gl_date            (_, x, _, _) = x
 157         gl_amount_positive (_, _, x, _) = Amount.sum_positive x
 158         gl_amount_negative (_, _, x, _) = Amount.sum_negative x
 159         gl_amount_balance  (_, _, x, _) = Amount.sum_balance  x
 160         gl_sum_positive    (_, _, _, x) = Amount.sum_positive x
 161         gl_sum_negative    (_, _, _, x) = Amount.sum_negative x
 162         gl_sum_balance     (_, _, _, x) = Amount.sum_balance  x
 163
 164 -- * Newtypes to avoid overlapping instances
 165
 166 newtype Scalar x
 167  =      Scalar x
 168 instance Functor Scalar where
 169         fmap f (Scalar x) = Scalar (f x)
 170
 171 -- * Types for folding
 172
 173 type Fold_Transaction acc transaction =
 174         Const
 175          ( acc
 176          , Simplified
 177             (Filter_Bool
 178              (Filter_Transaction transaction))
 179          )
 180 type Fold_Posting acc transaction =
 181         Const
 182          ( acc
 183          , Simplified
 184             (Filter_Bool
 185              (Filter_Posting transaction))
 186          )
 187 type Fold_Transaction_and_Posting acc transaction posting =
 188         Const
 189          ( acc
 190          , Simplified
 191             (Filter_Bool
 192              (Filter_Transaction transaction))
 193          , Simplified
 194             (Filter_Bool
 195              (Filter_Posting posting))
 196          )
 197
 198 -- * Class 'Filter'
 199
 200 newtype Simplified p
 201  = Simplified (Either p Bool)
 202  deriving (Eq, Show)
 203 simplified :: Simplified p -> Either p Bool
 204 simplified (Simplified x) = x
 205
 206 instance Functor Simplified where
 207         fmap _f (Simplified (Right b)) = Simplified (Right b)
 208         fmap f  (Simplified (Left x))  = Simplified (Left $ f x)
 209 instance Filter p x => Filter (Simplified p) x where
 210         test (Simplified (Right b)) _x = b
 211         test (Simplified (Left  f))  x = test f x
 212         simplify (Simplified (Right b)) _x = Simplified $ Right b
 213         simplify (Simplified (Left  f))  x =
 214                 Simplified $
 215                 case simplified $ simplify f x of
 216                  Right b  -> Right b
 217                  Left  sf -> Left (Simplified $ Left sf)
 218
 219 -- | Conjonctive ('&&') 'Monoid'.
 220 instance Monoid p => Monoid (Simplified p) where
 221         mempty = Simplified (Right True)
 222         mappend (Simplified x) (Simplified y) =
 223                 Simplified $
 224                 case (x, y) of
 225                  (Right bx   , Right by   ) -> Right (bx && by)
 226                  (Right True , Left _fy   ) -> y
 227                  (Right False, Left _fy   ) -> x
 228                  (Left _fx   , Right True ) -> x
 229                  (Left _fx   , Right False) -> y
 230                  (Left fx    , Left  fy   ) -> Left $ fx `mappend` fy
 231
 232 class Filter p x where
 233         test :: p -> x -> Bool
 234         simplify :: p -> Maybe x -> Simplified p
 235         simplify p _x = Simplified $ Left p
 236
 237 filter
 238  :: (Foldable t, Filter p x, Monoid x)
 239  => p -> t x -> x
 240 filter p =
 241         Data.Foldable.foldMap
 242          (\x -> if test p x then x else mempty)
 243
 244 -- ** Type 'Filter_Text'
 245
 246 data Filter_Text
 247  =   Filter_Text_Any
 248  |   Filter_Text_Exact Text
 249  |   Filter_Text_Regex Regex
 250  deriving (Eq, Show, Typeable)
 251
 252 instance Filter Filter_Text Text where
 253         test p x =
 254                 case p of
 255                  Filter_Text_Any     -> True
 256                  Filter_Text_Exact m -> (==) m x
 257                  Filter_Text_Regex m -> Regex.match m x
 258
 259 -- ** Type 'Filter_Ord'
 260
 261 data Filter_Ord    o
 262  =  Filter_Ord_Lt  o
 263  |  Filter_Ord_Le  o
 264  |  Filter_Ord_Gt  o
 265  |  Filter_Ord_Ge  o
 266  |  Filter_Ord_Eq  o
 267  |  Filter_Ord_Any
 268  deriving (Data, Eq, Show, Typeable)
 269
 270 instance Functor Filter_Ord where
 271         fmap f x =
 272                 case x of
 273                  Filter_Ord_Lt o -> Filter_Ord_Lt (f o)
 274                  Filter_Ord_Le o -> Filter_Ord_Le (f o)
 275                  Filter_Ord_Gt o -> Filter_Ord_Gt (f o)
 276                  Filter_Ord_Ge o -> Filter_Ord_Ge (f o)
 277                  Filter_Ord_Eq o -> Filter_Ord_Eq (f o)
 278                  Filter_Ord_Any  -> Filter_Ord_Any
 279 instance (Ord o, o ~ x)
 280  => Filter (Filter_Ord o) (Scalar x) where
 281         test p (Scalar x) =
 282                 case p of
 283                  Filter_Ord_Lt o -> (<)  x o
 284                  Filter_Ord_Le o -> (<=) x o
 285                  Filter_Ord_Gt o -> (>)  x o
 286                  Filter_Ord_Ge o -> (>=) x o
 287                  Filter_Ord_Eq o -> (==) x o
 288                  Filter_Ord_Any  -> True
 289 instance (Ord o, o ~ x)
 290  => Filter (Filter_Ord o) (Interval x) where
 291         test p i =
 292                 let l = Interval.low i in
 293                 let h = Interval.high i in
 294                 case p of
 295                  Filter_Ord_Lt o -> case compare (Interval.limit h) o of
 296                                    LT -> True
 297                                    EQ -> Interval.adherence h == Interval.Out
 298                                    GT -> False
 299                  Filter_Ord_Le o -> Interval.limit h <= o
 300                  Filter_Ord_Gt o -> case compare (Interval.limit l) o of
 301                                    LT -> False
 302                                    EQ -> Interval.adherence l == Interval.Out
 303                                    GT -> True
 304                  Filter_Ord_Ge o -> Interval.limit l >= o
 305                  Filter_Ord_Eq o -> Interval.limit l == o && Interval.limit h == o
 306                  Filter_Ord_Any  -> True
 307
 308 -- ** Type 'Filter_Interval'
 309
 310 data Filter_Interval x
 311  =   Filter_Interval_In (Interval (Interval.Unlimitable x))
 312  deriving (Eq, Ord, Show)
 313 --instance Functor Filter_Interval where
 314 --      fmap f (Filter_Interval_In i) = Filter_Interval_In (fmap (fmap f) i)
 315 instance (Ord o, o ~ x)
 316  => Filter (Filter_Interval o) (Scalar (Interval.Unlimitable x)) where
 317         test (Filter_Interval_In p) (Scalar x) =
 318                 Interval.locate x p == EQ
 319 instance (Ord o, o ~ x)
 320  => Filter (Filter_Interval o) (Interval (Interval.Unlimitable x)) where
 321         test (Filter_Interval_In p) i = Interval.into i p
 322
 323 -- ** Type 'Filter_Num_Abs'
 324
 325 newtype Num n
 326  => Filter_Num_Abs n
 327  =  Filter_Num_Abs (Filter_Ord n)
 328  deriving (Data, Eq, Show, Typeable)
 329
 330 instance (Num n, Ord x, n ~ x)
 331  => Filter (Filter_Num_Abs n) x where
 332         test (Filter_Num_Abs f) x = test f (Scalar (abs x))
 333
 334 -- ** Type 'Filter_Bool'
 335
 336 data Filter_Bool p
 337  =   Any
 338  |   Bool p
 339  |   Not (Filter_Bool p)
 340  |   And (Filter_Bool p) (Filter_Bool p)
 341  |   Or  (Filter_Bool p) (Filter_Bool p)
 342  deriving (Show)
 343 deriving instance Eq p => Eq (Filter_Bool p)
 344 instance Functor Filter_Bool where
 345         fmap _ Any         = Any
 346         fmap f (Bool x)    = Bool (f x)
 347         fmap f (Not t)     = Not (fmap f t)
 348         fmap f (And t0 t1) = And (fmap f t0) (fmap f t1)
 349         fmap f (Or  t0 t1) = Or  (fmap f t0) (fmap f t1)
 350 -- | Conjonctive ('And') 'Monoid'.
 351 instance Monoid (Filter_Bool p) where
 352         mempty  = Any
 353         mappend = And
 354 instance Foldable Filter_Bool where
 355         foldr _ acc Any         = acc
 356         foldr f acc (Bool p)    = f p acc
 357         foldr f acc (Not t)     = Data.Foldable.foldr f acc t
 358         foldr f acc (And t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
 359         foldr f acc (Or  t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
 360 instance Traversable Filter_Bool where
 361         traverse _ Any         = pure Any
 362         traverse f (Bool x)    = Bool <$> f x
 363         traverse f (Not t)     = Not  <$> traverse f t
 364         traverse f (And t0 t1) = And  <$> traverse f t0 <*> traverse f t1
 365         traverse f (Or  t0 t1) = Or   <$> traverse f t0 <*> traverse f t1
 366 instance Filter p x => Filter (Filter_Bool p) x where
 367         test Any         _ = True
 368         test (Bool p)    x = test p x
 369         test (Not t)     x = not $ test t x
 370         test (And t0 t1) x = test t0 x && test t1 x
 371         test (Or  t0 t1) x = test t0 x || test t1 x
 372
 373         simplify Any         _ = Simplified $ Right True
 374         simplify (Bool p)    x =
 375                 Simplified $
 376                 case simplified (simplify p x) of
 377                  Left p' -> Left (Bool p')
 378                  Right b -> Right b
 379         simplify (Not t)     x =
 380                 Simplified $
 381                 case simplified (simplify t x) of
 382                  Left p' -> Left (Not $ p')
 383                  Right b -> Right b
 384         simplify (And t0 t1) x =
 385                 Simplified $
 386                 case (simplified $ simplify t0 x, simplified $ simplify t1 x) of
 387                  (Right b0, Right  b1) -> Right (b0 && b1)
 388                  (Right b0, Left   p1) -> if b0 then Left p1 else Right False
 389                  (Left  p0, Right  b1) -> if b1 then Left p0 else Right False
 390                  (Left  p0, Left   p1) -> Left (And p0 p1)
 391         simplify (Or t0 t1) x =
 392                 Simplified $
 393                 case (simplified $ simplify t0 x, simplified $ simplify t1 x) of
 394                  (Right b0, Right b1) -> Right (b0 || b1)
 395                  (Right b0, Left  p1) -> if b0 then Right True else Left p1
 396                  (Left  p0, Right b1) -> if b1 then Right True else Left p0
 397                  (Left  p0, Left  p1) -> Left (Or p0 p1)
 398
 399 bool :: Filter p x => Filter_Bool p -> x -> Bool
 400 bool Any         _ = True
 401 bool (Bool p)    x = test p x
 402 bool (Not t)     x = not $ test t x
 403 bool (And t0 t1) x = test t0 x && test t1 x
 404 bool (Or  t0 t1) x = test t0 x || test t1 x
 405
 406 -- ** Type 'Filter_Unit'
 407
 408 newtype Filter_Unit
 409  =      Filter_Unit Filter_Text
 410  deriving (Eq, Show, Typeable)
 411
 412 instance Unit u => Filter Filter_Unit u where
 413         test (Filter_Unit f) = test f . unit_text
 414
 415 -- ** Type 'Filter_Account'
 416
 417 type Filter_Account
 418  =  [Filter_Account_Section]
 419
 420 data Filter_Account_Section
 421  =   Filter_Account_Section_Any
 422  |   Filter_Account_Section_Many
 423  |   Filter_Account_Section_Text Filter_Text
 424  deriving (Eq, Show, Typeable)
 425
 426 instance Filter Filter_Account Account where
 427         test f acct =
 428                 comp f (NonEmpty.toList acct)
 429                 where
 430                         comp :: [Filter_Account_Section] -> [Account.Name] -> Bool
 431                         comp [] [] = True
 432                         comp [Filter_Account_Section_Many] _  = True
 433                         comp [] _ = False
 434                         {-
 435                         comp (s:[]) (n:_) =
 436                                 case s of
 437                                  Filter_Account_Section_Any    -> True
 438                                  Filter_Account_Section_Many   -> True
 439                                  Filter_Account_Section_Text m -> test m n
 440                         -}
 441                         comp so@(s:ss) no@(n:ns) =
 442                                 case s of
 443                                  Filter_Account_Section_Any    -> comp ss ns
 444                                  Filter_Account_Section_Many   -> comp ss no || comp so ns
 445                                  Filter_Account_Section_Text m -> test m n && comp ss ns
 446                         comp _ []  = False
 447
 448 -- ** Type 'Filter_Amount'
 449
 450 type Filter_Quantity q
 451  =   Filter_Ord q
 452
 453 data       Amount a
 454  => Filter_Amount a
 455  =  Filter_Amount
 456  {  filter_amount_quantity :: Filter_Quantity (Amount_Quantity a)
 457  ,  filter_amount_unit     :: Filter_Unit
 458  } deriving (Typeable)
 459 deriving instance Amount a => Eq   (Filter_Amount a)
 460 deriving instance Amount a => Show (Filter_Amount a)
 461
 462 instance Amount a
 463  => Filter (Filter_Amount a) a where
 464         test (Filter_Amount fq fu) amt =
 465                 test fu (amount_unit amt) &&
 466                 test fq (Scalar (amount_quantity amt))
 467
 468 -- ** Type 'Filter_Date'
 469
 470 data Filter_Date
 471  =   Filter_Date_UTC    (Filter_Ord      Date)
 472  |   Filter_Date_Year   (Filter_Interval Integer)
 473  |   Filter_Date_Month  (Filter_Interval Int)
 474  |   Filter_Date_DoM    (Filter_Interval Int)
 475  |   Filter_Date_Hour   (Filter_Interval Int)
 476  |   Filter_Date_Minute (Filter_Interval Int)
 477  |   Filter_Date_Second (Filter_Interval Data.Fixed.Pico)
 478  deriving (Typeable)
 479 deriving instance Show (Filter_Date)
 480
 481 instance Filter Filter_Date Date where
 482         test (Filter_Date_UTC    f) d = test f $ Scalar d
 483         test (Filter_Date_Year   f) d = test f $ Scalar $ Interval.Limited $ Date.year   d
 484         test (Filter_Date_Month  f) d = test f $ Scalar $ Interval.Limited $ Date.month  d
 485         test (Filter_Date_DoM    f) d = test f $ Scalar $ Interval.Limited $ Date.dom    d
 486         test (Filter_Date_Hour   f) d = test f $ Scalar $ Interval.Limited $ Date.hour   d
 487         test (Filter_Date_Minute f) d = test f $ Scalar $ Interval.Limited $ Date.minute d
 488         test (Filter_Date_Second f) d = test f $ Scalar $ Interval.Limited $ Date.second d
 489
 490 instance Filter Filter_Date (Interval (Interval.Unlimitable Date)) where
 491         test (Filter_Date_UTC    f) d = test (Interval.Limited <$> f)  d
 492         test (Filter_Date_Year   f) d = maybe False (test f) $ Interval.fmap (fmap Date.year)   d
 493         test (Filter_Date_Month  f) d = maybe False (test f) $ Interval.fmap (fmap Date.month)  d
 494         test (Filter_Date_DoM    f) d = maybe False (test f) $ Interval.fmap (fmap Date.dom)    d
 495         test (Filter_Date_Hour   f) d = maybe False (test f) $ Interval.fmap (fmap Date.hour)   d
 496         test (Filter_Date_Minute f) d = maybe False (test f) $ Interval.fmap (fmap Date.minute) d
 497         test (Filter_Date_Second f) d = maybe False (test f) $ Interval.fmap (fmap Date.second) d
 498
 499 -- ** Type 'Filter_Tag'
 500
 501 data Filter_Tag
 502  =   Filter_Tag_Name  Filter_Text
 503  |   Filter_Tag_Value Filter_Text
 504  deriving (Typeable)
 505 deriving instance Show (Filter_Tag)
 506
 507 instance Filter Filter_Tag (Text, Text) where
 508         test (Filter_Tag_Name  f) (x, _) = test f x
 509         test (Filter_Tag_Value f) (_, x) = test f x
 510
 511 -- ** Type 'Filter_Posting'
 512
 513 data       Posting posting
 514  => Filter_Posting posting
 515  =  Filter_Posting_Account Filter_Account
 516  |  Filter_Posting_Amount (Filter_Amount (Posting_Amount posting))
 517  |  Filter_Posting_Unit Filter_Unit
 518  deriving (Typeable)
 519  -- Virtual
 520  -- Description Comp_String String
 521  -- Date Date.Span
 522  -- Account_Tag Comp_String String (Maybe (Comp_String, String))
 523  -- Account_Balance Comp_Num Comp_Num_Absolute Amount
 524  -- Depth Comp_Num Int
 525  -- None
 526  -- Real Bool
 527  -- Status Bool
 528  -- Tag Comp_String Tag.Name (Maybe (Comp_String, Tag.Value))
 529 deriving instance Posting p => Eq   (Filter_Posting p)
 530 deriving instance Posting p => Show (Filter_Posting p)
 531
 532 instance Posting p
 533  => Filter (Filter_Posting p) p where
 534         test (Filter_Posting_Account f) p =
 535                 test f $ posting_account p
 536         test (Filter_Posting_Amount  f) p =
 537                 Data.Foldable.any (test f) $ posting_amounts p
 538         test (Filter_Posting_Unit    f) p =
 539                 Data.Foldable.any (test f . amount_unit) $ posting_amounts p
 540
 541 newtype Cross t = Cross t
 542 instance (Transaction t, Transaction_Posting t ~ p, Posting p)
 543  => Filter (Filter_Transaction t) (Cross p) where
 544         test pr (Cross p) =
 545                 case pr of
 546                  (Filter_Transaction_Description _) -> True
 547                  (Filter_Transaction_Posting     f) -> test f p
 548                  (Filter_Transaction_Date        _) -> True  -- TODO: use posting_date
 549                  (Filter_Transaction_Tag         _) -> False -- TODO: use posting_tags
 550
 551 -- ** Type 'Filter_Transaction'
 552
 553 data        Transaction t
 554  =>  Filter_Transaction t
 555  =   Filter_Transaction_Description Filter_Text
 556  |   Filter_Transaction_Posting (Filter_Posting (Transaction_Posting t))
 557  |   Filter_Transaction_Date (Filter_Bool Filter_Date)
 558  |   Filter_Transaction_Tag (Filter_Bool Filter_Tag)
 559  deriving (Typeable)
 560 deriving instance Transaction t => Show (Filter_Transaction t)
 561
 562 instance Transaction t
 563  => Filter (Filter_Transaction t) t where
 564         test (Filter_Transaction_Description f) t =
 565                 test f $ transaction_description t
 566         test (Filter_Transaction_Posting f) t =
 567                 Data.Foldable.any (test f) $
 568                 transaction_postings t
 569         test (Filter_Transaction_Date f) t =
 570                 test f $ transaction_date t
 571         test (Filter_Transaction_Tag f) t =
 572                 Data.Monoid.getAny $
 573                 Data.Map.foldrWithKey
 574                  (\n -> mappend . Data.Monoid.Any .
 575                         Data.Foldable.any (test f . (n,)))
 576                  (Data.Monoid.Any False) $
 577                 transaction_tags t
 578
 579 instance
 580  ( Transaction transaction
 581  , Journal.Transaction transaction
 582  )
 583  => Consable (Fold_Transaction (Journal.Journal transaction) transaction)
 584  transaction where
 585         mcons t (Const (!j, ft)) =
 586                 Const . (, ft) $
 587                 if test ft t
 588                 then Journal.cons t j
 589                 else j
 590 instance
 591  ( Foldable foldable
 592  , Transaction transaction
 593  , Journal.Transaction transaction
 594  )
 595  => Consable (Fold_Transaction (Journal.Journal transaction) transaction)
 596  (foldable transaction) where
 597         mcons ts (Const (!j, ft)) =
 598                 Const . (, ft) $
 599                 case simplified ft of
 600                  Right False -> j
 601                  Right True ->
 602                         Data.Foldable.foldr
 603                          Journal.cons
 604                          j ts
 605                  Left f ->
 606                         Data.Foldable.foldr
 607                          (\t ->
 608                                 if test f t
 609                                 then Journal.cons t
 610                                 else id
 611                          ) j ts
 612
 613 -- ** Type 'Filter_Balance'
 614
 615 data        Balance b
 616  =>  Filter_Balance b
 617  =   Filter_Balance_Account Filter_Account
 618  |   Filter_Balance_Amount   (Filter_Amount (Balance_Amount b))
 619  |   Filter_Balance_Positive (Filter_Amount (Balance_Amount b))
 620  |   Filter_Balance_Negative (Filter_Amount (Balance_Amount b))
 621  deriving (Typeable)
 622 deriving instance Balance b => Eq   (Filter_Balance b)
 623 deriving instance Balance b => Show (Filter_Balance b)
 624
 625 instance Balance b
 626  => Filter (Filter_Balance b) b where
 627         test (Filter_Balance_Account f) b =
 628                 test f $ balance_account b
 629         test (Filter_Balance_Amount f) b =
 630                 test f $ balance_amount b
 631         test (Filter_Balance_Positive f) b =
 632                 Data.Foldable.any (test f) $
 633                 balance_positive b
 634         test (Filter_Balance_Negative f) b =
 635                 Data.Foldable.any (test f) $
 636                 balance_negative b
 637
 638 instance
 639  ( Balance.Posting posting
 640  , Posting posting
 641  , amount ~ Balance.Posting_Amount posting
 642  )
 643  => Consable (Fold_Posting (Balance.Balance_by_Account amount) posting)
 644  posting where
 645         mcons p (Const (!b, fp)) =
 646                 Const . (, fp) $
 647                 case simplified fp of
 648                  Right False -> b
 649                  Right True -> Balance.cons_by_account p b
 650                  Left f ->
 651                         if test f p
 652                         then Balance.cons_by_account p b
 653                         else b
 654 instance
 655  ( Transaction transaction
 656  , posting ~ Transaction_Posting transaction
 657  , amount ~ Balance.Posting_Amount posting
 658  , Balance.Amount amount
 659  , Balance.Posting posting
 660  )
 661  => Consable (Fold_Transaction_and_Posting
 662               (Balance.Balance_by_Account amount)
 663               transaction posting)
 664  transaction where
 665         mcons t (Const (!bal, ft, fp)) =
 666                 Const . (, ft, fp) $
 667                 case simplified ft of
 668                  Right False -> bal
 669                  Right True -> filter_postings $ transaction_postings t
 670                  Left f ->
 671                         if test f t
 672                         then filter_postings $ transaction_postings t
 673                         else bal
 674                 where filter_postings ps =
 675                         case simplified fp of
 676                          Right False -> bal
 677                          Right True ->
 678                                 Data.Foldable.foldl'
 679                                  (flip Balance.cons_by_account)
 680                                  bal ps
 681                          Left ff ->
 682                                 Data.Foldable.foldl'
 683                                  (\b p -> if test ff p then Balance.cons_by_account p b else b)
 684                                  bal ps
 685 instance
 686  ( Foldable foldable
 687  , Balance.Posting posting
 688  , Posting posting
 689  , amount ~ Balance.Posting_Amount posting
 690  )
 691  => Consable (Fold_Posting (Balance.Balance_by_Account amount) posting)
 692  (foldable posting) where
 693         mcons ps (Const (!bal, fp)) =
 694                 Const . (, fp) $
 695                 case simplified fp of
 696                  Right False -> bal
 697                  Right True ->
 698                         Data.Foldable.foldl'
 699                          (flip Balance.cons_by_account) bal ps
 700                  Left f ->
 701                         Data.Foldable.foldl' (\b p ->
 702                                 if test f p
 703                                 then Balance.cons_by_account p b
 704                                 else b) bal ps
 705
 706 -- ** Type 'Filter_GL'
 707
 708 data        GL r
 709  =>  Filter_GL r
 710  =   Filter_GL_Account Filter_Account
 711  |   Filter_GL_Amount_Positive (Filter_Amount (GL_Amount r))
 712  |   Filter_GL_Amount_Negative (Filter_Amount (GL_Amount r))
 713  |   Filter_GL_Amount_Balance  (Filter_Amount (GL_Amount r))
 714  |   Filter_GL_Sum_Positive    (Filter_Amount (GL_Amount r))
 715  |   Filter_GL_Sum_Negative    (Filter_Amount (GL_Amount r))
 716  |   Filter_GL_Sum_Balance     (Filter_Amount (GL_Amount r))
 717  deriving (Typeable)
 718 deriving instance GL r => Eq   (Filter_GL r)
 719 deriving instance GL r => Show (Filter_GL r)
 720
 721 instance GL r
 722  => Filter (Filter_GL r) r where
 723         test (Filter_GL_Account f) r =
 724                 test f $ gl_account r
 725         test (Filter_GL_Amount_Positive f) r =
 726                 Data.Foldable.any (test f) $
 727                 gl_amount_positive r
 728         test (Filter_GL_Amount_Negative f) r =
 729                 Data.Foldable.any (test f) $
 730                 gl_amount_negative r
 731         test (Filter_GL_Amount_Balance f) r =
 732                 test f $ gl_amount_balance r
 733         test (Filter_GL_Sum_Positive f) r =
 734                 Data.Foldable.any (test f) $
 735                 gl_sum_positive r
 736         test (Filter_GL_Sum_Negative f) r =
 737                 Data.Foldable.any (test f) $
 738                 gl_sum_negative r
 739         test (Filter_GL_Sum_Balance f) r =
 740                 test f $ gl_sum_balance r
 741 instance
 742  ( GL.Transaction transaction
 743  , Transaction    transaction
 744  , Posting        posting
 745  , posting ~ GL.Transaction_Posting transaction
 746  )
 747  => Consable (Fold_Transaction_and_Posting
 748               (GL.GL transaction)
 749               transaction posting)
 750  transaction where
 751         mcons t (Const (!gl, ft, fp)) =
 752                 Const . (, ft, fp) $
 753                 case simplified ft of
 754                  Right False -> gl
 755                  Right True ->
 756                         case simplified fp of
 757                          Right False -> gl
 758                          Right True -> GL.cons t gl
 759                          Left f ->
 760                                 GL.cons
 761                                  (GL.transaction_postings_filter (test f) t)
 762                                  gl
 763                  Left f ->
 764                         if test f t
 765                         then
 766                                 case simplified fp of
 767                                  Right False -> gl
 768                                  Right True -> GL.cons t gl
 769                                  Left ff ->
 770                                         GL.cons
 771                                          (GL.transaction_postings_filter (test ff) t)
 772                                          gl
 773                         else gl
 774 instance
 775  ( Foldable foldable
 776  , GL.Transaction transaction
 777  , Transaction    transaction
 778  , Posting        posting
 779  , posting ~ GL.Transaction_Posting transaction
 780  )
 781  => Consable (Fold_Transaction_and_Posting
 782               (GL.GL transaction)
 783               transaction posting)
 784  (foldable transaction) where
 785         mcons ts (Const (!gl, ft, fp)) =
 786                 Const . (, ft, fp) $
 787                 case simplified ft of
 788                  Right False -> gl
 789                  Right True ->
 790                         case simplified fp of
 791                          Right False -> gl
 792                          Right True ->
 793                                 Data.Foldable.foldr
 794                                  (GL.cons)
 795                                  gl ts
 796                          Left f ->
 797                                 Data.Foldable.foldr
 798                                  ( GL.cons
 799                                  . GL.transaction_postings_filter (test f) )
 800                                  gl ts
 801                  Left f ->
 802                         Data.Foldable.foldr
 803                          (\t ->
 804                                 if test f t
 805                                 then
 806                                         case simplified fp of
 807                                          Right False -> id
 808                                          Right True -> GL.cons t
 809                                          Left ff -> GL.cons $
 810                                                 GL.transaction_postings_filter (test ff) t
 811                                 else id
 812                          ) gl ts