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