Instantly share code, notes, and snippets.

Embed
What would you like to do?
Parser
module Main where
import Data.Functor (void)
import Control.Applicative ((<|>), empty, many, some, optional)
import Control.Monad (msum, replicateM)
import Control.Monad.State (StateT(runStateT))
import Control.Monad.State.Class (get, put)
import Data.Char (isHexDigit, chr, isDigit, isSpace)
import Data.Map (Map)
import Data.Maybe (listToMaybe, fromMaybe)
import Numeric (readHex, readFloat)
import qualified Data.Map as Map
type Parser = StateT String Maybe
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
input <- get
case input of
[] -> empty
(a:as)
| p a -> a <$ put as
| otherwise -> empty
char :: Char -> Parser Char
char = satisfy . (==)
spaces :: Parser String
spaces = many (satisfy isSpace)
lex' :: Parser a -> Parser a
lex' p = p <* spaces
noneOf :: [Char] -> Parser Char
noneOf chars = satisfy (not . (`elem` chars))
between :: Applicative f => f brac -> f ket -> f a -> f a
between brac ket a = brac *> a <* ket
jsonString :: Parser String
jsonString =
between
(char '\"')
(char '\"')
(some (special <|> unicode <|> chars))
where
chars = noneOf "\"\\"
escaped p = char '\\' *> p
special =
escaped
(msum
[ char '\"'
, char '\\'
, char '/'
, char '\b'
, char '\f'
, char '\n'
, char '\r'
, char '\t'
])
unicode = do
digits <- escaped (char 'u' *> replicateM 4 (satisfy isHexDigit))
case fst <$> listToMaybe (readHex digits) of
Nothing -> empty
(Just n) -> pure (chr n)
jsonNumber :: Parser Rational
jsonNumber = do
ds <- digits
case fst <$> listToMaybe (readFloat ds) of
Nothing -> empty
Just num -> pure num
where
unsignedIntDigits = some (satisfy isDigit)
signedIntDigits = (:) <$> char '-' <*> unsignedIntDigits
decimalDigits = (:) <$> char '.' <*> unsignedIntDigits
digits =
(<>)
<$> (signedIntDigits <|> unsignedIntDigits)
<*> (fromMaybe "" <$> optional decimalDigits)
string :: String -> Parser String
string = traverse char
jsonNull :: Parser String
jsonNull = string "null"
jsonFalse :: Parser String
jsonFalse = string "false"
jsonTrue :: Parser String
jsonTrue = string "true"
sepBy :: Parser sep -> Parser a -> Parser [a]
sepBy sep a = (:) <$> a <*> many (sep *> a)
data Value
= Object (Map String Value)
| Array [Value]
| String String
| Number Rational
| Bool Bool
| Null
deriving (Eq, Read, Show)
jsonArray :: Parser [Value]
jsonArray =
between
(lex' (char '['))
(lex' (char ']'))
(sepBy (lex' (char ',')) jsonValue)
jsonObject :: Parser (Map String Value)
jsonObject =
Map.fromList <$>
between
(lex' (char '{'))
(lex' (char '}'))
(sepBy (lex' (char ',')) keyValue)
where
keyValue = (,) <$> lex' jsonString <* lex' (char ':') <*> lex' jsonValue
jsonValue :: Parser Value
jsonValue =
spaces *>
msum
[ Object <$> jsonObject
, Array <$> jsonArray
, String <$> jsonString
, Null <$ jsonNull
, Bool False <$ jsonFalse
, Bool True <$ jsonTrue
, Number <$> jsonNumber
]
<* spaces
main :: IO ()
main = print "Hey"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment