Megaparsec.hs

module Core.Text.Megaparsec
  ( runParserF
  , any
  , exactly
  , satisfy
  , mapExactly
  , mapSatisfy
  , someSepBy
  , manySepBy
  ) where

import Prelude hiding (any)
import Text.Megaparsec.Char
import Text.Megaparsec
import qualified Data.Set as Set
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty

-- | Runs the parser, expecting it to consume all the input.
runParserF :: (Ord e, Stream s)
           => Parsec e s o
           -> String
           -> s
           -> Either (ParseError (Token s) e) o
runParserF parser = runParser $ parser <* eof

any :: MonadParsec e s m => m (Token s)
any = anyChar

exactly :: MonadParsec e s m => Token s -> m ()
exactly x = () <$ char x

-- | Applies the function to the input, then expects it to be the
-- function applied to the given value.
mapExactly :: (Eq a) => MonadParsec e s m => (Token s -> a) -> Token s -> m ()
mapExactly f expected = () <$ mapSatisfyRepr (expect . f) (Just expected)
  where expect x
          | x == f expected = Just x
          | otherwise = Nothing

-- | Applies the function to the input. If it succeeds, returns the output.
-- If it fails, returns an error indicating that the input was unexpected.
mapSatisfy :: MonadParsec e s m => (Token s -> Maybe a) -> m a
mapSatisfy f = mapSatisfyRepr f Nothing

mapSatisfyRepr :: MonadParsec e s m => (Token s -> Maybe a) -> Maybe (Token s) -> m a
mapSatisfyRepr f repr = token testSatisfy repr
  where testSatisfy input
          = case f input of
                 Nothing -> Left (pure (Tokens (input :| [])), Set.empty)
                 Just res -> Right res

someSepBy :: MonadParsec e s m => m a -> m b -> m (NonEmpty a)
x `someSepBy` sep = (:|) <$> x <*> many (sep *> x)

manySepBy :: MonadParsec e s m => m a -> m b -> m [a]
x `manySepBy` sep
    = NonEmpty.toList <$> (x `someSepBy` sep)
  <|> pure []