A tiny toy parser combinator library

{-# LANGUAGE FlexibleInstances, FunctionalDependencies, TupleSections #-}

module Parsy where

import Control.Applicative
import Control.Monad.Error.Class
import RIO
import RIO.List

class Collection e c | c -> e where
  elemAtIndex :: c -> Word -> Maybe e

instance Collection a [a] where
  elemAtIndex c i
    | genericLength c <= i = Nothing
    | otherwise = Just $ c `genericIndex` i

data ParseError = NoMatch | EOD deriving (Eq, Show)

newtype Parser c a = Parser { unParser :: c -> Word -> (Either ParseError a, Word) }

runParser :: c -> Parser c a -> Either (ParseError, Word) a
runParser collection parser = let (result, index) = unParser parser collection 0 in
  case result of
    Left e -> Left (e, index)
    Right a -> Right a

instance Functor (Parser c) where
  fmap f (Parser parse) = Parser $ \c i -> let
      (e, i') = parse c i
    in (fmap f e, i')

instance Applicative (Parser c) where
  pure a = Parser $ const (Right a,)
  (Parser f) <*> (Parser a) = Parser $ \c i -> let
      (f', fi) = f c i
      (a', ai) = a c fi
    in (f' <*> a', ai)

instance Monad (Parser c) where
  return = pure
  (Parser a) >>= f = Parser $ \c i -> let
      (a', ai) = a c i
    in case a' of
      Left e -> (Left e, i)
      Right a -> unParser (f a) c ai

instance MonadError ParseError (Parser c) where
  throwError e = Parser $ const (Left e,)
  catchError (Parser a) handler = Parser $ \c i -> let
      (a', ai) = a c i
    in case a' of
      Left e -> unParser (handler e) c i
      Right a -> (Right a, ai)

instance Alternative (Parser c) where
  empty = Parser undefined
  a <|> b = catchError a $ const b

advanceBy :: Int -> Parser c ()
advanceBy delta = Parser $ const $ \i -> (Right (), addDelta i)
  where
    addDelta i = fromIntegral $ delta + fromIntegral i

advance :: Parser c ()
advance = advanceBy 1

collection :: Parser c c
collection = Parser $ \c i -> (Right c, i)

index :: Parser c Word
index = Parser $ const $ \i -> (Right i, i)

putIndex :: Word -> Parser c ()
putIndex = Parser . const . const . (Right (),)

collectionWithIndex :: Parser c (c, Word)
collectionWithIndex = Parser $ \c i -> (Right (c, i), i)

current :: Collection a c => Parser c (Maybe a)
current = collectionWithIndex <&> uncurry elemAtIndex

eod :: Collection a c => Parser c ()
eod = current >>= maybe (return ()) (const $ throwError NoMatch)

atEOD :: Collection a c => Parser c Bool
atEOD = isNothing <$> current

satisfy :: Collection a c => (a -> Bool) -> Parser c a
satisfy predicate = do
  a <- current
  case a of
    Just a -> if predicate a
      then advance >> return a
      else throwError NoMatch
    Nothing -> throwError EOD

equals :: (Eq a, Collection a c) => a -> Parser c a
equals a = satisfy (== a)

many1 :: Parser c a -> Parser c [a]
many1 parser = liftA2 (:) parser $ many parser

many1SepBy :: Parser c a -> Parser c sep -> Parser c [a]
many1SepBy parser sep = liftA2 (:) parser $ many (sep *> parser)

manySepBy :: Parser c a -> Parser c sep -> Parser c [a]
manySepBy parser sep = many1SepBy parser sep <|> pure []

peek :: Parser c a -> Parser c ()
peek parser = index >>= \i -> void parser >> putIndex i

skip :: Parser c a -> Parser c ()
skip = void

skipMany :: Parser c a -> Parser c ()
skipMany = void . many

skipMany1 :: Parser c a -> Parser c ()
skipMany1 = void . many1

skipUntil :: Collection e c => Parser c a -> Parser c ()
skipUntil parser = do
  err <- catchError (peek parser $> Nothing) (return . Just)
  case err of
    Nothing -> return ()
    Just EOD -> throwError EOD
    Just _ -> advance >> skipUntil parser

skipTo :: Collection e c => Parser c a -> Parser c a
skipTo parser = skipUntil parser >> parser