module Text.Megaparsec.Prim
(
State (..)
, Stream (..)
, Parsec
, ParsecT
, MonadParsec (..)
, (<?>)
, unexpected
, getInput
, setInput
, getPosition
, setPosition
, pushPosition
, popPosition
, getTabWidth
, setTabWidth
, setParserState
, runParser
, runParser'
, runParserT
, runParserT'
, parse
, parseMaybe
, parseTest )
where
import Control.Monad
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Identity
import Control.Monad.Reader.Class
import Control.Monad.State.Class hiding (state)
import Control.Monad.Trans
import Control.Monad.Trans.Identity
import Data.Foldable (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid hiding ((<>))
import Data.Proxy
import Data.Semigroup
import Data.Set (Set)
import Prelude hiding (all)
import qualified Control.Applicative as A
import qualified Control.Monad.Fail as Fail
import qualified Control.Monad.Trans.Reader as L
import qualified Control.Monad.Trans.State.Lazy as L
import qualified Control.Monad.Trans.State.Strict as S
import qualified Control.Monad.Trans.Writer.Lazy as L
import qualified Control.Monad.Trans.Writer.Strict as S
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as E
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*), pure)
#endif
data State s = State
{ stateInput :: s
, statePos :: NonEmpty SourcePos
, stateTabWidth :: Pos }
deriving (Show, Eq)
data Reply e s a = Reply (State s) Consumption (Result (Token s) e a)
data Consumption
= Consumed
| Virgin
data Result t e a
= OK a
| Error (ParseError t e)
newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid)
toHints :: ParseError t e -> Hints t
toHints err = Hints hints
where hints = if E.null msgs then [] else [msgs]
msgs = errorExpected err
withHints :: Ord (Token s)
=> Hints (Token s)
-> (ParseError (Token s) e -> State s -> m b)
-> ParseError (Token s) e
-> State s
-> m b
withHints (Hints ps') c e@(ParseError pos us ps xs) =
if E.null us && E.null ps && not (E.null xs)
then c e
else c (ParseError pos us (E.unions (ps : ps')) xs)
accHints
:: Hints t
-> (a -> State s -> Hints t -> m b)
-> a
-> State s
-> Hints t
-> m b
accHints hs1 c x s hs2 = c x s (hs1 <> hs2)
refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t
refreshLastHint (Hints []) _ = Hints []
refreshLastHint (Hints (_:xs)) Nothing = Hints xs
refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs)
class Ord (Token s) => Stream s where
type Token s :: *
uncons :: s -> Maybe (Token s, s)
updatePos
:: Proxy s
-> Pos
-> SourcePos
-> Token s
-> (SourcePos, SourcePos)
instance Stream String where
type Token String = Char
uncons [] = Nothing
uncons (t:ts) = Just (t, ts)
updatePos = const defaultUpdatePos
instance Stream B.ByteString where
type Token B.ByteString = Char
uncons = B.uncons
updatePos = const defaultUpdatePos
instance Stream BL.ByteString where
type Token BL.ByteString = Char
uncons = BL.uncons
updatePos = const defaultUpdatePos
instance Stream T.Text where
type Token T.Text = Char
uncons = T.uncons
updatePos = const defaultUpdatePos
instance Stream TL.Text where
type Token TL.Text = Char
uncons = TL.uncons
updatePos = const defaultUpdatePos
type Parsec e s = ParsecT e s Identity
newtype ParsecT e s m a = ParsecT
{ unParser
:: forall b. State s
-> (a -> State s -> Hints (Token s) -> m b)
-> (ParseError (Token s) e -> State s -> m b)
-> (a -> State s -> Hints (Token s) -> m b)
-> (ParseError (Token s) e -> State s -> m b)
-> m b }
instance Functor (ParsecT e s m) where
fmap = pMap
pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b
pMap f p = ParsecT $ \s cok cerr eok eerr ->
unParser p s (cok . f) cerr (eok . f) eerr
instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where
pure = pPure
(<*>) = pAp
p1 *> p2 = p1 `pBind` const p2
p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 }
pAp :: Stream s
=> ParsecT e s m (a -> b)
-> ParsecT e s m a
-> ParsecT e s m b
pAp m k = ParsecT $ \s cok cerr eok eerr ->
let mcok x s' hs = unParser k s' (cok . x) cerr
(accHints hs (cok . x)) (withHints hs cerr)
meok x s' hs = unParser k s' (cok . x) cerr
(accHints hs (eok . x)) (withHints hs eerr)
in unParser m s mcok cerr meok eerr
instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where
empty = mzero
(<|>) = mplus
many p = reverse <$> manyAcc p
manyAcc :: ParsecT e s m a -> ParsecT e s m [a]
manyAcc p = ParsecT $ \s cok cerr eok _ ->
let errToHints c err _ = c (toHints err)
walk xs x s' _ =
unParser p s'
(seq xs $ walk $ x:xs)
cerr
manyErr
(errToHints $ cok (x:xs) s')
in unParser p s (walk []) cerr manyErr (errToHints $ eok [] s)
manyErr :: a
manyErr = error $
"Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser"
++ " that accepts an empty string."
instance (ErrorComponent e, Stream s)
=> Monad (ParsecT e s m) where
return = pure
(>>=) = pBind
fail = Fail.fail
pPure :: a -> ParsecT e s m a
pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty
pBind :: Stream s
=> ParsecT e s m a
-> (a -> ParsecT e s m b)
-> ParsecT e s m b
pBind m k = ParsecT $ \s cok cerr eok eerr ->
let mcok x s' hs = unParser (k x) s' cok cerr
(accHints hs cok) (withHints hs cerr)
meok x s' hs = unParser (k x) s' cok cerr
(accHints hs eok) (withHints hs eerr)
in unParser m s mcok cerr meok eerr
instance (ErrorComponent e, Stream s)
=> Fail.MonadFail (ParsecT e s m) where
fail = pFail
pFail :: ErrorComponent e => String -> ParsecT e s m a
pFail msg = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->
eerr (ParseError pos E.empty E.empty d) s
where d = E.singleton (representFail msg)
mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a
mkPT k = ParsecT $ \s cok cerr eok eerr -> do
(Reply s' consumption result) <- k s
case consumption of
Consumed ->
case result of
OK x -> cok x s' mempty
Error e -> cerr e s'
Virgin ->
case result of
OK x -> eok x s' mempty
Error e -> eerr e s'
instance (ErrorComponent e, Stream s, MonadIO m)
=> MonadIO (ParsecT e s m) where
liftIO = lift . liftIO
instance (ErrorComponent e, Stream s, MonadReader r m)
=> MonadReader r (ParsecT e s m) where
ask = lift ask
local f p = mkPT $ \s -> local f (runParsecT p s)
instance (ErrorComponent e, Stream s, MonadState st m)
=> MonadState st (ParsecT e s m) where
get = lift get
put = lift . put
instance (ErrorComponent e, Stream s, MonadCont m)
=> MonadCont (ParsecT e s m) where
callCC f = mkPT $ \s ->
callCC $ \c ->
runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s
where pack s a = Reply s Virgin (OK a)
instance (ErrorComponent e, Stream s, MonadError e' m)
=> MonadError e' (ParsecT e s m) where
throwError = lift . throwError
p `catchError` h = mkPT $ \s ->
runParsecT p s `catchError` \e ->
runParsecT (h e) s
instance (ErrorComponent e, Stream s)
=> MonadPlus (ParsecT e s m) where
mzero = pZero
mplus = pPlus
pZero :: ParsecT e s m a
pZero = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->
eerr (ParseError pos E.empty E.empty E.empty) s
pPlus :: (ErrorComponent e, Stream s)
=> ParsecT e s m a
-> ParsecT e s m a
-> ParsecT e s m a
pPlus m n = ParsecT $ \s cok cerr eok eerr ->
let meerr err ms =
let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')
neok x s' hs = eok x s' (toHints err <> hs)
neerr err' s' = eerr (err' <> err) (longestMatch ms s')
in unParser n s cok ncerr neok neerr
in unParser m s cok cerr eok meerr
longestMatch :: State s -> State s -> State s
longestMatch s1@(State _ pos1 _) s2@(State _ pos2 _) =
case pos1 `compare` pos2 of
LT -> s2
EQ -> s2
GT -> s1
instance MonadTrans (ParsecT e s) where
lift amb = ParsecT $ \s _ _ eok _ ->
amb >>= \a -> eok a s mempty
class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m)
=> MonadParsec e s m | m -> e s where
failure
:: Set (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> Set e
-> m a
label :: String -> m a -> m a
hidden :: m a -> m a
hidden = label ""
try :: m a -> m a
lookAhead :: m a -> m a
notFollowedBy :: m a -> m ()
withRecovery
:: (ParseError (Token s) e -> m a)
-> m a
-> m a
eof :: m ()
token
:: (Token s -> Either ( Set (ErrorItem (Token s))
, Set (ErrorItem (Token s))
, Set e ) a)
-> Maybe (Token s)
-> m a
tokens
:: (Token s -> Token s -> Bool)
-> [Token s]
-> m [Token s]
getParserState :: m (State s)
updateParserState :: (State s -> State s) -> m ()
instance (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where
failure = pFailure
label = pLabel
try = pTry
lookAhead = pLookAhead
notFollowedBy = pNotFollowedBy
withRecovery = pWithRecovery
eof = pEof
token = pToken
tokens = pTokens
getParserState = pGetParserState
updateParserState = pUpdateParserState
pFailure
:: Set (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> Set e
-> ParsecT e s m a
pFailure us ps xs = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->
eerr (ParseError pos us ps xs) s
pLabel :: String -> ParsecT e s m a -> ParsecT e s m a
pLabel l p = ParsecT $ \s cok cerr eok eerr ->
let el = Label <$> NE.nonEmpty l
cl = Label . (NE.fromList "rest of " <>) <$> NE.nonEmpty l
cok' x s' hs = cok x s' (refreshLastHint hs cl)
eok' x s' hs = eok x s' (refreshLastHint hs el)
eerr' err = eerr err
{ errorExpected = maybe E.empty E.singleton el }
in unParser p s cok' cerr eok' eerr'
pTry :: ParsecT e s m a -> ParsecT e s m a
pTry p = ParsecT $ \s cok _ eok eerr ->
unParser p s cok eerr eok eerr
pLookAhead :: ParsecT e s m a -> ParsecT e s m a
pLookAhead p = ParsecT $ \s _ cerr eok eerr ->
let eok' a _ _ = eok a s mempty
in unParser p s eok' cerr eok' eerr
pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()
pNotFollowedBy p = ParsecT $ \s@(State input pos _) _ _ eok eerr ->
let what = maybe EndOfInput (Tokens . nes . fst) (uncons input)
unexpect u = ParseError pos (E.singleton u) E.empty E.empty
cok' _ _ _ = eerr (unexpect what) s
cerr' _ _ = eok () s mempty
eok' _ _ _ = eerr (unexpect what) s
eerr' _ _ = eok () s mempty
in unParser p s cok' cerr' eok' eerr'
pWithRecovery
:: (ParseError (Token s) e -> ParsecT e s m a)
-> ParsecT e s m a
-> ParsecT e s m a
pWithRecovery r p = ParsecT $ \s cok cerr eok eerr ->
let mcerr err ms =
let rcok x s' _ = cok x s' mempty
rcerr _ _ = cerr err ms
reok x s' _ = eok x s' (toHints err)
reerr _ _ = cerr err ms
in unParser (r err) ms rcok rcerr reok reerr
meerr err ms =
let rcok x s' _ = cok x s' (toHints err)
rcerr _ _ = eerr err ms
reok x s' _ = eok x s' (toHints err)
reerr _ _ = eerr err ms
in unParser (r err) ms rcok rcerr reok reerr
in unParser p s cok mcerr eok meerr
pEof :: forall e s m. Stream s => ParsecT e s m ()
pEof = ParsecT $ \s@(State input (pos:|z) w) _ _ eok eerr ->
case uncons input of
Nothing -> eok () s mempty
Just (x,_) ->
let !apos = fst (updatePos (Proxy :: Proxy s) w pos x)
in eerr ParseError
{ errorPos = apos:|z
, errorUnexpected = (E.singleton . Tokens . nes) x
, errorExpected = E.singleton EndOfInput
, errorCustom = E.empty }
(State input (apos:|z) w)
pToken :: forall e s m a. Stream s
=> (Token s -> Either ( Set (ErrorItem (Token s))
, Set (ErrorItem (Token s))
, Set e ) a)
-> Maybe (Token s)
-> ParsecT e s m a
pToken test mtoken = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr ->
case uncons input of
Nothing -> eerr ParseError
{ errorPos = pos:|z
, errorUnexpected = E.singleton EndOfInput
, errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtoken
, errorCustom = E.empty } s
Just (c,cs) ->
let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c
in case test c of
Left (us, ps, xs) ->
apos `seq` eerr
(ParseError (apos:|z) us ps xs)
(State input (apos:|z) w)
Right x ->
let newstate = State cs (npos:|z) w
in npos `seq` cok x newstate mempty
pTokens :: forall e s m. Stream s
=> (Token s -> Token s -> Bool)
-> [Token s]
-> ParsecT e s m [Token s]
pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty
pTokens test tts = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr ->
let updatePos' = updatePos (Proxy :: Proxy s) w
toTokens = Tokens . NE.fromList . reverse
unexpect pos' u = ParseError
{ errorPos = pos'
, errorUnexpected = E.singleton u
, errorExpected = (E.singleton . Tokens . NE.fromList) tts
, errorCustom = E.empty }
go _ [] is rs =
let ris = reverse is
!npos = foldl' (\p t -> snd (updatePos' p t)) pos ris
in cok ris (State rs (npos:|z) w) mempty
go apos (t:ts) is rs =
case uncons rs of
Nothing ->
apos `seq` eerr
(unexpect (apos:|z) (toTokens is))
(State input (apos:|z) w)
Just (x,xs) ->
if test t x
then go apos ts (x:is) xs
else apos `seq` eerr
(unexpect (apos:|z) . toTokens $ x:is)
(State input (apos:|z) w)
in case uncons input of
Nothing ->
eerr (unexpect (pos:|z) EndOfInput) s
Just (x,xs) ->
let t:ts = tts
apos = fst (updatePos' pos x)
in if test t x
then go apos ts [x] xs
else apos `seq` eerr
(unexpect (apos:|z) $ Tokens (nes x))
(State input (apos:|z) w)
pGetParserState :: ParsecT e s m (State s)
pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty
pUpdateParserState :: (State s -> State s) -> ParsecT e s m ()
pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty
infix 0 <?>
(<?>) :: MonadParsec e s m => m a -> String -> m a
(<?>) = flip label
unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a
unexpected item = failure (E.singleton item) E.empty E.empty
nes :: a -> NonEmpty a
nes x = x :| []
getInput :: MonadParsec e s m => m s
getInput = stateInput <$> getParserState
setInput :: MonadParsec e s m => s -> m ()
setInput s = updateParserState (\(State _ pos w) -> State s pos w)
getPosition :: MonadParsec e s m => m SourcePos
getPosition = NE.head . statePos <$> getParserState
setPosition :: MonadParsec e s m => SourcePos -> m ()
setPosition pos = updateParserState $ \(State s (_:|z) w) ->
State s (pos:|z) w
pushPosition :: MonadParsec e s m => SourcePos -> m ()
pushPosition pos = updateParserState $ \(State s z w) ->
State s (NE.cons pos z) w
popPosition :: MonadParsec e s m => m ()
popPosition = updateParserState $ \(State s z w) ->
case snd (NE.uncons z) of
Nothing -> State s z w
Just z' -> State s z' w
getTabWidth :: MonadParsec e s m => m Pos
getTabWidth = stateTabWidth <$> getParserState
setTabWidth :: MonadParsec e s m => Pos -> m ()
setTabWidth w = updateParserState (\(State s pos _) -> State s pos w)
setParserState :: MonadParsec e s m => State s -> m ()
setParserState st = updateParserState (const st)
parse
:: Parsec e s a
-> String
-> s
-> Either (ParseError (Token s) e) a
parse = runParser
parseMaybe :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe p s =
case parse (p <* eof) "" s of
Left _ -> Nothing
Right x -> Just x
parseTest :: ( ShowErrorComponent e
, Ord (Token s)
, ShowToken (Token s)
, Show a )
=> Parsec e s a
-> s
-> IO ()
parseTest p input =
case parse p "" input of
Left e -> putStr (parseErrorPretty e)
Right x -> print x
runParser
:: Parsec e s a
-> String
-> s
-> Either (ParseError (Token s) e) a
runParser p name s = snd $ runParser' p (initialState name s)
runParser'
:: Parsec e s a
-> State s
-> (State s, Either (ParseError (Token s) e) a)
runParser' p = runIdentity . runParserT' p
runParserT :: Monad m
=> ParsecT e s m a
-> String
-> s
-> m (Either (ParseError (Token s) e) a)
runParserT p name s = snd `liftM` runParserT' p (initialState name s)
runParserT' :: Monad m
=> ParsecT e s m a
-> State s
-> m (State s, Either (ParseError (Token s) e) a)
runParserT' p s = do
(Reply s' _ result) <- runParsecT p s
case result of
OK x -> return (s', Right x)
Error e -> return (s', Left e)
initialState :: String -> s -> State s
initialState name s = State s (initialPos name :| []) defaultTabWidth
runParsecT :: Monad m
=> ParsecT e s m a
-> State s
-> m (Reply e s a)
runParsecT p s = unParser p s cok cerr eok eerr
where cok a s' _ = return $ Reply s' Consumed (OK a)
cerr err s' = return $ Reply s' Consumed (Error err)
eok a s' _ = return $ Reply s' Virgin (OK a)
eerr err s' = return $ Reply s' Virgin (Error err)
instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where
failure us ps xs = lift (failure us ps xs)
label n (L.StateT m) = L.StateT $ label n . m
try (L.StateT m) = L.StateT $ try . m
lookAhead (L.StateT m) = L.StateT $ \s ->
(,s) . fst <$> lookAhead (m s)
notFollowedBy (L.StateT m) = L.StateT $ \s ->
notFollowedBy (fst <$> m s) >> return ((),s)
withRecovery r (L.StateT m) = L.StateT $ \s ->
withRecovery (\e -> L.runStateT (r e) s) (m s)
eof = lift eof
token test mt = lift (token test mt)
tokens e ts = lift (tokens e ts)
getParserState = lift getParserState
updateParserState f = lift (updateParserState f)
instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where
failure us ps xs = lift (failure us ps xs)
label n (S.StateT m) = S.StateT $ label n . m
try (S.StateT m) = S.StateT $ try . m
lookAhead (S.StateT m) = S.StateT $ \s ->
(,s) . fst <$> lookAhead (m s)
notFollowedBy (S.StateT m) = S.StateT $ \s ->
notFollowedBy (fst <$> m s) >> return ((),s)
withRecovery r (S.StateT m) = S.StateT $ \s ->
withRecovery (\e -> S.runStateT (r e) s) (m s)
eof = lift eof
token test mt = lift (token test mt)
tokens e ts = lift (tokens e ts)
getParserState = lift getParserState
updateParserState f = lift (updateParserState f)
instance MonadParsec e s m => MonadParsec e s (L.ReaderT st m) where
failure us ps xs = lift (failure us ps xs)
label n (L.ReaderT m) = L.ReaderT $ label n . m
try (L.ReaderT m) = L.ReaderT $ try . m
lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m
notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m
withRecovery r (L.ReaderT m) = L.ReaderT $ \s ->
withRecovery (\e -> L.runReaderT (r e) s) (m s)
eof = lift eof
token test mt = lift (token test mt)
tokens e ts = lift (tokens e ts)
getParserState = lift getParserState
updateParserState f = lift (updateParserState f)
instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where
failure us ps xs = lift (failure us ps xs)
label n (L.WriterT m) = L.WriterT $ label n m
try (L.WriterT m) = L.WriterT $ try m
lookAhead (L.WriterT m) = L.WriterT $
(,mempty) . fst <$> lookAhead m
notFollowedBy (L.WriterT m) = L.WriterT $
(,mempty) <$> notFollowedBy (fst <$> m)
withRecovery r (L.WriterT m) = L.WriterT $
withRecovery (L.runWriterT . r) m
eof = lift eof
token test mt = lift (token test mt)
tokens e ts = lift (tokens e ts)
getParserState = lift getParserState
updateParserState f = lift (updateParserState f)
instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where
failure us ps xs = lift (failure us ps xs)
label n (S.WriterT m) = S.WriterT $ label n m
try (S.WriterT m) = S.WriterT $ try m
lookAhead (S.WriterT m) = S.WriterT $
(,mempty) . fst <$> lookAhead m
notFollowedBy (S.WriterT m) = S.WriterT $
(,mempty) <$> notFollowedBy (fst <$> m)
withRecovery r (S.WriterT m) = S.WriterT $
withRecovery (S.runWriterT . r) m
eof = lift eof
token test mt = lift (token test mt)
tokens e ts = lift (tokens e ts)
getParserState = lift getParserState
updateParserState f = lift (updateParserState f)
instance MonadParsec e s m => MonadParsec e s (IdentityT m) where
failure us ps xs = lift (failure us ps xs)
label n (IdentityT m) = IdentityT $ label n m
try = IdentityT . try . runIdentityT
lookAhead (IdentityT m) = IdentityT $ lookAhead m
notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m
withRecovery r (IdentityT m) = IdentityT $
withRecovery (runIdentityT . r) m
eof = lift eof
token test mt = lift (token test mt)
tokens e ts = lift $ tokens e ts
getParserState = lift getParserState
updateParserState f = lift $ updateParserState f