Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
JSON QuasiQuoting
--------------------------------------------------------------------
-- |
-- 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
{-# 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)
{-# language TemplateHaskell, QuasiQuotes #-}
module Main where
import JSONTypes
import JSONQuoter
main = putStrLn $ show [$json|[1,$(Fix $ JSRational False $ 2+1),3]|]
{-# 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
Something went wrong with that request. Please try again.