Created
March 2, 2012 23:53
-
-
Save petermarks/1962567 to your computer and use it in GitHub Desktop.
JSON QuasiQuoting
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-------------------------------------------------------------------- | |
-- | | |
-- Module : Text.JSON.Parsec | |
-- Copyright : (c) Galois, Inc. 2007-2009 | |
-- | |
-- Maintainer: Sigbjorn Finne <sof@galois.com> | |
-- Stability : provisional | |
-- Portability: portable | |
-- | |
-- Parse JSON values using the Parsec combinators. | |
module JSONParse | |
( p_value | |
, p_null | |
, p_boolean | |
, p_array | |
, p_string | |
, p_object | |
, p_number | |
, p_js_string | |
, p_js_object | |
, p_jvalue | |
, module Text.ParserCombinators.Parsec | |
) where | |
import Text.JSON.Types | |
import Text.ParserCombinators.Parsec | |
import Control.Monad | |
import Data.Char | |
import Numeric | |
p_value :: CharParser () JSValue -> CharParser () JSValue | |
p_value r = spaces *> p_jvalue r | |
tok :: CharParser () a -> CharParser () a | |
tok p = p <* spaces | |
p_jvalue :: CharParser () JSValue -> CharParser () JSValue | |
p_jvalue r = (JSNull <$ p_null) | |
<|> (JSBool <$> p_boolean) | |
<|> (JSArray <$> p_array r) | |
<|> (JSString <$> p_js_string) | |
<|> (JSObject <$> p_js_object r) | |
<|> (JSRational False <$> p_number) | |
<?> "JSON value" | |
p_null :: CharParser () () | |
p_null = tok (string "null") >> return () | |
p_boolean :: CharParser () Bool | |
p_boolean = tok | |
( (True <$ string "true") | |
<|> (False <$ string "false") | |
) | |
p_array :: CharParser () JSValue -> CharParser () [JSValue] | |
p_array r = between (tok (char '[')) (tok (char ']')) | |
$ r `sepBy` tok (char ',') | |
p_string :: CharParser () String | |
p_string = between (tok (char '"')) (char '"') (many p_char) | |
where p_char = (char '\\' >> p_esc) | |
<|> (satisfy (\x -> x /= '"' && x /= '\\')) | |
p_esc = ('"' <$ char '"') | |
<|> ('\\' <$ char '\\') | |
<|> ('/' <$ char '/') | |
<|> ('\b' <$ char 'b') | |
<|> ('\f' <$ char 'f') | |
<|> ('\n' <$ char 'n') | |
<|> ('\r' <$ char 'r') | |
<|> ('\t' <$ char 't') | |
<|> (char 'u' *> p_uni) | |
<?> "escape character" | |
p_uni = check =<< count 4 (satisfy isHexDigit) | |
where check x | code <= max_char = pure (toEnum code) | |
| otherwise = empty | |
where code = fst $ head $ readHex x | |
max_char = fromEnum (maxBound :: Char) | |
p_object :: CharParser () JSValue -> CharParser () [(String,JSValue)] | |
p_object r = between (tok (char '{')) (tok (char '}')) | |
$ p_field `sepBy` tok (char ',') | |
where p_field = (,) <$> (p_string <* tok (char ':')) <*> r | |
p_number :: CharParser () Rational | |
p_number = do s <- getInput | |
case readSigned readFloat s of | |
[(n,s1)] -> n <$ setInput s1 | |
_ -> empty | |
p_js_string :: CharParser () JSString | |
p_js_string = toJSString <$> p_string | |
p_js_object :: CharParser () JSValue -> CharParser () (JSObject JSValue) | |
p_js_object r = toJSObject <$> p_object r | |
-------------------------------------------------------------------------------- | |
-- XXX: Because Parsec is not Applicative yet... | |
pure :: a -> CharParser () a | |
pure = return | |
(<*>) :: CharParser () (a -> b) -> CharParser () a -> CharParser () b | |
(<*>) = ap | |
(*>) :: CharParser () a -> CharParser () b -> CharParser () b | |
(*>) = (>>) | |
(<*) :: CharParser () a -> CharParser () b -> CharParser () a | |
m <* n = do x <- m; _ <- n; return x | |
empty :: CharParser () a | |
empty = mzero | |
(<$>) :: (a -> b) -> CharParser () a -> CharParser () b | |
(<$>) = fmap | |
(<$) :: a -> CharParser () b -> CharParser () a | |
x <$ m = m >> return x |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# language TemplateHaskell #-} | |
module JSONQuoter where | |
import Language.Haskell.TH | |
import Data.Function | |
-- import Language.Haskell.Meta.Parse | |
import Language.Haskell.TH.Lift | |
import Language.Haskell.TH.Quote | |
import Text.JSON | |
import JSONParse | |
import Text.ParserCombinators.Parsec | |
$(deriveLift ''JSObject) | |
$(deriveLift ''JSString) | |
$(deriveLift ''JSValue) | |
jsonParse :: String -> ExpQ | |
jsonParse s = do | |
case result of | |
Right d -> [e| d |] | |
Left m -> fail $ show m | |
where | |
result = parse (fix p_jvalue) "source" s | |
json :: QuasiQuoter | |
json = QuasiQuoter jsonParse undefined | |
-- parseAnti :: CharParser () JSValue | |
-- parseAnti = do | |
-- hask <- string "$(" *> manyTill (char ")") | |
-- case parseExp hask of | |
-- Left s -> fail s | |
-- Right exp -> | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# language TemplateHaskell, QuasiQuotes #-} | |
module JSONTest where | |
import JSONQuoter | |
main = putStrLn $ show [$json|[1,2,3]|] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment