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_Test_Date Date.Read.Error
75 | Error_Test_Date_Interval (Integer, Integer)
81 ( Stream s (R.Error_State Error Identity) Char
84 => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t)
85 -> s -> IO (Either [R.Error Error] (Test_Bool t))
87 context_date <- Time.getCurrentTime
89 R.runParser_with_Error t context{context_date} "" s
91 -- ** Read 'Test_Text'
93 :: (Stream s m Char, Monad r)
94 => ParsecT s u m (String -> r Test_Text)
97 [ R.char '~' >> return (\s -> Regex.of_StringM s >>= (return . Test_Text_Regex))
98 , R.char '=' >> return (\s -> return (Test_Text_Exact $ Text.pack s))
99 , return (\s -> return (Test_Text_Exact $ Text.pack s))
104 => ParsecT s u m String
111 -- ** Read 'Test_Ord'
113 :: (Stream s m Char, Ord o)
114 => ParsecT s u m (o -> Test_Ord o)
117 [ R.string "=" >> return Test_Ord_Eq
118 , R.string "<=" >> return Test_Ord_Le
119 , R.string ">=" >> return Test_Ord_Ge
120 , R.string "<" >> return Test_Ord_Lt
121 , R.string ">" >> return Test_Ord_Gt
126 => ParsecT s u m String
136 -- ** Read 'Test_Num_Abs'
138 :: (Stream s m Char, Num n)
139 => ParsecT s u m (Test_Ord n -> m (Either (Test_Ord n) (Test_Num_Abs n)))
142 [ R.char '+' >> return (return . Right . Test_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 'Test_Bool'
162 => [ParsecT s u m (ParsecT s u m t)]
163 -> ParsecT s u m (Test_Bool t)
165 R.buildExpressionParser
167 (test_bool_term terms)
172 => R.OperatorTable s u m (Filter.Test_Bool t)
173 test_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 (test_bool_operator name >> return fun) assoc
184 prefix name fun = R.Prefix (test_bool_operator name >> return fun)
185 -- postfix name fun = Text.Parsec.Expr.Postfix (test_bool_operator name >> return fun)
189 => String -> ParsecT s u m ()
190 test_bool_operator name =
193 >> R.notFollowedBy test_bool_operator_letter
197 test_bool_operator_letter
198 :: Stream s m Char => ParsecT s u m Char
199 test_bool_operator_letter =
200 R.oneOf ['-', '&', '+']
204 => [ParsecT s u m (ParsecT s u m t)]
205 -> ParsecT s u m (Test_Bool t)
206 test_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 'Test_Account_Section'
278 => ParsecT s u m Test_Account_Section
279 test_account_section = do
282 <* R.lookAhead account_section_end
283 >> return Test_Account_Section_Any
285 >> R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
286 >>= (liftM (Test_Account_Section_Text . Test_Text_Regex) . Regex.of_StringM)
287 , R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
288 >>= (liftM (Test_Account_Section_Text . Test_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 Test_Account_Section_Many
294 account_section_end =
296 [ R.char account_section_sep >> return ()
297 , R.space_horizontal >> return ()
301 -- ** Read 'Test_Account'
302 account_section_sep :: Char
303 account_section_sep = ':'
307 => ParsecT s u m Test_Account
309 R.notFollowedBy $ R.space_horizontal
310 R.many1_separated test_account_section $
311 R.char account_section_sep
313 test_account_operator
315 => ParsecT s u m String
316 test_account_operator =
319 -- ** Read 'Test_Amount'
322 => ParsecT s u m (Test_Amount Amount)
324 R.notFollowedBy $ R.space_horizontal
328 amt <- Amount.Read.amount
330 (tst $ Amount.quantity amt) $
332 case Unit.text $ Amount.unit amt of
333 unit | Text.null unit -> Test_Text_Any
334 unit -> Test_Text_Exact unit)
337 unit <- Amount.Read.unit >>= tst . Text.unpack . Unit.text
338 return $ Test_Amount (Test_Ord_Any) (Test_Unit unit)
343 => ParsecT s u m String
344 test_amount_operator =
350 -- ** Read 'Test_Date'
352 :: (Stream s (R.Error_State Error m) Char, Monad m)
353 => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date)
357 (return $ read_date_pattern)
358 , test_ord >>= \tst ->
361 let (year, _, _) = Date.gregorian $ context_date ctx
362 Date.Read.date Error_Test_Date (Just year)
363 >>= return . Bool . Test_Date_UTC . tst
367 :: (Stream s (R.Error_State Error m) Char, Monad m)
368 => ParsecT s u (R.Error_State Error m) (Test_Bool Test_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_Test_Date_Interval $ of_digits <$> R.many1 R.digit
372 n1 <- R.option Nothing $ R.try $ do
374 Just <$> read_interval Error_Test_Date_Interval read2
375 n2 <- R.option Nothing $ R.try $ do
377 Just <$> read_interval Error_Test_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_Test_Date_Interval read2
397 sep <- Date.Read.hour_separator
398 minute <- read_interval Error_Test_Date_Interval read2
399 second <- R.option Interval.unlimited $ R.try $ do
401 read_interval Error_Test_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 (Test_Date_Year . Test_Interval_In) year
414 , just_when_limited (Test_Date_Month . Test_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month)
415 , just_when_limited (Test_Date_DoM . Test_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom)
416 , just_when_limited (Test_Date_Hour . Test_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour)
417 , just_when_limited (Test_Date_Minute . Test_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute)
418 , just_when_limited (Test_Date_Second . Test_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
461 -- ** Read 'Test_Tag'
467 => ParsecT s u m Test_Tag
469 make_test_text <- test_text
472 <* R.lookAhead test_tag_name_end
473 >> return (Test_Tag_Name Test_Text_Any)
474 , R.many1 (R.notFollowedBy (R.try test_tag_name_end) >> R.anyChar)
475 >>= (liftM Test_Tag_Name . make_test_text)
480 [ test_text_operator >> return ()
481 , R.space_horizontal >> return ()
486 => ParsecT s u m Test_Tag
488 make_test_text <- test_text
491 <* R.lookAhead test_tag_value_end
492 >> return (Test_Tag_Value Test_Text_Any)
493 , R.many1 (R.notFollowedBy (R.try test_tag_value_end) >> R.anyChar)
494 >>= (liftM Test_Tag_Value . make_test_text)
499 [ R.space_horizontal >> return ()
505 => ParsecT s u m (Test_Bool Test_Tag)
509 [ R.lookAhead (R.try $ test_tag_operator)
510 >> And (Bool n) . Bool <$> test_tag_value
516 => ParsecT s u m String
520 -- ** Read 'Test_Posting'
522 :: (Stream s m Char, Filter.Posting t)
523 => ParsecT s Context m (Test_Bool (Test_Posting t))
525 Data.Foldable.foldr Filter.And Filter.Any <$>
528 >> R.lookAhead R.anyToken
529 >> test_bool test_posting_terms
532 :: (Stream s m Char, Filter.Posting t)
533 => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
536 ( Filter.Test_Posting_Account
540 -- ** Read 'Test_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) (Test_Bool (Test_Transaction t))
546 Data.Foldable.foldr Filter.And Filter.Any <$>
549 >> R.lookAhead R.anyToken
550 >> test_bool test_transaction_terms
552 test_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) (Test_Transaction t))]
557 test_transaction_terms =
558 -- , jump [ "atag" ] comp_text parseFilterATag
559 -- , jump [ "code" ] comp_text parseFilterCode
560 [ jump [ "date" ] test_date_operator
561 (Filter.Test_Transaction_Date <$> test_date)
562 , jump [ "tag" ] test_tag_operator
563 (Filter.Test_Transaction_Tag <$> test_tag)
564 , jump [ "amount" ] test_amount_operator
565 (( Filter.Test_Transaction_Posting
566 . Filter.Test_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.Test_Transaction_Posting
576 . Filter.Test_Posting_Account
580 -- ** Read 'Test_Balance'
582 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
583 => ParsecT s Context m (Test_Bool (Test_Balance t))
585 Data.Foldable.foldr Filter.And Filter.Any <$>
588 >> R.lookAhead R.anyToken
589 >> test_bool test_balance_terms
592 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
593 => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
595 [ jump [ "D" ] test_amount_operator
596 ( Filter.Test_Balance_Positive
598 , jump [ "C" ] test_amount_operator
599 ( Filter.Test_Balance_Negative
601 , jump [ "B", "" ] test_amount_operator
602 ( Filter.Test_Balance_Amount
605 ( Filter.Test_Balance_Account
611 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
612 => ParsecT s Context m (Test_Bool (Test_GL t))
614 Data.Foldable.foldr Filter.And Filter.Any <$>
617 >> R.lookAhead R.anyToken
618 >> test_bool test_gl_terms
621 :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount)
622 => [ParsecT s Context m (ParsecT s Context m (Test_GL t))]
624 [ jump [ "D" ] test_amount_operator
625 ( Filter.Test_GL_Amount_Positive
627 , jump [ "C" ] test_amount_operator
628 ( Filter.Test_GL_Amount_Negative
630 , jump [ "B" ] test_amount_operator
631 ( Filter.Test_GL_Amount_Balance
633 , jump [ "RD" ] test_amount_operator
634 ( Filter.Test_GL_Sum_Positive
636 , jump [ "RC" ] test_amount_operator
637 ( Filter.Test_GL_Sum_Negative
639 , jump [ "RB" ] test_amount_operator
640 ( Filter.Test_GL_Sum_Balance
643 ( Filter.Test_GL_Account