]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Filter.hs
Ajout : GNUmakefile : stats.
[comptalang.git] / 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 (pure, (<$>), (<*>))
13 import Control.Applicative (Const(..))
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 -- * Newtypes to avoid overlapping instances
165
166 newtype Scalar x
167 = Scalar x
168 instance Functor Scalar where
169 fmap f (Scalar x) = Scalar (f x)
170
171 -- * Types for folding
172
173 type Fold_Transaction acc transaction =
174 Const
175 ( acc
176 , Simplified
177 (Filter_Bool
178 (Filter_Transaction transaction))
179 )
180 type Fold_Posting acc transaction =
181 Const
182 ( acc
183 , Simplified
184 (Filter_Bool
185 (Filter_Posting transaction))
186 )
187 type Fold_Transaction_and_Posting acc transaction posting =
188 Const
189 ( acc
190 , Simplified
191 (Filter_Bool
192 (Filter_Transaction transaction))
193 , Simplified
194 (Filter_Bool
195 (Filter_Posting posting))
196 )
197
198 -- * Class 'Filter'
199
200 newtype Simplified p
201 = Simplified (Either p Bool)
202 deriving (Eq, Show)
203 simplified :: Simplified p -> Either p Bool
204 simplified (Simplified x) = x
205
206 instance Functor Simplified where
207 fmap _f (Simplified (Right b)) = Simplified (Right b)
208 fmap f (Simplified (Left x)) = Simplified (Left $ f x)
209 instance Filter p x => Filter (Simplified p) x where
210 test (Simplified (Right b)) _x = b
211 test (Simplified (Left f)) x = test f x
212 simplify (Simplified (Right b)) _x = Simplified $ Right b
213 simplify (Simplified (Left f)) x =
214 Simplified $
215 case simplified $ simplify f x of
216 Right b -> Right b
217 Left sf -> Left (Simplified $ Left sf)
218
219 -- | Conjonctive ('&&') 'Monoid'.
220 instance Monoid p => Monoid (Simplified p) where
221 mempty = Simplified (Right True)
222 mappend (Simplified x) (Simplified y) =
223 Simplified $
224 case (x, y) of
225 (Right bx , Right by ) -> Right (bx && by)
226 (Right True , Left _fy ) -> y
227 (Right False, Left _fy ) -> x
228 (Left _fx , Right True ) -> x
229 (Left _fx , Right False) -> y
230 (Left fx , Left fy ) -> Left $ fx `mappend` fy
231
232 class Filter p x where
233 test :: p -> x -> Bool
234 simplify :: p -> Maybe x -> Simplified p
235 simplify p _x = Simplified $ Left p
236
237 filter
238 :: (Foldable t, Filter p x, Monoid x)
239 => p -> t x -> x
240 filter p =
241 Data.Foldable.foldMap
242 (\x -> if test p x then x else mempty)
243
244 -- ** Type 'Filter_Text'
245
246 data Filter_Text
247 = Filter_Text_Any
248 | Filter_Text_Exact Text
249 | Filter_Text_Regex Regex
250 deriving (Eq, Show, Typeable)
251
252 instance Filter Filter_Text Text where
253 test p x =
254 case p of
255 Filter_Text_Any -> True
256 Filter_Text_Exact m -> (==) m x
257 Filter_Text_Regex m -> Regex.match m x
258
259 -- ** Type 'Filter_Ord'
260
261 data Filter_Ord o
262 = Filter_Ord_Lt o
263 | Filter_Ord_Le o
264 | Filter_Ord_Gt o
265 | Filter_Ord_Ge o
266 | Filter_Ord_Eq o
267 | Filter_Ord_Any
268 deriving (Data, Eq, Show, Typeable)
269
270 instance Functor Filter_Ord where
271 fmap f x =
272 case x of
273 Filter_Ord_Lt o -> Filter_Ord_Lt (f o)
274 Filter_Ord_Le o -> Filter_Ord_Le (f o)
275 Filter_Ord_Gt o -> Filter_Ord_Gt (f o)
276 Filter_Ord_Ge o -> Filter_Ord_Ge (f o)
277 Filter_Ord_Eq o -> Filter_Ord_Eq (f o)
278 Filter_Ord_Any -> Filter_Ord_Any
279 instance (Ord o, o ~ x)
280 => Filter (Filter_Ord o) (Scalar x) where
281 test p (Scalar x) =
282 case p of
283 Filter_Ord_Lt o -> (<) x o
284 Filter_Ord_Le o -> (<=) x o
285 Filter_Ord_Gt o -> (>) x o
286 Filter_Ord_Ge o -> (>=) x o
287 Filter_Ord_Eq o -> (==) x o
288 Filter_Ord_Any -> True
289 instance (Ord o, o ~ x)
290 => Filter (Filter_Ord o) (Interval x) where
291 test p i =
292 let l = Interval.low i in
293 let h = Interval.high i in
294 case p of
295 Filter_Ord_Lt o -> case compare (Interval.limit h) o of
296 LT -> True
297 EQ -> Interval.adherence h == Interval.Out
298 GT -> False
299 Filter_Ord_Le o -> Interval.limit h <= o
300 Filter_Ord_Gt o -> case compare (Interval.limit l) o of
301 LT -> False
302 EQ -> Interval.adherence l == Interval.Out
303 GT -> True
304 Filter_Ord_Ge o -> Interval.limit l >= o
305 Filter_Ord_Eq o -> Interval.limit l == o && Interval.limit h == o
306 Filter_Ord_Any -> True
307
308 -- ** Type 'Filter_Interval'
309
310 data Filter_Interval x
311 = Filter_Interval_In (Interval (Interval.Unlimitable x))
312 deriving (Eq, Ord, Show)
313 --instance Functor Filter_Interval where
314 -- fmap f (Filter_Interval_In i) = Filter_Interval_In (fmap (fmap f) i)
315 instance (Ord o, o ~ x)
316 => Filter (Filter_Interval o) (Scalar (Interval.Unlimitable x)) where
317 test (Filter_Interval_In p) (Scalar x) =
318 Interval.locate x p == EQ
319 instance (Ord o, o ~ x)
320 => Filter (Filter_Interval o) (Interval (Interval.Unlimitable x)) where
321 test (Filter_Interval_In p) i = Interval.into i p
322
323 -- ** Type 'Filter_Num_Abs'
324
325 newtype Num n
326 => Filter_Num_Abs n
327 = Filter_Num_Abs (Filter_Ord n)
328 deriving (Data, Eq, Show, Typeable)
329
330 instance (Num n, Ord x, n ~ x)
331 => Filter (Filter_Num_Abs n) x where
332 test (Filter_Num_Abs f) x = test f (Scalar (abs x))
333
334 -- ** Type 'Filter_Bool'
335
336 data Filter_Bool p
337 = Any
338 | Bool p
339 | Not (Filter_Bool p)
340 | And (Filter_Bool p) (Filter_Bool p)
341 | Or (Filter_Bool p) (Filter_Bool p)
342 deriving (Show)
343 deriving instance Eq p => Eq (Filter_Bool p)
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 p) where
352 mempty = Any
353 mappend = And
354 instance Foldable Filter_Bool where
355 foldr _ acc Any = acc
356 foldr f acc (Bool p) = f p acc
357 foldr f acc (Not t) = Data.Foldable.foldr f acc t
358 foldr f acc (And t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
359 foldr f acc (Or t0 t1) = Data.Foldable.foldr f (Data.Foldable.foldr f acc t0) t1
360 instance Traversable Filter_Bool where
361 traverse _ Any = pure Any
362 traverse f (Bool x) = Bool <$> f x
363 traverse f (Not t) = Not <$> traverse f t
364 traverse f (And t0 t1) = And <$> traverse f t0 <*> traverse f t1
365 traverse f (Or t0 t1) = Or <$> traverse f t0 <*> traverse f t1
366 instance Filter p x => Filter (Filter_Bool p) x where
367 test Any _ = True
368 test (Bool p) x = test p x
369 test (Not t) x = not $ test t x
370 test (And t0 t1) x = test t0 x && test t1 x
371 test (Or t0 t1) x = test t0 x || test t1 x
372
373 simplify Any _ = Simplified $ Right True
374 simplify (Bool p) x =
375 Simplified $
376 case simplified (simplify p x) of
377 Left p' -> Left (Bool p')
378 Right b -> Right b
379 simplify (Not t) x =
380 Simplified $
381 case simplified (simplify t x) of
382 Left p' -> Left (Not $ p')
383 Right b -> Right b
384 simplify (And t0 t1) x =
385 Simplified $
386 case (simplified $ simplify t0 x, simplified $ simplify t1 x) of
387 (Right b0, Right b1) -> Right (b0 && b1)
388 (Right b0, Left p1) -> if b0 then Left p1 else Right False
389 (Left p0, Right b1) -> if b1 then Left p0 else Right False
390 (Left p0, Left p1) -> Left (And p0 p1)
391 simplify (Or t0 t1) x =
392 Simplified $
393 case (simplified $ simplify t0 x, simplified $ simplify t1 x) of
394 (Right b0, Right b1) -> Right (b0 || b1)
395 (Right b0, Left p1) -> if b0 then Right True else Left p1
396 (Left p0, Right b1) -> if b1 then Right True else Left p0
397 (Left p0, Left p1) -> Left (Or p0 p1)
398
399 bool :: Filter p x => Filter_Bool p -> x -> Bool
400 bool Any _ = True
401 bool (Bool p) x = test p x
402 bool (Not t) x = not $ test t x
403 bool (And t0 t1) x = test t0 x && test t1 x
404 bool (Or t0 t1) x = test t0 x || test t1 x
405
406 -- ** Type 'Filter_Unit'
407
408 newtype Filter_Unit
409 = Filter_Unit Filter_Text
410 deriving (Eq, Show, Typeable)
411
412 instance Unit u => Filter Filter_Unit u where
413 test (Filter_Unit f) = test f . unit_text
414
415 -- ** Type 'Filter_Account'
416
417 type Filter_Account
418 = [Filter_Account_Section]
419
420 data Filter_Account_Section
421 = Filter_Account_Section_Any
422 | Filter_Account_Section_Many
423 | Filter_Account_Section_Text Filter_Text
424 deriving (Eq, Show, Typeable)
425
426 instance Filter Filter_Account Account where
427 test f acct =
428 comp f (NonEmpty.toList acct)
429 where
430 comp :: [Filter_Account_Section] -> [Account.Name] -> Bool
431 comp [] [] = True
432 comp [Filter_Account_Section_Many] _ = True
433 comp [] _ = False
434 {-
435 comp (s:[]) (n:_) =
436 case s of
437 Filter_Account_Section_Any -> True
438 Filter_Account_Section_Many -> True
439 Filter_Account_Section_Text m -> test m n
440 -}
441 comp so@(s:ss) no@(n:ns) =
442 case s of
443 Filter_Account_Section_Any -> comp ss ns
444 Filter_Account_Section_Many -> comp ss no || comp so ns
445 Filter_Account_Section_Text m -> test m n && comp ss ns
446 comp _ [] = False
447
448 -- ** Type 'Filter_Amount'
449
450 type Filter_Quantity q
451 = Filter_Ord q
452
453 data Amount a
454 => Filter_Amount a
455 = Filter_Amount
456 { filter_amount_quantity :: Filter_Quantity (Amount_Quantity a)
457 , filter_amount_unit :: Filter_Unit
458 } deriving (Typeable)
459 deriving instance Amount a => Eq (Filter_Amount a)
460 deriving instance Amount a => Show (Filter_Amount a)
461
462 instance Amount a
463 => Filter (Filter_Amount a) a where
464 test (Filter_Amount fq fu) amt =
465 test fu (amount_unit amt) &&
466 test fq (Scalar (amount_quantity amt))
467
468 -- ** Type 'Filter_Date'
469
470 data Filter_Date
471 = Filter_Date_UTC (Filter_Ord Date)
472 | Filter_Date_Year (Filter_Interval Integer)
473 | Filter_Date_Month (Filter_Interval Int)
474 | Filter_Date_DoM (Filter_Interval Int)
475 | Filter_Date_Hour (Filter_Interval Int)
476 | Filter_Date_Minute (Filter_Interval Int)
477 | Filter_Date_Second (Filter_Interval Data.Fixed.Pico)
478 deriving (Typeable)
479 deriving instance Show (Filter_Date)
480
481 instance Filter Filter_Date Date where
482 test (Filter_Date_UTC f) d = test f $ Scalar d
483 test (Filter_Date_Year f) d = test f $ Scalar $ Interval.Limited $ Date.year d
484 test (Filter_Date_Month f) d = test f $ Scalar $ Interval.Limited $ Date.month d
485 test (Filter_Date_DoM f) d = test f $ Scalar $ Interval.Limited $ Date.dom d
486 test (Filter_Date_Hour f) d = test f $ Scalar $ Interval.Limited $ Date.hour d
487 test (Filter_Date_Minute f) d = test f $ Scalar $ Interval.Limited $ Date.minute d
488 test (Filter_Date_Second f) d = test f $ Scalar $ Interval.Limited $ Date.second d
489
490 instance Filter Filter_Date (Interval (Interval.Unlimitable Date)) where
491 test (Filter_Date_UTC f) d = test (Interval.Limited <$> f) d
492 test (Filter_Date_Year f) d = maybe False (test f) $ Interval.fmap (fmap Date.year) d
493 test (Filter_Date_Month f) d = maybe False (test f) $ Interval.fmap (fmap Date.month) d
494 test (Filter_Date_DoM f) d = maybe False (test f) $ Interval.fmap (fmap Date.dom) d
495 test (Filter_Date_Hour f) d = maybe False (test f) $ Interval.fmap (fmap Date.hour) d
496 test (Filter_Date_Minute f) d = maybe False (test f) $ Interval.fmap (fmap Date.minute) d
497 test (Filter_Date_Second f) d = maybe False (test f) $ Interval.fmap (fmap Date.second) d
498
499 -- ** Type 'Filter_Tag'
500
501 data Filter_Tag
502 = Filter_Tag_Name Filter_Text
503 | Filter_Tag_Value Filter_Text
504 deriving (Typeable)
505 deriving instance Show (Filter_Tag)
506
507 instance Filter Filter_Tag (Text, Text) where
508 test (Filter_Tag_Name f) (x, _) = test f x
509 test (Filter_Tag_Value f) (_, x) = test f x
510
511 -- ** Type 'Filter_Posting'
512
513 data Posting posting
514 => Filter_Posting posting
515 = Filter_Posting_Account Filter_Account
516 | Filter_Posting_Amount (Filter_Amount (Posting_Amount posting))
517 | Filter_Posting_Unit Filter_Unit
518 deriving (Typeable)
519 -- Virtual
520 -- Description Comp_String String
521 -- Date Date.Span
522 -- Account_Tag Comp_String String (Maybe (Comp_String, String))
523 -- Account_Balance Comp_Num Comp_Num_Absolute Amount
524 -- Depth Comp_Num Int
525 -- None
526 -- Real Bool
527 -- Status Bool
528 -- Tag Comp_String Tag.Name (Maybe (Comp_String, Tag.Value))
529 deriving instance Posting p => Eq (Filter_Posting p)
530 deriving instance Posting p => Show (Filter_Posting p)
531
532 instance Posting p
533 => Filter (Filter_Posting p) p where
534 test (Filter_Posting_Account f) p =
535 test f $ posting_account p
536 test (Filter_Posting_Amount f) p =
537 Data.Foldable.any (test f) $ posting_amounts p
538 test (Filter_Posting_Unit f) p =
539 Data.Foldable.any (test f . amount_unit) $ posting_amounts p
540
541 newtype Cross t = Cross t
542 instance (Transaction t, Transaction_Posting t ~ p, Posting p)
543 => Filter (Filter_Transaction t) (Cross p) where
544 test pr (Cross p) =
545 case pr of
546 (Filter_Transaction_Description _) -> True
547 (Filter_Transaction_Posting f) -> test f p
548 (Filter_Transaction_Date _) -> True -- TODO: use posting_date
549 (Filter_Transaction_Tag _) -> False -- TODO: use posting_tags
550
551 -- ** Type 'Filter_Transaction'
552
553 data Transaction t
554 => Filter_Transaction t
555 = Filter_Transaction_Description Filter_Text
556 | Filter_Transaction_Posting (Filter_Posting (Transaction_Posting t))
557 | Filter_Transaction_Date (Filter_Bool Filter_Date)
558 | Filter_Transaction_Tag (Filter_Bool Filter_Tag)
559 deriving (Typeable)
560 deriving instance Transaction t => Show (Filter_Transaction t)
561
562 instance Transaction t
563 => Filter (Filter_Transaction t) t where
564 test (Filter_Transaction_Description f) t =
565 test f $ transaction_description t
566 test (Filter_Transaction_Posting f) t =
567 Data.Foldable.any (test f) $
568 transaction_postings t
569 test (Filter_Transaction_Date f) t =
570 test f $ transaction_date t
571 test (Filter_Transaction_Tag f) t =
572 Data.Monoid.getAny $
573 Data.Map.foldrWithKey
574 (\n -> mappend . Data.Monoid.Any .
575 Data.Foldable.any (test f . (n,)))
576 (Data.Monoid.Any False) $
577 transaction_tags t
578
579 instance
580 ( Transaction transaction
581 , Journal.Transaction transaction
582 )
583 => Consable (Fold_Transaction (Journal.Journal transaction) transaction)
584 transaction where
585 mcons t (Const (!j, ft)) =
586 Const . (, ft) $
587 if test ft t
588 then Journal.cons t j
589 else j
590 instance
591 ( Foldable foldable
592 , Transaction transaction
593 , Journal.Transaction transaction
594 )
595 => Consable (Fold_Transaction (Journal.Journal transaction) transaction)
596 (foldable transaction) where
597 mcons ts (Const (!j, ft)) =
598 Const . (, ft) $
599 case simplified ft of
600 Right False -> j
601 Right True ->
602 Data.Foldable.foldr
603 Journal.cons
604 j ts
605 Left f ->
606 Data.Foldable.foldr
607 (\t ->
608 if test f t
609 then Journal.cons t
610 else id
611 ) j ts
612
613 -- ** Type 'Filter_Balance'
614
615 data Balance b
616 => Filter_Balance b
617 = Filter_Balance_Account Filter_Account
618 | Filter_Balance_Amount (Filter_Amount (Balance_Amount b))
619 | Filter_Balance_Positive (Filter_Amount (Balance_Amount b))
620 | Filter_Balance_Negative (Filter_Amount (Balance_Amount b))
621 deriving (Typeable)
622 deriving instance Balance b => Eq (Filter_Balance b)
623 deriving instance Balance b => Show (Filter_Balance b)
624
625 instance Balance b
626 => Filter (Filter_Balance b) b where
627 test (Filter_Balance_Account f) b =
628 test f $ balance_account b
629 test (Filter_Balance_Amount f) b =
630 test f $ balance_amount b
631 test (Filter_Balance_Positive f) b =
632 Data.Foldable.any (test f) $
633 balance_positive b
634 test (Filter_Balance_Negative f) b =
635 Data.Foldable.any (test f) $
636 balance_negative b
637
638 instance
639 ( Balance.Posting posting
640 , Posting posting
641 , amount ~ Balance.Posting_Amount posting
642 )
643 => Consable (Fold_Posting (Balance.Balance_by_Account amount) posting)
644 posting where
645 mcons p (Const (!b, fp)) =
646 Const . (, fp) $
647 case simplified fp of
648 Right False -> b
649 Right True -> Balance.cons_by_account p b
650 Left f ->
651 if test f p
652 then Balance.cons_by_account p b
653 else b
654 instance
655 ( Transaction transaction
656 , posting ~ Transaction_Posting transaction
657 , amount ~ Balance.Posting_Amount posting
658 , Balance.Amount amount
659 , Balance.Posting posting
660 )
661 => Consable (Fold_Transaction_and_Posting
662 (Balance.Balance_by_Account amount)
663 transaction posting)
664 transaction where
665 mcons t (Const (!bal, ft, fp)) =
666 Const . (, ft, fp) $
667 case simplified ft of
668 Right False -> bal
669 Right True -> filter_postings $ transaction_postings t
670 Left f ->
671 if test f t
672 then filter_postings $ transaction_postings t
673 else bal
674 where filter_postings ps =
675 case simplified fp of
676 Right False -> bal
677 Right True ->
678 Data.Foldable.foldl'
679 (flip Balance.cons_by_account)
680 bal ps
681 Left ff ->
682 Data.Foldable.foldl'
683 (\b p -> if test ff p then Balance.cons_by_account p b else b)
684 bal ps
685 instance
686 ( Foldable foldable
687 , Balance.Posting posting
688 , Posting posting
689 , amount ~ Balance.Posting_Amount posting
690 )
691 => Consable (Fold_Posting (Balance.Balance_by_Account amount) posting)
692 (foldable posting) where
693 mcons ps (Const (!bal, fp)) =
694 Const . (, fp) $
695 case simplified fp of
696 Right False -> bal
697 Right True ->
698 Data.Foldable.foldl'
699 (flip Balance.cons_by_account) bal ps
700 Left f ->
701 Data.Foldable.foldl' (\b p ->
702 if test f p
703 then Balance.cons_by_account p b
704 else b) bal ps
705
706 -- ** Type 'Filter_GL'
707
708 data GL r
709 => Filter_GL r
710 = Filter_GL_Account Filter_Account
711 | Filter_GL_Amount_Positive (Filter_Amount (GL_Amount r))
712 | Filter_GL_Amount_Negative (Filter_Amount (GL_Amount r))
713 | Filter_GL_Amount_Balance (Filter_Amount (GL_Amount r))
714 | Filter_GL_Sum_Positive (Filter_Amount (GL_Amount r))
715 | Filter_GL_Sum_Negative (Filter_Amount (GL_Amount r))
716 | Filter_GL_Sum_Balance (Filter_Amount (GL_Amount r))
717 deriving (Typeable)
718 deriving instance GL r => Eq (Filter_GL r)
719 deriving instance GL r => Show (Filter_GL r)
720
721 instance GL r
722 => Filter (Filter_GL r) r where
723 test (Filter_GL_Account f) r =
724 test f $ gl_account r
725 test (Filter_GL_Amount_Positive f) r =
726 Data.Foldable.any (test f) $
727 gl_amount_positive r
728 test (Filter_GL_Amount_Negative f) r =
729 Data.Foldable.any (test f) $
730 gl_amount_negative r
731 test (Filter_GL_Amount_Balance f) r =
732 test f $ gl_amount_balance r
733 test (Filter_GL_Sum_Positive f) r =
734 Data.Foldable.any (test f) $
735 gl_sum_positive r
736 test (Filter_GL_Sum_Negative f) r =
737 Data.Foldable.any (test f) $
738 gl_sum_negative r
739 test (Filter_GL_Sum_Balance f) r =
740 test f $ gl_sum_balance r
741 instance
742 ( GL.Transaction transaction
743 , Transaction transaction
744 , Posting posting
745 , posting ~ GL.Transaction_Posting transaction
746 )
747 => Consable (Fold_Transaction_and_Posting
748 (GL.GL transaction)
749 transaction posting)
750 transaction where
751 mcons t (Const (!gl, ft, fp)) =
752 Const . (, ft, fp) $
753 case simplified ft of
754 Right False -> gl
755 Right True ->
756 case simplified fp of
757 Right False -> gl
758 Right True -> GL.cons t gl
759 Left f ->
760 GL.cons
761 (GL.transaction_postings_filter (test f) t)
762 gl
763 Left f ->
764 if test f t
765 then
766 case simplified fp of
767 Right False -> gl
768 Right True -> GL.cons t gl
769 Left ff ->
770 GL.cons
771 (GL.transaction_postings_filter (test ff) t)
772 gl
773 else gl
774 instance
775 ( Foldable foldable
776 , GL.Transaction transaction
777 , Transaction transaction
778 , Posting posting
779 , posting ~ GL.Transaction_Posting transaction
780 )
781 => Consable (Fold_Transaction_and_Posting
782 (GL.GL transaction)
783 transaction posting)
784 (foldable transaction) where
785 mcons ts (Const (!gl, ft, fp)) =
786 Const . (, ft, fp) $
787 case simplified ft of
788 Right False -> gl
789 Right True ->
790 case simplified fp of
791 Right False -> gl
792 Right True ->
793 Data.Foldable.foldr
794 (GL.cons)
795 gl ts
796 Left f ->
797 Data.Foldable.foldr
798 ( GL.cons
799 . GL.transaction_postings_filter (test f) )
800 gl ts
801 Left f ->
802 Data.Foldable.foldr
803 (\t ->
804 if test f t
805 then
806 case simplified fp of
807 Right False -> id
808 Right True -> GL.cons t
809 Left ff -> GL.cons $
810 GL.transaction_postings_filter (test ff) t
811 else id
812 ) gl ts