{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}

-- | Simple parser implementation to replace flatparse
module Chart.Parse
  ( -- * Parser type and running
    Parser,
    Result (..),
    runParser,

    -- * Primitives
    satisfy,
    satisfyAscii,
    anyChar,
    eof,

    -- * Combinators
    empty,
    (<|>),
    optional,
    many,
    some,
    skipMany,
    chainr,
    withOption,

    -- * String matching
    char,
    byteString,

    -- * Utilities
    isDigit,
  )
where

import Control.Applicative (Alternative (empty, (<|>)))
import Control.Monad (MonadPlus (..), ap, void)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.Char (isDigit)
import Prelude hiding (replicate)

-- * Types

data Result e a
  = OK a ByteString
  | Fail
  | Err e
  deriving (Int -> Result e a -> ShowS
[Result e a] -> ShowS
Result e a -> String
(Int -> Result e a -> ShowS)
-> (Result e a -> String)
-> ([Result e a] -> ShowS)
-> Show (Result e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show a, Show e) => Int -> Result e a -> ShowS
forall e a. (Show a, Show e) => [Result e a] -> ShowS
forall e a. (Show a, Show e) => Result e a -> String
$cshowsPrec :: forall e a. (Show a, Show e) => Int -> Result e a -> ShowS
showsPrec :: Int -> Result e a -> ShowS
$cshow :: forall e a. (Show a, Show e) => Result e a -> String
show :: Result e a -> String
$cshowList :: forall e a. (Show a, Show e) => [Result e a] -> ShowS
showList :: [Result e a] -> ShowS
Show, (forall a b. (a -> b) -> Result e a -> Result e b)
-> (forall a b. a -> Result e b -> Result e a)
-> Functor (Result e)
forall a b. a -> Result e b -> Result e a
forall a b. (a -> b) -> Result e a -> Result e b
forall e a b. a -> Result e b -> Result e a
forall e a b. (a -> b) -> Result e a -> Result e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e a b. (a -> b) -> Result e a -> Result e b
fmap :: forall a b. (a -> b) -> Result e a -> Result e b
$c<$ :: forall e a b. a -> Result e b -> Result e a
<$ :: forall a b. a -> Result e b -> Result e a
Functor)

newtype Parser e a = Parser
  { forall e a. Parser e a -> ByteString -> Result e a
runParser :: ByteString -> Result e a
  }
  deriving ((forall a b. (a -> b) -> Parser e a -> Parser e b)
-> (forall a b. a -> Parser e b -> Parser e a)
-> Functor (Parser e)
forall a b. a -> Parser e b -> Parser e a
forall a b. (a -> b) -> Parser e a -> Parser e b
forall e a b. a -> Parser e b -> Parser e a
forall e a b. (a -> b) -> Parser e a -> Parser e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e a b. (a -> b) -> Parser e a -> Parser e b
fmap :: forall a b. (a -> b) -> Parser e a -> Parser e b
$c<$ :: forall e a b. a -> Parser e b -> Parser e a
<$ :: forall a b. a -> Parser e b -> Parser e a
Functor)

instance Applicative (Parser e) where
  pure :: forall a. a -> Parser e a
pure a
a = (ByteString -> Result e a) -> Parser e a
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e a) -> Parser e a)
-> (ByteString -> Result e a) -> Parser e a
forall a b. (a -> b) -> a -> b
$ \ByteString
s -> a -> ByteString -> Result e a
forall e a. a -> ByteString -> Result e a
OK a
a ByteString
s
  <*> :: forall a b. Parser e (a -> b) -> Parser e a -> Parser e b
(<*>) = Parser e (a -> b) -> Parser e a -> Parser e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (Parser e) where
  Parser ByteString -> Result e a
p >>= :: forall a b. Parser e a -> (a -> Parser e b) -> Parser e b
>>= a -> Parser e b
f = (ByteString -> Result e b) -> Parser e b
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e b) -> Parser e b)
-> (ByteString -> Result e b) -> Parser e b
forall a b. (a -> b) -> a -> b
$ \ByteString
s -> case ByteString -> Result e a
p ByteString
s of
    OK a
