Ticket #4849: Parsec.hs

File Parsec.hs, 9.2 KB (added by igloo, 8 years ago)
Line 
1
2module Parsec (Parser, (<|>), skipMany, space, string) where
3
4import Data.Char
5
6type CharParser st a    = GenParser Char st a
7
8space :: CharParser st Char
9space = satisfy (isSpace)
10
11satisfy :: (Char -> Bool) -> CharParser st Char
12satisfy f           = tokenPrim (\c -> show [c])
13                                (\pos c _cs -> updatePosChar pos c)
14                                (\c -> if f c then Just c else Nothing)
15
16string :: String -> CharParser st String
17string s            = tokens show updatePosString s
18
19{-# INLINE parsecReturn #-}
20{-# INLINE parsecBind   #-}
21{-# INLINE parsecPlus   #-}
22{-# INLINE tokenPrim    #-}
23
24infixr 1 <|>
25
26(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
27p1 <|> p2           = parsecPlus p1 p2
28
29type Parser a           = GenParser Char () a
30
31newtype GenParser tok st a = Parser { runP :: State tok st -> Consumed (Reply tok st a) }
32
33data Consumed a         = Consumed a                --input is consumed
34                        | Empty !a                  --no input is consumed
35
36data Reply tok st a     = Ok !a !(State tok st) ParseError    --parsing succeeded with "a"
37                        | Error ParseError                    --parsing failed
38
39data State tok st       = State { _stateInput :: [tok]
40                                , statePos    :: !SourcePos
41                                , _stateUser  :: !st
42                                }
43
44instance Monad (GenParser tok st) where
45  return x   = parsecReturn x
46  p >>= f    = parsecBind p f
47  fail msg   = parsecFail msg
48
49parsecReturn :: a -> GenParser tok st a
50parsecReturn x
51  = Parser (\state -> Empty (Ok x state (unknownError state)))
52
53parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
54parsecBind (Parser p) f
55    = Parser (\state ->
56        case (p state) of
57          Consumed reply1
58            -> Consumed $
59               case (reply1) of
60                 Ok x state1 err1 -> case runP (f x) state1 of
61                                       Empty reply2    -> mergeErrorReply err1 reply2
62                                       Consumed reply2 -> reply2
63                 Error err1       -> Error err1
64
65          Empty reply1
66            -> case (reply1) of
67                 Ok x state1 err1 -> case runP (f x) state1 of
68                                       Empty reply2 -> Empty (mergeErrorReply err1 reply2)
69                                       other        -> other
70                 Error err1       -> Empty (Error err1)
71      )
72
73mergeErrorReply :: ParseError -> Reply tok st a -> Reply tok st a
74mergeErrorReply err1 reply
75  = case reply of
76      Ok x state err2 -> Ok x state (mergeError err1 err2)
77      Error err2      -> Error (mergeError err1 err2)
78
79
80parsecFail :: String -> GenParser tok st a
81parsecFail msg
82  = Parser (\state ->
83      Empty (Error (newErrorMessage (Message msg) (statePos state))))
84
85parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
86parsecPlus (Parser p1) (Parser p2)
87    = Parser (\state ->
88        case (p1 state) of
89          Empty (Error err) -> case (p2 state) of
90                                 Empty reply -> Empty (mergeErrorReply err reply)
91                                 consumed    -> consumed
92          other             -> other
93      )
94
95tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
96tokenPrim show' nextpos test
97    = tokenPrimEx show' nextpos Nothing test
98
99tokenPrimEx :: (tok -> String) ->
100               (SourcePos -> tok -> [tok] -> SourcePos) ->
101               Maybe (SourcePos -> tok -> [tok] -> st -> st) ->
102               (tok -> Maybe a) ->
103               GenParser tok st a
104tokenPrimEx show' nextpos mbNextState test
105    = case mbNextState of
106        Nothing
107          -> Parser (\(State input pos user) ->
108              case input of
109                (c:cs) -> case test c of
110                            Just x  -> let newpos   = nextpos pos c cs
111                                           newstate = State cs newpos user
112                                       in seq newpos $ seq newstate $
113                                          Consumed (Ok x newstate (newErrorUnknown newpos))
114                            Nothing -> Empty (sysUnExpectError (show' c) pos)
115                []     -> Empty (sysUnExpectError "" pos)
116             )
117        Just nextState
118          -> Parser (\(State input pos user) ->
119              case input of
120                (c:cs) -> case test c of
121                            Just x  -> let newpos   = nextpos pos c cs
122                                           newuser  = nextState pos c cs user
123                                           newstate = State cs newpos newuser
124                                       in seq newpos $ seq newstate $
125                                          Consumed (Ok x newstate (newErrorUnknown newpos))
126                            Nothing -> Empty (sysUnExpectError (show' c) pos)
127                []     -> Empty (sysUnExpectError "" pos)
128             )
129
130sysUnExpectError :: String -> SourcePos -> Reply tok st a
131sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)
132
133unknownError :: State tok st -> ParseError
134unknownError state        = newErrorUnknown (statePos state)
135
136skipMany :: GenParser tok st a -> GenParser tok st ()
137skipMany p
138  = do{ _ <- manyAccum (\_ _ -> []) p
139      ; return ()
140      }
141
142manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
143manyAccum accum (Parser p)
144  = Parser (\state0 ->
145    let walk xs state r = case r of
146                           Empty (Error err)        -> Ok xs state err
147                           Empty _                  -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
148                           Consumed (Error err)     -> Error err
149                           Consumed (Ok x state' _) -> let ys = accum x xs
150                                                       in seq ys (walk ys state' (p state'))
151    in case (p state0) of
152         Empty reply  -> case reply of
153                           Ok _ _ _ -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
154                           Error err       -> Empty (Ok [] state0 err)
155         consumed     -> Consumed $ walk [] state0 consumed)
156
157tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
158tokens shows' nextposs s
159    = Parser (\(State input pos user) ->
160       let
161        ok cs             = let newpos   = nextposs pos s
162                                newstate = State cs newpos user
163                            in seq newpos $ seq newstate $
164                               (Ok s newstate (newErrorUnknown newpos))
165
166        errEof            = Error (setErrorMessage (Expect (shows' s))
167                                     (newErrorMessage (SysUnExpect "") pos))
168        errExpect c       = Error (setErrorMessage (Expect (shows' s))
169                                     (newErrorMessage (SysUnExpect (shows' [c])) pos))
170
171        walk [] cs        = ok cs
172        walk _  []        = errEof
173        walk (x:xs) (c:cs)| x == c        = walk xs cs
174                          | otherwise     = errExpect c
175
176        walk1 [] cs        = Empty (ok cs)
177        walk1 _  []        = Empty (errEof)
178        walk1 (x:xs) (c:cs)| x == c        = Consumed (walk xs cs)
179                           | otherwise     = Empty (errExpect c)
180
181       in walk1 s input)
182
183data Message        = SysUnExpect !String
184                    | UnExpect    !String
185                    | Expect      !String
186                    | Message     !String
187
188messageToEnum :: Message -> Int
189messageToEnum msg
190    = case msg of SysUnExpect _ -> 0
191                  UnExpect _    -> 1
192                  Expect _      -> 2
193                  Message _     -> 3
194
195messageCompare :: Message -> Message -> Ordering
196messageCompare msg1 msg2
197    = compare (messageToEnum msg1) (messageToEnum msg2)
198
199messageEq :: Message -> Message -> Bool
200messageEq msg1 msg2
201    = (messageCompare msg1 msg2 == EQ)
202
203data ParseError     = ParseError !SourcePos [Message]
204
205newErrorUnknown :: SourcePos -> ParseError
206newErrorUnknown pos
207    = ParseError pos []
208
209newErrorMessage :: Message -> SourcePos -> ParseError
210newErrorMessage msg pos
211    = ParseError pos [msg]
212
213setErrorMessage :: Message -> ParseError -> ParseError
214setErrorMessage msg (ParseError pos msgs)
215    = ParseError pos (msg:filter (not . messageEq msg) msgs)
216
217mergeError :: ParseError -> ParseError -> ParseError
218mergeError (ParseError pos msgs1) (ParseError _ msgs2)
219    = ParseError pos (msgs1 ++ msgs2)
220
221type SourceName     = String
222type Line           = Int
223type Column         = Int
224
225data SourcePos      = SourcePos SourceName !Line !Column
226
227updatePosString :: SourcePos -> String -> SourcePos
228updatePosString pos str = forcePos (foldl updatePosChar pos str)
229
230updatePosChar   :: SourcePos -> Char -> SourcePos
231updatePosChar (SourcePos name line column) c
232    = forcePos $
233      case c of
234        '\n' -> SourcePos name (line+1) 1
235        '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8))
236        _    -> SourcePos name line (column + 1)
237
238
239forcePos :: SourcePos -> SourcePos
240forcePos pos@(SourcePos _name line column)
241    = seq line (seq column (pos))
242