ParserT.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

-- | Turning strings into things
module Mini.Transformers.ParserT (
  -- * Types
  ParserT,
  ParseError,

  -- * Runners
  runParserT,

  -- * Parsers
  sat,
  item,
  symbol,
  string,
  oneOf,
  noneOf,

  -- * Combinators
  sepBy,
  sepBy1,
  endBy,
  endBy1,
  between,
  option,
) where

import Control.Applicative (
  Alternative (
    empty,
    many,
    (<|>)
  ),
 )
import Control.Monad (
  ap,
  liftM,
  (>=>),
 )
import Data.Bool (
  bool,
 )
import Data.Functor (
  (<&>),
 )
import Mini.Transformers.Class (
  MonadTrans (
    lift
  ),
 )

{-
 - Types
 -}

{- | A monad for parsing symbols of type /s/ with inner monad /m/ and return
type /a/
-}
newtype ParserT s m a = ParserT
  { runParserT :: [s] -> m (Either [ParseError s] (a, [s]))
  -- ^ Unwrap a 'ParserT' given a string of symbols
  }

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

instance (Monad m) => Applicative (ParserT s m) where
  pure a = ParserT $ pure . Right . (a,)
  (<*>) = ap

instance (Monad m, Eq s) => Alternative (ParserT s m) where
  empty = ParserT . const . pure $ Left [EmptyError]
  m <|> n = ParserT $ \ss ->
    runParserT m ss
      >>= either
        ( \e1 ->
            runParserT n ss
              <&> either
                (Left . mappend e1)
                Right
        )
        (pure . Right)

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

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

-- | Abstract representation of a parse error for symbols of type /s/
data ParseError s
  = EndOfInput
  | Unexpected s
  | EmptyError

instance (Show s) => Show (ParseError s) where
  show = \case
    EndOfInput -> "unexpected EOF"
    Unexpected s -> "unexpected " <> show s
    EmptyError -> "empty"

{-
 - Common Parsers
 -}

{- | From a predicate to a parser for symbols satisfying the predicate

> digit = sat Data.Char.isDigit
>
> spaces = Control.Applicative.many $ sat Data.Char.isSpace
-}
sat :: (Applicative m) => (s -> Bool) -> ParserT s m s
sat p =
  ParserT $ \case
    [] -> pure $ Left [EndOfInput]
    (s : ss) ->
      bool
        (pure $ Left [Unexpected s])
        (pure $ Right (s, ss))
        $ p s

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

-- | A parser for the given symbol
symbol :: (Applicative m, Eq s) => s -> ParserT s m s
symbol = sat . (==)

-- | A parser for the given string of symbols
string :: (Monad m, Traversable t, Eq s) => t s -> ParserT s m (t s)
string = traverse symbol

-- | A parser for any of the given symbols
oneOf :: (Applicative m, Foldable t, Eq s) => t s -> ParserT s m s
oneOf = sat . flip elem

-- | A parser for any symbol excluding the given symbols
noneOf :: (Applicative m, Foldable t, Eq s) => t s -> ParserT s m s
noneOf = sat . flip notElem

{-
 - Combinators
 -}

{- | Turn a parser and another parser into a parser for zero or more of the
former separated by the latter
-}
sepBy :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
sepBy p = option [] . sepBy1 p

{- | Turn a parser and another parser into a parser for one or more of the
former separated by the latter
-}
sepBy1 :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
sepBy1 p sep = (:) <$> p <*> many (sep *> p)

{- | Turn a parser and another parser into a parser for zero or more of the
former separated and ended by the latter
-}
endBy :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
endBy p = option [] . endBy1 p

{- | Turn a parser and another parser into a parser for one or more of the
former separated and ended by the latter
-}
endBy1 :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
endBy1 p sep = sepBy1 p sep <* sep

{- | Turn a first, second and third parser into a parser for the third enclosed
between the first and the second, returning the result of the third
-}
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

{- | From a default value and a parser to the parser returning the default value
in case of failure
-}
option :: (Monad m, Eq s) => a -> ParserT s m a -> ParserT s m a
option a p = p <|> pure a