{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Monad.Trans.Parser
  ( ParserT (..),
    ParseResult (..),
    ParseError (..),
    ErrorDesc (..),
  )
where

import Control.Monad
import Control.Monad.Cont.Class
import Control.Monad.Except
import Control.Monad.Parser.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Data.List (union)
import Data.Stream (Stream (..))

data ErrorDesc = Expected String | Note String deriving (ErrorDesc -> ErrorDesc -> Bool
(ErrorDesc -> ErrorDesc -> Bool)
-> (ErrorDesc -> ErrorDesc -> Bool) -> Eq ErrorDesc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorDesc -> ErrorDesc -> Bool
$c/= :: ErrorDesc -> ErrorDesc -> Bool
== :: ErrorDesc -> ErrorDesc -> Bool
$c== :: ErrorDesc -> ErrorDesc -> Bool
Eq)

data ParseError p = ParseError p [ErrorDesc]

makeOrList :: [String] -> String
makeOrList :: [String] -> String
makeOrList [] = String
""
makeOrList [String
x] = String
x
makeOrList [String
a, String
b] = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", or " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
makeOrList (String
x : [String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
makeOrList [String]
xs

instance Show p => Show (ParseError p) where
  show :: ParseError p -> String
show (ParseError p
p [ErrorDesc]
d) =
    p -> String
forall a. Show a => a -> String
show p
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
showExpects [String]
expects String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
showNotes [String]
notes
    where
      expects :: [String]
expects = [String
e | Expected String
e <- [ErrorDesc]
d]
      notes :: [String]
notes = [String
n | Note String
n <- [ErrorDesc]
d]
      showExpects :: [String] -> String
showExpects [] = String
""
      showExpects [String]
es = String
"expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
makeOrList [String]
es String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      showNotes :: [String] -> String
showNotes [] = String
""
      showNotes (String
n : [String]
ns) = String
"note: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
showNotes [String]
ns

joinErrors :: Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors :: ParseError p -> ParseError p -> ParseError p
joinErrors e1 :: ParseError p
e1@(ParseError p
p1 [ErrorDesc]
d1) e2 :: ParseError p
e2@(ParseError p
p2 [ErrorDesc]
d2)
  | [ErrorDesc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorDesc]
d1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([ErrorDesc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorDesc]
d2) = ParseError p
e2
  | [ErrorDesc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorDesc]
d2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([ErrorDesc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorDesc]
d1) = ParseError p
e1
  | p
p1 p -> p -> Bool
forall a. Ord a => a -> a -> Bool
> p
p2 = ParseError p
e1
  | p
p1 p -> p -> Bool
forall a. Ord a => a -> a -> Bool
< p
p2 = ParseError p
e2
  | Bool
otherwise = p -> [ErrorDesc] -> ParseError p
forall p. p -> [ErrorDesc] -> ParseError p
ParseError p
p1 ([ErrorDesc]
d1 [ErrorDesc] -> [ErrorDesc] -> [ErrorDesc]
forall a. Eq a => [a] -> [a] -> [a]
`union` [ErrorDesc]
d2)

emptyError :: Stream s => s -> ParseError (Pos s)
emptyError :: s -> ParseError (Pos s)
emptyError s
s = Pos s -> [ErrorDesc] -> ParseError (Pos s)
forall p. p -> [ErrorDesc] -> ParseError p
ParseError (s -> Pos s
forall s. Stream s => s -> Pos s
getPos s
s) []

data ParseResult v s
  = Parsed v s (ParseError (Pos s))
  | NoParse (ParseError (Pos s))

instance (Show v, Show (Pos s)) => Show (ParseResult v s) where
  show :: ParseResult v s -> String
show (Parsed v
v s
_ ParseError (Pos s)
_) = v -> String
forall a. Show a => a -> String
show v
v
  show (NoParse ParseError (Pos s)
e) = ParseError (Pos s) -> String
forall a. Show a => a -> String
show ParseError (Pos s)
e

-- | Parser monad transformer.

newtype ParserT s m a = ParserT {ParserT s m a -> s -> m (ParseResult a s)
runParserT :: s -> m (ParseResult a s)}

instance Functor m => Functor (ParserT s m) where
  fmap :: (a -> b) -> ParserT s m a -> ParserT s m b
fmap a -> b
f ParserT s m a
p = (s -> m (ParseResult b s)) -> ParserT s m b
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((ParseResult a s -> ParseResult b s)
-> m (ParseResult a s) -> m (ParseResult b s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseResult a s -> ParseResult b s
t (m (ParseResult a s) -> m (ParseResult b s))
-> (s -> m (ParseResult a s)) -> s -> m (ParseResult b s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
p)
    where
      t :: ParseResult a s -> ParseResult b s
t (NoParse ParseError (Pos s)
e) = ParseError (Pos s) -> ParseResult b s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse ParseError (Pos s)
e
      t (Parsed a
a s
s ParseError (Pos s)
e) = b -> s -> ParseError (Pos s) -> ParseResult b s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed (a -> b
f a
a) s
s ParseError (Pos s)
e

instance (Stream s, Applicative m, Monad m) => Applicative (ParserT s m) where
  pure :: a -> ParserT s m a
pure a
a = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> s -> ParseError (Pos s) -> ParseResult a s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed a
a s
s (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s)
  ParserT s m (a -> b)
mf <*> :: ParserT s m (a -> b) -> ParserT s m a -> ParserT s m b
<*> ParserT s m a
mx = (s -> m (ParseResult b s)) -> ParserT s m b
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult b s)) -> ParserT s m b)
-> (s -> m (ParseResult b s)) -> ParserT s m b
forall a b. (a -> b) -> a -> b
$ ParserT s m (a -> b) -> s -> m (ParseResult (a -> b) s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m (a -> b)
mf (s -> m (ParseResult (a -> b) s))
-> (ParseResult (a -> b) s -> m (ParseResult b s))
-> s
-> m (ParseResult b s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ParseResult (a -> b) s -> m (ParseResult b s)
pmf
    where
      pmf :: ParseResult (a -> b) s -> m (ParseResult b s)
pmf (NoParse ParseError (Pos s)
e) = ParseResult b s -> m (ParseResult b s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult b s -> m (ParseResult b s))
-> ParseResult b s -> m (ParseResult b s)
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseResult b s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse ParseError (Pos s)
e
      pmf (Parsed a -> b
f s
s ParseError (Pos s)
e1) = (a -> b)
-> ParseError (Pos s) -> ParseResult a s -> ParseResult b s
forall s t v.
Ord (Pos s) =>
(t -> v)
-> ParseError (Pos s) -> ParseResult t s -> ParseResult v s
pmx a -> b
f ParseError (Pos s)
e1 (ParseResult a s -> ParseResult b s)
-> m (ParseResult a s) -> m (ParseResult b s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
mx s
s
      pmx :: (t -> v)
-> ParseError (Pos s) -> ParseResult t s -> ParseResult v s
pmx t -> v
_ ParseError (Pos s)
e1 (NoParse ParseError (Pos s)
e2) = ParseError (Pos s) -> ParseResult v s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult v s)
-> ParseError (Pos s) -> ParseResult v s
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseError (Pos s) -> ParseError (Pos s)
forall p. Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors ParseError (Pos s)
e1 ParseError (Pos s)
e2
      pmx t -> v
f ParseError (Pos s)
e1 (Parsed t
x s
s' ParseError (Pos s)
e2) = v -> s -> ParseError (Pos s) -> ParseResult v s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed (t -> v
f t
x) s
s' (ParseError (Pos s) -> ParseResult v s)
-> ParseError (Pos s) -> ParseResult v s
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseError (Pos s) -> ParseError (Pos s)
forall p. Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors ParseError (Pos s)
e1 ParseError (Pos s)
e2

instance (Stream s, Monad m) => Monad (ParserT s m) where
  return :: a -> ParserT s m a
return = a -> ParserT s m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParserT s m a
m >>= :: ParserT s m a -> (a -> ParserT s m b) -> ParserT s m b
>>= a -> ParserT s m b
f = (s -> m (ParseResult b s)) -> ParserT s m b
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult b s)) -> ParserT s m b)
-> (s -> m (ParseResult b s)) -> ParserT s m b
forall a b. (a -> b) -> a -> b
$ ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
m (s -> m (ParseResult a s))
-> (ParseResult a s -> m (ParseResult b s))
-> s
-> m (ParseResult b s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ParseResult a s -> m (ParseResult b s)
first
    where
      first :: ParseResult a s -> m (ParseResult b s)
first (NoParse ParseError (Pos s)
e) = ParseResult b s -> m (ParseResult b s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult b s -> m (ParseResult b s))
-> ParseResult b s -> m (ParseResult b s)
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseResult b s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse ParseError (Pos s)
e
      first (Parsed a
r s
s ParseError (Pos s)
e) = ParseError (Pos s) -> ParseResult b s -> ParseResult b s
forall s v.
Ord (Pos s) =>
ParseError (Pos s) -> ParseResult v s -> ParseResult v s
second ParseError (Pos s)
e (ParseResult b s -> ParseResult b s)
-> m (ParseResult b s) -> m (ParseResult b s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT s m b -> s -> m (ParseResult b s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT (a -> ParserT s m b
f a
r) s
s
      second :: ParseError (Pos s) -> ParseResult v s -> ParseResult v s
second ParseError (Pos s)
e1 (NoParse ParseError (Pos s)
e2) = ParseError (Pos s) -> ParseResult v s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult v s)
-> ParseError (Pos s) -> ParseResult v s
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseError (Pos s) -> ParseError (Pos s)
forall p. Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors ParseError (Pos s)
e1 ParseError (Pos s)
e2
      second ParseError (Pos s)
e1 (Parsed v
r s
s ParseError (Pos s)
e2) = v -> s -> ParseError (Pos s) -> ParseResult v s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed v
r s
s (ParseError (Pos s) -> ParseResult v s)
-> ParseError (Pos s) -> ParseResult v s
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseError (Pos s) -> ParseError (Pos s)
forall p. Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors ParseError (Pos s)
e1 ParseError (Pos s)
e2

instance (Applicative m, Monad m, Stream s) => MonadFail (ParserT s m) where
  fail :: String -> ParserT s m a
fail String
msg = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a s -> m (ParseResult a s))
-> ParseResult a s -> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseResult a s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ Pos s -> [ErrorDesc] -> ParseError (Pos s)
forall p. p -> [ErrorDesc] -> ParseError p
ParseError (s -> Pos s
forall s. Stream s => s -> Pos s
getPos s
s) [String -> ErrorDesc
Note String
msg]

instance (Monad m, Stream s) => MonadParser (ParserT s m) where
  type Input (ParserT s m) = s

  parseStream :: ParserT s m (Input (ParserT s m))
parseStream = (s -> m (ParseResult s s)) -> ParserT s m s
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult s s)) -> ParserT s m s)
-> (s -> m (ParseResult s s)) -> ParserT s m s
forall a b. (a -> b) -> a -> b
$ \s
s -> ParseResult s s -> m (ParseResult s s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult s s -> m (ParseResult s s))
-> ParseResult s s -> m (ParseResult s s)
forall a b. (a -> b) -> a -> b
$ s -> s -> ParseError (Pos s) -> ParseResult s s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed s
s s
s (ParseError (Pos s) -> ParseResult s s)
-> ParseError (Pos s) -> ParseResult s s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s

  setParseStream :: Input (ParserT s m) -> ParserT s m ()
