{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

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

import Control.Applicative ((<**>))
import Data.Kind (Type)
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, Stream (Input m)) => MonadParser m where
  type Input m :: Type

  -- | The current input stream.

  parseStream :: m (Input m)

  -- | Replace the input stream.

  setParseStream :: Input m -> m ()

  -- | A parser that always fails.

  noParse :: m a

  -- | A parser that returns the next item.

  item :: m (Item (Input m))

  -- | @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 m => m ()
eof :: m ()
eof = m (Item (Input m)) -> m ()
forall (m :: * -> *) a. MonadParser m => m a -> m ()
notFollowedBy m (Item (Input m))
forall (m :: * -> *). MonadParser m => m (Item (Input m))
item m () -> String -> m ()
forall (m :: * -> *) a. MonadParser m => m a -> String -> m a
<?> String
"end of input"

-- | Fail with an "expected" message.

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

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

satisfy :: MonadParser 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 (m :: * -> *) a. MonadParser 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 (m :: * -> *) a. MonadParser m => m a
noParse

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

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

-- | Make a parser optional.

optional :: MonadParser 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 (m :: * -> *) a. MonadParser 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 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 (m :: * -> *) a. MonadParser m => m a -> m a -> m a
(<|>) m a
forall (m :: * -> *) a. MonadParser m => m a
noParse

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

many :: MonadParser 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 (m :: * -> *) a. MonadParser m => m a -> m [a]
many m a
p) m [a] -> m [a] -> m [a]
forall (m :: * -> *) a. MonadParser 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 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 (m :: * -> *) a. MonadParser 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 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 (m :: * -> *) a. MonadParser 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 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 (m :: * -> *) a. MonadParser 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 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 (m :: * -> *) a b.
MonadParser m =>
m a -> m b -> m (NonEmpty a)
sepBy1 m a
a m b
b m [a] -> m [a] -> m [a]
forall (m :: * -> *) a. MonadParser 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 m, Eq (Item (Input m)), Show (Item (Input m))) =>
  Item (Input m) ->
  m (Item (Input m))
like :: Item (Input m) -> m (Item (Input m))
like Item (Input m)
a = m (Item (Input m))
forall (m :: * -> *). MonadParser m => m (Item (Input m))
item m (Item (Input m))
-> (Item (Input m) -> Bool) -> m (Item (Input m))
forall (m :: * -> *) a. MonadParser m => m a -> (a -> Bool) -> m a
`satisfy` (Item (Input m) -> Item (Input m) -> Bool
forall a. Eq a => a -> a -> Bool
== Item (Input m)
a) m (Item (Input m)) -> String -> m (Item (Input m))
forall (m :: * -> *) a. MonadParser m => m a -> String -> m a
<?> Item (Input m) -> String
forall a. Show a => a -> String
show Item (Input m)
a

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

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

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

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

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

oneOf ::
  (MonadParser m, Eq (Item (Input m)), Show (Item (Input m))) =>
  [Item (Input m)] ->
  m (Item (Input m))
oneOf :: [Item (Input m)] -> m (Item (Input m))
oneOf [Item (Input m)]
l = m (Item (Input m))
forall (m :: * -> *). MonadParser m => m (Item (Input m))
item m (Item (Input m))
-> (Item (Input m) -> Bool) -> m (Item (Input m))
forall (m :: * -> *) a. MonadParser m => m a -> (a -> Bool) -> m a
`satisfy` (Item (Input m) -> [Item (Input m)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Item (Input m)]
l) m (Item (Input m)) -> String -> m (Item (Input m))
forall (m :: * -> *) a. MonadParser m => m a -> String -> m a
<?> String
"one of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Item (Input m)] -> String
forall a. Show a => a -> String
show [Item (Input m)]
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 m, Eq (Item (Input m)), Show (Item (Input m))) =>
  [Item (Input m)] ->
  m (Item (Input m))
noneOf :: [Item (Input m)] -> m (Item (Input m))
noneOf [Item (Input m)]
l = m (Item (Input m))
forall (m :: * -> *). MonadParser m => m (Item (Input m))
item m (Item (Input m))
-> (Item (Input m) -> Bool) -> m (Item (Input m))
forall (m :: * -> *) a. MonadParser m => m a -> (a -> Bool) -> m a
`satisfy` (Item (Input m) -> [Item (Input m)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Item (Input m)]
l) m (Item (Input m)) -> String -> m (Item (Input m))
forall (m :: * -> *) a. MonadParser m => m a -> String -> m a
<?> String
"none of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Item (Input m)] -> String
forall a. Show a => a -> String
show [Item (Input m)]
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 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 (m :: * -> *) a. MonadParser 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 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 (m :: * -> *) a. MonadParser 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 m => Input m -> m a -> m (a, Input m)
withInput :: Input m -> m a -> m (a, Input m)
withInput Input m
s' m a
p = do
  Input m
s <- m (Input m)
forall (m :: * -> *). MonadParser m => m (Input m)
parseStream
  Input m -> m ()
forall (m :: * -> *). MonadParser m => Input m -> m ()
setParseStream Input m
s'
  a
x <- m a
p
  Input m
s'' <- m (Input m)
forall (m :: * -> *). MonadParser m => m (Input m)
parseStream
  Input m -> m ()
forall (m :: * -> *). MonadParser m => Input m -> m ()
setParseStream Input m
s
  (a, Input m) -> m (a, Input m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Input m
s'')