]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Filter/Read.hs
Ajout : Filter : simplify et context.
[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 $
330 (Filter_Amount_Section_Quantity (tst $ Amount.quantity amt))
331 : case Unit.text $ Amount.unit amt of
332 unit | Text.null unit -> []
333 unit -> [Filter_Amount_Section_Unit (Filter_Unit (Filter_Text_Exact unit))]
334 , filter_text
335 >>= \tst -> do
336 unit <- Amount.Read.unit >>= tst . Text.unpack . Unit.text
337 return $ [Filter_Amount_Section_Unit (Filter_Unit unit)]
338 ]
339
340 filter_amount_operator
341 :: Stream s m Char
342 => ParsecT s u m String
343 filter_amount_operator =
344 R.choice_try
345 [ filter_ord_operator
346 , filter_text_operator
347 ]
348
349 -- ** Read 'Filter_Date'
350 filter_date
351 :: (Stream s (R.Error_State Error m) Char, Monad m)
352 => ParsecT s Context (R.Error_State Error m) (Filter_Bool Filter_Date)
353 filter_date = do
354 join $ R.choice_try
355 [ R.char '=' >>
356 (return $ read_date_pattern)
357 , filter_ord >>= \tst ->
358 return $ do
359 ctx <- R.getState
360 let (year, _, _) = Date.gregorian $ context_date ctx
361 Date.Read.date Error_Filter_Date (Just year)
362 >>= return . Bool . Filter_Date_UTC . tst
363 ]
364 where
365 read_date_pattern
366 :: (Stream s (R.Error_State Error m) Char, Monad m)
367 => ParsecT s u (R.Error_State Error m) (Filter_Bool Filter_Date)
368 read_date_pattern = (do
369 let read2 = of_digits <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
370 n0 <- read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
371 n1 <- R.option Nothing $ R.try $ do
372 _ <- R.char '/'
373 Just <$> read_interval Error_Filter_Date_Interval read2
374 n2 <- R.option Nothing $ R.try $ do
375 _ <- R.char '/'
376 Just <$> read_interval Error_Filter_Date_Interval read2
377 let (year, month, dom) =
378 case (n1, n2) of
379 (Nothing, Nothing) ->
380 ( Interval.unlimited
381 , n0
382 , Interval.unlimited )
383 (Just d1, Nothing) ->
384 ( Interval.unlimited
385 , n0
386 , d1 )
387 (Nothing, Just _d2) -> assert False undefined
388 (Just d1, Just d2) ->
389 ( n0
390 , d1
391 , d2 )
392 (hour, minute, second) <-
393 R.option (Interval.unlimited, Interval.unlimited, Interval.unlimited) $ R.try $ do
394 R.skipMany1 $ R.space_horizontal
395 hour <- read_interval Error_Filter_Date_Interval read2
396 sep <- Date.Read.hour_separator
397 minute <- read_interval Error_Filter_Date_Interval read2
398 second <- R.option Interval.unlimited $ R.try $ do
399 _ <- R.char sep
400 read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
401 -- tz <- R.option Time.utc $ R.try $ do
402 -- R.skipMany $ R.space_horizontal
403 -- Date.Read.time_zone
404 return
405 ( hour
406 , minute
407 , second
408 )
409 return $
410 foldr And Any $
411 catMaybes $
412 [ just_when_limited (Filter_Date_Year . Filter_Interval_In) year
413 , just_when_limited (Filter_Date_Month . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month)
414 , just_when_limited (Filter_Date_DoM . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom)
415 , just_when_limited (Filter_Date_Hour . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour)
416 , just_when_limited (Filter_Date_Minute . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute)
417 , just_when_limited (Filter_Date_Second . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) second)
418 ]
419 ) <?> "date-filter"
420 where
421 of_digits :: Num n => [Char] -> n
422 of_digits = fromInteger . R.integer_of_digits 10
423 just_when_limited f x =
424 if x == Interval.unlimited
425 then Nothing
426 else Just $ Bool $ f x
427
428 read_interval
429 :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
430 => ((x, x) -> e)
431 -> ParsecT s u (R.Error_State e m) x
432 -> ParsecT s u (R.Error_State e m) (Interval (Interval.Unlimitable x))
433 read_interval err read_digits = do
434 l <- R.choice_try
435 [ R.string ".." >> return Interval.Unlimited_low
436 , Interval.Limited <$> read_digits
437 ]
438 R.choice_try
439 [ when (l /= Interval.Unlimited_low)
440 (R.string ".." >> return ()) >> do
441 h <- R.choice_try
442 [ Interval.Limited <$> read_digits
443 , return Interval.Unlimited_high
444 ]
445 case (Interval.<=..<=) l h of
446 Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
447 Just i -> return i
448 , return $
449 case l of
450 Interval.Limited _ -> Interval.point l
451 _ -> Interval.unlimited
452 ]
453
454 filter_date_operator
455 :: Stream s m Char
456 => ParsecT s u m String
457 filter_date_operator =
458 filter_ord_operator
459
460 -- ** Read 'Filter_Tag'
461 tag_name_sep :: Char
462 tag_name_sep = ':'
463
464 filter_tag_name
465 :: Stream s m Char
466 => ParsecT s u m Filter_Tag
467 filter_tag_name = do
468 make_filter_text <- filter_text
469 R.choice_try
470 [ R.char '*'
471 <* R.lookAhead filter_tag_name_end
472 >> return (Filter_Tag_Name Filter_Text_Any)
473 , R.many1 (R.notFollowedBy (R.try filter_tag_name_end) >> R.anyChar)
474 >>= (liftM Filter_Tag_Name . make_filter_text)
475 ]
476 where
477 filter_tag_name_end =
478 R.choice_try
479 [ filter_text_operator >> return ()
480 , R.space_horizontal >> return ()
481 , R.eof
482 ]
483 filter_tag_value
484 :: Stream s m Char
485 => ParsecT s u m Filter_Tag
486 filter_tag_value = do
487 make_filter_text <- filter_text
488 R.choice_try
489 [ R.char '*'
490 <* R.lookAhead filter_tag_value_end
491 >> return (Filter_Tag_Value Filter_Text_Any)
492 , R.many1 (R.notFollowedBy (R.try filter_tag_value_end) >> R.anyChar)
493 >>= (liftM Filter_Tag_Value . make_filter_text)
494 ]
495 where
496 filter_tag_value_end =
497 R.choice_try
498 [ R.space_horizontal >> return ()
499 , R.eof
500 ]
501
502 filter_tag
503 :: Stream s m Char
504 => ParsecT s u m (Filter_Bool Filter_Tag)
505 filter_tag = do
506 n <- filter_tag_name
507 R.choice_try
508 [ R.lookAhead (R.try $ filter_tag_operator)
509 >> And (Bool n) . Bool <$> filter_tag_value
510 , return $ Bool n
511 ]
512
513 filter_tag_operator
514 :: Stream s m Char
515 => ParsecT s u m String
516 filter_tag_operator =
517 filter_text_operator
518
519 -- ** Read 'Filter_Posting'
520 filter_posting
521 :: (Stream s m Char, Filter.Posting t)
522 => ParsecT s Context m (Filter_Bool (Filter_Posting t))
523 filter_posting =
524 Data.Foldable.foldr Filter.And Filter.Any <$>
525 do R.many $
526 R.spaces
527 >> R.lookAhead R.anyToken
528 >> filter_bool filter_posting_terms
529
530 filter_posting_terms
531 :: (Stream s m Char, Filter.Posting t)
532 => [ParsecT s Context m (ParsecT s Context m (Filter_Posting t))]
533 filter_posting_terms =
534 [ return
535 ( Filter.Filter_Posting_Account
536 <$> filter_account )
537 ]
538
539 -- ** Read 'Filter_Transaction'
540 filter_transaction
541 :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t
542 , Posting_Amount (Transaction_Posting t) ~ Amount)
543 => ParsecT s Context (R.Error_State Error m) (Filter_Bool (Filter_Transaction t))
544 filter_transaction =
545 Data.Foldable.foldr Filter.And Filter.Any <$>
546 do R.many $
547 R.spaces
548 >> R.lookAhead R.anyToken
549 >> filter_bool filter_transaction_terms
550
551 filter_transaction_terms
552 :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m
553 , Posting_Amount (Transaction_Posting t) ~ Amount)
554 => [ParsecT s Context (R.Error_State Error m)
555 (ParsecT s Context (R.Error_State Error m) (Filter_Transaction t))]
556 filter_transaction_terms =
557 -- , jump [ "atag" ] comp_text parseFilterATag
558 -- , jump [ "code" ] comp_text parseFilterCode
559 [ jump [ "date" ] filter_date_operator
560 (Filter.Filter_Transaction_Date <$> filter_date)
561 , jump [ "tag" ] filter_tag_operator
562 (Filter.Filter_Transaction_Tag <$> filter_tag)
563 , jump [ "amount" ] filter_amount_operator
564 (( Filter.Filter_Transaction_Posting
565 . Filter.Filter_Posting_Amount
566 ) <$> filter_amount)
567 -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
568 -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
569 -- , jump [ "real" ] (R.char '=') parseFilterReal
570 -- , jump [ "status" ] (R.char '=') parseFilterStatus
571 -- , jump [ "sym" ] comp_text parseFilterSym
572 -- , R.lookAhead comp_num >> return parseFilterAmount
573 , return
574 ( Filter.Filter_Transaction_Posting
575 . Filter.Filter_Posting_Account
576 <$> filter_account )
577 ]
578
579 -- ** Read 'Filter_Balance'
580 filter_balance
581 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
582 => ParsecT s Context m (Filter_Bool (Filter_Balance t))
583 filter_balance =
584 Data.Foldable.foldr Filter.And Filter.Any <$>
585 do R.many $
586 R.spaces
587 >> R.lookAhead R.anyToken
588 >> filter_bool filter_balance_terms
589
590 filter_balance_terms
591 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
592 => [ParsecT s Context m (ParsecT s Context m (Filter_Balance t))]
593 filter_balance_terms =
594 [ jump [ "D" ] filter_amount_operator
595 ( Filter.Filter_Balance_Positive
596 <$> filter_amount )
597 , jump [ "C" ] filter_amount_operator
598 ( Filter.Filter_Balance_Negative
599 <$> filter_amount )
600 , jump [ "B", "" ] filter_amount_operator
601 ( Filter.Filter_Balance_Amount
602 <$> filter_amount )
603 , return
604 ( Filter.Filter_Balance_Account
605 <$> filter_account )
606 ]
607
608 -- ** Read 'Filter_GL'
609 filter_gl
610 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
611 => ParsecT s Context m (Filter_Bool (Filter_GL t))
612 filter_gl =
613 Data.Foldable.foldr Filter.And Filter.Any <$>
614 do R.many $
615 R.spaces
616 >> R.lookAhead R.anyToken
617 >> filter_bool filter_gl_terms
618
619 filter_gl_terms
620 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
621 => [ParsecT s Context m (ParsecT s Context m (Filter_GL t))]
622 filter_gl_terms =
623 [ jump [ "D" ] filter_amount_operator
624 ( Filter.Filter_GL_Amount_Positive
625 <$> filter_amount )
626 , jump [ "C" ] filter_amount_operator
627 ( Filter.Filter_GL_Amount_Negative
628 <$> filter_amount )
629 , jump [ "B" ] filter_amount_operator
630 ( Filter.Filter_GL_Amount_Balance
631 <$> filter_amount )
632 , jump [ "RD" ] filter_amount_operator
633 ( Filter.Filter_GL_Sum_Positive
634 <$> filter_amount )
635 , jump [ "RC" ] filter_amount_operator
636 ( Filter.Filter_GL_Sum_Negative
637 <$> filter_amount )
638 , jump [ "RB" ] filter_amount_operator
639 ( Filter.Filter_GL_Sum_Balance
640 <$> filter_amount )
641 , return
642 ( Filter.Filter_GL_Account
643 <$> filter_account )
644 ]