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