setParseStream Input (ParserT s m)
s = (s -> m (ParseResult () s)) -> ParserT s m ()
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult () s)) -> ParserT s m ())
-> (s -> m (ParseResult () s)) -> ParserT s m ()
forall a b. (a -> b) -> a -> b
$ \s
_ -> ParseResult () s -> m (ParseResult () s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult () s -> m (ParseResult () s))
-> ParseResult () s -> m (ParseResult () s)
forall a b. (a -> b) -> a -> b
$ () -> s -> ParseError (Pos s) -> ParseResult () s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed () s
Input (ParserT s m)
s (ParseError (Pos s) -> ParseResult () s)
-> ParseError (Pos s) -> ParseResult () s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
Input (ParserT s m)
s

  noParse :: ParserT s m a
noParse = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a s -> m (ParseResult a s))
-> ParseResult a s -> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseResult a s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s

  item :: ParserT s m (Item (Input (ParserT s m)))
item = (s -> m (ParseResult (Item s) s)) -> ParserT s m (Item s)
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult (Item s) s)) -> ParserT s m (Item s))
-> (s -> m (ParseResult (Item s) s)) -> ParserT s m (Item s)
forall a b. (a -> b) -> a -> b
$ ParseResult (Item s) s -> m (ParseResult (Item s) s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult (Item s) s -> m (ParseResult (Item s) s))
-> (s -> ParseResult (Item s) s) -> s -> m (ParseResult (Item s) s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> ParseResult (Item s) s
forall s. Stream s => s -> ParseResult (Item s) s
eat
    where
      eat :: s -> ParseResult (Item s) s
eat s
s = case s -> Maybe (Item s, s)
forall s. Stream s => s -> Maybe (Item s, s)
next s
s of
        Maybe (Item s, s)
Nothing -> ParseError (Pos s) -> ParseResult (Item s) s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult (Item s) s)
-> ParseError (Pos s) -> ParseResult (Item s) s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s
        Just (Item s
x, s
s') -> Item s -> s -> ParseError (Pos s) -> ParseResult (Item s) s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed Item s
x s
s' (ParseError (Pos s) -> ParseResult (Item s) s)
-> ParseError (Pos s) -> ParseResult (Item s) s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s'

  notFollowedBy :: ParserT s m a -> ParserT s m ()
notFollowedBy ParserT s m a
p = (s -> m (ParseResult () s)) -> ParserT s m ()
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult () s)) -> ParserT s m ())
-> (s -> m (ParseResult () s)) -> ParserT s m ()
forall a b. (a -> b) -> a -> b
$ \s
s -> s -> ParseResult a s -> ParseResult () s
forall s v s. Stream s => s -> ParseResult v s -> ParseResult () s
go s
s (ParseResult a s -> ParseResult () s)
-> m (ParseResult a s) -> m (ParseResult () s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
p s
s
    where
      go :: s -> ParseResult v s -> ParseResult () s
go s
s (NoParse ParseError (Pos s)
_) = () -> s -> ParseError (Pos s) -> ParseResult () s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed () s
s (ParseError (Pos s) -> ParseResult () s)
-> ParseError (Pos s) -> ParseResult () s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s
      go s
s ParseResult v s
_ = ParseError (Pos s) -> ParseResult () s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult () s)
-> ParseError (Pos s) -> ParseResult () s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s

  followedBy :: ParserT s m a -> ParserT s m ()
