ParserT.hs

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

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

  -- * Runner
  runParserT,

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

  -- * Combinators
  sepBy,
  sepBy1,
  endBy,
  endBy1,
  chainl,
  chainl1,
  chainr,
  chainr1,
  between,
  option,
  reject,
  accept,
) where

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

{-
 - Types
 -}

-- | A transformer parsing symbols /s/, inner monad /m/, return /a/
newtype ParserT s m a = ParserT
  { runParserT :: [s] -> m (Either ParseError (a, [s]))
  -- ^ Unwrap a 'ParserT' 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 $ pure . Right . (a,)
  (<*>) = ap

-- | Parse @p@ or, if @p@ fails, backtrack and parse @q@ via @p \<|\> q@
instance (Monad m, Eq s) => Alternative (ParserT s m) where
  empty = ParserT . const . pure $ Left mempty
  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)

-- | Combine the results of @p@ and @q@ via @p <> q@
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 = ParserT . const . pure . Left . ParseError . pure

-- | Abstract representation of a parse error
newtype ParseError = ParseError [String]
  deriving (Semigroup, Monoid)

instance Show ParseError where
  show (ParseError es) = "(parse error: " <> concat (intersperse ", " es) <> ")"

{-
 - Parsers
 -}

{- | Parse symbols satisfying a predicate

=== __Examples__

>>> runParserT (some $ sat isDigit) "123abc"
Right ("123","abc")
-}
sat :: (Applicative m, Show s) => (s -> Bool) -> ParserT s m s
sat p = ParserT $ \case
  [] -> pure . Left $ ParseError ["end of input"]
  (s : ss) ->
    bool
      (pure . Left $ ParseError ["unexpected " <> show s])
      (pure $ Right (s, ss))
      $ p s

{- | Parse any symbol

=== __Examples__

>>> runParserT (item *> item <* item) "bar"
Right ('a',"")
-}
item :: (Applicative m, Show s) => ParserT s m s
item = sat $ const True

{- | Parse a symbol

=== __Examples__

>>> runParserT (symbol 'f') "foo"
Right ('f',"oo")
-}
symbol :: (Applicative m, Show s, Eq s) => s -> ParserT s m s
symbol = sat . (==)

{- | Parse a sequence of symbols

=== __Examples__

>>> runParserT (string "foo") "foobar"
Right ("foo","bar")
-}
string :: (Monad m, Traversable t, Show s, Eq s) => t s -> ParserT s m (t s)
string = traverse symbol

{- | Parse symbols included in a collection

=== __Examples__

>>> runParserT (oneOf "abc") "bar"
Right ('b',"ar")
-}
oneOf :: (Applicative m, Foldable t, Show s, Eq s) => t s -> ParserT s m s
oneOf = sat . flip elem

{- | Parse symbols excluded from a collection

=== __Examples__

>>> runParserT (noneOf "abc") "foo"
Right ('f',"oo")
-}
noneOf :: (Applicative m, Foldable t, Show s, Eq s) => t s -> ParserT s m s
noneOf = sat . flip notElem

{- | Parse successfully only at end of input

=== __Examples__

>>> runParserT (string "foobar" *> eof) "foobar"
Right ((),"")
-}
eof :: (Monad m, Show s) => ParserT s m ()
eof = reject item

{-
 - Combinators
 -}

