]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Filter/Read.hs
Renommage : Filter.Test_* -> Filter.Filter_*.
[comptalang.git] / lib / Hcompta / Filter / Read.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module Hcompta.Filter.Read where
7
8 import Prelude hiding (filter)
9 -- import Control.Applicative ((<$>), (<*))
10 import Control.Exception (assert)
11 import Control.Monad (liftM, join, when)
12 -- import Control.Monad.Trans.Except (ExceptT(..), throwE)
13 import qualified Data.Char
14 import Data.Data
15 import qualified Data.Foldable
16 import Data.Functor.Identity (Identity)
17 import Data.Maybe (catMaybes)
18 import qualified Data.Time.Clock as Time
19 import qualified Text.Parsec.Expr as R
20 import qualified Text.Parsec as R hiding
21 ( char
22 , anyChar
23 , crlf
24 , newline
25 , noneOf
26 , oneOf
27 , satisfy
28 , space
29 , spaces
30 , string
31 )
32 -- import qualified Text.Parsec.Expr as R
33 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
34 import Data.String (fromString)
35 import qualified Data.Text as Text
36 import Data.Text (Text)
37 import Data.Typeable ()
38
39 import Hcompta.Lib.Interval (Interval)
40 import qualified Hcompta.Lib.Interval as Interval
41 import qualified Hcompta.Lib.Regex as Regex
42 -- import Hcompta.Lib.Regex (Regex)
43 import qualified Hcompta.Account as Account
44 import qualified Hcompta.Amount as Amount
45 import Hcompta.Amount (Amount)
46 import qualified Hcompta.Amount.Read as Amount.Read
47 import qualified Hcompta.Amount.Unit as Unit
48 import qualified Hcompta.Date as Date
49 import Hcompta.Date (Date)
50 import qualified Hcompta.Date.Read as Date.Read
51 import qualified Hcompta.Filter as Filter
52 import Hcompta.Filter hiding (Amount)
53 import qualified Hcompta.Lib.Parsec as R
54
55 -- * Parsers' types
56
57 -- ** Type 'Context'
58
59 data Context
60 = Context
61 { context_date :: Date
62 } deriving (Data, Eq, Show, Typeable)
63
64 context :: Context
65 context =
66 Context
67 { context_date = Date.nil
68 }
69
70 -- ** Type 'Error'
71
72 data Error
73 = Error_Unknown
74 | Error_Filter_Date Date.Read.Error
75 | Error_Filter_Date_Interval (Integer, Integer)
76 deriving (Show)
77
78 -- * Read
79
80 read ::
81 ( Stream s (R.Error_State Error Identity) Char
82 , Show t
83 )
84 => ParsecT s Context (R.Error_State Error Identity) (Filter_Bool t)
85 -> s -> IO (Either [R.Error Error] (Filter_Bool t))
86 read t s = do
87 context_date <- Time.getCurrentTime
88 return $
89 R.runParser_with_Error t context{context_date} "" s
90
91 -- ** Read 'Filter_Text'
92 filter_text
93 :: (Stream s m Char, Monad r)
94 => ParsecT s u m (String -> r Filter_Text)
95 filter_text =
96 R.choice_try
97 [ R.char '~' >> return (\s -> Regex.of_StringM s >>= (return . Filter_Text_Regex))
98 , R.char '=' >> return (\s -> return (Filter_Text_Exact $ Text.pack s))
99 , return (\s -> return (Filter_Text_Exact $ Text.pack s))
100 ]
101
102 filter_text_operator
103 :: Stream s m Char
104 => ParsecT s u m String
105 filter_text_operator =
106 R.choice_try
107 [ R.string "="
108 , R.string "~"
109 ]
110
111 -- ** Read 'Filter_Ord'
112 filter_ord
113 :: (Stream s m Char, Ord o)
114 => ParsecT s u m (o -> Filter_Ord o)
115 filter_ord =
116 R.choice_try
117 [ R.string "=" >> return Filter_Ord_Eq
118 , R.string "<=" >> return Filter_Ord_Le
119 , R.string ">=" >> return Filter_Ord_Ge
120 , R.string "<" >> return Filter_Ord_Lt
121 , R.string ">" >> return Filter_Ord_Gt
122 ]
123
124 filter_ord_operator
125 :: Stream s m Char
126 => ParsecT s u m String
127 filter_ord_operator =
128 R.choice_try
129 [ R.string "="
130 , R.string "<="
131 , R.string ">="
132 , R.string "<"
133 , R.string ">"
134 ]
135
136 -- ** Read 'Filter_Num_Abs'
137 filter_num_abs
138 :: (Stream s m Char, Num n)
139 => ParsecT s u m (Filter_Ord n -> m (Either (Filter_Ord n) (Filter_Num_Abs n)))
140 filter_num_abs =
141 R.choice_try
142 [ R.char '+' >> return (return . Right . Filter_Num_Abs)
143 , return (return . Left)
144 ]
145
146 text :: Stream s m Char => String -> ParsecT s Context m Text
147 text none_of =
148 fromString <$>
149 R.choice_try
150 [ borders inside
151 , R.many $ R.noneOf ("() " ++ none_of)
152 ]
153 where
154 borders = R.between (R.char '(') (R.char ')')
155 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
156 preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
157
158 -- ** Read 'Filter_Bool'
159
160 filter_bool
161 :: (Stream s m Char)
162 => [ParsecT s u m (ParsecT s u m t)]
163 -> ParsecT s u m (Filter_Bool t)
164 filter_bool terms =
165 R.buildExpressionParser
166 filter_bool_operators
167 (filter_bool_term terms)
168 <?> "filter_bool"
169
170 filter_bool_operators
171 :: Stream s m Char
172 => R.OperatorTable s u m (Filter.Filter_Bool t)
173 filter_bool_operators =
174 [ [ prefix "- " Filter.Not
175 ]
176 , [ binary " & " Filter.And R.AssocLeft
177 ]
178 , [ binary " + " Filter.Or R.AssocLeft
179 , binary " - " (\x -> Filter.And x . Filter.Not) R.AssocLeft
180 ]
181 ]
182 where
183 binary name fun assoc = R.Infix (filter_bool_operator name >> return fun) assoc
184 prefix name fun = R.Prefix (filter_bool_operator name >> return fun)
185 -- postfix name fun = Text.Parsec.Expr.Postfix (filter_bool_operator name >> return fun)
186
187 filter_bool_operator
188 :: Stream s m Char
189 => String -> ParsecT s u m ()
190 filter_bool_operator name =
191 R.try $
192 (R.string name
193 >> R.notFollowedBy filter_bool_operator_letter
194 -- <* R.spaces
195 <?> name)
196
197 filter_bool_operator_letter
198 :: Stream s m Char => ParsecT s u m Char
199 filter_bool_operator_letter =
200 R.oneOf ['-', '&', '+']
201
202 filter_bool_term
203 :: Stream s m Char
204 => [ParsecT s u m (ParsecT s u m t)]
205 -> ParsecT s u m (Filter_Bool t)
206 filter_bool_term terms = do
207 join (R.choice_try
208 ( (R.lookAhead (R.try (R.spaces >> R.char '('))
209 >> (return $ parens $
210 Data.Foldable.foldr Filter.And Filter.Any <$>
211 R.many (R.try (R.spaces >> expr)) ))
212 : map ((Filter.Bool <$>) <$>) terms
213 ) <* R.spaces <?> "boolean-expression")
214 where
215 expr =
216 R.lookAhead (R.try R.anyToken)
217 >> R.notFollowedBy (R.char ')')
218 >> filter_bool terms
219
220 parens
221 :: Stream s m Char
222 => ParsecT s u m a
223 -> ParsecT s u m a
224 parens =
225 R.between
226 (R.spaces >> R.char '(')
227 (R.spaces >> R.char ')')
228
229 bool :: Stream s m Char => ParsecT s u m Bool
230 bool = do
231 R.choice_try
232 [ R.choice_try
233 [ R.string "1"
234 , R.string "true"
235 , R.string "t"
236 ] >> return True
237 , R.choice_try
238 [ R.string "0"
239 , R.string "false"
240 , R.string "f"
241 ] >> return False
242 ]
243
244 jump :: Stream s m Char
245 => [String]
246 -> ParsecT s u m b
247 -> a
248 -> ParsecT s u m a
249 jump prefixes next r =
250 R.choice_try
251 (map (\s -> R.string s >> return r) prefixes)
252 <* R.lookAhead (R.try next)
253
254 -- ** Read Account.'Account.Name'
255 account_name :: Stream s m Char => ParsecT s u m Account.Name
256 account_name = do
257 fromString <$> do
258 R.many1 $ R.try account_name_char
259 where
260 account_name_char :: Stream s m Char => ParsecT s u m Char
261 account_name_char = do
262 c <- R.anyChar
263 case c of
264 -- _ | c == comment_begin -> R.parserZero
265 -- _ | c == account_section_sep -> R.parserZero
266 _ | R.is_space_horizontal c -> do
267 _ <- R.notFollowedBy $ R.space_horizontal
268 return c <* (R.lookAhead $ R.try $
269 ( R.try (R.char account_section_sep)
270 <|> account_name_char
271 ))
272 _ | not (Data.Char.isSpace c) -> return c
273 _ -> R.parserZero
274
275 -- ** Read 'Filter_Account_Section'
276 filter_account_section
277 :: (Stream s m Char)
278 => ParsecT s u m Filter_Account_Section
279 filter_account_section = do
280 R.choice_try
281 [ R.char '*'
282 <* R.lookAhead account_section_end
283 >> return Filter_Account_Section_Any
284 , R.char '~'
285 >> R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
286 >>= (liftM (Filter_Account_Section_Text . Filter_Text_Regex) . Regex.of_StringM)
287 , R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
288 >>= (liftM (Filter_Account_Section_Text . Filter_Text_Exact) . return . Text.pack)
289 , R.lookAhead account_section_end
290 >> R.many (R.try (R.char account_section_sep >> R.lookAhead (R.try account_section_end)))
291 >> return Filter_Account_Section_Many
292 ]
293 where
294 account_section_end =
295 R.choice_try
296 [ R.char account_section_sep >> return ()
297 , R.space_horizontal >> return ()
298 , R.eof
299 ]
300
301 -- ** Read 'Filter_Account'
302 account_section_sep :: Char
303 account_section_sep = ':'
304
305 filter_account
306 :: Stream s m Char
307 => ParsecT s u m Filter_Account
308 filter_account = do
309 R.notFollowedBy $ R.space_horizontal
310 R.many1_separated filter_account_section $
311 R.char account_section_sep
312
313 filter_account_operator
314 :: Stream s m Char
315 => ParsecT s u m String
316 filter_account_operator =
317 filter_text_operator
318
319 -- ** Read 'Filter_Amount'
320 filter_amount
321 :: Stream s m Char
322 => ParsecT s u m (Filter_Amount Amount)
323 filter_amount = do
324 R.notFollowedBy $ R.space_horizontal
325 R.choice_try
326 [ filter_ord
327 >>= \tst -> do
328 amt <- Amount.Read.amount
329 return $ Filter_Amount
330 (tst $ Amount.quantity amt) $
331 (Filter_Unit $
332 case Unit.text $ Amount.unit amt of
333 unit | Text.null unit -> Filter_Text_Any
334 unit -> Filter_Text_Exact unit)
335 , filter_text
336 >>= \tst -> do
337 unit <- Amount.Read.unit >>= tst . Text.unpack . Unit.text
338 return $ Filter_Amount (Filter_Ord_Any) (Filter_Unit unit)
339 ]
340
341 filter_amount_operator
342 :: Stream s m Char
343 => ParsecT s u m String
344 filter_amount_operator =
345 R.choice_try
346 [ filter_ord_operator
347 , filter_text_operator
348 ]
349
350 -- ** Read 'Filter_Date'
351 filter_date
352 :: (Stream s (R.Error_State Error m) Char, Monad m)
353 => ParsecT s Context (R.Error_State Error m) (Filter_Bool Filter_Date)
354 filter_date = do
355 join $ R.choice_try
356 [ R.char '=' >>
357 (return $ read_date_pattern)
358 , filter_ord >>= \tst ->
359 return $ do
360 ctx <- R.getState
361 let (year, _, _) = Date.gregorian $ context_date ctx
362 Date.Read.date Error_Filter_Date (Just year)
363 >>= return . Bool . Filter_Date_UTC . tst
364 ]
365 where
366 read_date_pattern
367 :: (Stream s (R.Error_State Error m) Char, Monad m)
368 => ParsecT s u (R.Error_State Error m) (Filter_Bool Filter_Date)
369 read_date_pattern = (do
370 let read2 = of_digits <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
371 n0 <- read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
372 n1 <- R.option Nothing $ R.try $ do
373 _ <- R.char '/'
374 Just <$> read_interval Error_Filter_Date_Interval read2
375 n2 <- R.option Nothing $ R.try $ do
376 _ <- R.char '/'
377 Just <$> read_interval Error_Filter_Date_Interval read2
378 let (year, month, dom) =
379 case (n1, n2) of
380 (Nothing, Nothing) ->
381 ( Interval.unlimited
382 , n0
383 , Interval.unlimited )
384 (Just d1, Nothing) ->
385 ( Interval.unlimited
386 , n0
387 , d1 )
388 (Nothing, Just _d2) -> assert False undefined
389 (Just d1, Just d2) ->
390 ( n0
391 , d1
392 , d2 )
393 (hour, minute, second) <-
394 R.option (Interval.unlimited, Interval.unlimited, Interval.unlimited) $ R.try $ do
395 R.skipMany1 $ R.space_horizontal
396 hour <- read_interval Error_Filter_Date_Interval read2
397 sep <- Date.Read.hour_separator
398 minute <- read_interval Error_Filter_Date_Interval read2
399 second <- R.option Interval.unlimited $ R.try $ do
400 _ <- R.char sep
401 read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
402 -- tz <- R.option Time.utc $ R.try $ do
403 -- R.skipMany $ R.space_horizontal
404 -- Date.Read.time_zone
405 return
406 ( hour
407 , minute
408 , second
409 )
410 return $
411 foldr And Any $
412 catMaybes $
413 [ just_when_limited (Filter_Date_Year . Filter_Interval_In) year
414 , just_when_limited (Filter_Date_Month . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month)
415 , just_when_limited (Filter_Date_DoM . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom)
416 , just_when_limited (Filter_Date_Hour . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour)
417 , just_when_limited (Filter_Date_Minute . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute)
418 , just_when_limited (Filter_Date_Second . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) second)
419 ]
420 ) <?> "date-filter"
421 where
422 of_digits :: Num n => [Char] -> n
423 of_digits = fromInteger . R.integer_of_digits 10
424 just_when_limited f x =
425 if x == Interval.unlimited
426 then Nothing
427 else Just $ Bool $ f x
428
429 read_interval
430 :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
431 => ((x, x) -> e)
432 -> ParsecT s u (R.Error_State e m) x
433 -> ParsecT s u (R.Error_State e m) (Interval (Interval.Unlimitable x))
434 read_interval err read_digits = do
435 l <- R.choice_try
436 [ R.string ".." >> return Interval.Unlimited_low
437 , Interval.Limited <$> read_digits
438 ]
439 R.choice_try
440 [ when (l /= Interval.Unlimited_low)
441 (R.string ".." >> return ()) >> do
442 h <- R.choice_try
443 [ Interval.Limited <$> read_digits
444 , return Interval.Unlimited_high
445 ]
446 case (Interval.<=..<=) l h of
447 Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
448 Just i -> return i
449 , return $
450 case l of
451 Interval.Limited _ -> Interval.point l
452 _ -> Interval.unlimited
453 ]
454
455 filter_date_operator
456 :: Stream s m Char
457 => ParsecT s u m String
458 filter_date_operator =
459 filter_ord_operator
460
461 -- ** Read 'Filter_Tag'
462 tag_name_sep :: Char
463 tag_name_sep = ':'
464
465 filter_tag_name
466 :: Stream s m Char
467 => ParsecT s u m Filter_Tag
468 filter_tag_name = do
469 make_filter_text <- filter_text
470 R.choice_try
471 [ R.char '*'
472 <* R.lookAhead filter_tag_name_end
473 >> return (Filter_Tag_Name Filter_Text_Any)
474 , R.many1 (R.notFollowedBy (R.try filter_tag_name_end) >> R.anyChar)
475 >>= (liftM Filter_Tag_Name . make_filter_text)
476 ]
477 where
478 filter_tag_name_end =
479 R.choice_try
480 [ filter_text_operator >> return ()
481 , R.space_horizontal >> return ()
482 , R.eof
483 ]
484 filter_tag_value
485 :: Stream s m Char
486 => ParsecT s u m Filter_Tag
487 filter_tag_value = do
488 make_filter_text <- filter_text
489 R.choice_try
490 [ R.char '*'
491 <* R.lookAhead filter_tag_value_end
492 >> return (Filter_Tag_Value Filter_Text_Any)
493 , R.many1 (R.notFollowedBy (R.try filter_tag_value_end) >> R.anyChar)
494 >>= (liftM Filter_Tag_Value . make_filter_text)
495 ]
496 where
497 filter_tag_value_end =
498 R.choice_try
499 [ R.space_horizontal >> return ()
500 , R.eof
501 ]
502
503 filter_tag
504 :: Stream s m Char
505 => ParsecT s u m (Filter_Bool Filter_Tag)
506 filter_tag = do
507 n <- filter_tag_name
508 R.choice_try
509 [ R.lookAhead (R.try $ filter_tag_operator)
510 >> And (Bool n) . Bool <$> filter_tag_value
511 , return $ Bool n
512 ]
513
514 filter_tag_operator
515 :: Stream s m Char
516 => ParsecT s u m String
517 filter_tag_operator =
518 filter_text_operator
519
520 -- ** Read 'Filter_Posting'
521 filter_posting
522 :: (Stream s m Char, Filter.Posting t)
523 => ParsecT s Context m (Filter_Bool (Filter_Posting t))
524 filter_posting =
525 Data.Foldable.foldr Filter.And Filter.Any <$>
526 do R.many $
527 R.spaces
528 >> R.lookAhead R.anyToken
529 >> filter_bool filter_posting_terms
530
531 filter_posting_terms
532 :: (Stream s m Char, Filter.Posting t)
533 => [ParsecT s Context m (ParsecT s Context m (Filter_Posting t))]
534 filter_posting_terms =
535 [ return
536 ( Filter.Filter_Posting_Account
537 <$> filter_account )
538 ]
539
540 -- ** Read 'Filter_Transaction'
541 filter_transaction
542 :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t
543 , Posting_Amount (Transaction_Posting t) ~ Amount)
544 => ParsecT s Context (R.Error_State Error m) (Filter_Bool (Filter_Transaction t))
545 filter_transaction =
546 Data.Foldable.foldr Filter.And Filter.Any <$>
547 do R.many $
548 R.spaces
549 >> R.lookAhead R.anyToken
550 >> filter_bool filter_transaction_terms
551
552 filter_transaction_terms
553 :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m
554 , Posting_Amount (Transaction_Posting t) ~ Amount)
555 => [ParsecT s Context (R.Error_State Error m)
556 (ParsecT s Context (R.Error_State Error m) (Filter_Transaction t))]
557 filter_transaction_terms =
558 -- , jump [ "atag" ] comp_text parseFilterATag
559 -- , jump [ "code" ] comp_text parseFilterCode
560 [ jump [ "date" ] filter_date_operator
561 (Filter.Filter_Transaction_Date <$> filter_date)
562 , jump [ "tag" ] filter_tag_operator
563 (Filter.Filter_Transaction_Tag <$> filter_tag)
564 , jump [ "amount" ] filter_amount_operator
565 (( Filter.Filter_Transaction_Posting
566 . Filter.Filter_Posting_Amount
567 ) <$> filter_amount)
568 -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
569 -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
570 -- , jump [ "real" ] (R.char '=') parseFilterReal
571 -- , jump [ "status" ] (R.char '=') parseFilterStatus
572 -- , jump [ "sym" ] comp_text parseFilterSym
573 -- , R.lookAhead comp_num >> return parseFilterAmount
574 , return
575 ( Filter.Filter_Transaction_Posting
576 . Filter.Filter_Posting_Account
577 <$> filter_account )
578 ]
579
580 -- ** Read 'Filter_Balance'
581 filter_balance
582 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
583 => ParsecT s Context m (Filter_Bool (Filter_Balance t))
584 filter_balance =
585 Data.Foldable.foldr Filter.And Filter.Any <$>
586 do R.many $
587 R.spaces
588 >> R.lookAhead R.anyToken
589 >> filter_bool filter_balance_terms
590
591 filter_balance_terms
592 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
593 => [ParsecT s Context m (ParsecT s Context m (Filter_Balance t))]
594 filter_balance_terms =
595 [ jump [ "D" ] filter_amount_operator
596 ( Filter.Filter_Balance_Positive
597 <$> filter_amount )
598 , jump [ "C" ] filter_amount_operator
599 ( Filter.Filter_Balance_Negative
600 <$> filter_amount )
601 , jump [ "B", "" ] filter_amount_operator
602 ( Filter.Filter_Balance_Amount
603 <$> filter_amount )
604 , return
605 ( Filter.Filter_Balance_Account
606 <$> filter_account )
607 ]
608
609 -- ** Read 'Filter_GL'
610 filter_gl
611 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
612 => ParsecT s Context m (Filter_Bool (Filter_GL t))
613 filter_gl =
614 Data.Foldable.foldr Filter.And Filter.Any <$>
615 do R.many $
616 R.spaces
617 >> R.lookAhead R.anyToken
618 >> filter_bool filter_gl_terms
619
620 filter_gl_terms
621 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
622 => [ParsecT s Context m (ParsecT s Context m (Filter_GL t))]
623 filter_gl_terms =
624 [ jump [ "D" ] filter_amount_operator
625 ( Filter.Filter_GL_Amount_Positive
626 <$> filter_amount )
627 , jump [ "C" ] filter_amount_operator
628 ( Filter.Filter_GL_Amount_Negative
629 <$> filter_amount )
630 , jump [ "B" ] filter_amount_operator
631 ( Filter.Filter_GL_Amount_Balance
632 <$> filter_amount )
633 , jump [ "RD" ] filter_amount_operator
634 ( Filter.Filter_GL_Sum_Positive
635 <$> filter_amount )
636 , jump [ "RC" ] filter_amount_operator
637 ( Filter.Filter_GL_Sum_Negative
638 <$> filter_amount )
639 , jump [ "RB" ] filter_amount_operator
640 ( Filter.Filter_GL_Sum_Balance
641 <$> filter_amount )
642 , return
643 ( Filter.Filter_GL_Account
644 <$> filter_account )
645 ]