a ByteString
s' -> Parser e b -> ByteString -> Result e b
forall e a. Parser e a -> ByteString -> Result e a
runParser (a -> Parser e b
f a
a) ByteString
s'
    Result e a
Fail -> Result e b
forall e a. Result e a
Fail
    Err e
e -> e -> Result e b
forall e a. e -> Result e a
Err e
e

instance Alternative (Parser e) where
  empty :: forall a. Parser e a
empty = (ByteString -> Result e a) -> Parser e a
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e a) -> Parser e a)
-> (ByteString -> Result e a) -> Parser e a
forall a b. (a -> b) -> a -> b
$ Result e a -> ByteString -> Result e a
forall a b. a -> b -> a
const Result e a
forall e a. Result e a
Fail
  Parser ByteString -> Result e a
p <|> :: forall a. Parser e a -> Parser e a -> Parser e a
<|> Parser ByteString -> Result e a
q = (ByteString -> Result e a) -> Parser e a
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e a) -> Parser e a)
-> (ByteString -> Result e a) -> Parser e a
forall a b. (a -> b) -> a -> b
$ \ByteString
s -> case ByteString -> Result e a
p ByteString
s of
    Result e a
Fail -> ByteString -> Result e a
q ByteString
s
    Result e a
ok -> Result e a
ok

instance MonadPlus (Parser e)

-- * Primitives

satisfy :: (Char -> Bool) -> Parser e Char
satisfy :: forall e. (Char -> Bool) -> Parser e Char
satisfy Char -> Bool
predicate = (ByteString -> Result e Char) -> Parser e Char
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e Char) -> Parser e Char)
-> (ByteString -> Result e Char) -> Parser e Char
forall a b. (a -> b) -> a -> b
$ \ByteString
s ->
  if ByteString -> Bool
B.null ByteString
s
    then Result e Char
forall e a. Result e a
Fail
    else
      let c :: Char
c = ByteString -> Char
BC.head ByteString
s
       in if Char -> Bool
predicate Char
c
            then Char -> ByteString -> Result e Char
forall e a. a -> ByteString -> Result e a
OK Char
c (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
s)
            else Result e Char
forall e a. Result e a
Fail

satisfyAscii :: (Char -> Bool) -> Parser e Char
satisfyAscii :: forall e. (Char -> Bool) -> Parser e Char
satisfyAscii = (Char -> Bool) -> Parser e Char
forall e. (Char -> Bool) -> Parser e Char
satisfy

anyChar :: Parser e Char
anyChar :: forall e. Parser e Char
anyChar = (ByteString -> Result e Char) -> Parser e Char
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e Char) -> Parser e Char)
-> (ByteString -> Result e Char) -> Parser e Char
forall a b. (a -> b) -> a -> b
$ \ByteString
s ->
  if ByteString -> Bool
B.null ByteString
s
    then Result e Char
forall e a. Result e a
Fail
    else Char -> ByteString -> Result e Char
forall e a. a -> ByteString -> Result e a
OK (ByteString -> Char
BC.head ByteString
s) (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
s)

eof :: Parser e ()
eof :: forall e. Parser e ()
eof = (ByteString -> Result e ()) -> Parser e ()
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e ()) -> Parser e ())
-> (ByteString -> Result e ()) -> Parser e ()
forall a b. (a -> b) -> a -> b
$ \ByteString
s ->
  if ByteString -> Bool
B.null ByteString
s
    then () -> ByteString -> Result e ()
forall e a. a -> ByteString -> Result e a
OK () ByteString
s
    else Result e ()
forall e a. Result e a
Fail

-- * Combinators

optional :: Parser e a -> Parser e (Maybe a)
optional :: forall e a. Parser e a -> Parser e (Maybe a)
optional Parser e a
p = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser e a -> Parser e (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e a
p) Parser e (Maybe a) -> Parser e (Maybe a) -> Parser e (Maybe a)
forall a. Parser e a -> Parser e a -> Parser e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> Parser e (Maybe a)
forall a. a -> Parser e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

