JSON QuasiQuoting

JSONParse.hs

--------------------------------------------------------------------
-- |
-- 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

{-# 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

{-# language TemplateHaskell, QuasiQuotes #-}

module Main where

import JSONTypes
import JSONQuoter

main = putStrLn $ show [$json|[1,$(Fix $ JSRational False $ 2+1),3]|]

JSONTypes.hs

{-# 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)