{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}

module Control.Monad.Parser.Class
  ( module Control.Monad.Parser.Class,
  )
where

import Control.Applicative ((<**>))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Stream

infixl 3 <|>

infixl 1 <?>

-- | A monad with parsing capabilities.

class Monad m => MonadParser s m | m -> s where
  -- | The current input stream.

  parseStream :: m s

  -- | Replace the input stream.

  setParseStream :: s -> m ()

  -- | A parser that always fails.

  noParse :: m a

  -- | A parser that returns the next item.

  item :: m (Item s)

  -- | @followedBy p@ is a parser that succeeds if @p@ succeeds, but it does not

  -- consume any input.

  followedBy :: m a -> m ()

  -- | @notFollowedBy p@ is a parser that only succeeds if @p@ fails. This

  -- parser will not consume any input.

  notFollowedBy :: m a -> m ()

  -- | @try p@ is a parser that does everything like @p@, except it forcefully

  -- resets the position of any error reported by @p@ to the current position.

  try :: m a -> m a

  -- | @p <|> q@ is a parser that is equivalent to @p@ when @p@ succeeds and

  -- @q@ when @p@ fails to parse anything.

  (<|>) :: m a -> m a -> m a

  -- | @p <?> msg@ is a parser that behaves like @p@, but when @p@ fails, it

  -- reports an error indicating that @msg@ was the expected input.

  (<?>) :: m a -> String -> m a

-- | Parser that succeeds if the stream is empty. Does not consume any items.

eof :: MonadParser s m => m ()
eof :: m ()
eof = m (Item s) -> m ()
forall s (m :: * -> *) a. MonadParser s m => m a -> m ()
notFollowedBy m (Item s)
forall s (m :: * -> *). MonadParser s m => m (Item s)
item m () -> String -> m ()
forall s (m :: * -> *) a. MonadParser s m => m a -> String -> m a
<?> String
"end of input"

-- | Fail with an "expected" message.

expected :: MonadParser s m => String -> m a
expected :: String -> m a
expected String
s = m a
forall s (m :: * -> *) a. MonadParser s m => m a
noParse m a -> String -> m a
forall s (m :: * -> *) a. MonadParser s m => m a -> String -> m a
<?> String
s

-- | Succeeds only if the value parsed by the parser satisfies the predicate.

