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 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
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
{-# 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 ->
JSONTest.hs
Haskell
1 2 3 4 5 6 7
{-# language TemplateHaskell, QuasiQuotes #-}
 
module JSONTest where
 
import JSONQuoter
 
main = putStrLn $ show [$json|[1,2,3]|]

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.