followedBy ParserT s m a
p = (s -> m (ParseResult () s)) -> ParserT s m ()
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult () s)) -> ParserT s m ())
-> (s -> m (ParseResult () s)) -> ParserT s m ()
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    ParseResult a s
r <- ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
p s
s
    ParseResult () s -> m (ParseResult () s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult () s -> m (ParseResult () s))
-> ParseResult () s -> m (ParseResult () s)
forall a b. (a -> b) -> a -> b
$ case ParseResult a s
r of
      (NoParse ParseError (Pos s)
e) -> ParseError (Pos s) -> ParseResult () s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse ParseError (Pos s)
e
      ParseResult a s
_ -> () -> s -> ParseError (Pos s) -> ParseResult () s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed () s
s (ParseError (Pos s) -> ParseResult () s)
-> ParseError (Pos s) -> ParseResult () s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s

  try :: ParserT s m a -> ParserT s m a
try ParserT s m a
p = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    ParseResult a s
r <- ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
p s
s
    ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a s -> m (ParseResult a s))
-> ParseResult a s -> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$ case ParseResult a s
r of
      NoParse ParseError (Pos s)
_ -> ParseError (Pos s) -> ParseResult a s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s
      ParseResult a s
_ -> ParseResult a s
r

  ParserT s m a
