Skip to content

@mmakowski /JSONParse.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
--------------------------------------------------------------------
-- |
-- 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
{-# language TemplateHaskell #-}
{-
quasi-quoter allows us to write stuff in another language (here: JSON) in Haskell
anti-quoting allows us to put Haskell in our JSON
-}
module JSONQuoter where
import Language.Haskell.TH
import Language.Haskell.TH.Lift
import Language.Haskell.TH.Quote
import Text.JSON
import JSONParse
import Text.ParserCombinators.Parsec
import Data.Function
{-
splices
[e||] -- expression
[d||] -- definition
[p||] -- pattern
Q is the monad it runs in (needs to run in a monad to generate fresh names etc.)
ExpQ is Q Exp
-}
$(deriveLift ''JSObject)
$(deriveLift ''JSString)
$(deriveLift ''JSValue)
jsonParse :: String -> ExpQ
jsonParse s = case result of
Right json -> [e| json |]
Left m -> fail $ show m
where result = parse (fix p_value) "source" s
json :: QuasiQuoter
json = QuasiQuoter jsonParse undefined undefined undefined
{-# language TemplateHaskell, QuasiQuotes #-}
module JSONTest where
import JSONQuoter
main = print [json|[1,2,3]|]
@Mikolaj

Hello!

@mmakowski
Owner

JSArray [JSRational False (1 % 1),JSRational False (2 % 1),JSRational False (3 % 1)]

@Mikolaj

na co Ci to?

@mmakowski
Owner

uczymy się grupowo TH robiąc quasi-quoter i anti-quoter do JSONa

@Mikolaj
@Mikolaj

:( But have fun. :)

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.