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