Parser.hs

-- | Extend a monad with the ability to parse symbol sequences
module Mini.Transformers.Parser (
  -- * Type
  ParserT (
    ParserT
  ),
  runParserT,

  -- * Parsers
  eof,
  item,
  look,
  noneOf,
  oneOf,
  peek,
  sat,
  string,
  symbol,

  -- * Combinators
  accept,
  atLeast,
  atMost,
  between,
  chainl1,
  chainr1,
  findAll,
  findAll1,
  findFirst,
  findLast,
  option,
  range,
  reject,
  sepBy,
  sepBy1,
  till,
  till1,
) where

import Control.Applicative (
  Alternative,
  empty,
  many,
  some,
  (<|>),
 )
import Control.Monad (
  ap,
  liftM,
  replicateM,
 )
import Control.Monad.IO.Class (
  MonadIO,
  liftIO,
 )
import Data.Bifunctor (
  first,
 )
import Data.Bool (
  bool,
 )
import Mini.Data.Recursion (
  list,
 )
import Mini.Random.Class (
  Random,
  random,
 )
import Mini.Transformers.Class (
  MonadTrans,
  lift,
 )
import Prelude (
  Applicative,
  Bool (
    True
  ),
  Eq,
  Foldable,
  Functor,
  Int,
  Maybe (
    Just,
    Nothing
  ),
  Monad,
  MonadFail,
  Monoid,
  Semigroup,
  Traversable,
  const,
  elem,
  fail,
  flip,
  fmap,
  maybe,
  mempty,
  notElem,
  pure,
  traverse,
  ($),
  (*>),
  (-),
  (.),
  (<$),
  (<$>),
  (<*),
  (<*>),
  (<>),
  (==),
  (>),
  (>>=),
 )

-- Type

-- | A transformer parsing symbols /s/, inner monad /m/, return /a/
newtype ParserT s m a = ParserT
  { runParserT :: [s] -> m (Maybe (a, [s]))
  -- ^ Unwrap a transformer computation with a sequence of symbols to parse
  }

instance (Monad m) => Functor (ParserT s m) where
  fmap = liftM

instance (Monad m) => Applicative (ParserT s m) where
  pure a = ParserT $ \ss -> pure (Just (a, ss))
  (<*>) = ap

instance (Monad m) => Alternative (ParserT s m) where
  empty = ParserT . const $ pure Nothing
  m <|> n = ParserT $ \ss -> (<|>) <$> runParserT m ss <*> runParserT n ss

