1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE Rank2Types #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 module Hcompta.Lib.Parsec where
7 import Control.Monad (void)
8 import Control.Monad.Trans.Class (lift)
9 import Control.Monad.Trans.State (StateT(..), get, put)
11 import Data.Char (Char)
12 import qualified Data.Char
14 import Data.Eq (Eq(..))
15 import Data.Foldable (elem, notElem, foldl')
16 import Data.Functor (Functor(..))
17 import Data.Functor.Identity (Identity(..))
18 import qualified Data.List
19 import Data.Maybe (Maybe(..))
20 import Data.Ord (Ord(..))
21 import Data.String (String)
22 import Prelude ( ($), (.)
31 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
32 import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
33 import qualified Text.Parsec.Pos as R
37 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
38 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
39 choice_try = Data.List.foldr ((<|>) . R.try) R.parserZero
40 -- choice_try = R.choice . Data.List.map R.try
42 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
48 many_separated p sep =
49 many1_separated p sep <|> return []
51 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
57 many1_separated p sep = do
59 xs <- R.many (R.try (sep >> p))
61 -- (:) <$> p <*> R.many (R.try (sep >> p))
63 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
67 -> ParsecT s u m (a, u)
73 -- ** Fixed 'R.satisfy'
75 -- | Like 'R.updatePosChar' but without '\t' being special.
76 updatePosChar :: R.SourcePos -> Char -> R.SourcePos
79 '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
80 _ -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
82 -- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
83 updatePosString :: R.SourcePos -> String -> R.SourcePos
84 updatePosString = foldl' updatePosChar
86 -- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
87 satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
88 satisfy f = R.tokenPrim (\c -> show [c])
89 (\pos c _cs -> updatePosChar pos c)
90 (\c -> if f c then Just c else Nothing)
92 -- | Like 'R.string' but using fixed 'updatePosString'.
93 string :: (Stream s m Char) => String -> ParsecT s u m String
94 string = R.tokens show updatePosString
96 -- | Like 'R.char' but using fixed 'satisfy'.
97 char :: (Stream s m Char) => Char -> ParsecT s u m Char
98 char c = satisfy (==c) <?> show [c]
100 -- | Like 'R.anyChar' but using fixed 'satisfy'.
101 anyChar :: (Stream s m Char) => ParsecT s u m Char
102 anyChar = satisfy (const True)
104 -- | Like 'R.oneOf' but using fixed 'satisfy'.
105 oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
106 oneOf cs = satisfy (`elem` cs)
108 -- | Like 'R.noneOf' but using fixed 'satisfy'.
109 noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
110 noneOf cs = satisfy (`notElem` cs)
112 -- ** Custom 'ParsecT' errors
114 -- | Use the 'StateT' monad transformer
115 -- to attach custom errors to the 'ParsecT' monad.
117 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
118 type Error_State e = StateT (R.SourcePos, [Error e])
120 = Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
121 | Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
122 | Error_At R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
125 instance Functor Error where
126 fmap _ (Error_Parser e) = Error_Parser e
127 fmap f (Error_Custom pos e) = Error_Custom pos (f e)
128 fmap f (Error_At pos es) = Error_At pos $ fmap (fmap f) es
130 -- | Like 'R.parserFail'
131 -- but fail with given custom error.
132 fail_with :: (Stream s (Error_State e m) Char, Monad m)
133 => String -> e -> ParsecT s u (Error_State e m) r
134 fail_with msg err = do
136 rp <- R.getPosition -- NOTE: reported position
137 _ <- (void R.anyChar <|> R.eof)
138 -- NOTE: somehow commits that this character has an error
139 p <- R.getPosition -- NOTE: compared position
141 _ | R.sourceLine p > R.sourceLine sp ||
142 (R.sourceLine p == R.sourceLine sp &&
143 R.sourceColumn p > R.sourceColumn sp)
144 -> lift $ put (p, [Error_Custom rp err])
145 _ | R.sourceLine p == R.sourceLine sp &&
146 R.sourceColumn p == R.sourceColumn sp
147 -> lift $ put (p, Error_Custom rp err:se)
151 -- | Like 'R.runParserT' but return as error an 'Error' list
152 runParserT_with_Error
153 :: (Stream s (Error_State e m) Char, Monad m)
154 => ParsecT s u (Error_State e m) r
155 -> u -> R.SourceName -> s
156 -> m (Either [Error e] r)
157 runParserT_with_Error p u sn s = do
158 (r, (sp, se)) <- runStateT
159 (R.runParserT p u sn s)
160 (R.initialPos sn, [])
162 Left pe | R.sourceLine (R.errorPos pe) < R.sourceLine sp ||
163 (R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
164 R.sourceColumn (R.errorPos pe) < R.sourceColumn sp)
165 -> return $ Left $ se -- NOTE: custom errors detected at a greater position
166 Left pe | R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
167 R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
168 -> return $ Left $ se -- NOTE: prefer custom errors
169 Left pe -> return $ Left $ [Error_Parser pe]
170 Right x -> return $ Right x
172 -- | Like 'R.runParserT_with_Error'
173 -- but applied on the 'Identity' monad.
175 :: (Stream s (Error_State e Identity) Char)
176 => ParsecT s u (Error_State e Identity) r
177 -> u -> R.SourceName -> s
178 -> Either [Error e] r
179 runParser_with_Error p u sn s =
181 runParserT_with_Error p u sn s
183 -- | Like 'R.runParserT_with_Error'
184 -- but propagate any failure to a calling 'ParsecT' monad.
185 runParserT_with_Error_fail ::
186 ( Stream s1 (Error_State ee m) Char
187 , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
190 -> (Error e -> Error ee)
191 -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
192 -> u -> R.SourceName -> s
193 -> ParsecT s1 u1 (Error_State ee m) r
194 runParserT_with_Error_fail msg map_ko p u sn s = do
195 r <- runParserT_with_Error p u sn s
197 Right ok -> return ok
199 rpos <- R.getPosition
202 lift $ put (pos, [Error_At rpos (fmap map_ko ko)])
204 where commit_position = (void R.anyChar) <|> R.eof
206 -- ** Mapping inner monad
208 -- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
209 -- but also requiring a second 'Monad' constraint
210 -- on the returned base container.
212 -- NOTE: This code is not used by Hcompta, still is left here
213 -- because it was not trivial to write it,
214 -- so eventually it may help others.
215 hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b
216 hoist nat m = R.mkPT $ \s -> do
217 c <- nat $ R.runParsecT m s
219 R.Consumed mrep -> R.Consumed $ nat mrep
220 R.Empty mrep -> R.Empty $ nat mrep
222 -- | Map the type of a 'StateT'.
224 -- NOTE: This code is not used by Hcompta, still is left here
225 -- because it was not trivial to write it,
226 -- so eventually it may help others.
227 smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a
228 smap s1_to_s0 s0_to_s1 st =
229 StateT (\s1_begin -> do
230 (a, s0_end) <- runStateT st (s1_to_s0 s1_begin)
231 return (a, s0_to_s1 s0_end))
235 -- | Return the 'Integer' obtained by multiplying the given digits
236 -- with the power of the given base respective to their rank.
238 :: Integer -- ^ Base.
239 -> [Char] -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
241 integer_of_digits base =
243 base*x + toInteger (Data.Char.digitToInt d)) 0
245 decimal :: Stream s m Char => ParsecT s u m Integer
246 decimal = integer 10 R.digit
247 hexadecimal :: Stream s m Char => ParsecT s u m Integer
248 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
249 octal :: Stream s m Char => ParsecT s u m Integer
250 octal = R.oneOf "oO" >> integer 8 R.octDigit
252 -- | Parse an 'Integer'.
253 integer :: Stream s m t
255 -> ParsecT s u m Char
256 -> ParsecT s u m Integer
257 integer base digit = do
258 digits <- R.many1 digit
259 let n = integer_of_digits base digits
264 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
265 is_space_horizontal :: Char -> Bool
266 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
268 -- | Like 'R.space' but using fixed 'satisfy'.
269 space :: Stream s m Char => ParsecT s u m Char
270 {-# INLINEABLE space #-}
271 space = satisfy Data.Char.isSpace <?> "space"
273 -- | Like 'R.spaces' but using fixed 'satisfy'.
274 spaces :: Stream s m Char => ParsecT s u m ()
275 {-# INLINEABLE spaces #-}
276 spaces = R.skipMany space <?> "spaces"
278 -- | Like 'R.tab' but using fixed 'satisfy'.
279 tab :: (Stream s m Char) => ParsecT s u m Char
280 {-# INLINEABLE tab #-}
281 tab = char '\t' <?> "tab"
283 -- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
284 space_horizontal :: Stream s m Char => ParsecT s u m Char
285 {-# INLINEABLE space_horizontal #-}
286 space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"
288 new_line :: Stream s m Char => ParsecT s u m ()
289 {-# INLINEABLE new_line #-}
290 new_line = (void (R.try (string "\r\n") <|> R.try (string "\n"))) <?> "newline"