satisfy :: MonadParser s m => m a -> (a -> Bool) -> m a
satisfy :: m a -> (a -> Bool) -> m a
satisfy m a
p a -> Bool
f = m a -> m a
forall s (m :: * -> *) a. MonadParser s m => m a -> m a
try (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
  a
i <- m a
p
  if a -> Bool
f a
i
    then a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
i
    else m a
forall s (m :: * -> *) a. MonadParser s m => m a
noParse

-- | Parse a single item satisfying the given predicate.

match :: MonadParser s m => (Item s -> Bool) -> m (Item s)
match :: (Item s -> Bool) -> m (Item s)
match = m (Item s) -> (Item s -> Bool) -> m (Item s)
forall s (m :: * -> *) a.
MonadParser s m =>
m a -> (a -> Bool) -> m a
satisfy m (Item s)
forall s (m :: * -> *). MonadParser s m => m (Item s)
item

-- | Make a parser optional.

optional :: MonadParser s m => m a -> m (Maybe a)
optional :: m a -> m (Maybe a)
optional m a
p = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall s (m :: * -> *) a. MonadParser s m => m a -> m a -> m a
<|> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Try a series of parsers in order, returning the first one that succeeds.

choice :: MonadParser s m => [m a] -> m a
choice :: [m a] -> m a
choice = (m a -> m a -> m a) -> m a -> [m a] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr m a -> m a -> m a
forall s (m :: * -> *) a. MonadParser s m => m a -> m a -> m a
(<|>) m a
forall s (m :: * -> *) a. MonadParser s m => m a
noParse

-- | Try to run the given parser as many times as possible.

many :: MonadParser s m => m a -> m [a]
many :: m a -> m [a]
many m a
p = ((:) (a -> [a] -> [a]) -> m a -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p m ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a -> m [a]
forall s (m :: * -> *) a. MonadParser s m => m a -> m [a]
many m a
p) m [a] -> m [a] -> m [a]
forall s (m :: * -> *) a. MonadParser s m => m a -> m a -> m a
<|> [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Try to run the given parser as many times as possible, but at least once.

-- The result is returned as a regular list, but is guaranteed to be non-empty.

many1 :: MonadParser s m => m a -> m [a]
many1 :: m a -> m [a]
many1 m a
p = (:) (a -> [a] -> [a]) -> m a -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p m ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a -> m [a]
forall s (m :: * -> *) a. MonadParser s m => m a -> m [a]
many m a
p

-- | Try to run the given parser as many times as possible, but at least once.

some :: MonadParser s m => m a -> m (NonEmpty a)
some :: m a -> m (NonEmpty a)
some m a
p = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a) -> m a -> m ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p m ([a] -> NonEmpty a) -> m [a] -> m (NonEmpty a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a -> m [a]
forall s (m :: * -> *) a. MonadParser s m => m a -> m [a]
many m a
p

-- | Parse a non-empty series of @a@ separated by @b@s (without a trailing @b@).

sepBy1 :: MonadParser s m => m a -> m b -> m (NonEmpty a)
sepBy1 :: m a -> m b -> m (NonEmpty a)
sepBy1 m a
a m b
b = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a) -> m a -> m ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a m ([a] -> NonEmpty a) -> m [a] -> m (NonEmpty a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a -> m [a]
forall s (m :: * -> *) a. MonadParser s m => m a -> m [a]
many (m b
b m b -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
a)

-- | Parse a potentially empty series of @a@ separated by @b@s (without a

-- trailing @b@).

sepBy :: MonadParser s m => m a -> m b -> m [a]
sepBy :: m a -> m b -> m [a]
sepBy m a
a m b
b = NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty a -> [a]) -> m (NonEmpty a) -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m b -> m (NonEmpty a)
forall s (m :: * -> *) a b.
MonadParser s m =>
m a -> m b -> m (NonEmpty a)
sepBy1 m a
a m b
b m [a] -> m [a] -> m [a]
forall s (m :: * -> *) a. MonadParser s m => m a -> m a -> m a
<|> [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Parse any value equal to @a@.

like :: (MonadParser s m, Eq (Item s), Show (Item s)) => Item s -> m (Item s)
like :: Item s -> m (Item s)
like Item s
a = m (Item s)
forall s (m :: * -> *). MonadParser s m => m (Item s)
item m (Item s) -> (Item s -> Bool) -> m (Item s)
forall s (m :: * -> *) a.
MonadParser s m =>
m a -> (a -> Bool) -> m a
`satisfy` (Item s -> Item s -> Bool
forall a. Eq a => a -> a -> Bool
== Item s
a) m (Item s) -> String -> m (Item s)
forall s (m :: * -> *) a. MonadParser s m => m a -> String -> m a
<?> Item s -> String
forall a. Show a => a -> String
show Item s
a

-- | Parse any value not equal to @a@.

unlike :: (MonadParser s m, Eq (Item s), Show (Item s)) => Item s -> m (Item s)
unlike :: Item s -> m (Item s)
unlike Item s
a = m (Item s)
forall s (m :: * -> *). MonadParser s m => m (Item s)
item m (Item s) -> (Item s -> Bool) -> m (Item s)
forall s (m :: * -> *) a.
MonadParser s m =>
m a -> (a -> Bool) -> m a
`satisfy` (Item s -> Item s -> Bool
forall a. Eq a => a -> a -> Bool
/= Item s
a) m (Item s) -> String -> m (Item s)
forall s (m :: * -> *) a. MonadParser s m => m a -> String -> m a
<?> String
"anything but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Item s -> String
forall a. Show a => a -> String
show Item s
a

-- | Parse a continuous sequence of items equal to the given one.

string ::
  (MonadParser s m, Eq (Item s), Show (Item s)) =>
  [Item s] ->
  m [Item s]
string :: [Item s] -> m [Item s]
string [] = [Item s] -> m [Item s]
forall (m :: * -> *) a. Monad m => a -> m a
return []
string (Item s
x : [Item s]
xs) = Item s -> m (Item s)
forall s (m :: * -> *).
(MonadParser s m, Eq (Item s), Show (Item s)) =>
Item s -> m (Item s)
like Item s
x m (Item s) -> m [Item s] -> m [Item s]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Item s] -> m [Item s]
forall s (m :: * -> *).
(MonadParser s m, Eq (Item s), Show (Item s)) =>
[Item s] -> m [Item s]
string [Item s]
xs m [Item s] -> m [Item s] -> m [Item s]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Item s] -> m [Item s]
forall (m :: * -> *) a. Monad m => a -> m a
return (Item s
x Item s -> [Item s] -> [Item s]
forall a. a -> [a] -> [a]
: [Item s]
xs)

-- | Parse any value equal to at least one element of the given list.

