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
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))]
336 unit <- Amount.Read.unit >>= tst . Text.unpack . Unit.text
337 return $ [Filter_Amount_Section_Unit (Filter_Unit unit)]
340 filter_amount_operator
342 => ParsecT s u m String
343 filter_amount_operator =
345 [ filter_ord_operator
346 , filter_text_operator
349 -- ** Read '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)
356 (return $ read_date_pattern)
357 , filter_ord >>= \tst ->
360 let (year, _, _) = Date.gregorian $ context_date ctx
361 Date.Read.date Error_Filter_Date (Just year)
362 >>= return . Bool . Filter_Date_UTC . tst
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
373 Just <$> read_interval Error_Filter_Date_Interval read2
374 n2 <- R.option Nothing $ R.try $ do
376 Just <$> read_interval Error_Filter_Date_Interval read2
377 let (year, month, dom) =
379 (Nothing, Nothing) ->
382 , Interval.unlimited )
383 (Just d1, Nothing) ->
387 (Nothing, Just _d2) -> assert False undefined
388 (Just d1, Just 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
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
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)
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
426 else Just $ Bool $ f x
429 :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
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
435 [ R.string ".." >> return Interval.Unlimited_low
436 , Interval.Limited <$> read_digits
439 [ when (l /= Interval.Unlimited_low)
440 (R.string ".." >> return ()) >> do
442 [ Interval.Limited <$> read_digits
443 , return Interval.Unlimited_high
445 case (Interval.<=..<=) l h of
446 Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
450 Interval.Limited _ -> Interval.point l
451 _ -> Interval.unlimited
456 => ParsecT s u m String
457 filter_date_operator =
460 -- ** Read 'Filter_Tag'
466 => ParsecT s u m Filter_Tag
468 make_filter_text <- filter_text
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)
477 filter_tag_name_end =
479 [ filter_text_operator >> return ()
480 , R.space_horizontal >> return ()
485 => ParsecT s u m Filter_Tag
486 filter_tag_value = do
487 make_filter_text <- filter_text
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)
496 filter_tag_value_end =
498 [ R.space_horizontal >> return ()
504 => ParsecT s u m (Filter_Bool Filter_Tag)
508 [ R.lookAhead (R.try $ filter_tag_operator)
509 >> And (Bool n) . Bool <$> filter_tag_value
515 => ParsecT s u m String
516 filter_tag_operator =
519 -- ** Read 'Filter_Posting'
521 :: (Stream s m Char, Filter.Posting t)
522 => ParsecT s Context m (Filter_Bool (Filter_Posting t))
524 Data.Foldable.foldr Filter.And Filter.Any <$>
527 >> R.lookAhead R.anyToken
528 >> filter_bool 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 =
535 ( Filter.Filter_Posting_Account
539 -- ** Read '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))
545 Data.Foldable.foldr Filter.And Filter.Any <$>
548 >> R.lookAhead R.anyToken
549 >> filter_bool filter_transaction_terms
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
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
574 ( Filter.Filter_Transaction_Posting
575 . Filter.Filter_Posting_Account
579 -- ** Read 'Filter_Balance'
581 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
582 => ParsecT s Context m (Filter_Bool (Filter_Balance t))
584 Data.Foldable.foldr Filter.And Filter.Any <$>
587 >> R.lookAhead R.anyToken
588 >> filter_bool 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
597 , jump [ "C" ] filter_amount_operator
598 ( Filter.Filter_Balance_Negative
600 , jump [ "B", "" ] filter_amount_operator
601 ( Filter.Filter_Balance_Amount
604 ( Filter.Filter_Balance_Account
608 -- ** Read 'Filter_GL'
610 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
611 => ParsecT s Context m (Filter_Bool (Filter_GL t))
613 Data.Foldable.foldr Filter.And Filter.Any <$>
616 >> R.lookAhead R.anyToken
617 >> filter_bool 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))]
623 [ jump [ "D" ] filter_amount_operator
624 ( Filter.Filter_GL_Amount_Positive
626 , jump [ "C" ] filter_amount_operator
627 ( Filter.Filter_GL_Amount_Negative
629 , jump [ "B" ] filter_amount_operator
630 ( Filter.Filter_GL_Amount_Balance
632 , jump [ "RD" ] filter_amount_operator
633 ( Filter.Filter_GL_Sum_Positive
635 , jump [ "RC" ] filter_amount_operator
636 ( Filter.Filter_GL_Sum_Negative
638 , jump [ "RB" ] filter_amount_operator
639 ( Filter.Filter_GL_Sum_Balance
642 ( Filter.Filter_GL_Account