1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module Hcompta.Filter.Read where
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
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
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 ()
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
61 { context_date :: Date
62 } deriving (Data, Eq, Show, Typeable)
67 { context_date = Date.nil
74 | Error_Filter_Date Date.Read.Error
75 | Error_Filter_Date_Interval (Integer, Integer)
81 ( Stream s (R.Error_State Error Identity) Char
84 => ParsecT s Context (R.Error_State Error Identity) (Filter_Bool t)
85 -> s -> IO (Either [R.Error Error] (Filter_Bool t))
87 context_date <- Time.getCurrentTime
89 R.runParser_with_Error t context{context_date} "" s
91 -- ** Read 'Filter_Text'
93 :: (Stream s m Char, Monad r)
94 => ParsecT s u m (String -> r Filter_Text)
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))
104 => ParsecT s u m String
105 filter_text_operator =
111 -- ** Read 'Filter_Ord'
113 :: (Stream s m Char, Ord o)
114 => ParsecT s u m (o -> Filter_Ord o)
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
126 => ParsecT s u m String
127 filter_ord_operator =
136 -- ** Read '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)))
142 [ R.char '+' >> return (return . Right . Filter_Num_Abs)
143 , return (return . Left)
146 text :: Stream s m Char => String -> ParsecT s Context m Text
151 , R.many $ R.noneOf ("() " ++ none_of)
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++')':[]))
158 -- ** Read 'Filter_Bool'
162 => [ParsecT s u m (ParsecT s u m t)]
163 -> ParsecT s u m (Filter_Bool t)
165 R.buildExpressionParser
166 filter_bool_operators
167 (filter_bool_term terms)
170 filter_bool_operators
172 => R.OperatorTable s u m (Filter.Filter_Bool t)
173 filter_bool_operators =
174 [ [ prefix "- " Filter.Not
176 , [ binary " & " Filter.And R.AssocLeft
178 , [ binary " + " Filter.Or R.AssocLeft
179 , binary " - " (\x -> Filter.And x . Filter.Not) R.AssocLeft
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)
189 => String -> ParsecT s u m ()
190 filter_bool_operator name =
193 >> R.notFollowedBy filter_bool_operator_letter
197 filter_bool_operator_letter
198 :: Stream s m Char => ParsecT s u m Char
199 filter_bool_operator_letter =
200 R.oneOf ['-', '&', '+']
204 => [ParsecT s u m (ParsecT s u m t)]
205 -> ParsecT s u m (Filter_Bool t)
206 filter_bool_term terms = do
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")
216 R.lookAhead (R.try R.anyToken)
217 >> R.notFollowedBy (R.char ')')
226 (R.spaces >> R.char '(')
227 (R.spaces >> R.char ')')
229 bool :: Stream s m Char => ParsecT s u m Bool
244 jump :: Stream s m Char
249 jump prefixes next r =
251 (map (\s -> R.string s >> return r) prefixes)
252 <* R.lookAhead (R.try next)
254 -- ** Read Account.'Account.Name'
255 account_name :: Stream s m Char => ParsecT s u m Account.Name
258 R.many1 $ R.try account_name_char
260 account_name_char :: Stream s m Char => ParsecT s u m Char
261 account_name_char = do
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
272 _ | not (Data.Char.isSpace c) -> return c
275 -- ** Read 'Filter_Account_Section'
276 filter_account_section
278 => ParsecT s u m Filter_Account_Section
279 filter_account_section = do
282 <* R.lookAhead account_section_end
283 >> return Filter_Account_Section_Any
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
294 account_section_end =
296 [ R.char account_section_sep >> return ()
297 , R.space_horizontal >> return ()
301 -- ** Read 'Filter_Account'
302 account_section_sep :: Char
303 account_section_sep = ':'
307 => ParsecT s u m Filter_Account
309 R.notFollowedBy $ R.space_horizontal
310 R.many1_separated filter_account_section $
311 R.char account_section_sep
313 filter_account_operator
315 => ParsecT s u m String
316 filter_account_operator =
319 -- ** Read 'Filter_Amount'
322 => ParsecT s u m (Filter_Amount Amount)
324 R.notFollowedBy $ R.space_horizontal
328 amt <- Amount.Read.amount
329 return $ Filter_Amount
330 (tst $ Amount.quantity amt) $
332 case Unit.text $ Amount.unit amt of
333 unit | Text.null unit -> Filter_Text_Any
334 unit -> Filter_Text_Exact unit)
337 unit <- Amount.Read.unit >>= tst . Text.unpack . Unit.text
338 return $ Filter_Amount (Filter_Ord_Any) (Filter_Unit unit)
341 filter_amount_operator
343 => ParsecT s u m String
344 filter_amount_operator =
346 [ filter_ord_operator
347 , filter_text_operator
350 -- ** Read '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)
357 (return $ read_date_pattern)
358 , filter_ord >>= \tst ->
361 let (year, _, _) = Date.gregorian $ context_date ctx
362 Date.Read.date Error_Filter_Date (Just year)
363 >>= return . Bool . Filter_Date_UTC . tst
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
374 Just <$> read_interval Error_Filter_Date_Interval read2
375 n2 <- R.option Nothing $ R.try $ do
377 Just <$> read_interval Error_Filter_Date_Interval read2
378 let (year, month, dom) =
380 (Nothing, Nothing) ->
383 , Interval.unlimited )
384 (Just d1, Nothing) ->
388 (Nothing, Just _d2) -> assert False undefined
389 (Just d1, Just 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
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
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)
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
427 else Just $ Bool $ f x
430 :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
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
436 [ R.string ".." >> return Interval.Unlimited_low
437 , Interval.Limited <$> read_digits
440 [ when (l /= Interval.Unlimited_low)
441 (R.string ".." >> return ()) >> do
443 [ Interval.Limited <$> read_digits
444 , return Interval.Unlimited_high
446 case (Interval.<=..<=) l h of
447 Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
451 Interval.Limited _ -> Interval.point l
452 _ -> Interval.unlimited
457 => ParsecT s u m String
458 filter_date_operator =
461 -- ** Read 'Filter_Tag'
467 => ParsecT s u m Filter_Tag
469 make_filter_text <- filter_text
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)
478 filter_tag_name_end =
480 [ filter_text_operator >> return ()
481 , R.space_horizontal >> return ()
486 => ParsecT s u m Filter_Tag
487 filter_tag_value = do
488 make_filter_text <- filter_text
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)
497 filter_tag_value_end =
499 [ R.space_horizontal >> return ()
505 => ParsecT s u m (Filter_Bool Filter_Tag)
509 [ R.lookAhead (R.try $ filter_tag_operator)
510 >> And (Bool n) . Bool <$> filter_tag_value
516 => ParsecT s u m String
517 filter_tag_operator =
520 -- ** Read 'Filter_Posting'
522 :: (Stream s m Char, Filter.Posting t)
523 => ParsecT s Context m (Filter_Bool (Filter_Posting t))
525 Data.Foldable.foldr Filter.And Filter.Any <$>
528 >> R.lookAhead R.anyToken
529 >> filter_bool 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 =
536 ( Filter.Filter_Posting_Account
540 -- ** Read '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))
546 Data.Foldable.foldr Filter.And Filter.Any <$>
549 >> R.lookAhead R.anyToken
550 >> filter_bool filter_transaction_terms
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
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
575 ( Filter.Filter_Transaction_Posting
576 . Filter.Filter_Posting_Account
580 -- ** Read 'Filter_Balance'
582 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
583 => ParsecT s Context m (Filter_Bool (Filter_Balance t))
585 Data.Foldable.foldr Filter.And Filter.Any <$>
588 >> R.lookAhead R.anyToken
589 >> filter_bool 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
598 , jump [ "C" ] filter_amount_operator
599 ( Filter.Filter_Balance_Negative
601 , jump [ "B", "" ] filter_amount_operator
602 ( Filter.Filter_Balance_Amount
605 ( Filter.Filter_Balance_Account
609 -- ** Read 'Filter_GL'
611 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
612 => ParsecT s Context m (Filter_Bool (Filter_GL t))
614 Data.Foldable.foldr Filter.And Filter.Any <$>
617 >> R.lookAhead R.anyToken
618 >> filter_bool 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))]
624 [ jump [ "D" ] filter_amount_operator
625 ( Filter.Filter_GL_Amount_Positive
627 , jump [ "C" ] filter_amount_operator
628 ( Filter.Filter_GL_Amount_Negative
630 , jump [ "B" ] filter_amount_operator
631 ( Filter.Filter_GL_Amount_Balance
633 , jump [ "RD" ] filter_amount_operator
634 ( Filter.Filter_GL_Sum_Positive
636 , jump [ "RC" ] filter_amount_operator
637 ( Filter.Filter_GL_Sum_Negative
639 , jump [ "RB" ] filter_amount_operator
640 ( Filter.Filter_GL_Sum_Balance
643 ( Filter.Filter_GL_Account