instance (Monad m) => Monad (ParserT s m) where
  m >>= k =
    ParserT $ \ss ->
      runParserT m ss
        >>= maybe
          (pure Nothing)
          (\(a, ss') -> runParserT (k a) ss')

instance MonadTrans (ParserT s) where
  lift m = ParserT $ \ss -> Just . (\a -> (a, ss)) <$> m

instance (Monad m, Semigroup a) => Semigroup (ParserT s m a) where
  m <> n = (<>) <$> m <*> n

instance (Monad m, Monoid a) => Monoid (ParserT s m a) where
  mempty = pure mempty

instance (Monad m) => MonadFail (ParserT s m) where
  fail = const empty

instance (MonadIO m) => MonadIO (ParserT s m) where
  liftIO = lift . liftIO

instance (Monad m, Random a) => Random (ParserT s m a) where
  random = first pure . random

-- Parsers

-- | Parse successfully only at end of input
eof :: (Monad m) => ParserT s m ()
eof = reject item

-- | Parse any symbol
item :: (Applicative m) => ParserT s m s
item = sat $ const True

-- | Parse the rest of the input without consuming it
look :: (Applicative m) => ParserT s m [s]
look = ParserT $ \ss -> pure $ Just (ss, ss)

-- | Parse the next symbol if excluded from a collection
noneOf :: (Applicative m, Foldable t, Eq s) => t s -> ParserT s m s
noneOf = sat . flip notElem

-- | Parse the next symbol if included in a collection
oneOf :: (Applicative m, Foldable t, Eq s) => t s -> ParserT s m s
oneOf = sat . flip elem

-- | Parse the next symbol without consuming it
peek :: (Monad m) => ParserT s m s
peek = accept item

-- | Parse the next symbol if it satisfies a predicate
sat :: (Applicative m) => (s -> Bool) -> ParserT s m s
sat p =
  ParserT $
    pure
      . list
        Nothing
        ( \s ss _ ->
            bool
              Nothing
              (Just (s, ss))
              $ p s
        )

-- | Parse a sequence of symbols
string :: (Monad m, Traversable t, Eq s) => t s -> ParserT s m (t s)
string = traverse symbol

-- | Parse a specific symbol
symbol :: (Applicative m, Eq s) => s -> ParserT s m s
symbol = sat . (==)

-- Combinators

-- | Parse @p@, without consuming input, iff @p@ succeeds via @accept p@
accept :: (Monad m) => ParserT s m a -> ParserT s m a
accept p = ParserT $ \ss -> fmap (\(a, _) -> (a, ss)) <$> runParserT p ss

-- | Parse @n@ or more occurrences of @p@ via @atLeast n p@
atLeast :: (Monad m) => Int -> ParserT s m a -> ParserT s m [a]
atLeast n p = replicateM n p <> many p

-- | Parse up to @n@ occurrences of @p@ via @atMost n p@
atMost :: (Monad m) => Int -> ParserT s m a -> ParserT s m [a]
atMost n p =
  bool
    (pure [])
    (option [] $ (:) <$> p <*> atMost (n - 1) p)
    $ n > 0

-- | Parse @p@ enclosed by @a@ and @b@ via @between a b p@
between
  :: (Monad m)
  => ParserT s m open
  -> ParserT s m close
  -> ParserT s m a
  -> ParserT s m a
between open close p = open *> p <* close

-- | Parse one or more @p@ left-associatively chained by @f@ via @chainl1 p f@
chainl1
  :: (Monad m)
  => ParserT s m a
  -> ParserT s m (a -> a -> a)
  -> ParserT s m a
chainl1 p f = p >>= go
 where
  go a = option a $ f <*> pure a <*> p >>= go

-- | Parse one or more @p@ right-associatively chained by @f@ via @chainr1 p f@
chainr1
  :: (Monad m)
  => ParserT s m a
  -> ParserT s m (a -> a -> a)
  -> ParserT s m a
chainr1 p f = go
 where
  go = p >>= rest
  rest a = option a $ f <*> pure a <*> go >>= rest

-- | Find and parse zero or more occurrences of @p@ via @findAll p@
findAll :: (Monad m) => ParserT s m a -> ParserT s m [a]
findAll = many . findFirst

-- | Find and parse one or more occurrences of @p@ via @findAll1 p@
findAll1 :: (Monad m) => ParserT s m a -> ParserT s m [a]
findAll1 = some . findFirst

-- | Find and parse the first occurrence of @p@ via @findFirst p@
findFirst :: (Monad m) => ParserT s m a -> ParserT s m a
findFirst p = p <|> (item *> findFirst p)

-- | Find and parse the last occurrence of @p@ via @findLast p@
findLast :: (Monad m) => ParserT s m a -> ParserT s m a
findLast p = findFirst p >>= flip option (findLast p)

-- | Parse @p@ returning @a@ in case of failure via @option a p@
option :: (Monad m) => a -> ParserT s m a -> ParserT s m a
option a p = p <|> pure a

-- | Parse between @lo@ and @hi@ occurrences of @p@ via @range lo hi p@
range :: (Monad m) => Int -> Int -> ParserT s m a -> ParserT s m [a]
range lo hi p = replicateM lo p <> atMost (hi - lo) p

-- | Parse @p@, without consuming input, iff @p@ fails via @reject p@
reject :: (Monad m) => ParserT s m a -> ParserT s m ()
reject p = ParserT $ \ss ->
  runParserT p ss
    >>= maybe
      (pure $ Just ((), ss))
      (const $ pure Nothing)

-- | Parse zero or more @p@ separated by @q@ via @p \`sepBy\` q@
sepBy :: (Monad m) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
sepBy p = option [] . sepBy1 p

-- | Parse one or more @p@ separated by @q@ via @p \`sepBy1\` q@
sepBy1 :: (Monad m) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
sepBy1 p sep = (:) <$> p <*> many (sep *> p)

-- | Parse zero or more @p@ until @q@ succeeds via @p \`till\` q@
till :: (Monad m) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
till p end = ([] <$ end) <|> till1 p end

-- | Parse one or more @p@ until @q@ succeeds via @p \`till1\` q@
till1 :: (Monad m) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
till1 p end = (:) <$> p <*> till p end