]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Lib/Parsec.hs
Ajout : Filter : Filter_Transaction_Posting : joint les tests sur le même Posting.
[comptalang.git] / lib / Hcompta / Lib / Parsec.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE Rank2Types #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 module Hcompta.Lib.Parsec where
6
7 import Control.Monad (void)
8 import Control.Monad.Trans.State (StateT(..), get, put)
9 -- import Control.Monad.Trans.Class (lift, MonadTrans(..))
10 import qualified Data.Char
11 import Data.Functor.Identity (Identity(..))
12 import qualified Data.List
13 import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
14 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
15 import qualified Text.Parsec.Pos as R
16 import Control.Monad.Trans.Class (lift)
17
18 -- * Combinators
19
20 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
21 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
22 choice_try = Data.List.foldr ((<|>) . R.try) R.parserZero
23 -- choice_try = R.choice . Data.List.map R.try
24
25 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
26 many_separated
27 :: Stream s m t
28 => ParsecT s u m a
29 -> ParsecT s u m b
30 -> ParsecT s u m [a]
31 many_separated p sep =
32 many1_separated p sep <|> return []
33
34 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
35 many1_separated
36 :: Stream s m t
37 => ParsecT s u m a
38 -> ParsecT s u m b
39 -> ParsecT s u m [a]
40 many1_separated p sep = do
41 x <- p
42 xs <- R.many (R.try (sep >> p))
43 return $ x:xs
44 -- (:) <$> p <*> R.many (R.try (sep >> p))
45
46 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
47 and_state
48 :: Stream s m t
49 => ParsecT s u m a
50 -> ParsecT s u m (a, u)
51 and_state p = do
52 a <- p
53 s <- R.getState
54 return (a, s)
55
56 -- ** Fixed 'R.satisfy'
57
58 -- | Like 'R.updatePosChar' but without '\t' being special.
59 updatePosChar :: R.SourcePos -> Char -> R.SourcePos
60 updatePosChar pos c =
61 case c of
62 '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
63 _ -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
64
65 -- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
66 updatePosString :: R.SourcePos -> String -> R.SourcePos
67 updatePosString = foldl updatePosChar
68
69 -- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
70 satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
71 satisfy f = R.tokenPrim (\c -> show [c])
72 (\pos c _cs -> updatePosChar pos c)
73 (\c -> if f c then Just c else Nothing)
74
75 -- | Like 'R.string' but using fixed 'updatePosString'.
76 string :: (Stream s m Char) => String -> ParsecT s u m String
77 string = R.tokens show updatePosString
78
79 -- | Like 'R.char' but using fixed 'satisfy'.
80 char :: (Stream s m Char) => Char -> ParsecT s u m Char
81 char c = satisfy (==c) <?> show [c]
82
83 -- | Like 'R.anyChar' but using fixed 'satisfy'.
84 anyChar :: (Stream s m Char) => ParsecT s u m Char
85 anyChar = satisfy (const True)
86
87 -- | Like 'R.oneOf' but using fixed 'satisfy'.
88 oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
89 oneOf cs = satisfy (`elem` cs)
90
91 -- | Like 'R.noneOf' but using fixed 'satisfy'.
92 noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
93 noneOf cs = satisfy (`notElem` cs)
94
95 -- ** Custom 'ParsecT' errors
96
97 -- | Use the 'StateT' monad transformer
98 -- to attach custom errors to the 'ParsecT' monad.
99 --
100 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
101 type Error_State e = StateT (R.SourcePos, [Error e])
102 data Error e
103 = Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
104 | Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
105 | Error_At R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
106 deriving (Show)
107
108 instance Functor Error where
109 fmap _ (Error_Parser e) = Error_Parser e
110 fmap f (Error_Custom pos e) = Error_Custom pos (f e)
111 fmap f (Error_At pos es) = Error_At pos $ map (fmap f) es
112
113 -- | Like 'R.parserFail'
114 -- but fail with given custom error.
115 fail_with :: (Stream s (Error_State e m) Char, Monad m)
116 => String -> e -> ParsecT s u (Error_State e m) r
117 fail_with msg err = do
118 (sp, se) <- lift get
119 rp <- R.getPosition -- NOTE: reported position
120 _ <- (void R.anyChar <|> R.eof)
121 -- NOTE: somehow commits that this character has an error
122 p <- R.getPosition -- NOTE: compared position
123 case () of
124 _ | R.sourceLine p > R.sourceLine sp ||
125 (R.sourceLine p == R.sourceLine sp &&
126 R.sourceColumn p > R.sourceColumn sp)
127 -> lift $ put (p, [Error_Custom rp err])
128 _ | R.sourceLine p == R.sourceLine sp &&
129 R.sourceColumn p == R.sourceColumn sp
130 -> lift $ put (p, Error_Custom rp err:se)
131 _ -> return ()
132 R.parserFail msg
133
134 -- | Like 'R.runParserT' but return as error an 'Error' list
135 runParserT_with_Error
136 :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
137 => ParsecT s u (Error_State e m) r
138 -> u -> R.SourceName -> s
139 -> m (Either [Error e] r)
140 runParserT_with_Error p u sn s = do
141 (r, (sp, se)) <- runStateT
142 (R.runParserT p u sn s)
143 (R.initialPos sn, [])
144 case r of
145 Left pe | R.sourceLine (R.errorPos pe) < R.sourceLine sp ||
146 (R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
147 R.sourceColumn (R.errorPos pe) < R.sourceColumn sp)
148 -> return $ Left $ se -- NOTE: custom errors detected at a greater position
149 Left pe | R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
150 R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
151 -> return $ Left $ se -- NOTE: prefer custom errors
152 Left pe -> return $ Left $ [Error_Parser pe]
153 Right x -> return $ Right x
154
155 -- | Like 'R.runParserT_with_Error'
156 -- but applied on the 'Identity' monad.
157 runParser_with_Error
158 :: (Stream s (Error_State e Identity) Char, Show r, Show e)
159 => ParsecT s u (Error_State e Identity) r
160 -> u -> R.SourceName -> s
161 -> Either [Error e] r
162 runParser_with_Error p u sn s =
163 runIdentity $
164 runParserT_with_Error p u sn s
165
166 -- | Like 'R.runParserT_with_Error'
167 -- but propagate any failure to a calling 'ParsecT' monad.
168 runParserT_with_Error_fail ::
169 ( Stream s1 (Error_State ee m) Char
170 , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
171 , Monad m, Show r, Show e, Show ee )
172 => String
173 -> (Error e -> Error ee)
174 -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
175 -> u -> R.SourceName -> s
176 -> ParsecT s1 u1 (Error_State ee m) r
177 runParserT_with_Error_fail msg map_ko p u sn s = do
178 r <- runParserT_with_Error p u sn s
179 case r of
180 Right ok -> return ok
181 Left ko -> do
182 rpos <- R.getPosition
183 _ <- commit_position
184 pos <- R.getPosition
185 lift $ put (pos, [Error_At rpos (map map_ko ko)])
186 fail msg
187 where commit_position = (void R.anyChar) <|> R.eof
188
189 -- ** Mapping inner monad
190
191 -- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
192 -- but also requiring a second 'Monad' constraint
193 -- on the returned base container.
194 --
195 -- NOTE: This code is not used by Hcompta, still is left here
196 -- because it was not trivial to write it,
197 -- so eventually it may help others.
198 hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b
199 hoist nat m = R.mkPT $ \s -> do
200 c <- nat $ R.runParsecT m s
201 return $ case c of
202 R.Consumed mrep -> R.Consumed $ nat mrep
203 R.Empty mrep -> R.Empty $ nat mrep
204
205 -- | Map the type of a 'StateT'.
206 --
207 -- NOTE: This code is not used by Hcompta, still is left here
208 -- because it was not trivial to write it,
209 -- so eventually it may help others.
210 smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a
211 smap s1_to_s0 s0_to_s1 st =
212 StateT (\s1_begin -> do
213 (a, s0_end) <- runStateT st (s1_to_s0 s1_begin)
214 return (a, s0_to_s1 s0_end))
215
216 -- * Numbers
217
218 -- | Return the 'Integer' obtained by multiplying the given digits
219 -- with the power of the given base respective to their rank.
220 integer_of_digits
221 :: Integer -- ^ Base.
222 -> [Char] -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
223 -> Integer
224 integer_of_digits base =
225 Data.List.foldl (\x d ->
226 base*x + toInteger (Data.Char.digitToInt d)) 0
227
228 decimal :: Stream s m Char => ParsecT s u m Integer
229 decimal = integer 10 R.digit
230 hexadecimal :: Stream s m Char => ParsecT s u m Integer
231 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
232 octal :: Stream s m Char => ParsecT s u m Integer
233 octal = R.oneOf "oO" >> integer 8 R.octDigit
234
235 -- | Parse an 'Integer'.
236 integer :: Stream s m t
237 => Integer
238 -> ParsecT s u m Char
239 -> ParsecT s u m Integer
240 integer base digit = do
241 digits <- R.many1 digit
242 let n = integer_of_digits base digits
243 seq n (return n)
244
245 -- * Whites
246
247 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
248 is_space_horizontal :: Char -> Bool
249 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
250
251 -- | Like 'R.space' but using fixed 'satisfy'.
252 space :: Stream s m Char => ParsecT s u m Char
253 {-# INLINEABLE space #-}
254 space = satisfy Data.Char.isSpace <?> "space"
255
256 -- | Like 'R.spaces' but using fixed 'satisfy'.
257 spaces :: Stream s m Char => ParsecT s u m ()
258 {-# INLINEABLE spaces #-}
259 spaces = R.skipMany space <?> "spaces"
260
261 -- | Like 'R.tab' but using fixed 'satisfy'.
262 tab :: (Stream s m Char) => ParsecT s u m Char
263 {-# INLINEABLE tab #-}
264 tab = char '\t' <?> "tab"
265
266 -- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
267 space_horizontal :: Stream s m Char => ParsecT s u m Char
268 {-# INLINEABLE space_horizontal #-}
269 space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"
270
271 new_line :: Stream s m Char => ParsecT s u m ()
272 {-# INLINEABLE new_line #-}
273 new_line = (void (R.try (string "\r\n") <|> R.try (string "\n"))) <?> "newline"