never executed always true always false
1 module Cheapskate.ParserCombinators (
2 Position(..)
3 , Parser
4 , parse
5 , (<?>)
6 , satisfy
7 , peekChar
8 , peekLastChar
9 , notAfter
10 , inClass
11 , notInClass
12 , endOfInput
13 , char
14 , anyChar
15 , getPosition
16 , setPosition
17 , takeWhile
18 , takeTill
19 , takeWhile1
20 , takeText
21 , skip
22 , skipWhile
23 , string
24 , scan
25 , lookAhead
26 , notFollowedBy
27 , option
28 , many1
29 , manyTill
30 , skipMany
31 , skipMany1
32 , count
33 ) where
34 import Prelude hiding (takeWhile)
35 import Data.Text (Text)
36 import qualified Data.Text as T
37 import Control.Monad
38 import Control.Monad.Fail ()
39 import Control.Applicative
40 import qualified Data.Set as Set
41
42 data Position = Position { line :: Int, column :: Int }
43 deriving (Ord, Eq)
44
45 instance Show Position where
46 show (Position ln cn) = "line " ++ show ln ++ " column " ++ show cn
47
48 -- the String indicates what the parser was expecting
49 data ParseError = ParseError Position String deriving Show
50
51 data ParserState = ParserState { subject :: Text
52 , position :: Position
53 , lastChar :: Maybe Char
54 }
55
56 advance :: ParserState -> Text -> ParserState
57 advance = T.foldl' go
58 where go :: ParserState -> Char -> ParserState
59 go st c = st{ subject = T.drop 1 (subject st)
60 , position = case c of
61 '\n' -> Position { line =
62 line (position st) + 1
63 , column = 1 }
64 _ -> Position { line =
65 line (position st)
66 , column =
67 column (position st) + 1
68 }
69 , lastChar = Just c }
70
71 newtype Parser a = Parser {
72 evalParser :: ParserState -> Either ParseError (ParserState, a)
73 }
74
75 instance Functor Parser where
76 fmap f (Parser g) = Parser $ \st ->
77 case g st of
78 Right (st', x) -> Right (st', f x)
79 Left e -> Left e
80 {-# INLINE fmap #-}
81
82 instance Applicative Parser where
83 pure x = Parser $ \st -> Right (st, x)
84 (Parser f) <*> (Parser g) = Parser $ \st ->
85 case f st of
86 Left e -> Left e
87 Right (st', h) -> case g st' of
88 Right (st'', x) -> Right (st'', h x)
89 Left e -> Left e
90 {-# INLINE pure #-}
91 {-# INLINE (<*>) #-}
92
93 instance Alternative Parser where
94 empty = Parser $ \st -> Left $ ParseError (position st) "(empty)"
95 (Parser f) <|> (Parser g) = Parser $ \st ->
96 case f st of
97 Right res -> Right res
98 Left (ParseError pos msg) ->
99 case g st of
100 Right res -> Right res
101 Left (ParseError pos' msg') -> Left $
102 case () of
103 -- return error for farthest match
104 _ | pos' > pos -> ParseError pos' msg'
105 | pos' < pos -> ParseError pos msg
106 | otherwise {- pos' == pos -}
107 -> ParseError pos (msg ++ " or " ++ msg')
108 {-# INLINE empty #-}
109 {-# INLINE (<|>) #-}
110
111 instance Monad Parser where
112 return x = Parser $ \st -> Right (st, x)
113 p >>= g = Parser $ \st ->
114 case evalParser p st of
115 Left e -> Left e
116 Right (st',x) -> evalParser (g x) st'
117 {-# INLINE return #-}
118 {-# INLINE (>>=) #-}
119
120 instance MonadFail Parser where
121 fail e = Parser $ \st -> Left $ ParseError (position st) e
122
123 instance MonadPlus Parser where
124 mzero = Parser $ \st -> Left $ ParseError (position st) "(mzero)"
125 mplus p1 p2 = Parser $ \st ->
126 case evalParser p1 st of
127 Right res -> Right res
128 Left _ -> evalParser p2 st
129 {-# INLINE mzero #-}
130 {-# INLINE mplus #-}
131
132 (<?>) :: Parser a -> String -> Parser a
133 p <?> msg = Parser $ \st ->
134 let startpos = position st in
135 case evalParser p st of
136 Left (ParseError _ _) ->
137 Left $ ParseError startpos msg
138 Right r -> Right r
139 {-# INLINE (<?>) #-}
140 infixl 5 <?>
141
142 parse :: Parser a -> Text -> Either ParseError a
143 parse p t =
144 fmap snd $ evalParser p ParserState{ subject = t
145 , position = Position 1 1
146 , lastChar = Nothing }
147
148 failure :: ParserState -> String -> Either ParseError (ParserState, a)
149 failure st msg = Left $ ParseError (position st) msg
150 {-# INLINE failure #-}
151
152 success :: ParserState -> a -> Either ParseError (ParserState, a)
153 success st x = Right (st, x)
154 {-# INLINE success #-}
155
156 satisfy :: (Char -> Bool) -> Parser Char
157 satisfy f = Parser g
158 where g st = case T.uncons (subject st) of
159 Just (c, _) | f c ->
160 success (advance st (T.singleton c)) c
161 _ -> failure st "character meeting condition"
162 {-# INLINE satisfy #-}
163
164 peekChar :: Parser (Maybe Char)
165 peekChar = Parser $ \st ->
166 case T.uncons (subject st) of
167 Just (c, _) -> success st (Just c)
168 Nothing -> success st Nothing
169 {-# INLINE peekChar #-}
170
171 peekLastChar :: Parser (Maybe Char)
172 peekLastChar = Parser $ \st -> success st (lastChar st)
173 {-# INLINE peekLastChar #-}
174
175 notAfter :: (Char -> Bool) -> Parser ()
176 notAfter f = do
177 mbc <- peekLastChar
178 case mbc of
179 Nothing -> return ()
180 Just c -> if f c then mzero else return ()
181
182 -- low-grade version of attoparsec's:
183 charClass :: String -> Set.Set Char
184 charClass = Set.fromList . go
185 where go (a:'-':b:xs) = [a..b] ++ go xs
186 go (x:xs) = x : go xs
187 go _ = ""
188 {-# INLINE charClass #-}
189
190 inClass :: String -> Char -> Bool
191 inClass s c = c `Set.member` s'
192 where s' = charClass s
193 {-# INLINE inClass #-}
194
195 notInClass :: String -> Char -> Bool
196 notInClass s = not . inClass s
197 {-# INLINE notInClass #-}
198
199 endOfInput :: Parser ()
200 endOfInput = Parser $ \st ->
201 if T.null (subject st)
202 then success st ()
203 else failure st "end of input"
204 {-# INLINE endOfInput #-}
205
206 char :: Char -> Parser Char
207 char c = satisfy (== c)
208 {-# INLINE char #-}
209
210 anyChar :: Parser Char
211 anyChar = satisfy (const True)
212 {-# INLINE anyChar #-}
213
214 getPosition :: Parser Position
215 getPosition = Parser $ \st -> success st (position st)
216 {-# INLINE getPosition #-}
217
218 -- note: this does not actually change the position in the subject;
219 -- it only changes what column counts as column N. It is intended
220 -- to be used in cases where we're parsing a partial line but need to
221 -- have accurate column information.
222 setPosition :: Position -> Parser ()
223 setPosition pos = Parser $ \st -> success st{ position = pos } ()
224 {-# INLINE setPosition #-}
225
226 takeWhile :: (Char -> Bool) -> Parser Text
227 takeWhile f = Parser $ \st ->
228 let t = T.takeWhile f (subject st) in
229 success (advance st t) t
230 {-# INLINE takeWhile #-}
231
232 takeTill :: (Char -> Bool) -> Parser Text
233 takeTill f = takeWhile (not . f)
234 {-# INLINE takeTill #-}
235
236 takeWhile1 :: (Char -> Bool) -> Parser Text
237 takeWhile1 f = Parser $ \st ->
238 case T.takeWhile f (subject st) of
239 t | T.null t -> failure st "characters satisfying condition"
240 | otherwise -> success (advance st t) t
241 {-# INLINE takeWhile1 #-}
242
243 takeText :: Parser Text
244 takeText = Parser $ \st ->
245 let t = subject st in
246 success (advance st t) t
247 {-# INLINE takeText #-}
248
249 skip :: (Char -> Bool) -> Parser ()
250 skip f = Parser $ \st ->
251 case T.uncons (subject st) of
252 Just (c,_) | f c -> success (advance st (T.singleton c)) ()
253 _ -> failure st "character satisfying condition"
254 {-# INLINE skip #-}
255
256 skipWhile :: (Char -> Bool) -> Parser ()
257 skipWhile f = Parser $ \st ->
258 let t' = T.takeWhile f (subject st) in
259 success (advance st t') ()
260 {-# INLINE skipWhile #-}
261
262 string :: Text -> Parser Text
263 string s = Parser $ \st ->
264 if s `T.isPrefixOf` (subject st)
265 then success (advance st s) s
266 else failure st "string"
267 {-# INLINE string #-}
268
269 scan :: s -> (s -> Char -> Maybe s) -> Parser Text
270 scan s0 f = Parser $ go s0 []
271 where go s cs st =
272 case T.uncons (subject st) of
273 Nothing -> finish st cs
274 Just (c, _) -> case f s c of
275 Just s' -> go s' (c:cs)
276 (advance st (T.singleton c))
277 Nothing -> finish st cs
278 finish st cs =
279 success st (T.pack (reverse cs))
280 {-# INLINE scan #-}
281
282 lookAhead :: Parser a -> Parser a
283 lookAhead p = Parser $ \st ->
284 case evalParser p st of
285 Right (_,x) -> success st x
286 Left _ -> failure st "lookAhead"
287 {-# INLINE lookAhead #-}
288
289 notFollowedBy :: Parser a -> Parser ()
290 notFollowedBy p = Parser $ \st ->
291 case evalParser p st of
292 Right (_,_) -> failure st "notFollowedBy"
293 Left _ -> success st ()
294 {-# INLINE notFollowedBy #-}
295
296 -- combinators (definitions borrowed from attoparsec)
297
298 option :: Alternative f => a -> f a -> f a
299 option x p = p <|> pure x
300 {-# INLINE option #-}
301
302 many1 :: Alternative f => f a -> f [a]
303 many1 p = liftA2 (:) p (many p)
304 {-# INLINE many1 #-}
305
306 manyTill :: Alternative f => f a -> f b -> f [a]
307 manyTill p end = go
308 where go = (end *> pure []) <|> liftA2 (:) p go
309 {-# INLINE manyTill #-}
310
311 skipMany :: Alternative f => f a -> f ()
312 skipMany p = go
313 where go = (p *> go) <|> pure ()
314 {-# INLINE skipMany #-}
315
316 skipMany1 :: Alternative f => f a -> f ()
317 skipMany1 p = p *> skipMany p
318 {-# INLINE skipMany1 #-}
319
320 count :: Monad m => Int -> m a -> m [a]
321 count n p = sequence (replicate n p)
322 {-# INLINE count #-}