diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ + + ©2009 Jason Dusek. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + . Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + . Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + . Names of the contributors to this software may not be used to endorse or + promote products derived from this software without specific prior written + permission. + + This software is provided by the contributors "as is" and any express or + implied warranties, including, but not limited to, the implied warranties of + merchantability and fitness for a particular purpose are disclaimed. In no + event shall the contributors be liable for any direct, indirect, incidental, + special, exemplary, or consequential damages (including, but not limited to, + procurement of substitute goods or services; loss of use, data, or profits; + or business interruption) however caused and on any theory of liability, + whether in contract, strict liability, or tort (including negligence or + otherwise) arising in any way out of the use of this software, even if + advised of the possibility of such damage. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,21 @@ + JSONb is a library for parsing JSON from lazy ByteStrings. It assumes the + input is UTF-8. + + + Test Suite + ---------------------------------------------------------------------------- + + We test the library by: + + . Pulling down large amounts of JSON from various web service providers. + + . Parsing and unparsing the JSON with our parser. + + . Feeding the original JSON along with our unparsed variety to the + json.org parser. + + . Testing that our parsed-unparsed JSON parses to the same JavaScript + values as the original JSON from the point of view of the json.org + parser. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main = defaultMain + diff --git a/Text/JSON/Escape.hs b/Text/JSON/Escape.hs new file mode 100644 --- /dev/null +++ b/Text/JSON/Escape.hs @@ -0,0 +1,76 @@ + + +{-# LANGUAGE TypeSynonymInstances + #-} + + +module Text.JSON.Escape where + + +import Data.Char +import Data.List +import qualified Data.ByteString.Lazy.Char8 as Lazy +import qualified Data.ByteString.Char8 as Strict + + + + +{-| Class of JSON escapable text. The solidus (@/@) is always escaped, as are + all ASCII control characters. Non-ASCII control characters + -} +class Escape t where + escape :: t -> t +instance Escape Strict.ByteString where + escape = Strict.concatMap (Strict.pack . esc) +instance Escape Lazy.ByteString where + escape = Lazy.concatMap (Lazy.pack . esc) +instance Escape String where + escape = concatMap esc + + +{-| Escapes an individual character for embedding in a JSON string. + -} +esc :: Char -> String +esc c = case c of + '"' -> "\\\"" + '\\' -> "\\\\" + '/' -> "\\/" + '\NUL' -> "\\u0000" + '\SOH' -> "\\u0001" + '\STX' -> "\\u0002" + '\ETX' -> "\\u0003" + '\EOT' -> "\\u0004" + '\ENQ' -> "\\u0005" + '\ACK' -> "\\u0006" + '\a' -> "\\u0007" + '\b' -> "\\b" + '\t' -> "\\t" + '\n' -> "\\n" + '\v' -> "\\u000b" + '\f' -> "\\f" + '\r' -> "\\r" + '\SO' -> "\\u000e" + '\SI' -> "\\u000f" + '\DLE' -> "\\u0010" + '\DC1' -> "\\u0011" + '\DC2' -> "\\u0012" + '\DC3' -> "\\u0013" + '\DC4' -> "\\u0014" + '\NAK' -> "\\u0015" + '\SYN' -> "\\u0016" + '\ETB' -> "\\u0017" + '\CAN' -> "\\u0018" + '\EM' -> "\\u0019" + '\SUB' -> "\\u001a" + '\ESC' -> "\\u001b" + '\FS' -> "\\u001c" + '\GS' -> "\\u001d" + '\RS' -> "\\u001e" + '\US' -> "\\u001f" + '\DEL' -> "\\u007f" + _ -> [c] + + +escaped c = esc c /= [c] + + diff --git a/Text/JSONb.hs b/Text/JSONb.hs new file mode 100644 --- /dev/null +++ b/Text/JSONb.hs @@ -0,0 +1,28 @@ + + +{-| ByteString parser for a simple, monomorphic JSON datatype. + -} +module Text.JSONb + ( Text.JSONb.Simple.JSON(..) + , Text.JSONb.Decode.decode + , Text.JSONb.Decode.break + , Text.JSONb.Encode.Style(..) + , Text.JSONb.Encode.encode + , Text.JSONb.Schema.Schema() + , Text.JSONb.Schema.schema + , Text.JSONb.Schema.schemas + , Text.JSONb.Schema.OneMany(..) + , Text.JSONb.Schema.Display.Display(..) + , Text.JSON.Escape.Escape(..) + , Text.JSON.Escape.escaped + ) where + + +import Text.JSONb.Simple +import Text.JSONb.Decode +import Text.JSONb.Encode +import Text.JSONb.Schema +import Text.JSONb.Schema.Display +import Text.JSON.Escape + + diff --git a/Text/JSONb/Decode.hs b/Text/JSONb/Decode.hs new file mode 100644 --- /dev/null +++ b/Text/JSONb/Decode.hs @@ -0,0 +1,213 @@ + + +{-# 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 + + diff --git a/Text/JSONb/Encode.hs b/Text/JSONb/Encode.hs new file mode 100644 --- /dev/null +++ b/Text/JSONb/Encode.hs @@ -0,0 +1,68 @@ + + +{-# LANGUAGE StandaloneDeriving + #-} + + +module Text.JSONb.Encode where + + +import Data.Ratio +import Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as Lazy + +import Data.Trie hiding (singleton) + +import Text.JSONb.Simple +import Text.JSON.Escape + + + + +{-| Encode 'JSON' as a lazy 'Lazy.ByteString'. All strings are treated as + UTF-8; ASCII control characters are escaped and UTF-8 multi-char sequences + are simply passed through. + -} +encode :: Style -> JSON -> Lazy.ByteString +encode style = Lazy.fromChunks . (:[]) . encode' style + + +{-| Encode 'JSON' as a strict 'ByteString'. All strings are treated as UTF-8; + ASCII control characters are escaped and UTF-8 multi-char sequences are + simply passed through. + -} +encode' :: Style -> JSON -> ByteString +encode' style@Compact json = case json of + Object trie -> '{' `cons` pairs trie `snoc` '}' + Array elems -> '[' `cons` elements elems `snoc` ']' + String s -> stringify s + Number r + | denominator r == 1 -> (pack . show . numerator) r + | otherwise -> (pack . show) (fromRational r :: Double) + Boolean True -> pack "true" + Boolean False -> pack "false" + Null -> pack "null" + where + comcat = intercalate (singleton ',') + elements = comcat . fmap (encode' style) + pairs = comcat . toListBy pair + where + pair k v = stringify k `snoc` ':' `append` encode' style v + + +{-| Style of serialization. Compact is the only one that is implemented at + present. + -} +data Style = Compact -- | LightSpaces | Indented +deriving instance Show Style +deriving instance Eq Style + + +{-| Escape a 'ByteString' representing a JSON string and wrap it in quote + marks. + -} +stringify :: ByteString -> ByteString +stringify s = '"' `cons` escape s `snoc` '"' + + + diff --git a/Text/JSONb/Schema.hs b/Text/JSONb/Schema.hs new file mode 100644 --- /dev/null +++ b/Text/JSONb/Schema.hs @@ -0,0 +1,193 @@ + + +{-# LANGUAGE StandaloneDeriving + , RelaxedPolyRec + #-} + + +module Text.JSONb.Schema where + + +import Data.Ord +import Data.Word +import Data.List (permutations) +import Data.Set as Set + +import Data.Trie as Trie + +import qualified Text.JSONb.Simple as Simple + + + + +{- + + JSON Schemas: + + document ::= array + + element ::= num | str | null | bool | object | array + + object ::= "{" Set(element) "}" + + array ::= "[" List(element) "]" + + num ::= "num" + str ::= "str" + null ::= "null" + bool ::= "bool" + + -} + + + + +{-| The type of JSON schemas. We treat the atomic types simply whereas objects + and arrays are treated specially. + + Objects are treated as maps of keys to sets of schema types. Say a certain + type of object sometimes has a string at a certain key and sometimes has a + null at that key; we should merge them and say the schema of that key is a + union of string and null. + + Arrays admit measure in the sense of how many elements there are of a + certain kind. We support three measures at present: any, one or more and + individual counts. We expect the "any" measure to prevail practice. Arrays + are also ordered; so one can distinguish an array that interleaves strings + and ints from one that is all strings and then all ints. + -} +data Schema counter + = Num + | Str + | Bool + | Null + | Obj (Props counter) + | Arr (Elements counter) +deriving instance (Eq counter) => Eq (Schema counter) +deriving instance (Ord counter) => Ord (Schema counter) + + +{-| Determine a schema for one JSON data item. + -} +schema :: (Counter counter) => Simple.JSON -> Schema counter +schema json = case json of + Simple.Object trie -> Obj $ props trie + Simple.Array list -> Arr . Elements $ schemas list + Simple.String _ -> Str + Simple.Number _ -> Num + Simple.Boolean _ -> Bool + Simple.Null -> Null + + +props :: (Counter counter) => Trie.Trie Simple.JSON -> Props counter +props = Props . fmap (Set.singleton . schema) + + +{-| Develop a schema for a list of JSON data, collating schemas according to + the measure, a well-ordered semigroup. + -} +schemas :: (Counter counter) => [Simple.JSON] -> [(counter, Schema counter)] +schemas json = foldr collate [] + [ (bottom, schema e) | e <- json ] + + +{-| Collate a list of counted schemas. Alike counted schemas that are adjacent + are replaced by a counted schema with an incremented counter. This + operation is mutually recursive with 'merge', in order to merge comaptible + object definitions before collating. + -} +collate + :: (Counter counter, Counter counter') + => (counter, Schema counter') + -> [(counter, Schema counter')] + -> [(counter, Schema counter')] +collate s [] = [s] +collate (c0, Obj p0) ((c1, Obj p1):t) + | match p0 p1 = (c0 `plus` c1, Obj $ merge p0 p1):t + | otherwise = (c0, Obj p0):(c1, Obj p1):t +collate (c0, schema0) ((c1, schema1):t) + | schema0 == schema1 = (c0 `plus` c1, schema0):t + | otherwise = (c0, schema0):(c1, schema1):t + + + + +data Props counter = Props (Trie.Trie (Set.Set (Schema counter))) +deriving instance (Eq counter) => Eq (Props counter) +instance (Ord counter) => Ord (Props counter) where + compare (Props trie0) (Props trie1) = comparing Trie.toList trie0 trie1 + +{-| Merge two property sets. This operation is mutually recursive with our + 'collate' and relies on polymorphic recusion in 'collate'. + -} +merge + :: (Counter counter) + => Props counter + -> Props counter + -> Props counter +merge (Props a) (Props b) = Props $ Trie.mergeBy ((Just .) . merge') a b + where + merge' = ((count_in . merge'' . count_out) .) . Set.union + where + -- We use the unary (existence) counter so that it collates set-like. + count_out = fmap ((,) ()) . Set.toList + count_in = Set.fromList . fmap snd + merge'' [ ] = [] + merge'' (h:t) = foldr collate' t (h:t) + where + -- We expect only very small sets of schemas. + collate' schema = shortest . fmap (collate schema) . permutations + shortest [ ] = [] + shortest (h:t) = foldr shortest' h t + where + shortest' x h + | length h < length x = h + | otherwise = x + +match + :: (Counter counter) + => Props counter + -> Props counter + -> Bool +match (Props a) (Props b) = Trie.keys a == Trie.keys b + + +data Elements counter = Elements [(counter, Schema counter)] +deriving instance (Eq counter) => Eq (Elements counter) +deriving instance (Ord counter) => Ord (Elements counter) + + +data OneMany = One | Many +deriving instance Eq OneMany +deriving instance Ord OneMany +deriving instance Show OneMany + + + + +{-| A well-ordered semigroup has a minimal element and an associative + operation. These are used to provide measures for schema. At present, we + allow three measures: whether there is one or more of a schema (measured + with '()'), whether there is one or more than one of an item (measured with + 'OneMany') and positive counts of items (measured with 'Word'). + -} +class (Eq t, Show t, Ord t) => Counter t where + bottom :: t + plus :: t -> t -> t + +instance Counter OneMany where + bottom = One + plus _ _ = Many + +instance Counter Word where + bottom = 1 + plus = (+) + +instance Counter () where + bottom = () + plus _ _ = () + + + + + diff --git a/Text/JSONb/Schema/Display.hs b/Text/JSONb/Schema/Display.hs new file mode 100644 --- /dev/null +++ b/Text/JSONb/Schema/Display.hs @@ -0,0 +1,111 @@ + + +module Text.JSONb.Schema.Display where + + +import Prelude hiding + ( lines + , unlines + , tail + , null + , unwords + , length + , repeat + , elem + , take + , concat + ) +import Data.Ord +import Data.List (foldl1') +import Data.Word +import Data.ByteString.Lazy.Char8 hiding (any, foldl1') +import qualified Data.Set as Set + +import qualified Data.Trie as Trie + +import Text.JSONb.Schema + + + + +class Display t where + {-| Provide a formatted 'ByteString' for the displayable. + -} + bytes :: t -> ByteString + + +instance (Display counter) => Display (Schema counter) where + bytes schema = case schema of + Num -> pack "num" + Str -> pack "str" + Bool -> pack "bool" + Null -> pack "null" + Obj (Props trie) -> pack "{ " `append` f trie `append` pack "\n}" + where + m = longest_key_len trie + f = dent 2 . unlines . Trie.toListBy prop_bytes + where + prop_bytes k set = k' `append` colon `append` join set' + where + colon = take (m - length k') space `append` pack " : " + k' = fromChunks [k] + k'' = length k' + bar = '\n' `cons` take m space `append` pack " | " + set' = (fmap bytes . Set.toList) set + join = if must_be_multiline 3 set' + then intercalate bar . fmap (dent (m + 3)) + else intercalate (pack " | ") + Arr (Elements list) -> if must_be_multiline 1 list' + then pack "[ " `append` intercalate nl list' `append` pack "\n]" + else pack "[ " `append` intercalate (pack " ") list' `append` pack " ]" + where + nl = pack "\n " + list' = fmap bytes list + +len = 64 + +must_be_multiline s items = broken items || too_long s items + +broken = any (elem '\n') + +too_long s = (> len + s) . sum . fmap ((+s) . length) + +dent n = intercalate ('\n' `cons` take n space) . lines + +space = repeat ' ' + +{-| Warning -- does not work on empty tries. + -} +longest_key_len = length . foldl1' longest . lazify . Trie.keys + where + lazify = fmap $ fromChunks . (:[]) + longest x h + | length h > length x = h + | otherwise = x + + +instance Display () where + bytes _ = empty + + +instance Display OneMany where + bytes One = empty + bytes Many = singleton '+' + + +instance Display Word where + bytes = (' ' `cons`) . pack . show + + +instance (Display counter) => Display (counter, Schema counter) where + bytes (count, schema) = bytes schema `append` bytes count + + + + +instance (Display counter) => Show (Schema counter) where + show = unpack . bytes + + + + diff --git a/Text/JSONb/Simple.hs b/Text/JSONb/Simple.hs new file mode 100644 --- /dev/null +++ b/Text/JSONb/Simple.hs @@ -0,0 +1,45 @@ + + + +{-# LANGUAGE StandaloneDeriving + #-} + + +{-| JSON datatype definition. + -} + + +module Text.JSONb.Simple where + + +import Data.ByteString + +import Data.Trie + + + +{-| A monomorphic JSON datatype, backed with 'Rational', strict 'ByteString' + and 'ByteString' 'Trie'. + -} +data JSON + = Object (Trie JSON) + | Array [JSON] + | String ByteString + | Number Rational + | Boolean Bool + | Null +deriving instance Eq JSON +instance Show JSON where + show json = case json of + Object trie -> unlines $ "Object" : trie_show trie + Array list -> unlines $ "Array" : fmap show list + String bytes -> unwords ["String", show bytes] + Number rational -> unwords ["Number", show rational] + Boolean bool -> unwords ["Boolean", show bool] + Null -> "Null" + where + trie_show = fmap edge_show . toList + where + edge_show (k, v) = unwords [show k, "->", show v] + + diff --git a/examples/JSONSchema.hs b/examples/JSONSchema.hs new file mode 100644 --- /dev/null +++ b/examples/JSONSchema.hs @@ -0,0 +1,104 @@ +#!/usr/bin/env runhaskell + + +{-# LANGUAGE NoMonomorphismRestriction + #-} + + +import Prelude hiding + ( interact + , lines + , unlines + , tail + , null + , unwords + , length + , repeat + , elem + , take + ) +import System.Exit +import System.IO (stderr, stdout) +import System.Environment +import Data.ByteString.Lazy (hPutStr) +import Data.ByteString.Lazy.Char8 hiding (any, reverse, foldr) +import Data.Word +import qualified Data.Set as Set + +import qualified Data.Trie as Trie + +import qualified Text.JSONb as JSONb + + + + +help = (unlines . fmap pack) + [ "USAGE: json-schema (--any|--count|--one-many)? < json_file.json" + , "" + , "Derives a schema for JSON input, counting according to the option" + , "spec or using one-many counting by default. An example is probably best." + , "JSON that looks this:" + , "" + , " { id: 0, name: \"molly\", windage: 1.2 }" + , " { id: 0, name: \"edmund\", windage: null }" + , "" + , "is assigned this schema under one-many counting:" + , "" + , " { id : num" + , " name : str" + , " windage : num | null" + , " }+" + , "" + , "but is assigned this schema under plain old integral counting:" + , "" + , " { id : num" + , " name : str" + , " windage : num | null" + , " } 2" + , "" + , "and is assigned this schema under any counting:" + , "" + , " { id : num" + , " name : str" + , " windage : num | null" + , " }" + , "" + , "Notice that properties sum types; the schema inferencer assumes JSON" + , "objects with like property names are the same object type." + , "" + ] + + +main = do + args <- getArgs + case args of + [] -> op (JSONb.schemas :: Counting JSONb.OneMany) + ["--any"] -> op (JSONb.schemas :: Counting ()) + ["--one-many"] -> op (JSONb.schemas :: Counting JSONb.OneMany) + ["--count"] -> op (JSONb.schemas :: Counting Word) + ["-h"] -> hPutStr stdout help + ["-?"] -> hPutStr stdout help + ["--help"] -> hPutStr stdout help + _ -> do + hPutStr stderr $ pack "!! Invalid option or options.\n" + hPutStr stderr help + exitFailure + where + op schemas = interact (display . schemas . progressive) + + +display = unlines . fmap JSONb.bytes + + +progressive = progressive_parse' [] + where + progressive_parse' acc bytes + | null bytes = reverse acc + | otherwise = case JSONb.break bytes of + (Left _, _) -> progressive_parse' acc (tail bytes) + (Right piece, rem) -> progressive_parse' (piece:acc) rem + + +type Counting c = [JSONb.JSON] -> [(c, JSONb.Schema c)] + + diff --git a/json-b.cabal b/json-b.cabal new file mode 100644 --- /dev/null +++ b/json-b.cabal @@ -0,0 +1,57 @@ +name : json-b +version : 0.0.0 +category : Text +license : BSD3 +license-file : LICENSE +author : Jason Dusek +maintainer : jsonb@solidsnack.be +homepage : http://github.com/jsnx/JSONb/ +synopsis : JSON parser that uses byte strings. +description : + This parser consumes lazy ByteStrings to produce JSON in a simple, efficient + format backed with a strict ByteStrings, Rationals and ByteString tries. See + the schema generation tools and the command line JSON schema generator (in + the examples subdir) for an example of how to use the parsing tools. + + +cabal-version : >= 1.2.3 +build-type : Simple +extra-source-files : README + test/SimpleUnits.hs + + +library + build-depends : base >= 2 && < 4 + , containers + , utf8-string >= 0.3 + , bytestring >= 0.9 + , bytestringparser-temporary >= 0.4.1 + , bytestring-nums >= 0.3.1 + , bytestring-trie >= 0.1.4 + exposed-modules : Text.JSONb + Text.JSONb.Simple + Text.JSONb.Schema + Text.JSONb.Schema.Display + Text.JSONb.Decode + Text.JSONb.Encode + Text.JSON.Escape + extensions : StandaloneDeriving + FlexibleInstances + RelaxedPolyRec + ScopedTypeVariables + ParallelListComp + + +executable json-schema + main-is : examples/JSONSchema.hs + build-depends : base + , containers + , utf8-string >= 0.3 + , bytestring >= 0.9 + , bytestringparser-temporary >= 0.4.1 + , bytestring-nums >= 0.3.1 + , bytestring-trie >= 0.1.4 + extensions : FlexibleInstances + RelaxedPolyRec + NoMonomorphismRestriction + diff --git a/test/SimpleUnits.hs b/test/SimpleUnits.hs new file mode 100644 --- /dev/null +++ b/test/SimpleUnits.hs @@ -0,0 +1,133 @@ + + +{-# LANGUAGE StandaloneDeriving + #-} + + +import Data.List (concatMap, nub) +import Data.Ratio +import Data.ByteString.Lazy.Char8 (pack) +import qualified Data.ByteString.Char8 as Strict +import Test.QuickCheck + +import Data.Trie +import qualified Data.ByteString.UTF8 as UTF8 + +import qualified Text.JSONb as JSONb + + + + +prop_structures_parse = samples structure_tests + + +samples tests = forAll (elements tests) with_classifiers + where + with_classifiers :: (String, JSONb.JSON, [String]) -> Property + with_classifiers = compound (property . array_parse) classifiers + where + compound = foldl (flip ($)) + array_parse (s, j, info) = rt s == Right j + classifiers = (fmap classifier . nub . concatMap third) tests + where + third (_,_,t) = t + classifier string p x = classify (string `elem` third x) string $ p x + + +prop_integer_round_trip :: Integer -> Property +prop_integer_round_trip n = collect bin $ case (rt . show) n of + Right (JSONb.Number r) -> r == fromIntegral n + _ -> False + where + bin + | n == 0 = Bounds (Open (-1)) (Open 1) + | n >= 1 && n < 100 = Bounds (Closed 1) (Open 100) + | n > -100 && n <= -1 = Bounds (Open (-100)) (Closed (-1)) + | n <= -100 = Bounds Infinite (Closed (-100)) + | n >= -100 = Bounds (Closed (100)) Infinite + + +prop_double_round_trip :: Double -> Property +prop_double_round_trip n = collect bin $ case (rt . show) n of + Right (JSONb.Number r) -> fromRational r == n + _ -> False + where + bin + | n < 1 && n > -1 = Bounds (Open (-1)) (Open 1) + | n >= 1 && n < 100 = Bounds (Closed 1) (Open 100) + | n > -100 && n <= -1 = Bounds (Open (-100)) (Closed (-1)) + | n <= -100 = Bounds Infinite (Closed (-100)) + | n >= -100 = Bounds (Closed (100)) Infinite + + +prop_string_round_trip s = high . escapes $ case round_trip bytes of + Right (JSONb.String b) -> bytes == b + _ -> False + where + bytes = UTF8.fromString s + round_trip = JSONb.decode . JSONb.encode JSONb.Compact . JSONb.String + high = classify (any (> '\x7f') s) "above ASCII" + escapes = classify (any JSONb.escaped s) "escaped chars" + + +data Bounds n where + Bounds :: (Show n, Num n) => Bound n -> Bound n -> Bounds n +instance (Show n) => Show (Bounds n) where + show (Bounds l r) = case (l, r) of + (Open l, Open r) -> "(" ++ show l ++ ".." ++ show r ++ ")" + (Closed l, Closed r) -> "[" ++ show l ++ ".." ++ show r ++ "]" + (Closed l, Open r) -> "[" ++ show l ++ ".." ++ show r ++ ")" + (Open l, Closed r) -> "(" ++ show l ++ ".." ++ show r ++ "]" + (Closed l, Infinite) -> "[" ++ show l ++ ".." + (Infinite, Closed r) -> ".." ++ show r ++ "]" + (Open l, Infinite) -> "(" ++ show l ++ ".." + (Infinite, Open r) -> ".." ++ show r ++ ")" + (Infinite, Infinite) -> ".." + + +data Bound n where + Open :: (Show n, Num n) => n -> Bound n + Closed :: (Show n, Num n) => n -> Bound n + Infinite :: (Show n, Num n) => Bound n + + +rt = JSONb.decode . pack + + + +structure_tests = + [ ( "[ 7, 6 ]", (JSONb.Array . fmap JSONb.Number) [7, 6] + , ["array", "excessive spacing", "integers"] ) + , ( "[7,6]", (JSONb.Array . fmap JSONb.Number) [7, 6] + , ["array", "compact spacing", "integers"] ) + , ( "[7.6, 21]", (JSONb.Array . fmap JSONb.Number) [7.6, 21.0] + , ["array", "normal spacing", "floats"] ) + , ( "[22.0 ,7.6,]", (JSONb.Array . fmap JSONb.Number) [22, 7.6] + , ["array", "weird comma spacing", "extra comma", "floats"] ) + , ( "[\"22.0\" ,7.6,]" + , JSONb.Array [(JSONb.String . Strict.pack) "22.0", JSONb.Number 7.6] + , ["array", "weird comma spacing", "extra comma", "floats", "strings"] ) + , ( "{ \"ixion\":6 }" + , (JSONb.Object . fromList) [(Strict.pack "ixion", JSONb.Number 6)] + , ["object", "no commas", "integers"] ) + , ( "{ \"Ack\":\"Success\" ,\"Build\" :\"e605_core_Bundled_8000231_R1\"}" + , (JSONb.Object . fromList) + [ (Strict.pack "Ack", JSONb.String (Strict.pack "Success")) + , ( Strict.pack "Build" + , JSONb.String (Strict.pack "e605_core_Bundled_8000231_R1") ) ] + , ["object", "random spacing", "strings"] ) + , ( "{\n\"Ack\"\n:\n\"Success\" , \"Build\":\"e605_core_Bundled_8000231_R1\"}" + , (JSONb.Object . fromList) + [ (Strict.pack "Ack", JSONb.String (Strict.pack "Success")) + , ( Strict.pack "Build" + , JSONb.String (Strict.pack "e605_core_Bundled_8000231_R1") ) ] + , ["object", "newlines", "strings"] ) + , ( "{\"Ack\":\"Success\",\"Build\":\"e605_core_Bundled_8000231_R1\"}" + , (JSONb.Object . fromList) + [ (Strict.pack "Ack", JSONb.String (Strict.pack "Success")) + , ( Strict.pack "Build" + , JSONb.String (Strict.pack "e605_core_Bundled_8000231_R1") ) ] + , ["object", "compact spacing", "strings"] ) + ] + +