]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Model/Filter/Read.hs
Ajout : Model.Filter : Test_Amount.
[comptalang.git] / lib / Hcompta / Model / Filter / Read.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module Hcompta.Model.Filter.Read where
7
8 import Prelude hiding (filter)
9 import Control.Applicative ((<$>), (<*))
10 import Control.Exception (assert)
11 import Control.Monad (liftM, join)
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 qualified Hcompta.Lib.Regex as Regex
40 -- import Hcompta.Lib.Regex (Regex)
41 import qualified Hcompta.Model.Account as Account
42 import qualified Hcompta.Model.Amount as Amount
43 import Hcompta.Model.Amount (Amount)
44 import qualified Hcompta.Model.Amount.Read as Amount.Read
45 import qualified Hcompta.Model.Amount.Unit as Unit
46 import qualified Hcompta.Model.Date as Date
47 import Hcompta.Model.Date (Date)
48 import qualified Hcompta.Model.Date.Read as Date.Read
49 import qualified Hcompta.Model.Filter as Filter
50 import Hcompta.Model.Filter hiding (Amount)
51 import qualified Hcompta.Lib.Parsec as R
52
53 -- * Parsers' types
54
55 -- ** Type 'Context'
56
57 data Context
58 = Context
59 { context_date :: Date
60 } deriving (Data, Eq, Show, Typeable)
61
62 context :: Context
63 context =
64 Context
65 { context_date = Date.nil
66 }
67
68 -- ** Type 'Error'
69
70 data Error
71 = Error_Unknown
72 | Error_Test_Date Date.Read.Error
73 deriving (Show)
74
75 -- * Read
76
77 read ::
78 ( Stream s (R.Error_State Error Identity) Char
79 , Show t
80 )
81 => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t)
82 -> s -> IO (Either [R.Error Error] (Test_Bool t))
83 read t s = do
84 context_date <- Time.getCurrentTime
85 return $
86 R.runParser_with_Error t context{context_date} "" s
87
88 -- ** Read 'Test_Text'
89 test_text
90 :: (Stream s m Char, Monad r)
91 => ParsecT s u m (String -> r Test_Text)
92 test_text =
93 R.choice_try
94 [ R.char '~' >> return (\s -> Regex.of_StringM s >>= (return . Test_Text_Regex))
95 , R.char '=' >> return (\s -> return (Test_Text_Exact $ Text.pack s))
96 , return (\s -> return (Test_Text_Exact $ Text.pack s))
97 ]
98
99 test_text_operator
100 :: Stream s m Char
101 => ParsecT s u m String
102 test_text_operator =
103 R.choice_try
104 [ R.string "="
105 , R.string "~"
106 ]
107
108 -- ** Read 'Test_Ord'
109 test_ord
110 :: (Stream s m Char, Ord o)
111 => ParsecT s u m (o -> Test_Ord o)
112 test_ord =
113 R.choice_try
114 [ R.string "=" >> return Test_Ord_Eq
115 , R.string "<=" >> return Test_Ord_Le
116 , R.string ">=" >> return Test_Ord_Ge
117 , R.string "<" >> return Test_Ord_Lt
118 , R.string ">" >> return Test_Ord_Gt
119 ]
120
121 test_ord_operator
122 :: Stream s m Char
123 => ParsecT s u m String
124 test_ord_operator =
125 R.choice_try
126 [ R.string "="
127 , R.string "<="
128 , R.string ">="
129 , R.string "<"
130 , R.string ">"
131 ]
132
133 -- ** Read 'Test_Num_Abs'
134 test_num_abs
135 :: (Stream s m Char, Num n)
136 => ParsecT s u m (Test_Ord n -> m (Either (Test_Ord n) (Test_Num_Abs n)))
137 test_num_abs =
138 R.choice_try
139 [ R.char '+' >> return (return . Right . Test_Num_Abs)
140 , return (return . Left)
141 ]
142
143 text :: Stream s m Char => String -> ParsecT s Context m Text
144 text none_of =
145 fromString <$>
146 R.choice_try
147 [ borders inside
148 , R.many $ R.noneOf ("() " ++ none_of)
149 ]
150 where
151 borders = R.between (R.char '(') (R.char ')')
152 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
153 preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
154
155 -- ** Read 'Test_Bool'
156
157 test_bool
158 :: (Stream s m Char)
159 => [ParsecT s u m (ParsecT s u m t)]
160 -> ParsecT s u m (Test_Bool t)
161 test_bool terms =
162 R.buildExpressionParser
163 test_bool_operators
164 (test_bool_term terms)
165 <?> "test_bool"
166
167 test_bool_operators
168 :: Stream s m Char
169 => R.OperatorTable s u m (Filter.Test_Bool t)
170 test_bool_operators =
171 [ [ prefix "- " Filter.Not
172 ]
173 , [ binary " & " Filter.And R.AssocLeft
174 ]
175 , [ binary " + " Filter.Or R.AssocLeft
176 , binary " - " (\x -> Filter.And x . Filter.Not) R.AssocLeft
177 ]
178 ]
179 where
180 binary name fun assoc = R.Infix (test_bool_operator name >> return fun) assoc
181 prefix name fun = R.Prefix (test_bool_operator name >> return fun)
182 -- postfix name fun = Text.Parsec.Expr.Postfix (test_bool_operator name >> return fun)
183
184 test_bool_operator
185 :: Stream s m Char
186 => String -> ParsecT s u m ()
187 test_bool_operator name =
188 R.try $
189 (R.string name
190 >> R.notFollowedBy test_bool_operator_letter
191 -- <* R.spaces
192 <?> name)
193
194 test_bool_operator_letter
195 :: Stream s m Char => ParsecT s u m Char
196 test_bool_operator_letter =
197 R.oneOf ['-', '&', '+']
198
199 test_bool_term
200 :: Stream s m Char
201 => [ParsecT s u m (ParsecT s u m t)]
202 -> ParsecT s u m (Test_Bool t)
203 test_bool_term terms = do
204 join (R.choice_try
205 ( (R.lookAhead (R.try (R.spaces >> R.char '('))
206 >> (return $ parens $
207 Data.Foldable.foldr Filter.And Filter.Any <$>
208 R.many (R.try (R.spaces >> expr)) ))
209 : map ((Filter.Bool <$>) <$>) terms
210 ) <* R.spaces <?> "boolean-expression")
211 where
212 expr =
213 R.lookAhead (R.try R.anyToken)
214 >> R.notFollowedBy (R.char ')')
215 >> test_bool terms
216
217 parens
218 :: Stream s m Char
219 => ParsecT s u m a
220 -> ParsecT s u m a
221 parens =
222 R.between
223 (R.spaces >> R.char '(')
224 (R.spaces >> R.char ')')
225
226 bool :: Stream s m Char => ParsecT s u m Bool
227 bool = do
228 R.choice_try
229 [ R.choice_try
230 [ R.string "1"
231 , R.string "true"
232 , R.string "t"
233 ] >> return True
234 , R.choice_try
235 [ R.string "0"
236 , R.string "false"
237 , R.string "f"
238 ] >> return False
239 ]
240
241 jump :: Stream s m Char
242 => [String]
243 -> ParsecT s u m b
244 -> a
245 -> ParsecT s u m a
246 jump prefixes next r =
247 R.choice_try
248 (map (\s -> R.string s >> return r) prefixes)
249 <* R.lookAhead (R.try next)
250
251 -- ** Read Account.'Account.Name'
252 account_name :: Stream s m Char => ParsecT s u m Account.Name
253 account_name = do
254 fromString <$> do
255 R.many1 $ R.try account_name_char
256 where
257 account_name_char :: Stream s m Char => ParsecT s u m Char
258 account_name_char = do
259 c <- R.anyChar
260 case c of
261 -- _ | c == comment_begin -> R.parserZero
262 -- _ | c == account_section_sep -> R.parserZero
263 _ | R.is_space_horizontal c -> do
264 _ <- R.notFollowedBy $ R.space_horizontal
265 return c <* (R.lookAhead $ R.try $
266 ( R.try (R.char account_section_sep)
267 <|> account_name_char
268 ))
269 _ | not (Data.Char.isSpace c) -> return c
270 _ -> R.parserZero
271
272 -- ** Read 'Test_Account_Section'
273 test_account_section
274 :: (Stream s m Char)
275 => (String -> ParsecT s u m Test_Text)
276 -> ParsecT s u m Test_Account_Section
277 test_account_section make_test_text = do
278 R.choice_try
279 [ R.char '*'
280 <* R.lookAhead account_section_end
281 >> return Test_Account_Section_Any
282 , R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))
283 >>= (liftM Test_Account_Section_Text . make_test_text)
284 , R.lookAhead account_section_end
285 >> R.many (R.try (R.char account_section_sep >> R.lookAhead (R.try account_section_end)))
286 >> return Test_Account_Section_Many
287 ]
288 where
289 account_section_end =
290 R.choice_try
291 [ R.char account_section_sep >> return ()
292 , R.space_horizontal >> return ()
293 , R.eof
294 ]
295
296 -- ** Read 'Test_Account'
297 account_section_sep :: Char
298 account_section_sep = ':'
299
300 test_account
301 :: Stream s m Char
302 => ParsecT s u m Test_Account
303 test_account = do
304 R.notFollowedBy $ R.space_horizontal
305 make_test_text <- test_text
306 R.many1_separated (test_account_section make_test_text) $
307 R.char account_section_sep
308
309 -- ** Read 'Test_Amount'
310 test_amount
311 :: Stream s m Char
312 => ParsecT s u m (Test_Amount Amount)
313 test_amount = do
314 R.notFollowedBy $ R.space_horizontal
315 tst <- test_ord
316 amt <- Amount.Read.amount
317 return $ Test_Amount
318 (tst $ Amount.quantity amt)
319 (Test_Unit $ Test_Text_Exact $ Unit.text $ Amount.unit amt)
320
321 test_amount_operator
322 :: Stream s m Char
323 => ParsecT s u m String
324 test_amount_operator =
325 test_ord_operator
326
327 -- ** Read 'Test_Date'
328 test_date
329 :: (Stream s (R.Error_State Error m) Char, Monad m)
330 => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date)
331 test_date = do
332 join $ R.choice_try
333 [ R.char '=' >>
334 (return $ read_date_pattern)
335 , test_ord >>= \tst ->
336 return $ do
337 ctx <- R.getState
338 let (year, _, _) = Date.gregorian $ context_date ctx
339 Date.Read.date Error_Test_Date (Just year)
340 >>= return . Bool . Test_Date_UTC . tst
341 ]
342 where
343 read_date_pattern
344 :: (Stream s (R.Error_State e m) Char, Monad m)
345 => ParsecT s u (R.Error_State e m) (Test_Bool Test_Date)
346 read_date_pattern = (do
347 let read2 = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
348 n0 <- read_range $ R.many1 R.digit
349 n1 <- R.option Nothing $ R.try $ do
350 _ <- R.char '/'
351 Just <$> read_range read2
352 n2 <- R.option Nothing $ R.try $ do
353 _ <- R.char '/'
354 Just <$> read_range read2
355 let (year, month, dom) =
356 case (n1, n2) of
357 (Nothing, Nothing) ->
358 ( test_range_all
359 , of_digits <$> n0
360 , test_range_all )
361 (Just d1, Nothing) ->
362 ( test_range_all
363 , of_digits <$> n0
364 , of_digits <$> d1 )
365 (Nothing, Just _d2) -> assert False undefined
366 (Just d1, Just d2) ->
367 ( R.integer_of_digits 10 <$> n0
368 , of_digits <$> d1
369 , of_digits <$> d2 )
370 (hour, minute, second) <-
371 R.option (test_range_all, test_range_all, test_range_all) $ R.try $ do
372 R.skipMany1 $ R.space_horizontal
373 hour <- read_range read2
374 sep <- Date.Read.hour_separator
375 minute <- read_range read2
376 second <- R.option test_range_all $ R.try $ do
377 _ <- R.char sep
378 read_range $ R.many1 R.digit
379 -- tz <- R.option Time.utc $ R.try $ do
380 -- R.skipMany $ R.space_horizontal
381 -- Date.Read.time_zone
382 return
383 ( of_digits <$> hour
384 , of_digits <$> minute
385 , of_digits <$> second
386 )
387 return $
388 foldr And Any $
389 catMaybes $
390 [ just_when_bounded Test_Date_Year year
391 , just_when_bounded Test_Date_Month month
392 , just_when_bounded Test_Date_DoM dom
393 , just_when_bounded Test_Date_Hour hour
394 , just_when_bounded Test_Date_Minute minute
395 , just_when_bounded Test_Date_Second second
396 ]
397 ) <?> "date-filter"
398 where
399 of_digits :: Num n => [Char] -> n
400 of_digits = fromInteger . R.integer_of_digits 10
401 just_when_bounded f x =
402 case x of
403 Test_Range_In Nothing Nothing -> Nothing
404 _ -> Just $ Bool $ f x
405
406 read_range :: Stream s m Char
407 => ParsecT s u m a
408 -> ParsecT s u m (Test_Range a)
409 read_range read_digits = do
410 a0 <- R.choice_try
411 [ R.char '*' >> return Nothing
412 , Just <$> read_digits
413 ]
414 R.choice_try
415 [ R.char '-' >>
416 (Test_Range_In a0 <$> R.choice_try
417 [ R.char '*' >> return Nothing
418 , Just <$> read_digits
419 ])
420 , return $ maybe test_range_all Test_Range_Eq a0
421 ]
422
423 test_date_operator
424 :: Stream s m Char
425 => ParsecT s u m String
426 test_date_operator =
427 test_ord_operator
428
429 -- ** Read 'Test_Tag'
430 tag_name_sep :: Char
431 tag_name_sep = ':'
432
433 test_tag_name
434 :: Stream s m Char
435 => ParsecT s u m Test_Tag
436 test_tag_name = do
437 make_test_text <- test_text
438 R.choice_try
439 [ R.char '*'
440 <* R.lookAhead test_tag_name_end
441 >> return (Test_Tag_Name Test_Text_Any)
442 , R.many1 (R.notFollowedBy (R.try test_tag_name_end) >> R.anyChar)
443 >>= (liftM Test_Tag_Name . make_test_text)
444 ]
445 where
446 test_tag_name_end =
447 R.choice_try
448 [ test_text_operator >> return ()
449 , R.space_horizontal >> return ()
450 , R.eof
451 ]
452 test_tag_value
453 :: Stream s m Char
454 => ParsecT s u m Test_Tag
455 test_tag_value = do
456 make_test_text <- test_text
457 R.choice_try
458 [ R.char '*'
459 <* R.lookAhead test_tag_value_end
460 >> return (Test_Tag_Value Test_Text_Any)
461 , R.many1 (R.notFollowedBy (R.try test_tag_value_end) >> R.anyChar)
462 >>= (liftM Test_Tag_Value . make_test_text)
463 ]
464 where
465 test_tag_value_end =
466 R.choice_try
467 [ R.space_horizontal >> return ()
468 , R.eof
469 ]
470
471 test_tag
472 :: Stream s m Char
473 => ParsecT s u m (Test_Bool Test_Tag)
474 test_tag = do
475 n <- test_tag_name
476 R.choice_try
477 [ R.lookAhead (R.try $ test_tag_operator)
478 >> And (Bool n) . Bool <$> test_tag_value
479 , return $ Bool n
480 ]
481
482 test_tag_operator
483 :: Stream s m Char
484 => ParsecT s u m String
485 test_tag_operator =
486 test_text_operator
487
488 -- ** Read 'Test_Posting'
489 test_posting
490 :: (Stream s m Char, Filter.Posting t)
491 => ParsecT s Context m (Test_Bool (Test_Posting t))
492 test_posting =
493 Data.Foldable.foldr Filter.And Filter.Any <$>
494 do R.many $
495 R.spaces
496 >> R.lookAhead R.anyToken
497 >> test_bool test_posting_terms
498
499 test_posting_terms
500 :: (Stream s m Char, Filter.Posting t)
501 => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
502 test_posting_terms =
503 [ return
504 ( Filter.Test_Posting_Account
505 <$> test_account )
506 ]
507
508 -- ** Read 'Test_Transaction'
509 test_transaction
510 :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t
511 , Posting_Amount (Transaction_Posting t) ~ Amount)
512 => ParsecT s Context (R.Error_State Error m) (Test_Bool (Test_Transaction t))
513 test_transaction =
514 Data.Foldable.foldr Filter.And Filter.Any <$>
515 do R.many $
516 R.spaces
517 >> R.lookAhead R.anyToken
518 >> test_bool test_transaction_terms
519
520 test_transaction_terms
521 :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m
522 , Posting_Amount (Transaction_Posting t) ~ Amount)
523 => [ParsecT s Context (R.Error_State Error m)
524 (ParsecT s Context (R.Error_State Error m) (Test_Transaction t))]
525 test_transaction_terms =
526 -- , jump [ "atag" ] comp_text parseFilterATag
527 -- , jump [ "code" ] comp_text parseFilterCode
528 [ jump [ "date" ] test_date_operator
529 (Filter.Test_Transaction_Date <$> test_date)
530 , jump [ "tag" ] test_tag_operator
531 (Filter.Test_Transaction_Tag <$> test_tag)
532 , jump [ "amount" ] test_amount_operator
533 (( Filter.Test_Transaction_Posting
534 . Filter.Test_Posting_Amount
535 ) <$> test_amount)
536 -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
537 -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
538 -- , jump [ "real" ] (R.char '=') parseFilterReal
539 -- , jump [ "status" ] (R.char '=') parseFilterStatus
540 -- , jump [ "sym" ] comp_text parseFilterSym
541 -- , R.lookAhead comp_num >> return parseFilterAmount
542 , return
543 ( Filter.Test_Transaction_Posting
544 . Filter.Test_Posting_Account
545 <$> test_account )
546 ]
547
548 -- ** Read 'Test_Balance'
549 test_balance
550 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
551 => ParsecT s Context m (Test_Bool (Test_Balance t))
552 test_balance =
553 Data.Foldable.foldr Filter.And Filter.Any <$>
554 do R.many $
555 R.spaces
556 >> R.lookAhead R.anyToken
557 >> test_bool test_balance_terms
558
559 test_balance_terms
560 :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
561 => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
562 test_balance_terms =
563 [ jump [ "amount" ] test_amount_operator
564 ( Filter.Test_Balance_Amount
565 <$> test_amount )
566 , jump [ "debit" ] test_amount_operator
567 ( Filter.Test_Balance_Positive
568 <$> test_amount )
569 , jump [ "credit" ] test_amount_operator
570 ( Filter.Test_Balance_Negative
571 <$> test_amount )
572 , return
573 ( Filter.Test_Balance_Account
574 <$> test_account )
575 ]