p <|> :: ParserT s m a -> ParserT s m a -> ParserT s m a
<|> ParserT s m a
q = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
p s
s m (ParseResult a s)
-> (ParseResult a s -> m (ParseResult a s)) -> m (ParseResult a s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> ParseResult a s -> m (ParseResult a s)
first s
s
    where
      first :: s -> ParseResult a s -> m (ParseResult a s)
first s
_ (Parsed a
a s
s' ParseError (Pos s)
e) = ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a s -> m (ParseResult a s))
-> ParseResult a s -> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$ a -> s -> ParseError (Pos s) -> ParseResult a s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed a
a s
s' ParseError (Pos s)
e
      first s
s (NoParse ParseError (Pos s)
e) = ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
q s
s m (ParseResult a s)
-> (ParseResult a s -> m (ParseResult a s)) -> m (ParseResult a s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseError (Pos s) -> ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) s v.
(Applicative f, Ord (Pos s)) =>
ParseError (Pos s) -> ParseResult v s -> f (ParseResult v s)
second ParseError (Pos s)
e
      second :: ParseError (Pos s) -> ParseResult v s -> f (ParseResult v s)
second ParseError (Pos s)
e1 (Parsed v
a s
s' ParseError (Pos s)
e2) = ParseResult v s -> f (ParseResult v s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult v s -> f (ParseResult v s))
-> ParseResult v s -> f (ParseResult v s)
forall a b. (a -> b) -> a -> b
$ v -> s -> ParseError (Pos s) -> ParseResult v s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed v
a s
s' (ParseError (Pos s) -> ParseResult v s)
-> ParseError (Pos s) -> ParseResult v s
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseError (Pos s) -> ParseError (Pos s)
forall p. Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors ParseError (Pos s)
e1 ParseError (Pos s)
e2
      second ParseError (Pos s)
