]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Filter.hs
Ajout : Filter : simplify et context.
[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 (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