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