e1 (NoParse ParseError (Pos s)
e2) = ParseResult v s -> f (ParseResult v s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult v s -> f (ParseResult v s))
-> ParseResult v s -> f (ParseResult v s)
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseResult v s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult v s)
-> ParseError (Pos s) -> ParseResult v s
forall a b. (a -> b) -> a -> b
$ ParseError (Pos s) -> ParseError (Pos s) -> ParseError (Pos s)
forall p. Ord p => ParseError p -> ParseError p -> ParseError p
joinErrors ParseError (Pos s)
e1 ParseError (Pos s)
e2

  ParserT s m a
p <?> :: ParserT s m a -> String -> ParserT s m a
<?> String
n = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> Pos s -> ParseResult a s -> ParseResult a s
labelize (s -> Pos s
forall s. Stream s => s -> Pos s
getPos s
s) (ParseResult a s -> ParseResult a s)
-> m (ParseResult a s) -> m (ParseResult a s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
p s
s
    where
      labelize :: Pos s -> ParseResult a s -> ParseResult a s
labelize Pos s
here (Parsed a
a s
s ParseError (Pos s)
e) = a -> s -> ParseError (Pos s) -> ParseResult a s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed a
a s
s (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ Pos s -> ParseError (Pos s) -> ParseError (Pos s)
name Pos s
here ParseError (Pos s)
e
      labelize Pos s
here (NoParse ParseError (Pos s)
e) = ParseError (Pos s) -> ParseResult a s
forall v s. ParseError (Pos s) -> ParseResult v s
NoParse (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ Pos s -> ParseError (Pos s) -> ParseError (Pos s)
name Pos s
here ParseError (Pos s)
e
      name :: Pos s -> ParseError (Pos s) -> ParseError (Pos s)
name Pos s
here e :: ParseError (Pos s)
e@(ParseError Pos s
pos [ErrorDesc]
_)
        | Pos s
pos Pos s -> Pos s -> Bool
forall a. Ord a => a -> a -> Bool
> Pos s
here = ParseError (Pos s)
e
        | Bool
otherwise = Pos s -> [ErrorDesc] -> ParseError (Pos s)
forall p. p -> [ErrorDesc] -> ParseError p
ParseError Pos s
here [String -> ErrorDesc
Expected String
n]

instance Stream s => MonadTrans (ParserT s) where
  lift :: m a -> ParserT s m a
lift m a
m = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    a
a <- m a
m
    ParseResult a s -> m (ParseResult a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a s -> m (ParseResult a s))
-> ParseResult a s -> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$ a -> s -> ParseError (Pos s) -> ParseResult a s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed a
a s
s (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s

instance (Stream s, MonadIO m) => MonadIO (ParserT s m) where
  liftIO :: IO a -> ParserT s m a
liftIO = m a -> ParserT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ParserT s m a) -> (IO a -> m a) -> IO a -> ParserT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance (Stream s, MonadState s' m) => MonadState s' (ParserT s m) where
  get :: ParserT s m s'
get = m s' -> ParserT s m s'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s'
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s' -> ParserT s m ()
put s'
s = m () -> ParserT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ParserT s m ()) -> m () -> ParserT s m ()
forall a b. (a -> b) -> a -> b
$ s' -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s'
s

instance (Stream s, MonadError e m) => MonadError e (ParserT s m) where
  throwError :: e -> ParserT s m a
throwError e
e = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ m (ParseResult a s) -> s -> m (ParseResult a s)
forall a b. a -> b -> a
const (m (ParseResult a s) -> s -> m (ParseResult a s))
-> m (ParseResult a s) -> s -> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$ e -> m (ParseResult a s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
  catchError :: ParserT s m a -> (e -> ParserT s m a) -> ParserT s m a
catchError ParserT s m a
m e -> ParserT s m a
f = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
m s
s m (ParseResult a s)
-> (e -> m (ParseResult a s)) -> m (ParseResult a s)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
e -> ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT (e -> ParserT s m a
f e
e) s
s

instance (Stream s, MonadReader r m) => MonadReader r (ParserT s m) where
  ask :: ParserT s m r
ask = m r -> ParserT s m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> ParserT s m a -> ParserT s m a
local r -> r
f ParserT s m a
st = (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> (r -> r) -> m (ParseResult a s) -> m (ParseResult a s)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT ParserT s m a
st s
s)

instance (Stream s, MonadCont m) => MonadCont (ParserT s m) where
  callCC :: ((a -> ParserT s m b) -> ParserT s m a) -> ParserT s m a
callCC (a -> ParserT s m b) -> ParserT s m a
f =
    (s -> m (ParseResult a s)) -> ParserT s m a
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult a s)) -> ParserT s m a)
-> (s -> m (ParseResult a s)) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$
      \s
s -> ((ParseResult a s -> m (ParseResult b s)) -> m (ParseResult a s))
-> m (ParseResult a s)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((ParseResult a s -> m (ParseResult b s)) -> m (ParseResult a s))
 -> m (ParseResult a s))
