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.Trans.State (StateT(..), get, put)
8 -- import Control.Monad.Trans.Class (lift, MonadTrans(..))
9 import qualified Data.Char
10 import Data.Functor.Identity (Identity(..))
11 import qualified Data.List
12 import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
13 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
14 import qualified Text.Parsec.Pos as R
15 import Control.Monad.Trans.Class (lift)
19 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
20 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
21 choice_try = Data.List.foldr (\a -> (<|>) (R.try a)) R.parserZero
22 -- choice_try = R.choice . Data.List.map R.try
24 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
30 many_separated p sep =
31 many1_separated p sep <|> return []
33 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
39 many1_separated p sep = do
41 xs <- R.many (R.try (sep >> p))
43 -- (:) <$> p <*> R.many (R.try (sep >> p))
45 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
49 -> ParsecT s u m (a, u)
55 -- ** Fixed 'R.satisfy'
57 -- | Like 'R.updatePosChar' but without '\t' being special.
58 updatePosChar :: R.SourcePos -> Char -> R.SourcePos
61 '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
62 _ -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
64 -- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
65 updatePosString :: R.SourcePos -> String -> R.SourcePos
66 updatePosString pos s = foldl updatePosChar pos s
68 -- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
69 satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
70 satisfy f = R.tokenPrim (\c -> show [c])
71 (\pos c _cs -> updatePosChar pos c)
72 (\c -> if f c then Just c else Nothing)
74 -- | Like 'R.string' but using fixed 'updatePosString'.
75 string :: (Stream s m Char) => String -> ParsecT s u m String
76 string s = R.tokens show updatePosString s
78 -- | Like 'R.char' but using fixed 'satisfy'.
79 char :: (Stream s m Char) => Char -> ParsecT s u m Char
80 char c = satisfy (==c) <?> show [c]
82 -- | Like 'R.anyChar' but using fixed 'satisfy'.
83 anyChar :: (Stream s m Char) => ParsecT s u m Char
84 anyChar = satisfy (const True)
86 -- | Like 'R.oneOf' but using fixed 'satisfy'.
87 oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
88 oneOf cs = satisfy (\c -> elem c cs)
90 -- | Like 'R.noneOf' but using fixed 'satisfy'.
91 noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
92 noneOf cs = satisfy (\c -> not (elem c cs))
94 -- ** Custom 'ParsecT' errors
96 -- | Use the 'StateT' monad transformer
97 -- to attach custom errors to the 'ParsecT' monad.
99 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
100 type Error_State e = StateT (R.SourcePos, [Error e])
102 = Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
103 | Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
104 | Error_At R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
107 instance Functor Error where
108 fmap _ (Error_Parser e) = Error_Parser e
109 fmap f (Error_Custom pos e) = Error_Custom pos (f e)
110 fmap f (Error_At pos es) = Error_At pos $ map (fmap f) es
112 -- | Like 'R.parserFail'
113 -- but fail with given custom error.
114 fail_with :: (Stream s (Error_State e m) Char, Monad m)
115 => String -> e -> ParsecT s u (Error_State e m) r
116 fail_with msg err = do
118 rp <- R.getPosition -- NOTE: reported position
119 _ <- ((R.anyChar >> return ()) <|> R.eof)
120 -- NOTE: somehow commits that this character has an error
121 p <- R.getPosition -- NOTE: compared position
123 _ | R.sourceLine p > R.sourceLine sp ||
124 (R.sourceLine p == R.sourceLine sp &&
125 R.sourceColumn p > R.sourceColumn sp)
126 -> lift $ put (p, Error_Custom rp err:[])
127 _ | R.sourceLine p == R.sourceLine sp &&
128 R.sourceColumn p == R.sourceColumn sp
129 -> lift $ put (p, Error_Custom rp err:se)
133 -- | Like 'R.runParserT' but return as error an 'Error' list
134 runParserT_with_Error
135 :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
136 => ParsecT s u (Error_State e m) r
137 -> u -> R.SourceName -> s
138 -> m (Either [Error e] r)
139 runParserT_with_Error p u sn s = do
140 (r, (sp, se)) <- runStateT
141 (R.runParserT p u sn s)
142 (R.initialPos sn, [])
144 Left pe | R.sourceLine (R.errorPos pe) < R.sourceLine sp ||
145 (R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
146 R.sourceColumn (R.errorPos pe) < R.sourceColumn sp)
147 -> return $ Left $ se -- NOTE: custom errors detected at a greater position
148 Left pe | R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
149 R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
150 -> return $ Left $ se -- NOTE: prefer custom errors
151 Left pe -> return $ Left $ Error_Parser pe:[]
152 Right x -> return $ Right x
154 -- | Like 'R.runParserT_with_Error'
155 -- but applied on the 'Identity' monad.
157 :: (Stream s (Error_State e Identity) Char, Show r, Show e)
158 => ParsecT s u (Error_State e Identity) r
159 -> u -> R.SourceName -> s
160 -> Either [Error e] r
161 runParser_with_Error p u sn s =
163 runParserT_with_Error p u sn s
165 -- | Like 'R.runParserT_with_Error'
166 -- but propagate any failure to a calling 'ParsecT' monad.
167 runParserT_with_Error_fail ::
168 ( Stream s1 (Error_State ee m) Char
169 , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
170 , Monad m, Show r, Show e, Show ee )
172 -> (Error e -> Error ee)
173 -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
174 -> u -> R.SourceName -> s
175 -> ParsecT s1 u1 (Error_State ee m) r
176 runParserT_with_Error_fail msg map_ko p u sn s = do
177 r <- runParserT_with_Error p u sn s
179 Right ok -> return ok
181 rpos <- R.getPosition
184 lift $ put (pos, Error_At rpos (map map_ko ko):[])
186 where commit_position = (R.anyChar >> return ()) <|> R.eof
188 -- ** Mapping inner monad
190 -- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
191 -- but also requiring a second 'Monad' constraint
192 -- on the returned base container.
194 -- NOTE: This code is not used by Hcompta, still is left here
195 -- because it was not trivial to write it,
196 -- so eventually it may help others.
197 hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b
198 hoist nat m = R.mkPT $ \s -> do
199 c <- nat $ R.runParsecT m s
201 R.Consumed mrep -> R.Consumed $ nat mrep
202 R.Empty mrep -> R.Empty $ nat mrep
204 -- | Map the type of a 'StateT'.
206 -- NOTE: This code is not used by Hcompta, still is left here
207 -- because it was not trivial to write it,
208 -- so eventually it may help others.
209 smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a
210 smap s1_to_s0 s0_to_s1 st =
211 StateT (\s1_begin -> do
212 (a, s0_end) <- runStateT st (s1_to_s0 s1_begin)
213 return (a, s0_to_s1 s0_end))
217 -- | Return the 'Integer' obtained by multiplying the given digits
218 -- with the power of the given base respective to their rank.
220 :: Integer -- ^ Base.
221 -> [Char] -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
223 integer_of_digits base =
224 Data.List.foldl (\x d ->
225 base*x + toInteger (Data.Char.digitToInt d)) 0
227 decimal :: Stream s m Char => ParsecT s u m Integer
228 decimal = integer 10 R.digit
229 hexadecimal :: Stream s m Char => ParsecT s u m Integer
230 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
231 octal :: Stream s m Char => ParsecT s u m Integer
232 octal = R.oneOf "oO" >> integer 8 R.octDigit
234 -- | Parse an 'Integer'.
235 integer :: Stream s m t
237 -> ParsecT s u m Char
238 -> ParsecT s u m Integer
239 integer base digit = do
240 digits <- R.many1 digit
241 let n = integer_of_digits base digits
246 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
247 is_space_horizontal :: Char -> Bool
248 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
250 -- | Like 'R.space' but using fixed 'satisfy'.
251 space :: Stream s m Char => ParsecT s u m Char
252 {-# INLINEABLE space #-}
253 space = satisfy Data.Char.isSpace <?> "space"
255 -- | Like 'R.spaces' but using fixed 'satisfy'.
256 spaces :: Stream s m Char => ParsecT s u m ()
257 {-# INLINEABLE spaces #-}
258 spaces = R.skipMany space <?> "spaces"
260 -- | Like 'R.tab' but using fixed 'satisfy'.
261 tab :: (Stream s m Char) => ParsecT s u m Char
262 {-# INLINEABLE tab #-}
263 tab = char '\t' <?> "tab"
265 -- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
266 space_horizontal :: Stream s m Char => ParsecT s u m Char
267 {-# INLINEABLE space_horizontal #-}
268 space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"
270 new_line :: Stream s m Char => ParsecT s u m ()
271 {-# INLINEABLE new_line #-}
272 new_line = ((R.try (string "\r\n") <|> R.try (string "\n")) >> return ()) <?> "newline"