json-b-0.0.0: Text/JSONb/Decode.hs
{-# LANGUAGE ScopedTypeVariables
, ParallelListComp
#-}
{-| Parse UTF-8 JSON into native Haskell types.
-}
module Text.JSONb.Decode where
import Data.Char
import Prelude hiding (null, last, takeWhile)
import qualified Data.ByteString as ByteString.Strict
import Data.ByteString.Lazy.Char8
hiding (reverse, null, takeWhile, elem, concatMap)
import Control.Applicative hiding (empty)
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import qualified Data.Trie.Convenience as Trie
import Data.ParserCombinators.Attoparsec.Char8 hiding (string)
import qualified Data.ParserCombinators.Attoparsec.Char8 as Attoparsec
import Data.ByteString.Nums.Careless
import Text.JSONb.Simple
{-| Interpret a 'ByteString' as any JSON literal.
-}
decode :: ByteString -> Either (ParseError, ByteString) JSON
decode bytes = case Attoparsec.parse json bytes of
(remainder, Left e) -> Left (e, remainder)
(r, Right j) -> Right j
{-| Split out the first parseable JSON literal from the input, returning
the result of the attempt along with the remainder of the input or the
whole input if not parseable item was discovered.
-}
break :: ByteString -> (Either ParseError JSON, ByteString)
break bytes = case Attoparsec.parse json bytes of
(_, Left e) -> (Left e, bytes)
(remainder, result) -> (result, remainder)
{-| Tries to parse any JSON literal.
-}
json :: Parser JSON
json = do
whitespace
choice [object, array, string, number, boolean, null]
{-| Parse a JSON object (dictionary).
-}
object :: Parser JSON
object = do
char '{'
whitespace
Object . Trie.fromListS <$> properties []
where
properties acc = do
key <- string_literal
whitespace
char ':'
something <- json
whitespace
let
acc' = (strictify key, something) : acc
choice
[ char ',' >> whitespace >> choice
[ char '}' >> return acc'
, properties acc'
]
, char '}' >> return acc'
]
{-| Parse a JSON array.
-}
array :: Parser JSON
array = do
char '['
Array <$> elements []
where
elements acc = do
something <- json
whitespace
let
acc' = something : acc
finish = char ']' >> return (reverse acc')
choice
[ char ',' >> whitespace >> choice [finish, elements acc']
, finish
]
{-| Parses a string literal, unescaping as it goes.
-}
string :: Parser JSON
string = String . strictify <$> string_literal
{-| Parses a numeric literal to a @Rational@.
-}
number :: Parser JSON
number = Number <$> do
(sign :: Rational) <- '-' ?> (-1) <|> pure 1
n <- choice
[ do
integer_part <- digits
char '.'
fractional_part <- digits
return $ float (integer_part `snoc` '.' `append` fractional_part)
, do
char '.'
fractional_part <- digits
return $ float ('.' `cons` fractional_part)
, do
integer_part <- digits
return $ int integer_part
]
(exponent <*> pure (sign * n)) <|> (ended >> return (sign * n))
where
c ?> r = char c >> pure r
digits = takeWhile1 isDigit
exponent :: Parser (Rational -> Rational)
exponent = do
char 'e' <|> char 'E'
op <- '-' ?> (/) <|> '+' ?> (*) <|> pure (*)
(e :: Int) <- int <$> digits
pure (`op` (10^e))
ended = notFollowedBy $ satisfy oops
where
oops c = isAlphaNum c || elem c ".+-"
{-| Parse a JSON Boolean literal.
-}
boolean :: Parser JSON
boolean = Boolean <$> choice
[ Attoparsec.string "true" >> return True
, Attoparsec.string "false" >> return False
]
{-| Parse a JSON null literal.
-}
null :: Parser JSON
null = Attoparsec.string "null" >> return Null
{-| Per RFC 4627, section 2 "JSON Grammar", only a limited set of whitespace
characters actually count as insignificant whitespace.
-}
whitespace :: Parser ()
whitespace = skipMany (satisfy w)
where
w ' ' = True -- ASCII space.
w '\n' = True -- Newline.
w '\r' = True -- Carriage return.
w '\t' = True -- Horizontal tab.
w _ = False -- Not a JSON space.
{-| Parse a JSON string literal and unescape it but don't wrap it in a string
constructor (we might wrap it as a dict key instead).
-}
string_literal :: Parser ByteString
string_literal = char '"' >> recurse empty
where
recurse acc = do
text <- takeWhile (not . (`elem` "\\\""))
choice
[ char '"' >> return (acc `append` text)
, do
char '\\'
c <- escape_sequence
recurse (acc `append` text `append` UTF8.fromString [c])
]
where
escape_sequence = do
choice [ c >> r | c <- fmap char "n/\"rfbt\\u"
| r <- fmap return "\n/\"\r\f\b\t\\" ++ [u] ]
where
u = do
(a,b,c,d) <- (,,,) <$> hex <*> hex <*> hex <*> hex
return . toEnum $ a * 0x1000
+ b * 0x100
+ c * 0x10
+ d * 0x1
where
hex = choice digits
where
prep (n, chars) = fmap (fmap ((+n) . ord) . char) chars
digits = concatMap prep [ (-48, ['0'..'9'])
, (-55, ['A'..'F'])
, (-87, ['a'..'f']) ]
{-| Turn a lazy 'ByteString' in to a strict 'ByteString.Strict.ByteString'.
-}
strictify :: ByteString -> ByteString.Strict.ByteString
strictify = ByteString.Strict.concat . toChunks