{-# 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, -- * 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 transformer parsing symbols /s/, inner monad /m/, return /a/ newtype ParserT s m a = ParserT { runParserT :: [s] -> m (Either [ParseError s] (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 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) 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 -- | Abstract representation of a parse error for symbols /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" {- - Parsers -} -- | Parse symbols satisfying a predicate 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 -- | Parse any symbol item :: (Applicative m) => ParserT s m s item = sat $ const True -- | Parse a symbol symbol :: (Applicative m, Eq s) => s -> ParserT s m s symbol = sat . (==) -- | Parse a sequence of symbols string :: (Monad m, Traversable t, Eq s) => t s -> ParserT s m (t s) string = traverse symbol -- | Parse symbols included in a collection oneOf :: (Applicative m, Foldable t, Eq s) => t s -> ParserT s m s oneOf = sat . flip elem -- | Parse symbols excluded from a collection noneOf :: (Applicative m, Foldable t, Eq s) => t s -> ParserT s m s noneOf = sat . flip notElem {- - Combinators -} -- | Parse zero or more @p@ separated by @q@ via @p \`sepBy\` q@ 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@ 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@ 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@ 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 @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 @p@ returning @a@ in case of failure via @option a p@ option :: (Monad m, Eq s) => a -> ParserT s m a -> ParserT s m a option a p = p <|> pure a