-
Notifications
You must be signed in to change notification settings - Fork 50
/
Parser.purs
146 lines (115 loc) · 5.62 KB
/
Parser.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
module Text.Parsing.Parser
( ParseError(..)
, parseErrorMessage
, parseErrorPosition
, ParseState(..)
, ParserT(..)
, Parser
, runParser
, runParserT
, hoistParserT
, mapParserT
, consume
, position
, fail
, failWithPosition
, region
) where
import Prelude
import Control.Alt (class Alt)
import Control.Apply (lift2)
import Control.Lazy (defer, class Lazy)
import Control.Monad.Error.Class (class MonadThrow, throwError, catchError)
import Control.Monad.Except (class MonadError, ExceptT(..), runExceptT, mapExceptT)
import Control.Monad.Rec.Class (class MonadRec)
import Control.Monad.State (class MonadState, StateT(..), evalStateT, gets, mapStateT, modify_, runStateT)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.MonadPlus (class Alternative, class MonadZero, class MonadPlus, class Plus)
import Data.Either (Either(..))
import Data.Identity (Identity)
import Data.Newtype (class Newtype, unwrap, over)
import Data.Tuple (Tuple(..))
import Text.Parsing.Parser.Pos (Position, initialPos)
-- | A parsing error, consisting of a message and position information.
data ParseError = ParseError String Position
parseErrorMessage :: ParseError -> String
parseErrorMessage (ParseError msg _) = msg
parseErrorPosition :: ParseError -> Position
parseErrorPosition (ParseError _ pos) = pos
instance showParseError :: Show ParseError where
show (ParseError msg pos) =
"(ParseError " <> show msg <> " " <> show pos <> ")"
derive instance eqParseError :: Eq ParseError
derive instance ordParseError :: Ord ParseError
-- | Contains the remaining input and current position.
data ParseState s = ParseState s Position Boolean
-- | The Parser monad transformer.
-- |
-- | The first type argument is the stream type. Typically, this is either `String`,
-- | or some sort of token stream.
newtype ParserT s m a = ParserT (ExceptT ParseError (StateT (ParseState s) m) a)
derive instance newtypeParserT :: Newtype (ParserT s m a) _
-- | Apply a parser, keeping only the parsed result.
runParserT :: forall m s a. Monad m => s -> ParserT s m a -> m (Either ParseError a)
runParserT s p = evalStateT (runExceptT (unwrap p)) initialState where
initialState = ParseState s initialPos false
-- | The `Parser` monad is a synonym for the parser monad transformer applied to the `Identity` monad.
type Parser s = ParserT s Identity
-- | Apply a parser, keeping only the parsed result.
runParser :: forall s a. s -> Parser s a -> Either ParseError a
runParser s = unwrap <<< runParserT s
hoistParserT :: forall s m n a. (m ~> n) -> ParserT s m a -> ParserT s n a
hoistParserT = mapParserT
-- | Change the underlying monad action and data type in a ParserT monad action.
mapParserT :: forall b n s a m.
( m (Tuple (Either ParseError a) (ParseState s))
-> n (Tuple (Either ParseError b) (ParseState s))
) -> ParserT s m a -> ParserT s n b
mapParserT = over ParserT <<< mapExceptT <<< mapStateT
instance lazyParserT :: Lazy (ParserT s m a) where
defer f = ParserT (ExceptT (defer (runExceptT <<< unwrap <<< f)))
instance semigroupParserT :: (Monad m, Semigroup a) => Semigroup (ParserT s m a) where
append = lift2 (<>)
instance monoidParserT :: (Monad m, Monoid a) => Monoid (ParserT s m a) where
mempty = pure mempty
derive newtype instance functorParserT :: Functor m => Functor (ParserT s m)
derive newtype instance applyParserT :: Monad m => Apply (ParserT s m)
derive newtype instance applicativeParserT :: Monad m => Applicative (ParserT s m)
derive newtype instance bindParserT :: Monad m => Bind (ParserT s m)
derive newtype instance monadParserT :: Monad m => Monad (ParserT s m)
derive newtype instance monadRecParserT :: MonadRec m => MonadRec (ParserT s m)
derive newtype instance monadStateParserT :: Monad m => MonadState (ParseState s) (ParserT s m)
derive newtype instance monadThrowParserT :: Monad m => MonadThrow ParseError (ParserT s m)
derive newtype instance monadErrorParserT :: Monad m => MonadError ParseError (ParserT s m)
instance altParserT :: Monad m => Alt (ParserT s m) where
alt p1 p2 = (ParserT <<< ExceptT <<< StateT) \(s@(ParseState i p _)) -> do
Tuple e s'@(ParseState _ _ c') <- runStateT (runExceptT (unwrap p1)) (ParseState i p false)
case e of
Left _
| not c' -> runStateT (runExceptT (unwrap p2)) s
_ -> pure (Tuple e s')
instance plusParserT :: Monad m => Plus (ParserT s m) where
empty = fail "No alternative"
instance alternativeParserT :: Monad m => Alternative (ParserT s m)
instance monadZeroParserT :: Monad m => MonadZero (ParserT s m)
instance monadPlusParserT :: Monad m => MonadPlus (ParserT s m)
instance monadTransParserT :: MonadTrans (ParserT s) where
lift = ParserT <<< lift <<< lift
-- | Set the consumed flag.
consume :: forall s m. Monad m => ParserT s m Unit
consume = modify_ \(ParseState input pos _) ->
ParseState input pos true
-- | Returns the current position in the stream.
position :: forall s m. Monad m => ParserT s m Position
position = gets \(ParseState _ pos _) -> pos
-- | Fail with a message.
fail :: forall m s a. Monad m => String -> ParserT s m a
fail message = failWithPosition message =<< position
-- | Fail with a message and a position.
failWithPosition :: forall m s a. Monad m => String -> Position -> ParserT s m a
failWithPosition message pos = throwError (ParseError message pos)
-- | Contextualize parsing failures inside a region. If a parsing failure
-- | occurs, then the `ParseError` will be transformed by each containing
-- | `region` as the parser backs out the call stack.
region :: forall m s a. Monad m => (ParseError -> ParseError) -> ParserT s m a -> ParserT s m a
region context p = catchError p $ \err -> throwError $ context err