skipMany :: Parser e a -> Parser e ()
skipMany :: forall e a. Parser e a -> Parser e ()
skipMany Parser e a
p = Parser e ()
go
  where
    go :: Parser e ()
go = (Parser e a
p Parser e a -> Parser e () -> Parser e ()
forall a b. Parser e a -> Parser e b -> Parser e b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e ()
go) Parser e () -> Parser e () -> Parser e ()
forall a. Parser e a -> Parser e a -> Parser e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser e ()
forall a. a -> Parser e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

chainr :: (a -> b -> b) -> Parser e a -> Parser e b -> Parser e b
chainr :: forall a b e.
(a -> b -> b) -> Parser e a -> Parser e b -> Parser e b
chainr a -> b -> b
f Parser e a
p Parser e b
z = Parser e b
go
  where
    go :: Parser e b
go = (a -> b -> b
f (a -> b -> b) -> Parser e a -> Parser e (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e a
p Parser e (b -> b) -> Parser e b -> Parser e b
forall a b. Parser e (a -> b) -> Parser e a -> Parser e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser e b
go) Parser e b -> Parser e b -> Parser e b
forall a. Parser e a -> Parser e a -> Parser e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser e b
z

withOption :: Parser e a -> (a -> Parser e b) -> Parser e b -> Parser e b
withOption :: forall e a b.
Parser e a -> (a -> Parser e b) -> Parser e b -> Parser e b
withOption Parser e a
p a -> Parser e b
f Parser e b
def = (Parser e a
p Parser e a -> (a -> Parser e b) -> Parser e b
forall a b. Parser e a -> (a -> Parser e b) -> Parser e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parser e b
f) Parser e b -> Parser e b -> Parser e b
forall a. Parser e a -> Parser e a -> Parser e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser e b
def

-- * String matching

char :: Char -> Parser e ()
char :: forall e. Char -> Parser e ()
char Char
c = Parser e Char -> Parser e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser e Char -> Parser e ()) -> Parser e Char -> Parser e ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser e Char
forall e. (Char -> Bool) -> Parser e Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)

byteString :: ByteString -> Parser e ()
byteString :: forall e. ByteString -> Parser e ()
byteString ByteString
bs = (ByteString -> Result e ()) -> Parser e ()
forall e a. (ByteString -> Result e a) -> Parser e a
Parser ((ByteString -> Result e ()) -> Parser e ())
-> (ByteString -> Result e ()) -> Parser e ()
forall a b. (a -> b) -> a -> b
$ \ByteString
s ->
  if ByteString
bs ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
s
    then () -> ByteString -> Result e ()
forall e a. a -> ByteString -> Result e a
OK () (Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
bs) ByteString
s)
    else Result e ()
forall e a. Result e a
Fail

-- * Repetition

many :: Parser e a -> Parser e [a]
many :: forall e a. Parser e a -> Parser e [a]
many Parser e a
p = Parser e [a]
go
  where
    go :: Parser e [a]
go = ((:) (a -> [a] -> [a]) -> Parser e a -> Parser e ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e a
p Parser e ([a] -> [a]) -> Parser e [a] -> Parser e [a]
forall a b. Parser e (a -> b) -> Parser e a -> Parser e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser e [a]
go) Parser e [a] -> Parser e [a] -> Parser e [a]
forall a. Parser e a -> Parser e a -> Parser e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser e [a]
forall a. a -> Parser e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

some :: Parser e a -> Parser e [a]
some :: forall e a. Parser e a -> Parser e [a]
some Parser e a
p = (:) (a -> [a] -> [a]) -> Parser e a -> Parser e ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e a
p Parser e ([a] -> [a]) -> Parser e [a] -> Parser e [a]
forall a b. Parser e (a -> b) -> Parser e a -> Parser e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser e a -> Parser e [a]
forall e a. Parser e a -> Parser e [a]
many Parser e a
p