lib/Hcompta/Filter.hs

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