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 JSONTypes | |
import Text.ParserCombinators.Parsec | |
import Control.Monad | |
import Data.Char | |
import Numeric | |
p_value :: CharParser () r -> CharParser () (JSValue r) | |
p_value r = spaces *> p_jvalue r | |
tok :: CharParser () a -> CharParser () a | |
tok p = p <* spaces | |
p_jvalue :: CharParser () r -> CharParser () (JSValue r) | |
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 () r -> CharParser () [r] | |
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 () r -> CharParser () [(String,r)] | |
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 () r -> CharParser () (JSObject r) | |
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, QuasiQuotes, FlexibleInstances, FlexibleContexts, | |
UndecidableInstances #-} | |
module JSONQuoter ( | |
json | |
, Fix(..) | |
) where | |
import Language.Haskell.TH | |
import Data.Function | |
import Control.Applicative ((<$>)) | |
import Language.Haskell.Meta.Parse | |
import Language.Haskell.TH.Lift | |
import Language.Haskell.TH.Quote | |
import JSONTypes | |
import JSONParse | |
import Text.ParserCombinators.Parsec | |
$(deriveLift ''JSObject) | |
$(deriveLift ''JSString) | |
$(deriveLift ''JSValue) | |
newtype Fix f = Fix (f (Fix f)) | |
instance (Show (f (Fix f))) => Show (Fix f) where | |
showsPrec p (Fix f) = showString "Fix " . showParen True (showsPrec p f) | |
instance (Lift (f (Fix f))) => Lift (Fix f) where | |
lift (Fix f) = [e| Fix f |] | |
data Free f a = Pure a | Free (f (Free f a)) | |
instance (Show (f (Free f a)), Show a) => Show (Free f a) where | |
showsPrec p (Pure v) = showString "Pure " . showParen True (showsPrec p v) | |
showsPrec p (Free f) = showString "Free " . showParen True (showsPrec p f) | |
instance (Lift (f (Free f Exp))) => Lift (Free f Exp) where | |
lift (Pure e) = return e | |
lift (Free f) = appE [e| Fix |] [e| f |] | |
jsonParse :: String -> ExpQ | |
jsonParse s = do | |
case result of | |
Right d -> [e| d |] | |
Left m -> fail $ show m | |
where | |
result = parse (parserWithAnti p_jvalue) "source" s | |
json :: QuasiQuoter | |
json = QuasiQuoter jsonParse undefined | |
parseAnti :: CharParser () Exp | |
parseAnti = do | |
hask <- string "$(" >> manyTill anyChar (char ')') | |
case parseExp hask of | |
Left s -> fail s | |
Right exp -> return exp | |
fixParser :: (CharParser () (Fix f) -> CharParser () (f (Fix f))) -> CharParser () (Fix f) | |
fixParser f = fix $ \g -> Fix <$> f g | |
parserWithAnti :: (CharParser () (Free f Exp) -> CharParser () (f (Free f Exp))) -> CharParser () (Free f Exp) | |
parserWithAnti f = fix $ \g -> (Free <$> f g) <|> (Pure <$> parseAnti) |
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 Main where | |
import JSONTypes | |
import JSONQuoter | |
main = putStrLn $ show [$json|[1,$(Fix $ JSRational False $ 2+1),3]|] |
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 DeriveDataTypeable #-} | |
-------------------------------------------------------------------- | |
-- | | |
-- Module : Text.JSON.Types | |
-- Copyright : (c) Galois, Inc. 2007-2009 | |
-- License : BSD3 | |
-- | |
-- Maintainer: Sigbjorn Finne <sof@galois.com> | |
-- Stability : provisional | |
-- Portability: portable | |
-- | |
-------------------------------------------------------------------- | |
-- | |
-- Basic support for working with JSON values. | |
-- | |
module JSONTypes ( | |
-- * JSON Types | |
JSValue(..) | |
-- * Wrapper Types | |
, JSString({-fromJSString-}..) | |
, toJSString | |
, JSObject({-fromJSObject-}..) | |
, toJSObject | |
, get_field | |
, set_field | |
) where | |
import Data.Typeable ( Typeable ) | |
-- | |
-- | JSON values | |
-- | |
-- The type to which we encode Haskell values. There's a set | |
-- of primitives, and a couple of heterogenous collection types. | |
-- | |
-- Objects: | |
-- | |
-- An object structure is represented as a pair of curly brackets | |
-- surrounding zero or more name\/value pairs (or members). A name is a | |
-- string. A single colon comes after each name, separating the name | |
-- from the value. A single comma separates a value from a | |
-- following name. | |
-- | |
-- Arrays: | |
-- | |
-- An array structure is represented as square brackets surrounding | |
-- zero or more values (or elements). Elements are separated by commas. | |
-- | |
-- Only valid JSON can be constructed this way | |
-- | |
data JSValue r | |
= JSNull | |
| JSBool !Bool | |
| JSRational Bool{-as Float?-} !Rational | |
| JSString JSString | |
| JSArray [r] | |
| JSObject (JSObject r) | |
deriving (Show, Read, Eq, Ord, Typeable) | |
-- | Strings can be represented a little more efficiently in JSON | |
newtype JSString = JSONString { fromJSString :: String } | |
deriving (Eq, Ord, Show, Read, Typeable) | |
-- | Turn a Haskell string into a JSON string. | |
toJSString :: String -> JSString | |
toJSString = JSONString | |
-- Note: we don't encode the string yet, that's done when serializing. | |
-- | As can association lists | |
newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] } | |
deriving (Eq, Ord, Show, Read, Typeable ) | |
-- | Make JSON object out of an association list. | |
toJSObject :: [(String,a)] -> JSObject a | |
toJSObject = JSONObject | |
-- | Get the value of a field, if it exist. | |
get_field :: JSObject a -> String -> Maybe a | |
get_field (JSONObject xs) x = lookup x xs | |
-- | Set the value of a field. Previous values are overwritten. | |
set_field :: JSObject a -> String -> a -> JSObject a | |
set_field (JSONObject xs) k v = JSONObject ((k,v) : filter ((/= k).fst) xs) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment