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