public
Created

JSON QuasiQuoting

  • Download Gist
JSONParse.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
--------------------------------------------------------------------
-- |
-- 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
JSONQuoter.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
{-# 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)
JSONTest.hs
Haskell
1 2 3 4 5 6 7 8
{-# language TemplateHaskell, QuasiQuotes #-}
 
module Main where
 
import JSONTypes
import JSONQuoter
 
main = putStrLn $ show [$json|[1,$(Fix $ JSRational False $ 2+1),3]|]
JSONTypes.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
 
{-# 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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.