text-json-qq 0.3.0 → 0.4.0
raw patch · 2 files changed
+15/−200 lines, 2 filesdep +json-qq
Dependencies added: json-qq
Files
- src/Text/JSON/QQ.hs +12/−197
- text-json-qq.cabal +3/−3
src/Text/JSON/QQ.hs view
@@ -52,6 +52,8 @@ import Text.JSON import Text.JSON.Generic +import Data.JSON.QQ+ import Data.Ratio import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Error@@ -74,22 +76,18 @@ Left err -> error $ "Error in jsonExp: " ++ show err Right val -> return $ toExp val where- parsed' = parse jpValue "txt" txt+ parsed' = parsedJson txt ---- -- JSValue etc to ExpQ -----------class ToExp a where- toExp :: a -> Exp--instance ToExp JsonValue where- toExp (JsonString str) = +toExp :: JsonValue -> Exp+toExp (JsonString str) = AppE (ConE $ mkName "Text.JSON.JSString") (AppE (VarE $ mkName "Text.JSON.toJSString") (LitE (StringL $ str))) - toExp (JsonNull) = ConE $ mkName "Text.JSON.Types.JSNull"+toExp (JsonNull) = ConE $ mkName "Text.JSON.Types.JSNull" - toExp (JsonObject objs) = +toExp (JsonObject objs) = AppE (ConE $ mkName "Text.JSON.JSObject") (AppE (VarE $ mkName "Text.JSON.toJSObject") (ListE $ jsList )) where jsList :: [Exp] -- [(String,JSValue)]@@ -98,200 +96,17 @@ objs2list (HashStringKey k,v) = TupE [LitE (StringL k), toExp v] objs2list (HashVarKey k,v) = TupE [VarE $ mkName k, toExp v] - toExp (JsonArray arr) =+toExp (JsonArray arr) = AppE (ConE $ mkName "Text.JSON.JSArray") (ListE $ map toExp arr) - toExp (JsonNumber b rat) =+toExp (JsonNumber b rat) = AppE (AppE (ConE $ mkName "Text.JSON.JSRational") (ConE $ mkName (if b then "True" else "False"))) (InfixE (Just (LitE (IntegerL $ numerator rat))) (VarE $ mkName "Data.Ratio.%") (Just (LitE (IntegerL $ denominator rat)))) - toExp (JsonIdVar v) =+toExp (JsonIdVar v) = VarE $ mkName v - toExp (JsonBool b) =+toExp (JsonBool b) = AppE (ConE $ mkName "Text.JSON.JSBool") (ConE $ mkName (if b then "True" else "False")) - toExp (JsonCode exp) =+toExp (JsonCode exp) = AppE (VarE $ mkName "Text.JSON.Generic.toJSON") exp------------ ToJsonOrId---- class ToJsonOrId a where--- toJsonOrId :: a -> JSValue------------ Internal representation--data JsonValue =- JsonNull- | JsonString String- | JsonNumber Bool Rational- | JsonObject [(HashKey,JsonValue)] -- [(String,JsonValue)]- | JsonArray [JsonValue]- | JsonIdVar String- | JsonBool Bool- | JsonCode Exp--data HashKey =- HashVarKey String- | HashStringKey String----------- Grammar--- jp = json parsec--------(=>>) :: Monad m => m a -> b -> m b-x =>> y = x >> return y---(>>>=) :: Monad m => m a -> (a -> b) -> m b-x >>>= y = x >>= return . y--type JsonParser = Parser JsonValue--data QQJsCode =- QQjs JSValue- | QQcode String--jpValue :: JsonParser-jpValue = do- spaces- res <- jpTrue <|> jpFalse <|> try jpIdVar <|> jpNull <|> jpString <|> jpObject <|> jpNumber <|> jpArray <|> jpCode- spaces- return res--jpTrue :: JsonParser-jpTrue = jpBool "true" True--jpFalse :: JsonParser-jpFalse = jpBool "false" False--jpBool :: String -> Bool -> JsonParser-jpBool txt b = string txt =>> JsonBool b--jpCode :: JsonParser-jpCode = do- string "<|"- parseExp' >>>= JsonCode- where- parseExp' = do- str <- untilString- case (parseExp str) of- Left l -> fail l- Right r -> return r-----jpIdVar :: JsonParser-jpIdVar = between (string "<<") (string ">>") symbol >>>= JsonIdVar---jpNull :: JsonParser-jpNull = do- string "null" =>> JsonNull--jpString :: JsonParser -jpString = between (char '"') (char '"') (option [""] $ many chars) >>= return . JsonString . concat -- do--jpNumber :: JsonParser -jpNumber = do- val <- float- return $ JsonNumber False (toRational val)--jpObject :: JsonParser-jpObject = do- list <- between (char '{') (char '}') (commaSep jpHash)- return $ JsonObject $ list- where- jpHash :: CharParser () (HashKey,JsonValue) -- (String,JsonValue)- jpHash = do- spaces- name <- varKey <|> symbolKey <|> quotedStringKey- spaces- char ':'- spaces- value <- jpValue- spaces- return (name,value)--symbolKey :: CharParser () HashKey-symbolKey = symbol >>>= HashStringKey--quotedStringKey :: CharParser () HashKey-quotedStringKey = quotedString >>>= HashStringKey--varKey :: CharParser () HashKey-varKey = do- char '$'- sym <- symbol- return $ HashVarKey sym--jpArray :: CharParser () JsonValue-jpArray = between (char '[') (char ']') (commaSep jpValue) >>>= JsonArray------------ helpers for parser/grammar--untilString :: Parser String-untilString = do- n0 <- option "" $ many1 (noneOf "|")- char '|'- n1 <- option "" $ many1 (noneOf ">")- char '>'- if not $ null n1- then do n2 <- untilString- return $ concat [n0,n1,n2]- else return $ concat [n0,n1]- ---float :: CharParser st Double -float = do- isMinus <- option ' ' (char '-')- d <- many1 digit- o <- option "" withDot- e <- option "" withE- return $ (read $ isMinus : d ++ o ++ e :: Double)--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--quotedString :: CharParser () String-quotedString = between (char '"') (char '"') (option [""] $ many chars) >>>= concat--symbol :: CharParser () String-symbol = many1 (noneOf "\\ \":;><$")--commaSep p = p `sepBy` (char ',')--chars :: CharParser () String-chars = do- try (string "\\\"")- <|> try (string "\\/")- <|> try (string "\\\\")- <|> try (string "\\b")- <|> try (string "\\f")- <|> try (string "\\n")- <|> try (string "\\r")- <|> try (string "\\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]
text-json-qq.cabal view
@@ -1,5 +1,5 @@ name: text-json-qq-version: 0.3.0+version: 0.4.0 synopsis: Json Quasiquatation for Haskell. -- A longer description of the package.@@ -18,14 +18,14 @@ license-file: COPYING.txt author: Oscar Finnsson maintainer: oscar.finnsson@gmail.com-category: Text+category: JSON build-type: Simple cabal-version: >=1.6 library hs-source-dirs: src exposed-modules: Text.JSON.QQ- build-depends: base >= 4.3 && < 5, json, parsec >= 2 && < 3, template-haskell, haskell-src-meta >= 0.1.0+ build-depends: base >= 4.3 && < 5, json-qq, json, parsec >= 2 && < 3, template-haskell, haskell-src-meta >= 0.1.0 source-repository head type: git