]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Filter/Read.hs
Déplace hcompta-calculus vers lol-calculus et lol-typing
[comptalang.git] / lib / Hcompta / Filter / Read.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE Rank2Types #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TupleSections #-}
9 {-# LANGUAGE TypeFamilies #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-}
11 module Hcompta.Filter.Read where
12
13 import Control.Applicative ((<$>), (<*))
14 import Control.Exception (assert)
15 import Control.Monad (Monad(..), liftM, join, when, (=<<), (>=>), void, forM)
16 import Data.Bool
17 import Data.Char
18 import Data.Data
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import qualified Data.Foldable
22 import Data.Foldable (Foldable(..))
23 import Data.Functor (Functor(..))
24 import Data.Functor.Identity (Identity)
25 import Data.List ((++), concat, map, reverse)
26 import Data.Maybe (Maybe(..), catMaybes)
27 import Data.Ord (Ord(..))
28 import Data.String (String, fromString)
29 import Data.Text (Text)
30 import qualified Data.Text as Text
31 import qualified Data.Time.Clock as Time
32 import Data.Typeable ()
33 import Prelude (($), (.), Integer, IO, Num(..), undefined)
34 import qualified Text.Parsec.Expr as R
35 import qualified Text.Parsec as R hiding
36 ( char
37 , anyChar
38 , crlf
39 , newline
40 , noneOf
41 , oneOf
42 , satisfy
43 , space
44 , spaces
45 , string
46 )
47 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
48 import Text.Show (Show(..))
49
50 -- import qualified Hcompta.Amount as Amount
51 import Hcompta.Date (Date)
52 import qualified Hcompta.Date as Date
53 import Hcompta.Filter
54 import qualified Hcompta.Filter as Filter
55 import qualified Hcompta.Filter.Amount as Filter.Amount
56 import qualified Hcompta.Filter.Amount.Read as Amount.Read
57 import qualified Hcompta.Filter.Date.Read as Date.Read
58 import Hcompta.Lib.Interval (Interval)
59 import qualified Hcompta.Lib.Interval as Interval
60 import qualified Hcompta.Lib.Parsec as R
61 import qualified Hcompta.Lib.Regex as Regex
62 -- import Hcompta.Polarize
63 -- import qualified Hcompta.Quantity as Quantity
64 import qualified Hcompta.Posting as Posting
65 import qualified Hcompta.Unit as Unit
66
67 -- * Type 'Context'
68 data Context
69 = Context
70 { context_date :: Date
71 } deriving (Data, Eq, Show, Typeable)
72
73 context :: Context
74 context =
75 Context
76 { context_date = Date.nil
77 }
78
79 -- * Type 'Error'
80 data Error
81 = Error_Unknown
82 | Error_Filter_Date Date.Read.Error
83 | Error_Filter_Date_Interval (Integer, Integer)
84 deriving (Show)
85
86 -- * Read
87 read ::
88 ( Stream s (R.Error_State Error Identity) Char
89 , Show t
90 )
91 => ParsecT s Context (R.Error_State Error Identity) (Filter_Bool t)
92 -> s -> IO (Either [R.Error Error] (Filter_Bool t))
93 read t s = do
94 context_date <- Time.getCurrentTime
95 return $
96 R.runParser_with_Error t context{context_date} "" s
97
98 -- * Read 'Filter_Text'
99 filter_text
100 :: (Stream s m Char, Monad r)
101 => ParsecT s u m (String -> r Filter_Text)
102 filter_text =
103 R.choice_try
104 [ R.char '~' >> return (Regex.of_StringM >=> (return . Filter_Text_Regex))
105 , R.char '=' >> return (\s -> return (Filter_Text_Exact $ Text.pack s))
106 , return (\s -> return (Filter_Text_Exact $ Text.pack s))
107 ]
108
109 filter_text_operator
110 :: Stream s m Char
111 => ParsecT s u m String
112 filter_text_operator =
113 R.choice_try
114 [ R.string "="
115 , R.string "~"
116 ]
117
118 -- * Read 'Filter_Ord'
119 filter_ord
120 :: (Stream s m Char, Ord o)
121 => ParsecT s u m (o -> Filter_Ord o)
122 filter_ord =
123 R.choice_try
124 [ R.string "=" >> return (Filter_Ord Eq)
125 , R.string "<=" >> return (Filter_Ord Le) -- NOTE: before "<"
126 , R.string ">=" >> return (Filter_Ord Ge) -- NOTE: before ">"
127 , R.string "<" >> return (Filter_Ord Lt)
128 , R.string ">" >> return (Filter_Ord Gt)
129 ]
130
131 filter_ord_operator
132 :: Stream s m Char
133 => ParsecT s u m String
134 filter_ord_operator =
135 R.choice_try
136 [ R.string "="
137 , R.string "<="
138 , R.string ">="
139 , R.string "<"
140 , R.string ">"
141 ]
142
143 -- * Read 'Filter_Num_Abs'
144 filter_num_abs
145 :: (Stream s m Char, Num n)
146 => ParsecT s u m (Filter_Ord n -> m (Either (Filter_Ord n) (Filter_Num_Abs n)))
147 filter_num_abs =
148 R.choice_try
149 [ R.char '+' >> return (return . Right . Filter_Num_Abs)
150 , return (return . Left)
151 ]
152
153 text :: Stream s m Char => String -> ParsecT s Context m Text
154 text none_of =
155 fromString <$>
156 R.choice_try
157 [ borders inside
158 , R.many $ R.noneOf ("() " ++ none_of)
159 ]
160 where
161 borders = R.between (R.char '(') (R.char ')')
162 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
163 preserve_inside = inside >>= (\x -> return $ '(':(x++[')']))
164
165 -- * Read 'Filter_Bool'
166 filter_bool
167 :: (Stream s m Char)
168 => [ParsecT s u m (ParsecT s u m (Filter_Bool t))]
169 -> ParsecT s u m (Filter_Bool t)
170 filter_bool terms =
171 R.buildExpressionParser
172 filter_bool_operators
173 (filter_bool_term terms)
174 <?> "filter_bool"
175
176 filter_bool_operators
177 :: Stream s m Char
178 => R.OperatorTable s u m (Filter.Filter_Bool t)
179 filter_bool_operators =
180 [ [ prefix "- " Filter.Not
181 ]
182 , [ binary " & " Filter.And R.AssocLeft
183 ]
184 , [ binary " + " Filter.Or R.AssocLeft
185 , binary " - " (\x -> Filter.And x . Filter.Not) R.AssocLeft
186 ]
187 ]
188 where
189 binary name fun = R.Infix (filter_bool_operator name >> return fun)
190 prefix name fun = R.Prefix (filter_bool_operator name >> return fun)
191 -- postfix name fun = Text.Parsec.Expr.Postfix (filter_bool_operator name >> return fun)
192
193 filter_bool_operator
194 :: Stream s m Char
195 => String -> ParsecT s u m ()
196 filter_bool_operator name =
197 R.try $
198 (R.string name
199 >> R.notFollowedBy filter_bool_operator_letter
200 -- <* R.spaces
201 <?> name)
202
203 filter_bool_operator_letter
204 :: Stream s m Char => ParsecT s u m Char
205 filter_bool_operator_letter =
206 R.oneOf ['-', '&', '+']
207
208 filter_bool_term
209 :: Stream s m Char
210 => [ParsecT s u m (ParsecT s u m (Filter_Bool t))]
211 -> ParsecT s u m (Filter_Bool t)
212 filter_bool_term terms = (do
213 join $ R.choice_try
214 ( (R.lookAhead (R.try (R.spaces >> R.char '('))
215 >> (return $ parens $
216 Data.Foldable.foldr Filter.And Filter.Any <$>
217 R.many (R.try (R.spaces >> expr)) ))
218 : terms
219 ) <* R.spaces) <?> "boolean-term"
220 where
221 expr =
222 R.lookAhead (R.try R.anyToken)
223 >> R.notFollowedBy (R.char ')')
224 >> filter_bool terms
225
226 parens
227 :: Stream s m Char
228 => ParsecT s u m a
229 -> ParsecT s u m a
230 parens =
231 R.between
232 (R.spaces >> R.char '(')
233 (R.spaces >> R.char ')')
234
235 bool :: Stream s m Char => ParsecT s u m Bool
236 bool = do
237 R.choice_try
238 [ R.choice_try
239 [ R.string "1"
240 , R.string "true"
241 , R.string "t"
242 ] >> return True
243 , R.choice_try
244 [ R.string "0"
245 , R.string "false"
246 , R.string "f"
247 ] >> return False
248 ]
249
250 jump :: Stream s m Char
251 => [String]
252 -> ParsecT s u m b
253 -> a
254 -> ParsecT s u m a
255 jump prefixes next r =
256 R.choice_try (map (\s -> R.string s >> return r) prefixes)
257 <* R.lookAhead (R.try next)
258
259 -- * Read 'Filter_Account'
260
261 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
262 newtype Forall_Filter_Account
263 = Forall_Filter_Account
264 { get_Forall_Filter_Account ::
265 forall acct.
266 ( Account acct
267 ) => Filter_Account_Component acct
268 }
269
270 filter_account
271 :: Stream s m Char
272 => ParsecT s Context m (Filter_Bool Forall_Filter_Account)
273 filter_account = do
274 f <- R.many $ R.spaces
275 >> R.lookAhead R.anyToken
276 >> filter_bool filter_account_terms
277 return $
278 Data.Foldable.foldr
279 Filter.And
280 Filter.Any f
281
282 filter_account_terms
283 :: Stream s m Char
284 => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_Account))]
285 filter_account_terms =
286 [ jump [ "AT" ] filter_account_operator $ do
287 f <- filter_tag
288 return $
289 Bool $ Forall_Filter_Account $
290 Filter.Filter_Account_Tag f
291 , return $ do
292 f <- filter_account_path
293 return $
294 Bool $ Forall_Filter_Account $
295 Filter.Filter_Account_Path f
296 ]
297
298 filter_account_operator
299 :: Stream s m Char
300 => ParsecT s u m String
301 filter_account_operator =
302 R.choice_try
303 [ filter_ord_operator
304 ]
305
306 filter_account_path
307 :: Stream s m Char
308 => ParsecT s u m (Filter_Path Account_Section)
309 filter_account_path = do
310 R.notFollowedBy $ R.space_horizontal
311 Filter_Ord o () <-
312 R.option (Filter_Ord Eq ()) $ R.try $
313 (\f -> f ()) <$> filter_ord
314 strings <-
315 R.many1_separated
316 (R.many (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c))))
317 (R.char account_section_sep)
318 sections <- forM strings $ \s ->
319 case s of
320 "" -> return Filter_Path_Section_Many
321 "*" -> return Filter_Path_Section_Any
322 '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
323 t -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t
324 return $ Filter_Path o $
325 (if sections == [] then [Filter_Path_Section_Many] else sections)
326
327 account_section_sep :: Char
328 account_section_sep = ':'
329
330 -- * Read 'Filter_Amount'
331
332 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
333 newtype Forall_Filter_Amount_Decimal
334 = Forall_Filter_Amount_Decimal
335 { get_Forall_Filter_Amount_Decimal ::
336 forall amt.
337 ( Amount amt
338 , Amount_Quantity amt ~ Filter.Amount.Quantity
339 ) => Filter_Amount amt
340 }
341
342 filter_amount
343 :: Stream s m Char
344 => (Filter_Ord Filter.Amount.Quantity -> Filter_Polarized Filter.Amount.Quantity)
345 -> ParsecT s u m Forall_Filter_Amount_Decimal
346 filter_amount flt_polarized = do
347 R.notFollowedBy $ R.space_horizontal
348 R.choice_try
349 [ filter_ord
350 >>= \(flt_ord::Filter.Amount.Quantity -> Filter_Ord Filter.Amount.Quantity) -> do
351 amt <- Amount.Read.amount
352 return $ Forall_Filter_Amount_Decimal $ And
353 (Bool $ Filter_Amount_Section_Quantity (flt_polarized $ flt_ord $ Filter.Amount.amount_quantity amt))
354 (case Unit.unit_text $ Filter.amount_unit amt of
355 u | Text.null u -> Any
356 u -> Bool $ Filter_Amount_Section_Unit (Filter_Unit (Filter_Text_Exact u)))
357 , filter_text
358 >>= \flt_ord -> do
359 unit_ <- Amount.Read.unit >>= flt_ord . Text.unpack . Unit.unit_text
360 return $ Forall_Filter_Amount_Decimal $ Bool $ Filter_Amount_Section_Unit (Filter_Unit unit_)
361 ]
362
363 filter_amount_operator
364 :: Stream s m Char
365 => ParsecT s u m String
366 filter_amount_operator =
367 R.choice_try
368 [ filter_ord_operator
369 , filter_text_operator
370 ]
371
372 -- * Read 'Filter_Date'
373 filter_date
374 :: (Stream s (R.Error_State Error m) Char, Monad m)
375 => ParsecT s Context (R.Error_State Error m) (Filter_Bool Filter_Date)
376 filter_date = do
377 join $ R.choice_try
378 [ R.char '=' >>
379 (return $ read_date_pattern)
380 , filter_ord >>= \tst ->
381 return $ do
382 ctx <- R.getState
383 let (year, _, _) = Date.gregorian $ context_date ctx
384 liftM (Bool . Filter_Date_UTC . tst) $
385 Date.Read.date Error_Filter_Date (Just year)
386 ]
387 where
388 read_date_pattern
389 :: (Stream s (R.Error_State Error m) Char, Monad m)
390 => ParsecT s u (R.Error_State Error m) (Filter_Bool Filter_Date)
391 read_date_pattern = (do
392 let read2 = of_digits <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
393 n0 <- read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
394 n1 <- R.option Nothing $ R.try $ do
395 _ <- R.char '/'
396 Just <$> read_interval Error_Filter_Date_Interval read2
397 n2 <- R.option Nothing $ R.try $ do
398 _ <- R.char '/'
399 Just <$> read_interval Error_Filter_Date_Interval read2
400 let (year, month, dom) =
401 case (n1, n2) of
402 (Nothing, Nothing) ->
403 ( Interval.unlimited
404 , n0
405 , Interval.unlimited )
406 (Just d1, Nothing) ->
407 ( Interval.unlimited
408 , n0
409 , d1 )
410 (Nothing, Just _d2) -> assert False undefined
411 (Just d1, Just d2) ->
412 ( n0
413 , d1
414 , d2 )
415 (hour, minute, second) <-
416 R.option (Interval.unlimited, Interval.unlimited, Interval.unlimited) $ R.try $ do
417 _ <- R.char '_'
418 hour <- read_interval Error_Filter_Date_Interval read2
419 sep <- R.char Date.Read.hour_separator
420 minute <- read_interval Error_Filter_Date_Interval read2
421 second <- R.option Interval.unlimited $ R.try $ do
422 _ <- R.char sep
423 read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
424 -- tz <- R.option Time.utc $ R.try $ do
425 -- -- R.skipMany $ R.space_horizontal
426 -- Date.Read.time_zone
427 return
428 ( hour
429 , minute
430 , second
431 )
432 return $
433 foldr And Any $
434 catMaybes $
435 [ just_when_limited (Filter_Date_Year . Filter_Interval_In) year
436 , just_when_limited (Filter_Date_Month . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month)
437 , just_when_limited (Filter_Date_DoM . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom)
438 , just_when_limited (Filter_Date_Hour . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour)
439 , just_when_limited (Filter_Date_Minute . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute)
440 , just_when_limited (Filter_Date_Second . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) second)
441 ]
442 ) <?> "date-filter"
443 where
444 of_digits :: Num n => [Char] -> n
445 of_digits = fromInteger . R.integer_of_digits 10
446 just_when_limited f x =
447 if x == Interval.unlimited
448 then Nothing
449 else Just $ Bool $ f x
450
451 read_interval
452 :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
453 => ((x, x) -> e)
454 -> ParsecT s u (R.Error_State e m) x
455 -> ParsecT s u (R.Error_State e m) (Interval (Interval.Unlimitable x))
456 read_interval err read_digits = do
457 l <- R.choice_try
458 [ R.string ".." >> return Interval.Unlimited_low
459 , Interval.Limited <$> read_digits
460 ]
461 R.choice_try
462 [ when (l /= Interval.Unlimited_low)
463 (void $ R.string "..") >> do
464 h <- R.choice_try
465 [ Interval.Limited <$> read_digits
466 , return Interval.Unlimited_high
467 ]
468 case (Interval.<=..<=) l h of
469 Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
470 Just i -> return i
471 , return $
472 case l of
473 Interval.Limited _ -> Interval.point l
474 _ -> Interval.unlimited
475 ]
476
477 filter_date_operator
478 :: Stream s m Char
479 => ParsecT s u m String
480 filter_date_operator =
481 filter_ord_operator
482
483 -- * Read 'Filter_Wording'
484 filter_wording
485 :: Stream s m Char
486 => ParsecT s u m Filter_Text
487 filter_wording = (do
488 make_filter_text <- filter_text
489 R.between (R.char '"') (R.char '"') $
490 make_filter_text =<< (R.many $ R.try $ R.satisfy (/= '"'))
491 ) <?> "wording"
492
493 filter_wording_operator
494 :: Stream s m Char
495 => ParsecT s u m String
496 filter_wording_operator =
497 filter_text_operator
498
499 -- * Read 'Filter_Tag'
500 filter_tag
501 :: Stream s m Char
502 => ParsecT s u m Filter_Tags
503 filter_tag = do
504 R.notFollowedBy $ R.space_horizontal
505 Filter_Ord o () <- (\f -> f ()) <$> filter_ord
506 filter_tag_value <-
507 R.choice_try
508 [ R.char '<' >> return Filter_Tag_Value_First
509 , R.char '>' >> return Filter_Tag_Value_Last
510 , return Filter_Tag_Value_Any
511 ]
512 strings <-
513 R.many1_separated
514 (R.many (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c))))
515 (R.char account_section_sep)
516 sections <- forM strings $ \s ->
517 case s of
518 "" -> return Filter_Path_Section_Many
519 "*" -> return Filter_Path_Section_Any
520 '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
521 t -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t
522 case reverse sections of
523 [] -> R.parserZero
524 [p] -> return $ Bool $ Filter_Tag_Path $ Filter_Path o [p]
525 value:rev_path ->
526 return $ And
527 (Bool $ Filter_Tag_Path $ Filter_Path o $ reverse rev_path)
528 (Bool $ Filter_Tag_Value $ filter_tag_value $
529 case value of
530 Filter_Path_Section_Any -> Filter_Text_Any
531 Filter_Path_Section_Many -> Filter_Text_Any
532 Filter_Path_Section_Text ft -> ft
533 )
534
535 filter_tag_operator
536 :: Stream s m Char
537 => ParsecT s u m String
538 filter_tag_operator = do
539 void filter_ord_operator
540 R.choice_try
541 [ R.string "<"
542 , R.string ">"
543 , R.string ""
544 ]
545
546 -- * Read 'Filter_Posting'
547
548 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
549 newtype Forall_Filter_Posting_Decimal
550 = Forall_Filter_Posting_Decimal
551 { get_Forall_Filter_Posting_Decimal ::
552 forall ptg.
553 ( Posting ptg
554 , Amount_Quantity (Posting.Posting_Amount ptg) ~ Filter.Amount.Quantity
555 ) => Filter_Posting ptg
556 }
557
558 filter_posting
559 :: Stream s m Char
560 => ParsecT s Context m (Filter_Bool Forall_Filter_Posting_Decimal)
561 filter_posting =
562 Data.Foldable.foldr Filter.And Filter.Any <$>
563 do R.many $
564 R.spaces
565 >> R.lookAhead R.anyToken
566 >> filter_bool filter_posting_terms
567
568 filter_posting_terms
569 :: Stream s m Char
570 => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_Posting_Decimal))]
571 filter_posting_terms =
572 [ jump [ "a", "amount" ] filter_amount_operator $ do
573 f <- filter_amount Filter_Polarized_Sum
574 return $
575 Bool $ Forall_Filter_Posting_Decimal $
576 Filter.Filter_Posting_Amount $
577 get_Forall_Filter_Amount_Decimal f
578 , jump [ "[]" ] (return ()) $ do
579 return $
580 Bool $ Forall_Filter_Posting_Decimal $
581 Filter_Posting_Type $
582 Filter_Posting_Type_Exact Posting_Type_Virtual
583 , return $ do
584 f <- filter_account
585 return $
586 Bool $ Forall_Filter_Posting_Decimal $
587 Filter_Posting_Account $
588 get_Forall_Filter_Account <$> f
589 ]
590
591 -- * Read 'Filter_Transaction'
592
593 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
594 newtype Forall_Filter_Transaction_Decimal
595 = Forall_Filter_Transaction_Decimal
596 { get_Forall_Filter_Transaction_Decimal ::
597 forall txn.
598 ( Transaction txn
599 , Amount_Quantity (Posting.Posting_Amount (Transaction_Posting txn)) ~ Filter.Amount.Quantity
600 ) => Filter_Transaction txn
601 }
602
603 filter_transaction ::
604 ( Stream s (R.Error_State Error m) Char
605 , Monad m
606 ) => ParsecT s Context (R.Error_State Error m)
607 (Filter_Bool Forall_Filter_Transaction_Decimal)
608 filter_transaction =
609 {-glue_posting . -}Data.Foldable.foldr Filter.And Filter.Any <$>
610 do R.many $
611 R.spaces
612 >> R.lookAhead R.anyToken
613 >> filter_bool filter_transaction_terms
614 {-
615 where
616 glue_posting
617 :: Filter_Bool Forall_Filter_Transaction_Decimal
618 -> Filter_Bool Forall_Filter_Transaction_Decimal
619 glue_posting fb =
620 case fb of
621 Any -> Any
622 Bool p -> Bool p
623 (Or b0 b1) -> Or (glue_posting b0) (glue_posting b1)
624 (Not b) ->
625 case glue_posting b of
626 Bool f ->
627 Bool $ Forall_Filter_Transaction_Decimal $
628 case get_Forall_Filter_Transaction_Decimal f of
629 Filter_Transaction_Posting p -> Filter_Transaction_Posting (Not p)
630 x -> x
631 g -> Not g
632 (And b0 b1) ->
633 case (glue_posting b0, glue_posting b1) of
634 (g0@(Bool (Forall_Filter_Transaction_Decimal f0)), g1@(Bool (Forall_Filter_Transaction_Decimal f1))) ->
635 Bool $ Forall_Filter_Transaction_Decimal $
636 case (f0, f1) of
637 (Filter_Transaction_Posting p0, Filter_Transaction_Posting p1) ->
638 Filter_Transaction_Posting (And p0 p1)
639 (x, y) -> y
640 (g0@(Bool f0), g1@(Bool f1)) ->
641 Bool $ Forall_Filter_Transaction_Decimal $
642 case get_Forall_Filter_Transaction_Decimal f0 of
643 Filter_Transaction_Posting p0 ->
644 Filter_Transaction_Posting (Not p0)
645 (x) -> x
646 {-
647 case (get_Forall_Filter_Transaction_Decimal f0, get_Forall_Filter_Transaction_Decimal f1) of
648 (Filter_Transaction_Posting p0, Filter_Transaction_Posting p1) ->
649 Filter_Transaction_Posting (And p0 p1)
650 (x, y) -> x
651 -}
652 (g0, g1) -> And g0 g1
653 {-
654 case (glue_posting b0, glue_posting b1) of
655 (g0@(Bool t0), g1@(Bool t1)) ->
656 case (get_Forall_Filter_Transaction_Decimal t0, get_Forall_Filter_Transaction_Decimal t1) of
657 (Filter_Transaction_Posting p0, Filter_Transaction_Posting p1) ->
658 Bool $ Forall_Filter_Transaction_Decimal $
659 Filter_Transaction_Posting $ Not p0
660 x -> And g0 g1
661 (Bool (Filter_Transaction_Posting p0), Any) ->
662 Bool $
663 Forall_Filter_Transaction_Decimal $
664 Filter_Transaction_Posting p0
665 (Any, Bool (Filter_Transaction_Posting p1)) ->
666 Bool $
667 Forall_Filter_Transaction_Decimal $
668 Filter_Transaction_Posting p1
669 (b0', b1') -> And b0' b1'
670 -}
671 -}
672
673 filter_transaction_terms ::
674 ( Stream s (R.Error_State Error m) Char
675 , Monad m
676 ) => [ParsecT s Context (R.Error_State Error m)
677 (ParsecT s Context (R.Error_State Error m)
678 (Filter_Bool Forall_Filter_Transaction_Decimal))]
679 filter_transaction_terms =
680 -- , jump [ "atag" ] comp_text parseFilterATag
681 -- , jump [ "code" ] comp_text parseFilterCode
682 [ jump [ "AT" ] filter_account_operator $ do
683 f <- filter_tag
684 return $
685 Bool $ Forall_Filter_Transaction_Decimal $
686 Filter_Transaction_Posting $
687 Bool $ Filter_Posting_Account $
688 Bool $ Filter_Account_Tag f
689 , jump [ "date", "d" ] filter_date_operator $ do
690 f <- filter_date
691 return $
692 Bool $ Forall_Filter_Transaction_Decimal $
693 Filter.Filter_Transaction_Date f
694 , jump [ "tag", "T" ] filter_tag_operator $ do
695 f <- filter_tag
696 return $
697 Bool $ Forall_Filter_Transaction_Decimal $
698 Filter.Filter_Transaction_Tag f
699 , jump [ "debit", "D" ] filter_amount_operator $ do
700 f <- filter_amount Filter_Polarized_Positive
701 return $
702 Bool $ Forall_Filter_Transaction_Decimal $
703 Filter_Transaction_Posting $
704 Bool $ Filter_Posting_Amount $
705 get_Forall_Filter_Amount_Decimal f
706 , jump [ "credit", "C" ] filter_amount_operator $ do
707 f <- filter_amount Filter_Polarized_Negative
708 return $
709 Bool $ Forall_Filter_Transaction_Decimal $
710 Filter_Transaction_Posting $
711 Bool $ Filter_Posting_Amount $
712 get_Forall_Filter_Amount_Decimal f
713 , jump [ "wording", "W" ] filter_wording_operator $ do
714 f <- filter_wording
715 return $
716 Bool $ Forall_Filter_Transaction_Decimal $
717 Filter.Filter_Transaction_Wording f
718 , return $ do
719 f <- filter_account
720 return $
721 Bool $ Forall_Filter_Transaction_Decimal $
722 Filter_Transaction_Posting $
723 Bool $ Filter_Posting_Account $
724 get_Forall_Filter_Account <$> f
725 {-
726 -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
727 -- , jump [ "real" ] (R.char '=') parseFilterReal
728 -- , jump [ "status" ] (R.char '=') parseFilterStatus
729 -- , jump [ "sym" ] comp_text parseFilterSym
730 -- , R.lookAhead comp_num >> return parseFilterAmount
731 -}
732 ]
733
734 -- * Read 'Filter_Balance'
735
736 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
737 newtype Forall_Filter_Balance_Decimal
738 = Forall_Filter_Balance_Decimal
739 { get_Forall_Filter_Balance_Decimal ::
740 forall txn.
741 ( Balance txn
742 , Amount_Quantity (Balance_Amount txn) ~ Filter.Amount.Quantity
743 ) => Filter_Balance txn
744 }
745
746 filter_balance
747 :: Stream s m Char
748 => ParsecT s Context m (Filter_Bool Forall_Filter_Balance_Decimal)
749 filter_balance =
750 Data.Foldable.foldr Filter.And Filter.Any <$>
751 do R.many $
752 R.spaces
753 >> R.lookAhead R.anyToken
754 >> filter_bool filter_balance_terms
755
756 filter_balance_terms
757 :: Stream s m Char
758 => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_Balance_Decimal))]
759 filter_balance_terms =
760 [ jump [ "AT" ] filter_account_operator $ do
761 f <- filter_tag
762 return $
763 Bool $ Forall_Filter_Balance_Decimal $
764 Filter_Balance_Account $
765 Bool $ Filter_Account_Tag f
766 , jump [ "RD", "debit" ] filter_amount_operator $ do
767 f <- filter_amount Filter_Polarized_Positive
768 return $
769 Bool $ Forall_Filter_Balance_Decimal $
770 Filter_Balance_Amount $
771 get_Forall_Filter_Amount_Decimal f
772 , jump [ "RC", "credit" ] filter_amount_operator $ do
773 f <- filter_amount Filter_Polarized_Negative
774 return $
775 Bool $ Forall_Filter_Balance_Decimal $
776 Filter_Balance_Amount $
777 get_Forall_Filter_Amount_Decimal f
778 , jump [ "RB", "balance" ] filter_amount_operator $ do
779 f <- filter_amount Filter_Polarized_Sum
780 return $
781 Bool $ Forall_Filter_Balance_Decimal $
782 Filter_Balance_Amount $
783 get_Forall_Filter_Amount_Decimal f
784 , return $ do
785 f <- filter_account
786 return $
787 Bool $ Forall_Filter_Balance_Decimal $
788 Filter_Balance_Account $
789 get_Forall_Filter_Account <$> f
790 ]
791
792 -- * Read 'Filter_GL'
793
794 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
795 newtype Forall_Filter_GL_Decimal
796 = Forall_Filter_GL_Decimal
797 { get_Forall_Filter_GL_Decimal ::
798 forall txn.
799 ( GL txn
800 , Amount_Quantity (GL_Amount txn) ~ Filter.Amount.Quantity
801 ) => Filter_GL txn
802 }
803
804 filter_gl
805 :: Stream s m Char
806 => ParsecT s Context m (Filter_Bool Forall_Filter_GL_Decimal)
807 filter_gl =
808 Data.Foldable.foldr Filter.And Filter.Any <$>
809 do R.many $
810 R.spaces
811 >> R.lookAhead R.anyToken
812 >> filter_bool filter_gl_terms
813
814 filter_gl_terms
815 :: Stream s m Char
816 => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_GL_Decimal))]
817 filter_gl_terms =
818 [ jump [ "AT" ] filter_account_operator $ do
819 f <- filter_tag
820 return $
821 Bool $ Forall_Filter_GL_Decimal $
822 Filter_GL_Account $
823 Bool $ Filter_Account_Tag f
824 , jump [ "D", "debit" ] filter_amount_operator $ do
825 f <- filter_amount Filter_Polarized_Positive
826 return $
827 Bool $ Forall_Filter_GL_Decimal $
828 Filter_GL_Amount $
829 get_Forall_Filter_Amount_Decimal f
830 , jump [ "C", "credit" ] filter_amount_operator $ do
831 f <- filter_amount Filter_Polarized_Negative
832 return $
833 Bool $ Forall_Filter_GL_Decimal $
834 Filter_GL_Amount $
835 get_Forall_Filter_Amount_Decimal f
836 , jump [ "B", "balance" ] filter_amount_operator $ do
837 f <- filter_amount Filter_Polarized_Sum
838 return $
839 Bool $ Forall_Filter_GL_Decimal $
840 Filter_GL_Amount $
841 get_Forall_Filter_Amount_Decimal f
842 , jump [ "RD", "running-debit" ] filter_amount_operator $ do
843 f <- filter_amount Filter_Polarized_Positive
844 return $
845 Bool $ Forall_Filter_GL_Decimal $
846 Filter_GL_Sum $
847 get_Forall_Filter_Amount_Decimal f
848 , jump [ "RC", "running-credit" ] filter_amount_operator $ do
849 f <- filter_amount Filter_Polarized_Negative
850 return $
851 Bool $ Forall_Filter_GL_Decimal $
852 Filter_GL_Sum $
853 get_Forall_Filter_Amount_Decimal f
854 , jump [ "RB", "running-balance" ] filter_amount_operator $ do
855 f <- filter_amount Filter_Polarized_Sum
856 return $
857 Bool $ Forall_Filter_GL_Decimal $
858 Filter_GL_Sum $
859 get_Forall_Filter_Amount_Decimal f
860 , return $ do
861 f <- filter_account
862 return $
863 Bool $ Forall_Filter_GL_Decimal $
864 Filter_GL_Account $
865 get_Forall_Filter_Account <$> f
866 ]