]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Model/Filter/Read.hs
Correction : Lib.Parsec : détection et propagation des erreurs.
[comptalang.git] / lib / Hcompta / Model / Filter / Read.hs
1 module Hcompta.Model.Filter.Read where
2
3 import Control.Monad (liftM)
4 import Control.Applicative ((<$>))
5 import Data.Maybe (isJust)
6 import qualified Text.Parsec as R
7 import qualified Text.Parsec.Expr as R
8 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
9
10 import qualified Hcompta.Model.Filter as Filter
11 import Hcompta.Model.Filter (Comp_Number(..), Comp_String(..))
12
13 -- * The 'Context' type
14
15 data Context
16 = Context
17 { context_day :: !Day
18 } deriving (Data, Eq, Show, Typeable)
19
20 -- * Comparing
21
22 comp_string :: Stream s m Char => ParsecT s u m Comp_String
23 comp_string =
24 R.choice_try
25 [ R.string "=" >> return Comp_String_Eq
26 , R.string "~" >> return Comp_String_Regexp
27 ]
28
29 comp_number :: Stream s m Char => ParsecT s u m Comp_Number
30 comp_number =
31 R.choice_try
32 [ R.string "=" >> return Comp_Number_Eq
33 , R.string "<=" >> return Comp_Number_Lt_Eq
34 , R.string ">=" >> return Comp_Number_Gt_Eq
35 , R.string "<" >> return Comp_Number_Lt
36 , R.string ">" >> return Comp_Number_Gt
37 ]
38
39 comp_number_absolute :: Stream s m Char => ParsecT s u m Comp_Num_Absolute
40 comp_number_absolute =
41 liftM isJust $ R.optionMaybe (char '+')
42
43 string :: Stream s m Char => String -> ParsecT s Context m String
44 string none_of =
45 R.choice_try [borders inside, R.many $ R.noneOf ("() " ++ none_of)]
46 where
47 borders inside = between (char '(') (char ')') inside
48 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, many1 $ R.noneOf "()"])
49 preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
50
51 parseBool :: Stream s m Char => ParsecT s u m Bool
52 parseBool = do
53 R.choice_try
54 [ R.choice_try
55 [ R.string "1"
56 , R.string "true"
57 , R.string "t"
58 ] >> return True
59 , R.choice_try
60 [ R.string "0"
61 , R.string "false"
62 , R.string "f"
63 ] >> return False
64 ]
65
66 account :: Stream s m Char => ParsecT s Context m Filter
67 account = do
68 o <- R.optionMaybe comp_string
69 liftM (Filter.Account $ fromMaybe Comp_String_Eq o)
70 (liftM (accountNameComponents) $ string (" \t"++"+-&"))
71
72 parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
73 parseFilterAmount = do
74 Filter.Amount
75 <$> comp_number
76 <*> comp_number_absolute
77 <*> amount
78
79 parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
80 parseFilterATag = do
81 c <- comp_string
82 liftM (uncurry (ATag c))
83 parseTag
84
85 --parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
86 --parseFilterCode = do
87 -- string "code="
88 -- liftM Code $
89 -- try (do {
90 -- choice
91 -- [ inparen
92 -- , R.many nonspace
93 -- ]
94 -- return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
95 -- })
96
97 parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
98 parseFilterBalance = do
99 nc <- comp_number
100 absc <- comp_number_absolute
101 a <- parseAmount Nothing
102 return $ Bal (nc, absc) a
103
104 parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
105 parseFilterDate = do
106 char '='
107 ctx <- getState
108 liftM Date $
109 periodexprdatespan (qCtxDay ctx)
110
111 parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
112 parseFilterDate2 = do
113 char '='
114 ctx <- getState
115 liftM Date2 $
116 periodexprdatespan (qCtxDay ctx)
117
118 parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
119 parseFilterDesc = do
120 c <- comp_string
121 liftM (Desc c)
122 (string "")
123
124 parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
125 parseFilterDepth = do
126 c <- comp_number
127 liftM (Depth c . fromIntegral) $
128 parseDecimal
129
130 parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
131 parseFilterReal = do
132 char '='
133 liftM Real
134 parseBool
135
136 -- | Parse the boolean value part of a "status:" query, allowing "*" as
137 -- another way to spell True, similar to the journal file format.
138 parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
139 parseFilterStatus = do
140 char '='
141 liftM Status $
142 try (char '*' >> return True) <|> parseBool
143
144 --parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
145 --parseFilterSym = do
146 -- string "cur="
147 -- liftM Sym
148 -- commoditysymbol
149
150 parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
151 parseFilterTag = do
152 c <- comp_string
153 liftM (uncurry (Tag c))
154 parseTag
155
156 parens :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
157 parens = between (parseLexeme $ char '(') (parseLexeme $ char ')')
158
159 operators :: Stream s m Char => R.OperatorTable s u m Filter
160 operators =
161 [ [ prefix "- " Filter.Not
162 , prefix "not " Filter.Not
163 ]
164 , [ binary " & " Filter.And R.AssocLeft
165 , binary " and " Filter.And R.AssocLeft
166 , binary " - " (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
167 , binary " but " (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
168 ]
169 , [ binary " + " Filter.Or R.AssocLeft
170 , binary " or " Filter.Or R.AssocLeft
171 ]
172 ]
173 where
174 binary name fun assoc = R.Infix (do{ operator name; return fun }) assoc
175 prefix name fun = R.Prefix (do{ operator name; return fun })
176 -- postfix name fun = Text.Parsec.Expr.Postfix (do{ operator name; return fun })
177
178 operator_letter :: Stream s m Char => ParsecT s u m Char
179 operator_letter = oneOf ['+', '-', '&']
180
181 operator :: Stream s m Char => String -> ParsecT s u m ()
182 operator name =
183 parseLexeme $ try $
184 do{ R.string name
185 ; R.notFollowedBy operator_letter <?> ("end of " ++ show name)
186 }
187
188 parseFilterTerm :: Stream s m Char => ParsecT s Context m Filter
189 parseFilterTerm = do
190 r <- R.choice_try
191 [ R.lookAhead (char '(')
192 >> (return $
193 parens (liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
194 R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> R.notFollowedBy (char ')') >> parseFilterExpr)))
195 , jump [ "account","acct" ] comp_string parseFilterAccount
196 , jump [ "amount", "amt" ] comp_number parseFilterAmount
197 , jump [ "atag" ] comp_string parseFilterATag
198 , jump [ "balance", "bal" ] comp_number parseFilterBalance
199 -- , jump [ "code" ] comp_string parseFilterCode
200 , jump [ "date" ] (char '=') parseFilterDate
201 , jump [ "date2", "edate" ] (char '=') parseFilterDate2
202 , jump [ "depth" ] comp_number parseFilterDepth
203 , jump [ "description","descr","desc" ] comp_string parseFilterDesc
204 , jump [ "real" ] (char '=') parseFilterReal
205 , jump [ "status" ] (char '=') parseFilterStatus
206 -- , jump [ "sym" ] comp_string parseFilterSym
207 , jump [ "tag" ] comp_string parseFilterTag
208 , R.lookAhead comp_number >> return parseFilterAmount
209 , return parseFilterAccount
210 ] <* parseWhiteSpace <?> "query expression"
211 r
212 where
213 jump l next r = R.choice_try (map (\s -> R.string s >> return r) l) <* R.lookAhead next
214
215 expr :: Stream s m Char => ParsecT s Context m Filter
216 expr = R.buildExpressionParser operators parseFilterTerm <?> "query"
217
218 filter :: Stream s m Char => ParsecT s Context m Filter
219 filter =
220 liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
221 R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> parseFilterExpr)
222
223 {-
224
225 query :: Day -> String -> Either ParseError Filter
226 query d s = runParser (parseFilter <* eof) QCtx{qCtxDay=d} "" s
227
228 simplifyFilter :: Filter -> Filter
229 simplifyFilter q =
230 -- let q' = simplify q
231 -- in if q' == q then q else simplifyFilter q'
232 simplify q -- NOTE: should be stable without recurring
233 where
234 simplify (And None _) = None
235 simplify (And _ None) = None
236 simplify (And Any Any) = Any
237 simplify (And q q'@(Date _)) = simplify (And q' q) -- XXX: useful?
238 simplify (And q q') | q == q' = simplify q
239 | otherwise = case (simplify q, simplify q') of
240 (None, _) -> None
241 (_, None) -> None
242 (Any, q') -> q'
243 (q, Any) -> q
244 (q, q') -> And q q'
245 simplify (Or None q') = simplify q'
246 simplify (Or q None) = simplify q
247 simplify (Or Any _) = Any
248 simplify (Or _ Any) = Any
249 -- simplify (Or q q'@(Date _)) = simplify (Or q' q)
250 simplify (Or q q') | q == q' = simplify q
251 | otherwise = case (simplify q, simplify q') of
252 (None, q') -> q'
253 (q, None) -> q
254 (Any, _) -> q'
255 (_, Any) -> q
256 (q, q') -> Or q q'
257 simplify (Date (DateSpan Nothing Nothing)) = Any
258 simplify (Date2 (DateSpan Nothing Nothing)) = Any
259 simplify q = q
260 -}