module Data.JSON.QQ (JsonValue (..), HashKey (..), parsedJson) where
import Control.Applicative
import Language.Haskell.TH
import Text.ParserCombinators.Parsec hiding (many, (<|>))
import Language.Haskell.Meta.Parse
import qualified Data.Attoparsec.Text as A
import Data.Scientific (Scientific)
import qualified Data.Text as T
parsedJson :: String -> Either ParseError JsonValue
parsedJson = parse (jpValue <* eof) "txt"
data JsonValue =
JsonNull
| JsonString String
| JsonNumber Scientific
| JsonObject [(HashKey,JsonValue)]
| JsonArray [JsonValue]
| JsonBool Bool
| JsonCode Exp
deriving (Eq, Show)
data HashKey =
HashVarKey String
| HashStringKey String
deriving (Eq, Show)
type JsonParser = Parser JsonValue
jpValue :: JsonParser
jpValue = do
spaces
res <- jpBool <|> jpNull <|> jpString <|> jpObject <|> jpNumber <|> jpArray <|> jpCode
spaces
return res
jpBool :: JsonParser
jpBool = JsonBool <$> (string "true" *> pure True <|> string "false" *> pure False)
jpCode :: JsonParser
jpCode = JsonCode <$> (string "#{" *> parseExp')
where
parseExp' = do
str <- many1 (noneOf "}") <* char '}'
case (parseExp str) of
Left l -> fail l
Right r -> return r
jpNull :: JsonParser
jpNull = string "null" *> pure JsonNull
jpString :: JsonParser
jpString = between (char '"') (char '"') (option [""] $ many chars) >>= return . JsonString . concat
jpNumber :: JsonParser
jpNumber = JsonNumber <$> do
isMinus <- option "" (string "-")
d <- many1 digit
o <- option "" withDot
e <- option "" withE
convert (isMinus ++ d ++ o ++ e)
where
withE = do
e <- char 'e' <|> char 'E'
plusMinus <- option "" (string "+" <|> string "-")
d <- many digit
return $ e : plusMinus ++ d
withDot = do
o <- char '.'
d <- many digit
return $ o:d
convert :: String -> Parser Scientific
convert = either fail return . A.parseOnly (A.scientific <* A.endOfInput) . T.pack
jpObject :: JsonParser
jpObject = do
list <- between (char '{') (char '}') (spaces *> commaSep jpHash)
return $ JsonObject $ list
where
jpHash :: CharParser () (HashKey,JsonValue)
jpHash = do
spaces
name <- varKey <|> symbolKey <|> quotedStringKey
spaces
_ <- char ':'
spaces
value <- jpValue
spaces
return (name,value)
symbolKey :: CharParser () HashKey
symbolKey = HashStringKey <$> symbol
quotedStringKey :: CharParser () HashKey
quotedStringKey = HashStringKey <$> quotedString
varKey :: CharParser () HashKey
varKey = HashVarKey <$> (char '$' *> symbol)
jpArray :: CharParser () JsonValue
jpArray = JsonArray <$> between (char '[') (char ']') (spaces *> commaSep jpValue)
quotedString :: CharParser () String
quotedString = concat <$> between (char '"') (char '"') (option [""] $ many chars)
symbol :: CharParser () String
symbol = many1 (noneOf "\\ \":;><${}")
commaSep :: CharParser () a -> CharParser () [a]
commaSep p = p `sepBy` (char ',')
chars :: CharParser () String
chars = do
try (string "\\\"" *> pure "\"")
<|> try (string "\\\\" *> pure "\\")
<|> try (string "\\/" *> pure "/")
<|> try (string "\\b" *> pure "\b")
<|> try (string "\\f" *> pure "\f")
<|> try (string "\\n" *> pure "\n")
<|> try (string "\\r" *> pure "\r")
<|> try (string "\\t" *> pure "\t")
<|> try (unicodeChars)
<|> many1 (noneOf "\\\"")
unicodeChars :: CharParser () String
unicodeChars = do
u <- string "\\u"
d1 <- hexDigit
d2 <- hexDigit
d3 <- hexDigit
d4 <- hexDigit
return $ u ++ [d1] ++ [d2] ++ [d3] ++ [d4]