{- | Parse zero or more @p@ separated by @q@ via @p \`sepBy\` q@

=== __Examples__

>>> runParserT (sat isDigit `sepBy` symbol ',') "1,2,3,four"
Right ("123",",four")
-}
sepBy :: (Monad m, Eq s) => 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@

=== __Examples__

>>> runParserT (sat isDigit `sepBy1` symbol ',') "1,2,3,four"
Right ("123",",four")
-}
sepBy1 :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
sepBy1 p sep = (:) <$> p <*> many (sep *> p)

{- | Parse zero or more @p@ separated and ended by @q@ via @p \`endBy\` q@

=== __Examples__

>>> runParserT (sat isDigit `endBy` symbol ',') "1,2,3,four"
Right ("123","four")
-}
endBy :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
endBy p = option [] . endBy1 p

{- | Parse one or more @p@ separated and ended by @q@ via @p \`endBy1\` q@

=== __Examples__

>>> runParserT (sat isDigit `endBy1` symbol ',') "1,2,3,four"
Right ("123","four")
-}
endBy1 :: (Monad m, Eq s) => ParserT s m a -> ParserT s m b -> ParserT s m [a]
endBy1 p sep = sepBy1 p sep <* sep

{- | Parse zero or more @p@ left-chained with @op@ atop @a@ via @chainl p op a@

=== __Examples__

>>> runParserT (chainl (read <$> some (sat isDigit)) ((+) <$ item) 10) "2a3b4c"
Right (9,"c")
-}
chainl
  :: (Monad m, Eq s)
  => ParserT s m a
  -> ParserT s m (a -> a -> a)
  -> a
  -> ParserT s m a
chainl p op a = option a $ chainl1 p op

{- | Parse one or more @p@ left-chained with @op@ via @chainl1 p op@

=== __Examples__

>>> runParserT (chainl1 (read <$> some (sat isDigit)) ((+) <$ item)) "2a3b4c"
Right (9,"c")
-}
chainl1
  :: (Monad m, Eq s)
  => ParserT s m a
  -> ParserT s m (a -> a -> a)
  -> ParserT s m a
chainl1 p op = p >>= go
 where
  go a = option a $ op <*> pure a <*> p >>= go

{- | Parse zero or more @p@ right-chained with @op@ atop @a@ via @chainr p op a@

=== __Examples__

>>> runParserT (chainr (read <$> some (sat isDigit)) ((*) <$ item) 10) "2a3b4c"
Right (24,"c")
-}
chainr
  :: (Monad m, Eq s)
  => ParserT s m a
  -> ParserT s m (a -> a -> a)
  -> a
  -> ParserT s m a
chainr p op a = option a $ chainr1 p op

{- | Parse one or more @p@ right-chained with @op@ via @chainr1 p op@

=== __Examples__

>>> runParserT (chainr1 (read <$> some (sat isDigit)) ((*) <$ item)) "2a3b4c"
Right (24,"c")
-}
chainr1
  :: (Monad m, Eq s)
  => ParserT s m a
  -> ParserT s m (a -> a -> a)
  -> ParserT s m a
chainr1 p op = go
 where
  go = p >>= rest
  rest a = option a $ op <*> pure a <*> go >>= rest

{- | Parse @p@ enclosed by @a@ and @b@ via @between a b p@

=== __Examples__

>>> runParserT (between (symbol '(') (symbol ')') (many $ sat isLetter)) "(yes)"
Right ("yes","")
-}
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 @p@ returning @a@ in case of failure via @option a p@

=== __Examples__

>>> runParserT (option "foo" $ string "bar") "baz"
Right ("foo","baz")
-}
option :: (Monad m, Eq s) => a -> ParserT s m a -> ParserT s m a
option a p = p <|> pure a

{- | Parse @p@, without consuming input, iff @p@ fails via @reject p@

=== __Examples__

>>> runParserT (string "foo" <* reject (sat isLetter)) "foo(bar)"
Right ("foo","(bar)")
-}
reject :: (Monad m, Show a) => ParserT s m a -> ParserT s m ()
reject p = ParserT $ \ss ->
  runParserT p ss
    >>= either
      (const . pure $ Right ((), ss))
      (pure . Left . ParseError . pure . mappend "unexpected " . show . fst)

{- | Parse @p@, without consuming input, iff @p@ succeeds via @accept p@

=== __Examples__

>>> runParserT (accept item >>= pure . (== 'a')) "foo"
Right (False,"foo")
-}
accept :: (Monad m) => ParserT s m a -> ParserT s m a
accept p = ParserT $ \ss ->
  runParserT p ss
    >>= either
      (pure . Left)
      (pure . Right . (,ss) . fst)