oneOf :: (MonadParser s m, Eq (Item s), Show (Item s)) => [Item s] -> m (Item s)
oneOf :: [Item s] -> m (Item s)
oneOf [Item s]
l = m (Item s)
forall s (m :: * -> *). MonadParser s m => m (Item s)
item m (Item s) -> (Item s -> Bool) -> m (Item s)
forall s (m :: * -> *) a.
MonadParser s m =>
m a -> (a -> Bool) -> m a
`satisfy` (Item s -> [Item s] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Item s]
l) m (Item s) -> String -> m (Item s)
forall s (m :: * -> *) a. MonadParser s m => m a -> String -> m a
<?> String
"one of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Item s] -> String
forall a. Show a => a -> String
show [Item s]
l

-- | Parse any value not equivalent to any element of the given list.

-- For a version that accepts non-Show items, see @noneOf'@.

noneOf ::
  (MonadParser s m, Eq (Item s), Show (Item s)) =>
  [Item s] ->
  m (Item s)
noneOf :: [Item s] -> m (Item s)
noneOf [Item s]
l = m (Item s)
forall s (m :: * -> *). MonadParser s m => m (Item s)
item m (Item s) -> (Item s -> Bool) -> m (Item s)
forall s (m :: * -> *) a.
MonadParser s m =>
m a -> (a -> Bool) -> m a
`satisfy` (Item s -> [Item s] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Item s]
l) m (Item s) -> String -> m (Item s)
forall s (m :: * -> *) a. MonadParser s m => m a -> String -> m a
<?> String
"none of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Item s] -> String
forall a. Show a => a -> String
show [Item s]
l

-- | @chainl1 p op@ Parse a chain of *one* or more occurrences of @p@,

-- separated by @op@. Return a value obtained by a left associative application

-- of all functions returned by @op@ to the values returned by @p@.

--

-- This is particularly useful for parsing left associative infix operators.

chainl1 :: MonadParser s m => m a -> m (a -> a -> a) -> m a
chainl1 :: m a -> m (a -> a -> a) -> m a
chainl1 m a
p m (a -> a -> a)
op = m a
scan
  where
    scan :: m a
scan = m a
p m a -> m (a -> a) -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> m (a -> a)
rst
    rst :: m (a -> a)
rst = (\a -> a -> a
f a
y a -> a
g a
x -> a -> a
g (a -> a -> a
f a
x a
y)) ((a -> a -> a) -> a -> (a -> a) -> a -> a)
-> m (a -> a -> a) -> m (a -> (a -> a) -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a -> a)
op m (a -> (a -> a) -> a -> a) -> m a -> m ((a -> a) -> a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
p m ((a -> a) -> a -> a) -> m (a -> a) -> m (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (a -> a)
rst m (a -> a) -> m (a -> a) -> m (a -> a)
forall s (m :: * -> *) a. MonadParser s m => m a -> m a -> m a
<|> (a -> a) -> m (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id

-- | @chainr1 p op@ Parse a chain of *one* or more occurrences of @p@,

-- separated by @op@. Return a value obtained by a right associative application

-- of all functions returned by @op@ to the values returned by @p@.

--

-- This is particularly useful for parsing right associative infix operators.

chainr1 :: MonadParser s m => m a -> m (a -> a -> a) -> m a
chainr1 :: m a -> m (a -> a -> a) -> m a
chainr1 m a
p m (a -> a -> a)
op = m a
scan
  where
    scan :: m a
scan = m a
p m a -> m (a -> a) -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> m (a -> a)
rst
    rst :: m (a -> a)
rst = ((a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> a) -> a -> a -> a)
-> m (a -> a -> a) -> m (a -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a -> a)
op m (a -> a -> a) -> m a -> m (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
scan) m (a -> a) -> m (a -> a) -> m (a -> a)
forall s (m :: * -> *) a. MonadParser s m => m a -> m a -> m a
<|> (a -> a) -> m (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id

-- | Run a parser on a different stream of items.

withInput :: MonadParser s m => s -> m a -> m (a, s)
withInput :: s -> m a -> m (a, s)
withInput s
s' m a
p = do
  s
s <- m s
forall s (m :: * -> *). MonadParser s m => m s
parseStream
  s -> m ()
forall s (m :: * -> *). MonadParser s m => s -> m ()
setParseStream s
s'
  a
x <- m a
p
  s
s'' <- m s
forall s (m :: * -> *). MonadParser s m => m s
parseStream
  s -> m ()
forall s (m :: * -> *). MonadParser s m => s -> m ()
setParseStream s
s
  (a, s) -> m (a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, s
s'')