lib/Hcompta/Filter.hs

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