97 lines
2.6 KiB
Haskell
97 lines
2.6 KiB
Haskell
{-# LANGUAGE InstanceSigs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
module Language.Json.Parser (runParser, Parser, exact, char, oneOf, optional, anyChar, satisfies, times, sepBy, eof) where
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import Control.Applicative (Alternative (..), asum)
|
|
import Data.Functor (($>))
|
|
|
|
newtype Parser a = Parser (Text -> Reply a)
|
|
|
|
data Reply a
|
|
= Done Text a -- rest, result
|
|
| Fail
|
|
|
|
instance Functor Reply where
|
|
fmap :: (a -> b) -> Reply a -> Reply b
|
|
fmap f = \case
|
|
Done rest result -> Done rest (f result)
|
|
Fail -> Fail
|
|
|
|
runParser :: Parser a -> Text -> Maybe (Text, a)
|
|
runParser (Parser computeA) input = case computeA input of
|
|
Done rest result -> Just (rest, result)
|
|
Fail -> Nothing
|
|
|
|
instance Functor Parser where
|
|
fmap :: (a -> b) -> Parser a -> Parser b
|
|
fmap func (Parser computeA) = Parser (fmap func . computeA)
|
|
|
|
instance Applicative Parser where
|
|
pure :: a -> Parser a
|
|
pure a = Parser $ \ input -> Done input a
|
|
(<*>) :: Parser (a -> b) -> Parser a -> Parser b
|
|
(<*>) (Parser computeF) (Parser computeA) = Parser $ \ input -> case computeF input of
|
|
Done rest f -> f <$> computeA rest
|
|
Fail -> Fail
|
|
|
|
instance Monad Parser where
|
|
(>>=) :: Parser a -> (a -> Parser b) -> Parser b
|
|
(>>=) (Parser computeA) f = Parser $ \ input -> case computeA input of
|
|
Done rest a -> let
|
|
(Parser computeB) = f a
|
|
in computeB rest
|
|
Fail -> Fail
|
|
|
|
exact :: Text -> Parser ()
|
|
exact prefix = Parser $ \ input -> case Text.stripPrefix prefix input of
|
|
Just rest -> Done rest ()
|
|
Nothing -> Fail
|
|
|
|
instance Alternative Parser where
|
|
empty :: Parser a
|
|
empty = Parser $ const Fail
|
|
(<|>) :: Parser a -> Parser a -> Parser a
|
|
(<|>) (Parser first) (Parser second) = Parser $ \ input -> case first input of
|
|
Fail -> second input
|
|
x -> x
|
|
|
|
char :: Char -> Parser Char
|
|
char c = exact (Text.singleton c) $> c
|
|
|
|
oneOf :: [Parser a] -> Parser a
|
|
oneOf = asum
|
|
|
|
optional :: Parser a -> Parser (Maybe a)
|
|
optional parser = fmap Just parser <|> pure Nothing
|
|
|
|
anyChar :: Parser Char
|
|
anyChar = Parser $ \ input -> case Text.uncons input of
|
|
Just (c, rest) -> Done rest c
|
|
Nothing -> Fail
|
|
|
|
satisfies :: (Char -> Bool) -> Parser Char
|
|
satisfies f = do
|
|
c <- anyChar
|
|
if f c
|
|
then pure c
|
|
else empty
|
|
|
|
times :: Int -> Parser a -> Parser [a]
|
|
times n body = go n
|
|
where
|
|
go 0 = pure []
|
|
go i = do
|
|
x <- body
|
|
xs <- go $ pred i
|
|
pure $ x:xs
|
|
|
|
sepBy :: Parser a -> Parser b -> Parser [a]
|
|
sepBy p sep = do
|
|
first <- optional p
|
|
rest <- sep *> sepBy p sep <|> pure []
|
|
|
|
pure $ maybe id (:) first rest
|
|
|
|
eof :: Parser Bool
|
|
eof = anyChar *> empty <|> pure True
|