text-json-qq 0.1.1 → 0.2.0
raw patch · 2 files changed
+91/−92 lines, 2 filesdep +haskell-src-meta
Dependencies added: haskell-src-meta
Files
- src/Text/JSON/QQ.hs +89/−90
- text-json-qq.cabal +2/−2
src/Text/JSON/QQ.hs view
@@ -17,15 +17,21 @@ -- -- The quasiquatation can also bind to variables like -- --- > myCode = [$jsonQQ| {age: <<age>>, name: <<name>>} |]+-- > myCode = [$jsonQQ| {age: <|age|>, name: <|name|>} |] -- > where age = 34 :: Integer -- > name = "Pelle" -- -- where the function @toJSON@ will be called on @age@ and @name@ runtime.+--+-- You can also insert Haskell code: +--+-- > myCode = [$jsonQQ| {age: <|age + 34 :: Integer|>, name: <|map toUpper name|>} |]+-- > where age = 34 :: Integer+-- > name = "Pelle" -- -- You can use a similar syntax if you want to insert a value of type JSValue like -- --- > myCode = [$jsonQQ| {"age": <<<age>>>} |]+-- > myCode = [$jsonQQ| {"age": <<age>>} |] -- -- If you want to replace the name of the key in a hash you'll use the $-syntax: -- @@ -49,7 +55,10 @@ import Data.Ratio import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Error+-- import Text.Parsec.Perm +import Language.Haskell.Meta.Parse+ jsonQQ :: QuasiQuoter jsonQQ = QuasiQuoter jsonExp jsonPat @@ -58,10 +67,9 @@ jsonExp txt = case parsed' of Left err -> error $ "Error in jsonExp: " ++ show err- Right val -> return $ toExp val -- test -- dataToExpQ undefined test -- [| test |] -- [| toJSObject [("a","b")] |] --+ Right val -> return $ toExp val where parsed' = parse jpValue "txt" txt- -- test = JSObject $ toJSObject [("a",JSNull)] jsonPat :: String -> PatQ jsonPat s = undefined@@ -76,12 +84,12 @@ instance ToExp JsonValue where toExp (JsonString str) = - AppE (ConE $ mkName "Text.JSON.Types.JSString") (AppE (VarE $ mkName "Text.JSON.Types.toJSString") (LitE (StringL $ 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 (JsonObject objs) = - AppE (ConE $ mkName "Text.JSON.Types.JSObject") (AppE (VarE $ mkName "Text.JSON.Types.toJSObject") (ListE $ jsList ))+ AppE (ConE $ mkName "Text.JSON.JSObject") (AppE (VarE $ mkName "Text.JSON.toJSObject") (ListE $ jsList )) where jsList :: [Exp] -- [(String,JSValue)] jsList = map objs2list (objs)@@ -90,20 +98,20 @@ objs2list (HashVarKey k,v) = TupE [VarE $ mkName k, toExp v] toExp (JsonArray arr) =- AppE (ConE $ mkName "Text.JSON.Types.JSArray") (ListE $ map toExp arr)+ AppE (ConE $ mkName "Text.JSON.JSArray") (ListE $ map toExp arr) toExp (JsonNumber b rat) =- AppE (AppE (ConE $ mkName "Text.JSON.Types.JSRational") (ConE $ mkName (if b then "True" else "False"))) (InfixE (Just (LitE (IntegerL $ numerator rat))) (VarE $ mkName "Data.Ratio.%") (Just (LitE (IntegerL $ denominator 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 (JsonVar v) =- AppE (VarE $ mkName "Text.JSON.Generic.toJSON") (VarE $ mkName v)- toExp (JsonIdVar v) = VarE $ mkName v toExp (JsonBool b) =- AppE (ConE $ mkName "Text.JSON.Types.JSBool") (ConE $ mkName (if b then "True" else "False"))+ AppE (ConE $ mkName "Text.JSON.JSBool") (ConE $ mkName (if b then "True" else "False")) + toExp (JsonCode exp) =+ AppE (VarE $ mkName "Text.JSON.Generic.toJSON") exp+ ------- -- ToJsonOrId @@ -119,85 +127,84 @@ | JsonNumber Bool Rational | JsonObject [(HashKey,JsonValue)] -- [(String,JsonValue)] | JsonArray [JsonValue]- | JsonVar String | JsonIdVar String | JsonBool Bool+ | JsonCode Exp data HashKey = HashVarKey String | HashStringKey String --- data JsonHashPair =--- JsonStringPair String JsonValue--- | JsonVarPair String JsonValue- ------ -- 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 :: CharParser st JsonValue+jpValue :: JsonParser jpValue = do spaces- res <- jpTrue <|> jpFalse <|> try jpVar <|> try jpIdVar <|> jpNull <|> jpString <|> jpObject <|> try jpNumber <|> jpArray+ res <- jpTrue <|> jpFalse <|> try jpIdVar <|> jpNull <|> jpString <|> jpObject <|> jpNumber <|> jpArray <|> jpCode spaces return res -jpTrue :: CharParser st JsonValue-jpTrue = do- string "true"- return $ JsonBool True+jpTrue :: JsonParser+jpTrue = jpBool "true" True -jpFalse :: CharParser st JsonValue-jpFalse = do- string "false"- return $ JsonBool False+jpFalse :: JsonParser+jpFalse = jpBool "false" False -jpIdVar :: CharParser st JsonValue-jpIdVar = do- string "<<<"- sym <- symbol- string ">>>"- return $ JsonIdVar sym+jpBool :: String -> Bool -> JsonParser+jpBool txt b = string txt =>> JsonBool b -jpVar :: CharParser st JsonValue-jpVar = do- string "<<"- sym <- symbol- string ">>"- return $ JsonVar sym+jpCode :: JsonParser+jpCode = do+ string "<|"+ parseExp' >>>= JsonCode+ where+ parseExp' = do+ str <- untilString+ case (parseExp str) of+ Left l -> fail l+ Right r -> return r -jpNull :: CharParser st JsonValue++++jpIdVar :: JsonParser+jpIdVar = between (string "<<") (string ">>") symbol >>>= JsonIdVar+++jpNull :: JsonParser jpNull = do- string "null"- return $ JsonNull+ string "null" =>> JsonNull -jpString :: CharParser st JsonValue -jpString = do- char '"'- sym <- try $ option [""] $ many chars- char '"'- return $ JsonString $ concat sym +jpString :: JsonParser +jpString = between (char '"') (char '"') (option [""] $ many chars) >>= return . JsonString . concat -- do -jpNumber :: CharParser st JsonValue +jpNumber :: JsonParser jpNumber = do val <- float return $ JsonNumber False (toRational val) -jpObject :: CharParser st JsonValue+jpObject :: JsonParser jpObject = do- char '{'- spaces- list <- commaSep jpHash- spaces- char '}'+ list <- between (char '{') (char '}') (commaSep jpHash) return $ JsonObject $ list where- jpHash :: CharParser st (HashKey,JsonValue) -- (String,JsonValue)+ jpHash :: CharParser () (HashKey,JsonValue) -- (String,JsonValue) jpHash = do spaces name <- varKey <|> symbolKey <|> quotedStringKey@@ -208,34 +215,37 @@ spaces return (name,value) -symbolKey :: CharParser st HashKey-symbolKey = do- sym <- symbol- return $ HashStringKey sym+symbolKey :: CharParser () HashKey+symbolKey = symbol >>>= HashStringKey -quotedStringKey :: CharParser st HashKey-quotedStringKey = do- quo <- quotedString- return $ HashStringKey quo+quotedStringKey :: CharParser () HashKey+quotedStringKey = quotedString >>>= HashStringKey -varKey :: CharParser st HashKey+varKey :: CharParser () HashKey varKey = do char '$' sym <- symbol return $ HashVarKey sym -jpArray :: CharParser st JsonValue-jpArray = do- char '['- spaces- list <- commaSep jpValue- spaces- char ']'- return $ JsonArray list+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 '-')@@ -255,26 +265,15 @@ d <- many digit return $ o:d --- jsonSymbol :: CharParser st String--- jsonSymbol = do--- symbol <|> symbol'--- where--- symbol' = do--- char '"'--quotedString :: CharParser st String-quotedString = do- char '"'- sym <- try $ option [""] $ many chars- char '"'- return $ concat sym +quotedString :: CharParser () String+quotedString = between (char '"') (char '"') (option [""] $ many chars) >>>= concat -symbol :: CharParser st String-symbol = many1 (noneOf "\\ \":;><") -- alphaNum -- should be replaced!+symbol :: CharParser () String+symbol = many1 (noneOf "\\ \":;><$") commaSep p = p `sepBy` (char ',') -chars :: CharParser st String+chars :: CharParser () String chars = do try (string "\\\"") <|> try (string "\\/")@@ -287,7 +286,7 @@ <|> try (unicodeChars) <|> many1 (noneOf "\\\"") -unicodeChars :: CharParser st String+unicodeChars :: CharParser () String unicodeChars = do u <- string "\\u" d1 <- hexDigit
text-json-qq.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1.1+Version: 0.2.0 -- A short (one-line) description of the package. Synopsis: Json Quasiquatation for Haskell.@@ -55,7 +55,7 @@ -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.2 -build-depends: base >= 4.2 && < 5, json, parsec >= 2 && < 3, template-haskell+build-depends: base >= 4.2 && < 5, json, parsec >= 2 && < 3, template-haskell, haskell-src-meta >= 0.1.0 hs-source-dirs: src