-> ((ParseResult a s -> m (ParseResult b s))
    -> m (ParseResult a s))
-> m (ParseResult a s)
forall a b. (a -> b) -> a -> b
$
        \ParseResult a s -> m (ParseResult b s)
k ->
          ParserT s m a -> s -> m (ParseResult a s)
forall s (m :: * -> *) a. ParserT s m a -> s -> m (ParseResult a s)
runParserT
            ( (a -> ParserT s m b) -> ParserT s m a
f ((a -> ParserT s m b) -> ParserT s m a)
-> (a -> ParserT s m b) -> ParserT s m a
forall a b. (a -> b) -> a -> b
$
                \a
a -> (s -> m (ParseResult b s)) -> ParserT s m b
forall s (m :: * -> *) a.
(s -> m (ParseResult a s)) -> ParserT s m a
ParserT ((s -> m (ParseResult b s)) -> ParserT s m b)
-> (s -> m (ParseResult b s)) -> ParserT s m b
forall a b. (a -> b) -> a -> b
$ \s
s' -> ParseResult a s -> m (ParseResult b s)
k (ParseResult a s -> m (ParseResult b s))
-> ParseResult a s -> m (ParseResult b s)
forall a b. (a -> b) -> a -> b
$ a -> s -> ParseError (Pos s) -> ParseResult a s
forall v s. v -> s -> ParseError (Pos s) -> ParseResult v s
Parsed a
a s
s' (ParseError (Pos s) -> ParseResult a s)
-> ParseError (Pos s) -> ParseResult a s
forall a b. (a -> b) -> a -> b
$ s -> ParseError (Pos s)
forall s. Stream s => s -> ParseError (Pos s)
emptyError s
s'
            )
            s
s