Pasted

{-# 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