├── tests ├── unit │ ├── fail29.json │ ├── fail30.json │ ├── fail16.json │ ├── fail31.json │ ├── fail2.json │ ├── fail24.json │ ├── fail33.json │ ├── fail4.json │ ├── fail8.json │ ├── fail23.json │ ├── fail27.json │ ├── fail28.json │ ├── fail9.json │ ├── fail19.json │ ├── fail20.json │ ├── fail5.json │ ├── fail6.json │ ├── fail7.json │ ├── fail11.json │ ├── fail12.json │ ├── fail14.json │ ├── fail25.json │ ├── fail15.json │ ├── fail17.json │ ├── fail21.json │ ├── fail22.json │ ├── fail3.json │ ├── fail26.json │ ├── fail32.json │ ├── fail13.json │ ├── fail18.json │ ├── pass2.json │ ├── fail1.json │ ├── fail10.json │ ├── pass3.json │ └── pass1.json ├── Unit.hs ├── Makefile ├── GenericTest.hs ├── HUnit.hs ├── Parallel.hs ├── QC.hs └── QuickCheckUtils.hs ├── Setup.hs ├── .gitignore ├── .travis.yml ├── LICENSE ├── CHANGES ├── Text ├── JSON │ ├── Pretty.hs │ ├── Types.hs │ ├── ReadP.hs │ ├── Parsec.hs │ ├── Generic.hs │ └── String.hs └── JSON.hs └── json.cabal /tests/unit/fail29.json: -------------------------------------------------------------------------------- 1 | [0e] -------------------------------------------------------------------------------- /tests/unit/fail30.json: -------------------------------------------------------------------------------- 1 | [0e+] -------------------------------------------------------------------------------- /tests/unit/fail16.json: -------------------------------------------------------------------------------- 1 | [\naked] -------------------------------------------------------------------------------- /tests/unit/fail31.json: -------------------------------------------------------------------------------- 1 | [0e+-1] -------------------------------------------------------------------------------- /tests/unit/fail2.json: -------------------------------------------------------------------------------- 1 | ["Unclosed array" -------------------------------------------------------------------------------- /tests/unit/fail24.json: -------------------------------------------------------------------------------- 1 | ['single quote'] -------------------------------------------------------------------------------- /tests/unit/fail33.json: -------------------------------------------------------------------------------- 1 | ["mismatch"} -------------------------------------------------------------------------------- /tests/unit/fail4.json: -------------------------------------------------------------------------------- 1 | ["extra comma",] -------------------------------------------------------------------------------- /tests/unit/fail8.json: -------------------------------------------------------------------------------- 1 | ["Extra close"]] -------------------------------------------------------------------------------- /tests/unit/fail23.json: -------------------------------------------------------------------------------- 1 | ["Bad value", truth] -------------------------------------------------------------------------------- /tests/unit/fail27.json: -------------------------------------------------------------------------------- 1 | ["line 2 | break"] -------------------------------------------------------------------------------- /tests/unit/fail28.json: -------------------------------------------------------------------------------- 1 | ["line\ 2 | break"] -------------------------------------------------------------------------------- /tests/unit/fail9.json: -------------------------------------------------------------------------------- 1 | {"Extra comma": true,} -------------------------------------------------------------------------------- /tests/unit/fail19.json: -------------------------------------------------------------------------------- 1 | {"Missing colon" null} -------------------------------------------------------------------------------- /tests/unit/fail20.json: -------------------------------------------------------------------------------- 1 | {"Double colon":: null} -------------------------------------------------------------------------------- /tests/unit/fail5.json: -------------------------------------------------------------------------------- 1 | ["double extra comma",,] -------------------------------------------------------------------------------- /tests/unit/fail6.json: -------------------------------------------------------------------------------- 1 | [ , "<-- missing value"] -------------------------------------------------------------------------------- /tests/unit/fail7.json: -------------------------------------------------------------------------------- 1 | ["Comma after the close"], -------------------------------------------------------------------------------- /tests/unit/fail11.json: -------------------------------------------------------------------------------- 1 | {"Illegal expression": 1 + 2} -------------------------------------------------------------------------------- /tests/unit/fail12.json: -------------------------------------------------------------------------------- 1 | {"Illegal invocation": alert()} -------------------------------------------------------------------------------- /tests/unit/fail14.json: -------------------------------------------------------------------------------- 1 | {"Numbers cannot be hex": 0x14} -------------------------------------------------------------------------------- /tests/unit/fail25.json: -------------------------------------------------------------------------------- 1 | [" tab character in string "] -------------------------------------------------------------------------------- /tests/unit/fail15.json: -------------------------------------------------------------------------------- 1 | ["Illegal backslash escape: \x15"] -------------------------------------------------------------------------------- /tests/unit/fail17.json: -------------------------------------------------------------------------------- 1 | ["Illegal backslash escape: \017"] -------------------------------------------------------------------------------- /tests/unit/fail21.json: -------------------------------------------------------------------------------- 1 | {"Comma instead of colon", null} -------------------------------------------------------------------------------- /tests/unit/fail22.json: -------------------------------------------------------------------------------- 1 | ["Colon instead of comma": false] -------------------------------------------------------------------------------- /tests/unit/fail3.json: -------------------------------------------------------------------------------- 1 | {unquoted_key: "keys must be quoted"} -------------------------------------------------------------------------------- /tests/unit/fail26.json: -------------------------------------------------------------------------------- 1 | ["tab\ character\ in\ string\ "] -------------------------------------------------------------------------------- /tests/unit/fail32.json: -------------------------------------------------------------------------------- 1 | {"Comma instead if closing brace": true, -------------------------------------------------------------------------------- /tests/unit/fail13.json: -------------------------------------------------------------------------------- 1 | {"Numbers cannot have leading zeroes": 013} -------------------------------------------------------------------------------- /tests/unit/fail18.json: -------------------------------------------------------------------------------- 1 | [[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]] -------------------------------------------------------------------------------- /tests/unit/pass2.json: -------------------------------------------------------------------------------- 1 | [[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]] -------------------------------------------------------------------------------- /tests/unit/fail1.json: -------------------------------------------------------------------------------- 1 | "A JSON payload should be an object or array, not a string." -------------------------------------------------------------------------------- /tests/unit/fail10.json: -------------------------------------------------------------------------------- 1 | {"Extra value after close": true} "misplaced quoted value" -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Distribution.Simple 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /dist-newstyle 3 | .ghc.environment.* 4 | /tests/.ghc 5 | /tests/.hpc 6 | -------------------------------------------------------------------------------- /tests/unit/pass3.json: -------------------------------------------------------------------------------- 1 | { 2 | "JSON Test Pattern pass3": { 3 | "The outermost value": "must be an object or array.", 4 | "In this test": "It is an object." 5 | } 6 | } 7 | -------------------------------------------------------------------------------- /tests/Unit.hs: -------------------------------------------------------------------------------- 1 | 2 | import Text.JSON 3 | import Network.RPC.JSON 4 | import System.Exit 5 | 6 | main = do 7 | case (decode test1 :: Result JSRequest) of 8 | Ok _ -> exitWith ExitSuccess 9 | 10 | 11 | test1 = 12 | "{\"method\":\"feed.add\",\"params\":{\"uri\":\"http://rss.slashdot.org/Slashdot/slashdot\"},\"version\":\"1.1\" }" 13 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | ODIR=.ghc 2 | 3 | $(ODIR): 4 | mkdir $(ODIR) 5 | 6 | all: $(ODIR) 7 | ghc -cpp -O QC.hs --make -o QC -no-recomp -i.. -odir=$(ODIR) -hidir=$(ODIR) 8 | time ./QC 9 | runhaskell -i.. HUnit.hs 10 | 11 | generic: $(ODIR) 12 | ghc -i.. --make -fforce-recomp -odir=$(ODIR) -hidir=$(ODIR) GenericTest.hs -o GenericTest 13 | ./GenericTest 14 | 15 | clean: 16 | $(RM) -r $(ODIR) 17 | $(RM) *.html *.tix QC 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | env: 2 | - GHCVER=7.0.4 3 | - GHCVER=7.2.2 4 | - GHCVER=7.4.2 5 | - GHCVER=7.6.3 6 | - GHCVER=7.8.4 7 | - GHCVER=7.10.3 8 | - GHCVER=8.0.2 9 | - GHCVER=8.2.2 10 | - GHCVER=8.4.1 11 | - GHCVER=head 12 | 13 | before_install: 14 | - sudo add-apt-repository -y ppa:hvr/ghc 15 | - sudo apt-get update 16 | - sudo apt-get install cabal-install-head ghc-$GHCVER 17 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/head/bin:$PATH 18 | 19 | install: 20 | - cabal update 21 | - cabal install --depend 22 | - ghc --version 23 | 24 | script: 25 | - cabal configure -v2 26 | - cabal build 27 | - cabal sdist 28 | - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; 29 | cd dist/; 30 | if [ -f "$SRC_TGZ" ]; then 31 | cabal install "$SRC_TGZ"; 32 | else 33 | echo "expected '$SRC_TGZ' not found"; 34 | exit 1; 35 | fi 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Galois, Inc. 2007 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /tests/unit/pass1.json: -------------------------------------------------------------------------------- 1 | [ 2 | "JSON Test Pattern pass1", 3 | {"object with 1 member":["array with 1 element"]}, 4 | {}, 5 | [], 6 | -42, 7 | true, 8 | false, 9 | null, 10 | { 11 | "integer": 1234567890, 12 | "real": -9876.543210, 13 | "e": 0.123456789e-12, 14 | "E": 1.234567890E+34, 15 | "": 23456789012E66, 16 | "zero": 0, 17 | "one": 1, 18 | "space": " ", 19 | "quote": "\"", 20 | "backslash": "\\", 21 | "controls": "\b\f\n\r\t", 22 | "slash": "/ & \/", 23 | "alpha": "abcdefghijklmnopqrstuvwyz", 24 | "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ", 25 | "digit": "0123456789", 26 | "0123456789": "digit", 27 | "special": "`1~!@#$%^&*()_+-={':[,]}|;.?", 28 | "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A", 29 | "true": true, 30 | "false": false, 31 | "null": null, 32 | "array":[ ], 33 | "object":{ }, 34 | "address": "50 St. James Street", 35 | "url": "http://www.JSON.org/", 36 | "comment": "// /* */": " ", 38 | " s p a c e d " :[1,2 , 3 39 | 40 | , 41 | 42 | 4 , 5 , 6 ,7 ],"compact":[1,2,3,4,5,6,7], 43 | "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}", 44 | "quotes": "" \u0022 %22 0x22 034 "", 45 | "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" 46 | : "A key can be any string" 47 | }, 48 | 0.5 ,98.6 49 | , 50 | 99.44 51 | , 52 | 53 | 1066, 54 | 1e1, 55 | 0.1e1, 56 | 1e-1, 57 | 1e00,2e+00,2e-00 58 | ,"rosebud"] -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | Version 0.11 2 | * Limit floating-point range to that of Double to avoid allocation 3 | overflows when constructing Rationals 4 | 5 | Version 0.10 6 | * Use MonadFail, so that it works with GHC 8.8 7 | 8 | Version 0.9.1 9 | * Merge-in contributions from Neil Mitchell to support GHC 7.10 10 | 11 | Version 0.9 12 | * Merge-in contributions from Neil Mitchell to accomodate working with HEAD. 13 | 14 | Version 0.8 15 | * Add `Applicative` instance for `GetJSON` 16 | 17 | Version 0.4.4: released 2009-01-17; changes from 0.4.2 18 | 19 | * Fixes handling of unterminated strings. 20 | 21 | Version 0.4.3: released 2009-01-17; changes from 0.4.2 22 | 23 | * optimize some common cases..string and int literals. 24 | Reduces parse times by > 2x on larger dict inputs containing 25 | both kinds of lits. 26 | 27 | Version 0.4.2: released 2009-01-17; changes from 0.4.1 28 | 29 | * fixed Cabal build issues with various versions of 'base' and Data.Generic 30 | * fixed whitespace-handling bug in Parsec-based frontend. 31 | 32 | Version 0.4.1: released 2009-01-12; changes from 0.3.6 33 | 34 | * Addition of extra JSON instances: 35 | - IntMap, Set, Array, IntSet 36 | 37 | * Dropped initial letter case-lowering for constructors: 38 | - Maybe's constructors are mapped to "Nothing","Just". 39 | - Either's constructors are mapped to "Left", "Right". 40 | 41 | * Ordering's are represented by their constructor names (was 42 | funky int-mapping.) 43 | 44 | * JSON.Text.Result is now an instance of MonadError; contributed 45 | by Andy Gimblett. 46 | 47 | * Included Lennart Augustsson's contributed generic JSON encoder, 48 | in Text.JSON.Generic 49 | 50 | * Optional JSON dict-mapping for Data.Map and Data.IntMap 51 | 52 | -------------------------------------------------------------------------------- /Text/JSON/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- | Display JSON values using pretty printing combinators. 2 | 3 | module Text.JSON.Pretty 4 | ( module Text.JSON.Pretty 5 | , module Text.PrettyPrint.HughesPJ 6 | ) where 7 | 8 | import Text.JSON.Types 9 | import Text.PrettyPrint.HughesPJ 10 | import qualified Text.PrettyPrint.HughesPJ as PP 11 | import Data.Ratio 12 | import Data.Char 13 | import Numeric 14 | 15 | pp_value :: JSValue -> Doc 16 | pp_value v = case v of 17 | JSNull -> pp_null 18 | JSBool x -> pp_boolean x 19 | JSRational asf x -> pp_number asf x 20 | JSString x -> pp_js_string x 21 | JSArray vs -> pp_array vs 22 | JSObject xs -> pp_js_object xs 23 | 24 | pp_null :: Doc 25 | pp_null = text "null" 26 | 27 | pp_boolean :: Bool -> Doc 28 | pp_boolean True = text "true" 29 | pp_boolean False = text "false" 30 | 31 | pp_number :: Bool -> Rational -> Doc 32 | pp_number _ x | denominator x == 1 = integer (numerator x) 33 | pp_number True x = float (fromRational x) 34 | pp_number _ x = double (fromRational x) 35 | 36 | pp_array :: [JSValue] -> Doc 37 | pp_array xs = brackets $ fsep $ punctuate comma $ map pp_value xs 38 | 39 | pp_string :: String -> Doc 40 | pp_string x = doubleQuotes $ hcat $ map pp_char x 41 | where pp_char '\\' = text "\\\\" 42 | pp_char '"' = text "\\\"" 43 | pp_char c | isControl c = uni_esc c 44 | pp_char c = char c 45 | 46 | uni_esc c = text "\\u" PP.<> text (pad 4 (showHex (fromEnum c) "")) 47 | 48 | pad n cs | len < n = replicate (n-len) '0' ++ cs 49 | | otherwise = cs 50 | where len = length cs 51 | 52 | pp_object :: [(String,JSValue)] -> Doc 53 | pp_object xs = braces $ fsep $ punctuate comma $ map pp_field xs 54 | where pp_field (k,v) = pp_string k PP.<> colon <+> pp_value v 55 | 56 | pp_js_string :: JSString -> Doc 57 | pp_js_string x = pp_string (fromJSString x) 58 | 59 | pp_js_object :: JSObject JSValue -> Doc 60 | pp_js_object x = pp_object (fromJSObject x) 61 | 62 | -------------------------------------------------------------------------------- /tests/GenericTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, ExtendedDefaultRules, EmptyDataDecls #-} 2 | module Main where 3 | import Text.JSON.Generic 4 | import Data.Word 5 | import Data.Int 6 | 7 | data Foo = Foo { a :: Int, b :: Bool, c :: Baz } | None 8 | deriving (Typeable, Data, Show, Eq) 9 | 10 | data Baz = Baz Int 11 | deriving (Typeable, Data, Show, Eq) 12 | 13 | data Bar = Int :+: Int | Zero 14 | deriving (Typeable, Data, Show, Eq) 15 | 16 | newtype New a = New a 17 | deriving (Typeable, Data, Show, Eq) 18 | 19 | newtype Apples = Apples { noApples :: Int } 20 | deriving (Typeable, Data, Show, Eq) 21 | 22 | data Record = Record { x :: Int, y :: Double, z :: Float, s :: String, t :: (Bool, Int) } 23 | deriving (Typeable, Data, Show, Eq) 24 | 25 | rec = Record { x = 1, y = 2, z = 3.5, s = "hello", t = (True, 0) } 26 | 27 | data Tree a = Leaf | Node (Tree a) a (Tree a) 28 | deriving (Typeable, Data, Show, Eq) 29 | 30 | atree = build 4 31 | where build 0 = Leaf 32 | build 1 = Node Leaf 100 Leaf 33 | build n = Node (build (n-1)) n (build (n-2)) 34 | 35 | data Color = Red | Green | Blue 36 | deriving (Typeable, Data, Show, Eq, Enum) 37 | 38 | from (Ok x) = x 39 | from (Error s) = error s 40 | 41 | viaJSON :: (Data a) => a -> a 42 | viaJSON = from . fromJSON . toJSON 43 | 44 | testJSON :: (Data a, Eq a) => a -> Bool 45 | testJSON x = --x == viaJSON x 46 | x == decodeJSON (encodeJSON x) 47 | 48 | tests = and [ 49 | testJSON (1::Integer), 50 | testJSON (42::Int), 51 | testJSON (100::Word8), 52 | testJSON (-1000::Int64), 53 | testJSON (4.2::Double), 54 | testJSON (4.1::Float), 55 | testJSON True, 56 | testJSON 'q', 57 | testJSON "Hello, World\n", 58 | testJSON (Nothing :: Maybe Int), 59 | testJSON (Just "aa"), 60 | testJSON [], 61 | testJSON [1,2,3,4], 62 | testJSON (Left 1 :: Either Int Bool), 63 | testJSON (Right True :: Either Int Bool), 64 | testJSON (1,True), 65 | testJSON (1,2,True,'a',"apa",(4.5,99)), 66 | testJSON $ Baz 11, 67 | testJSON $ Foo 1 True (Baz 42), 68 | testJSON None, 69 | testJSON $ 2 :+: 3, 70 | testJSON Zero, 71 | testJSON $ New (2 :+: 3), 72 | testJSON rec, 73 | testJSON [LT,EQ,GT], 74 | testJSON atree, 75 | testJSON (), 76 | testJSON $ Apples 42, 77 | testJSON [Red .. Blue] 78 | ] 79 | 80 | main :: IO () 81 | main = if tests then return () else error "Generic test failed" 82 | -------------------------------------------------------------------------------- /Text/JSON/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | -- | Basic support for working with JSON values. 3 | 4 | module Text.JSON.Types ( 5 | 6 | -- * JSON Types 7 | JSValue(..) 8 | 9 | -- * Wrapper Types 10 | , JSString({-fromJSString-}..) 11 | , toJSString 12 | 13 | , JSObject({-fromJSObject-}..) 14 | , toJSObject 15 | 16 | , get_field 17 | , set_field 18 | 19 | ) where 20 | 21 | import Data.Typeable ( Typeable ) 22 | import Data.String(IsString(..)) 23 | 24 | -- 25 | -- | JSON values 26 | -- 27 | -- The type to which we encode Haskell values. There's a set 28 | -- of primitives, and a couple of heterogenous collection types. 29 | -- 30 | -- Objects: 31 | -- 32 | -- An object structure is represented as a pair of curly brackets 33 | -- surrounding zero or more name\/value pairs (or members). A name is a 34 | -- string. A single colon comes after each name, separating the name 35 | -- from the value. A single comma separates a value from a 36 | -- following name. 37 | -- 38 | -- Arrays: 39 | -- 40 | -- An array structure is represented as square brackets surrounding 41 | -- zero or more values (or elements). Elements are separated by commas. 42 | -- 43 | -- Only valid JSON can be constructed this way 44 | -- 45 | data JSValue 46 | = JSNull 47 | | JSBool !Bool 48 | | JSRational Bool{-as Float?-} !Rational 49 | | JSString JSString 50 | | JSArray [JSValue] 51 | | JSObject (JSObject JSValue) 52 | deriving (Show, Read, Eq, Ord, Typeable) 53 | 54 | -- | Strings can be represented a little more efficiently in JSON 55 | newtype JSString = JSONString { fromJSString :: String } 56 | deriving (Eq, Ord, Show, Read, Typeable) 57 | 58 | -- | Turn a Haskell string into a JSON string. 59 | toJSString :: String -> JSString 60 | toJSString = JSONString 61 | -- Note: we don't encode the string yet, that's done when serializing. 62 | 63 | instance IsString JSString where 64 | fromString = toJSString 65 | 66 | instance IsString JSValue where 67 | fromString = JSString . fromString 68 | 69 | -- | As can association lists 70 | newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] } 71 | deriving (Eq, Ord, Show, Read, Typeable ) 72 | 73 | -- | Make JSON object out of an association list. 74 | toJSObject :: [(String,a)] -> JSObject a 75 | toJSObject = JSONObject 76 | 77 | -- | Get the value of a field, if it exist. 78 | get_field :: JSObject a -> String -> Maybe a 79 | get_field (JSONObject xs) x = lookup x xs 80 | 81 | -- | Set the value of a field. Previous values are overwritten. 82 | set_field :: JSObject a -> String -> a -> JSObject a 83 | set_field (JSONObject xs) k v = JSONObject ((k,v) : filter ((/= k).fst) xs) 84 | -------------------------------------------------------------------------------- /json.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: json 3 | version: 0.11 4 | synopsis: Support for serialising Haskell to and from JSON 5 | description: 6 | JSON (JavaScript Object Notation) is a lightweight data-interchange 7 | format. It is easy for humans to read and write. It is easy for 8 | machines to parse and generate. It is based on a subset of the 9 | JavaScript Programming Language, Standard ECMA-262 3rd Edition - 10 | December 1999. 11 | . 12 | This library provides a parser and pretty printer for converting 13 | between Haskell values and JSON. 14 | category: Web 15 | license: BSD-3-Clause 16 | license-file: LICENSE 17 | author: Galois Inc. 18 | maintainer: Iavor S. Diatchki (iavor.diatchki@gmail.com) 19 | Copyright: (c) 2007-2018 Galois Inc. 20 | build-type: Simple 21 | extra-doc-files: 22 | CHANGES 23 | extra-source-files: 24 | tests/GenericTest.hs 25 | tests/HUnit.hs 26 | tests/Makefile 27 | tests/Parallel.hs 28 | tests/QC.hs 29 | tests/QuickCheckUtils.hs 30 | tests/Unit.hs 31 | tests/unit/fail1.json 32 | tests/unit/fail10.json 33 | tests/unit/fail11.json 34 | tests/unit/fail12.json 35 | tests/unit/fail13.json 36 | tests/unit/fail14.json 37 | tests/unit/fail15.json 38 | tests/unit/fail16.json 39 | tests/unit/fail17.json 40 | tests/unit/fail18.json 41 | tests/unit/fail19.json 42 | tests/unit/fail2.json 43 | tests/unit/fail20.json 44 | tests/unit/fail21.json 45 | tests/unit/fail22.json 46 | tests/unit/fail23.json 47 | tests/unit/fail24.json 48 | tests/unit/fail25.json 49 | tests/unit/fail26.json 50 | tests/unit/fail27.json 51 | tests/unit/fail28.json 52 | tests/unit/fail29.json 53 | tests/unit/fail3.json 54 | tests/unit/fail30.json 55 | tests/unit/fail31.json 56 | tests/unit/fail32.json 57 | tests/unit/fail33.json 58 | tests/unit/fail4.json 59 | tests/unit/fail5.json 60 | tests/unit/fail6.json 61 | tests/unit/fail7.json 62 | tests/unit/fail8.json 63 | tests/unit/fail9.json 64 | tests/unit/pass1.json 65 | tests/unit/pass2.json 66 | tests/unit/pass3.json 67 | 68 | source-repository head 69 | type: git 70 | location: https://github.com/GaloisInc/json.git 71 | 72 | flag split-base 73 | default: True 74 | description: Use the new split base package. 75 | flag parsec 76 | default: True 77 | description: Add support for parsing with Parsec. 78 | flag pretty 79 | default: True 80 | description: Add support for using pretty printing combinators. 81 | flag generic 82 | default: True 83 | description: Add support for generic encoder. 84 | 85 | flag mapdict 86 | default: False 87 | description: Encode Haskell maps as JSON dicts 88 | 89 | library 90 | default-language: Haskell2010 91 | exposed-modules: Text.JSON, 92 | Text.JSON.Types, 93 | Text.JSON.String, 94 | Text.JSON.ReadP 95 | ghc-options: -Wall -O2 96 | 97 | if flag(split-base) 98 | if flag(generic) 99 | build-depends: base >=4.9 && <5, syb >= 0.3.3 100 | 101 | exposed-modules: Text.JSON.Generic 102 | Cpp-Options: -DBASE_4 103 | else 104 | build-depends: base >= 3 && <4 105 | 106 | build-depends: array, containers, bytestring, mtl, text 107 | 108 | if flag(parsec) 109 | build-depends: parsec 110 | exposed-modules: Text.JSON.Parsec 111 | if flag(pretty) 112 | build-depends: pretty 113 | exposed-modules: Text.JSON.Pretty 114 | else 115 | build-depends: base < 3 116 | 117 | if flag(mapdict) 118 | cpp-options: -DMAP_AS_DICT 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /Text/JSON/ReadP.hs: -------------------------------------------------------------------------------- 1 | -- | Parse JSON values using the ReadP combinators. 2 | 3 | module Text.JSON.ReadP 4 | ( p_value 5 | , p_null 6 | , p_boolean 7 | , p_array 8 | , p_string 9 | , p_object 10 | , p_number 11 | , p_js_string 12 | , p_js_object 13 | , module Text.ParserCombinators.ReadP 14 | ) where 15 | 16 | import Text.JSON.Types 17 | import Text.ParserCombinators.ReadP 18 | import Control.Monad 19 | import Data.Char 20 | import Numeric 21 | 22 | token :: ReadP a -> ReadP a 23 | token p = skipSpaces **> p 24 | 25 | p_value :: ReadP JSValue 26 | p_value = (JSNull <$$ p_null) 27 | <||> (JSBool <$$> p_boolean) 28 | <||> (JSArray <$$> p_array) 29 | <||> (JSString <$$> p_js_string) 30 | <||> (JSObject <$$> p_js_object) 31 | <||> (JSRational False <$$> p_number) 32 | 33 | p_null :: ReadP () 34 | p_null = token (string "null") >> return () 35 | 36 | p_boolean :: ReadP Bool 37 | p_boolean = token 38 | ( (True <$$ string "true") 39 | <||> (False <$$ string "false") 40 | ) 41 | 42 | p_array :: ReadP [JSValue] 43 | p_array = between (token (char '[')) (token (char ']')) 44 | $ p_value `sepBy` token (char ',') 45 | 46 | p_string :: ReadP String 47 | p_string = between (token (char '"')) (char '"') (many p_char) 48 | where p_char = (char '\\' >> p_esc) 49 | <||> (satisfy (\x -> x /= '"' && x /= '\\')) 50 | 51 | p_esc = ('"' <$$ char '"') 52 | <||> ('\\' <$$ char '\\') 53 | <||> ('/' <$$ char '/') 54 | <||> ('\b' <$$ char 'b') 55 | <||> ('\f' <$$ char 'f') 56 | <||> ('\n' <$$ char 'n') 57 | <||> ('\r' <$$ char 'r') 58 | <||> ('\t' <$$ char 't') 59 | <||> (char 'u' **> p_uni) 60 | 61 | p_uni = check =<< count 4 (satisfy isHexDigit) 62 | where check x | code <= max_char = return (toEnum code) 63 | | otherwise = pfail 64 | where code = fst $ head $ readHex x 65 | max_char = fromEnum (maxBound :: Char) 66 | 67 | p_object :: ReadP [(String,JSValue)] 68 | p_object = between (token (char '{')) (token (char '}')) 69 | $ p_field `sepBy` token (char ',') 70 | where p_field = (,) <$$> (p_string <** token (char ':')) <**> p_value 71 | 72 | p_number :: ReadP Rational 73 | p_number = readS_to_P safeRationalReads 74 | 75 | -- reading into a Double with reads is safe for huge floating-point literals 76 | -- this will allow all floating-point literals that are small enough to fit 77 | -- into a Double (and are thus compatible with most other json implementations) 78 | -- to be parsed here without opening us to oversized Rational allocations 79 | safeRationalReads :: ReadS Rational 80 | safeRationalReads str = 81 | case reads str of 82 | [(d,_)] | not (isInfinite (d :: Double)) -> readSigned readFloat str 83 | _ -> [] 84 | 85 | p_js_string :: ReadP JSString 86 | p_js_string = toJSString <$$> p_string 87 | 88 | p_js_object :: ReadP (JSObject JSValue) 89 | p_js_object = toJSObject <$$> p_object 90 | 91 | -------------------------------------------------------------------------------- 92 | -- XXX: Because ReadP is not Applicative yet... 93 | 94 | (<**>) :: ReadP (a -> b) -> ReadP a -> ReadP b 95 | (<**>) = ap 96 | 97 | (**>) :: ReadP a -> ReadP b -> ReadP b 98 | (**>) = (>>) 99 | 100 | (<**) :: ReadP a -> ReadP b -> ReadP a 101 | m <** n = do x <- m; _ <- n; return x 102 | 103 | (<||>) :: ReadP a -> ReadP a -> ReadP a 104 | (<||>) = (+++) 105 | 106 | (<$$>) :: (a -> b) -> ReadP a -> ReadP b 107 | (<$$>) = fmap 108 | 109 | (<$$) :: a -> ReadP b -> ReadP a 110 | x <$$ m = m >> return x 111 | 112 | -------------------------------------------------------------------------------- /Text/JSON/Parsec.hs: -------------------------------------------------------------------------------- 1 | -- | Parse JSON values using the Parsec combinators. 2 | 3 | module Text.JSON.Parsec 4 | ( p_value 5 | , p_null 6 | , p_boolean 7 | , p_array 8 | , p_string 9 | , p_object 10 | , p_number 11 | , p_js_string 12 | , p_js_object 13 | , p_jvalue 14 | , module Text.ParserCombinators.Parsec 15 | ) where 16 | 17 | import Text.JSON.Types 18 | import Text.ParserCombinators.Parsec 19 | import Control.Monad 20 | import Data.Char 21 | import Numeric 22 | 23 | p_value :: CharParser () JSValue 24 | p_value = spaces **> p_jvalue 25 | 26 | tok :: CharParser () a -> CharParser () a 27 | tok p = p <** spaces 28 | 29 | p_jvalue :: CharParser () JSValue 30 | p_jvalue = (JSNull <$$ p_null) 31 | <|> (JSBool <$$> p_boolean) 32 | <|> (JSArray <$$> p_array) 33 | <|> (JSString <$$> p_js_string) 34 | <|> (JSObject <$$> p_js_object) 35 | <|> (JSRational False <$$> p_number) 36 | "JSON value" 37 | 38 | p_null :: CharParser () () 39 | p_null = tok (string "null") >> return () 40 | 41 | p_boolean :: CharParser () Bool 42 | p_boolean = tok 43 | ( (True <$$ string "true") 44 | <|> (False <$$ string "false") 45 | ) 46 | 47 | p_array :: CharParser () [JSValue] 48 | p_array = between (tok (char '[')) (tok (char ']')) 49 | $ p_jvalue `sepBy` tok (char ',') 50 | 51 | p_string :: CharParser () String 52 | p_string = between (char '"') (tok (char '"')) (many p_char) 53 | where p_char = (char '\\' >> p_esc) 54 | <|> (satisfy (\x -> x /= '"' && x /= '\\')) 55 | 56 | p_esc = ('"' <$$ char '"') 57 | <|> ('\\' <$$ char '\\') 58 | <|> ('/' <$$ char '/') 59 | <|> ('\b' <$$ char 'b') 60 | <|> ('\f' <$$ char 'f') 61 | <|> ('\n' <$$ char 'n') 62 | <|> ('\r' <$$ char 'r') 63 | <|> ('\t' <$$ char 't') 64 | <|> (char 'u' **> p_uni) 65 | "escape character" 66 | 67 | p_uni = check =<< count 4 (satisfy isHexDigit) 68 | where check x | code <= max_char = return (toEnum code) 69 | | otherwise = mzero 70 | where code = fst $ head $ readHex x 71 | max_char = fromEnum (maxBound :: Char) 72 | 73 | p_object :: CharParser () [(String,JSValue)] 74 | p_object = between (tok (char '{')) (tok (char '}')) 75 | $ p_field `sepBy` tok (char ',') 76 | where p_field = (,) <$$> (p_string <** tok (char ':')) <**> p_jvalue 77 | 78 | p_number :: CharParser () Rational 79 | p_number = tok 80 | $ do s <- getInput 81 | case (reads s, readSigned readFloat s) of 82 | ([(x,_)], _) 83 | | isInfinite (x :: Double) -> fail "number out of range" 84 | (_, [(y,s')]) -> y <$$ setInput s' 85 | _ -> mzero "number" 86 | 87 | p_js_string :: CharParser () JSString 88 | p_js_string = toJSString <$$> p_string 89 | 90 | p_js_object :: CharParser () (JSObject JSValue) 91 | p_js_object = toJSObject <$$> p_object 92 | 93 | -------------------------------------------------------------------------------- 94 | -- XXX: Because Parsec is not Applicative yet... 95 | 96 | (<**>) :: CharParser () (a -> b) -> CharParser () a -> CharParser () b 97 | (<**>) = ap 98 | 99 | (**>) :: CharParser () a -> CharParser () b -> CharParser () b 100 | (**>) = (>>) 101 | 102 | (<**) :: CharParser () a -> CharParser () b -> CharParser () a 103 | m <** n = do x <- m; _ <- n; return x 104 | 105 | (<$$>) :: (a -> b) -> CharParser () a -> CharParser () b 106 | (<$$>) = fmap 107 | 108 | (<$$) :: a -> CharParser () b -> CharParser () a 109 | x <$$ m = m >> return x 110 | 111 | -------------------------------------------------------------------------------- /tests/HUnit.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | 3 | import Text.JSON 4 | import Test.HUnit 5 | import System.Exit (exitFailure) 6 | import Control.Monad (when) 7 | import System.IO 8 | import Data.Either 9 | import qualified Data.Map as M 10 | 11 | isError (Error _) = True 12 | isError _ = False 13 | 14 | 15 | main = do counts <- runTestTT tests 16 | when (errors counts > 0 || failures counts > 0) exitFailure 17 | 18 | tests = TestList 19 | [shouldFail "non-array top level" "fail1" (undefined :: String) 20 | ,shouldFail "unclosed array" "fail2" (undefined :: JSValue) 21 | ,shouldFail "object keys must be quoted" "fail3" (undefined :: JSValue) 22 | ,shouldFail "extra comma" "fail4" (undefined :: JSValue) 23 | ,shouldFail "double extra comma" "fail5" (undefined :: JSValue) 24 | ,shouldFail "missing value" "fail6" (undefined :: JSValue) 25 | ,shouldFail "comma after close" "fail7" (undefined :: JSValue) 26 | ,shouldFail "extra close" "fail8" (undefined :: JSValue) 27 | ,shouldFail "extra comma" "fail9" (undefined :: JSValue) 28 | ,shouldFail "extra value" "fail10" (undefined :: JSValue) 29 | ,shouldFail "illegal expression" "fail11" (undefined :: JSValue) 30 | ,shouldFail "illegal expression" "fail12" (undefined :: JSValue) 31 | ,shouldFail "numbers with leading zeroes" "fail13" (undefined :: JSValue) 32 | ,shouldFail "numbers in hex" "fail14" (undefined :: JSValue) 33 | ,shouldFail "illegal backslash" "fail15" (undefined :: JSValue) 34 | ,shouldFail "unquoted char" "fail16" (undefined :: JSValue) 35 | ,shouldFail "illegal escape" "fail17" (undefined :: JSValue) 36 | ,shouldPass "deep objects" "fail18" (undefined :: JSValue) -- depth is allowed to be limited, but why bother? 37 | ,shouldFail "missing colon" "fail19" (undefined :: JSValue) 38 | ,shouldFail "double colon" "fail20" (undefined :: JSValue) 39 | ,shouldFail "comma instead of colon" "fail21" (undefined :: JSValue) 40 | ,shouldFail "colon intead of comma" "fail22" (undefined :: JSValue) 41 | ,shouldFail "invalid token" "fail23" (undefined :: JSValue) 42 | ,shouldFail "single quotes" "fail24" (undefined :: JSValue) 43 | ,shouldFail "literal tabs" "fail25" (undefined :: JSValue) 44 | ,shouldFail "tabs in strings" "fail26" (undefined :: JSValue) 45 | ,shouldFail "newline in strings" "fail27" (undefined :: JSValue) 46 | ,shouldFail "escaped newline in strings" "fail28" (undefined :: JSValue) 47 | ,shouldFail "funny number" "fail29" (undefined :: JSValue) 48 | ,shouldFail "funny number 2" "fail30" (undefined :: JSValue) 49 | ,shouldFail "funny number 3" "fail31" (undefined :: JSValue) 50 | ,shouldFail "unterminated array" "fail32" (undefined :: JSValue) 51 | ,shouldFail "unterminated array" "fail33" (undefined :: JSValue) 52 | 53 | , shouldPass "complex valid input 1" "pass1" (undefined :: JSValue) 54 | , shouldPass "complex valid input 2" "pass2" (undefined :: JSValue) 55 | , shouldPass "complex valid input 3" "pass3" (undefined :: JSValue) 56 | ] 57 | 58 | ------------------------------------------------------------------------ 59 | 60 | load n = readFile ("unit/" ++ n ++ ".json") 61 | 62 | shouldFail :: JSON a => String -> String -> a -> Test 63 | shouldFail s n (x :: a) = TestLabel ("Should fail: " ++ s) $ 64 | TestCase $ do 65 | -- hPutStrLn stderr $ ("\t\tShould fail: " ++ s) 66 | s <- load n 67 | assert =<< case decodeStrict s :: Result a of 68 | Ok _ -> return False 69 | Error s -> -- do hPrint stderr s 70 | return True 71 | 72 | 73 | shouldPass :: JSON a => String -> String -> a -> Test 74 | shouldPass s n (x :: a) = TestLabel ("Should pass: " ++ s) $ 75 | TestCase $ do 76 | -- hPutStrLn stderr $ ("\t\tShould pass: " ++ s) 77 | s <- load n 78 | assert =<< case decodeStrict s :: Result a of 79 | Ok _ -> return True 80 | Error s -> do hPrint stderr s 81 | return False 82 | 83 | -------------------------------------------------------------------------------- /tests/Parallel.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Test.QuickCheck.Parallel 4 | -- Copyright : (c) Don Stewart 2006 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : dons@cse.unsw.edu.au 8 | -- Stability : experimental 9 | -- Portability : non-portable (uses Control.Exception, Control.Concurrent) 10 | -- 11 | -- A parallel batch driver for running QuickCheck on threaded or SMP systems. 12 | -- See the /Example.hs/ file for a complete overview. 13 | -- 14 | 15 | module Parallel ( 16 | pRun, 17 | pDet, 18 | pNon 19 | ) where 20 | 21 | import Test.QuickCheck 22 | import Data.List 23 | import Control.Concurrent (forkIO) 24 | 25 | import Control.Concurrent.Chan 26 | import Control.Concurrent.MVar 27 | 28 | import Control.Exception hiding (evaluate) 29 | import System.Random 30 | import System.IO (hFlush,stdout) 31 | import Text.Printf 32 | 33 | type Name = String 34 | type Depth = Int 35 | type Test = (Name, Depth -> IO String) 36 | 37 | -- | Run a list of QuickCheck properties in parallel chunks, using 38 | -- 'n' Haskell threads (first argument), and test to a depth of 'd' 39 | -- (second argument). Compile your application with '-threaded' and run 40 | -- with the SMP runtime's '-N4' (or however many OS threads you want to 41 | -- donate), for best results. 42 | -- 43 | -- > import Test.QuickCheck.Parallel 44 | -- > 45 | -- > do n <- getArgs >>= readIO . head 46 | -- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] 47 | -- 48 | -- Will run 'n' threads over the property list, to depth 1000. 49 | -- 50 | pRun :: Int -> Int -> [Test] -> IO () 51 | pRun n depth tests = do 52 | chan <- newChan 53 | ps <- getChanContents chan 54 | work <- newMVar tests 55 | 56 | forM_ [1..n] $ forkIO . thread work chan 57 | 58 | let wait xs i 59 | | i >= n = return () -- done 60 | | otherwise = case xs of 61 | Nothing : xs -> wait xs $! i+1 62 | Just s : xs -> putStr s >> hFlush stdout >> wait xs i 63 | wait ps 0 64 | 65 | where 66 | thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () 67 | thread work chan me = loop 68 | where 69 | loop = do 70 | job <- modifyMVar work $ \jobs -> return $ case jobs of 71 | [] -> ([], Nothing) 72 | (j:js) -> (js, Just j) 73 | case job of 74 | Nothing -> writeChan chan Nothing -- done 75 | Just (name,prop) -> do 76 | v <- prop depth 77 | writeChan chan . Just $ printf "%d: %-25s: %s" me name v 78 | loop 79 | 80 | 81 | -- | Wrap a property, and run it on a deterministic set of data 82 | pDet :: Testable a => a -> Int -> IO String 83 | pDet a n = mycheck Det defaultConfig 84 | { configMaxTest = n 85 | , configEvery = \n args -> unlines args } a 86 | 87 | -- | Wrap a property, and run it on a non-deterministic set of data 88 | pNon :: Testable a => a -> Int -> IO String 89 | pNon a n = mycheck NonDet defaultConfig 90 | { configMaxTest = n 91 | , configEvery = \n args -> unlines args } a 92 | 93 | data Mode = Det | NonDet 94 | 95 | ------------------------------------------------------------------------ 96 | 97 | mycheck :: Testable a => Mode -> Config -> a -> IO String 98 | mycheck Det config a = do 99 | let rnd = mkStdGen 99 -- deterministic 100 | mytests config (evaluate a) rnd 0 0 [] 101 | 102 | mycheck NonDet config a = do 103 | rnd <- newStdGen -- different each run 104 | mytests config (evaluate a) rnd 0 0 [] 105 | 106 | mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String 107 | mytests config gen rnd0 ntest nfail stamps 108 | | ntest == configMaxTest config = do done "OK," ntest stamps 109 | | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps 110 | | otherwise = do 111 | case ok result of 112 | Nothing -> 113 | mytests config gen rnd1 ntest (nfail+1) stamps 114 | Just True -> 115 | mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) 116 | Just False -> 117 | return ( "Falsifiable after " 118 | ++ show ntest 119 | ++ " tests:\n" 120 | ++ unlines (arguments result) 121 | ) 122 | where 123 | result = generate (configSize config ntest) rnd2 gen 124 | (rnd1,rnd2) = split rnd0 125 | 126 | done :: String -> Int -> [[String]] -> IO String 127 | done mesg ntest stamps = 128 | return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) 129 | where 130 | table = display 131 | . map entry 132 | . reverse 133 | . sort 134 | . map pairLength 135 | . group 136 | . sort 137 | . filter (not . null) 138 | $ stamps 139 | 140 | display [] = ".\n" 141 | display [x] = " (" ++ x ++ ").\n" 142 | display xs = ".\n" ++ unlines (map (++ ".") xs) 143 | 144 | pairLength xss@(xs:_) = (length xss, xs) 145 | entry (n, xs) = percentage n ntest 146 | ++ " " 147 | ++ concat (intersperse ", " xs) 148 | 149 | percentage n m = show ((100 * n) `div` m) ++ "%" 150 | 151 | forM_ = flip mapM_ 152 | -------------------------------------------------------------------------------- /tests/QC.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fglasgow-exts #-} 2 | module Main where 3 | 4 | import Text.JSON 5 | 6 | import Parallel 7 | 8 | import qualified Data.Map as Map 9 | import qualified Data.Set as Set 10 | import qualified Data.IntMap as IntMap 11 | import qualified Data.IntSet as IntSet 12 | 13 | import qualified Control.Exception as C (catch,evaluate) 14 | import Control.Monad 15 | import Foreign 16 | import System.Environment 17 | import System.IO 18 | import System.IO.Unsafe 19 | import Data.Word 20 | import Data.Int 21 | 22 | import Test.QuickCheck hiding (test) 23 | import QuickCheckUtils 24 | import Debug.Trace 25 | import Text.Printf 26 | 27 | import Data.IntSet ( IntSet ) 28 | import qualified Data.ByteString as S 29 | import qualified Data.ByteString.Lazy as L 30 | import qualified Data.Sequence as Seq 31 | import qualified Data.Map as M 32 | import qualified Data.IntMap as I 33 | 34 | ------------------------------------------------------------------------ 35 | -- low level ones: 36 | 37 | main :: IO () 38 | main = do 39 | hSetBuffering stdout NoBuffering 40 | s <- getArgs 41 | let n = if null s then 100 else read (head s) 42 | k = doIt n 43 | 44 | k basics 45 | k atomicCharacterTypes 46 | k numbers 47 | k listlikes 48 | k containers 49 | k sumtypes 50 | k products 51 | 52 | 53 | doIt n (s,x) = putStrLn (" *** " ++ s) >> pRun 2 n x 54 | 55 | 56 | type T a = a -> Property 57 | type B a = a -> Bool 58 | 59 | p :: Testable a => a -> Int -> IO String 60 | p = pNon 61 | 62 | test :: forall a. (Show a,Arbitrary a, Eq a, JSON a) => a -> Property 63 | test _ = forAll (arbitrary :: Gen a) $ \a -> 64 | Ok a == decode (encode a) 65 | 66 | instance Arbitrary JSString where 67 | arbitrary = liftM toJSString arbitrary 68 | coarbitrary = undefined 69 | 70 | instance (Ord e, Arbitrary e) => Arbitrary (JSObject e) where 71 | arbitrary = do 72 | ks <- arbitrary 73 | vs <- arbitrary 74 | return . toJSObject . M.toList . M.fromList . zip ks $ vs 75 | 76 | coarbitrary = undefined 77 | 78 | ------------------------------------------------------------------------ 79 | 80 | -- tests :: [(String, Int -> IO String)] 81 | basics = ("Basic types", 82 | [("Bool", p (test :: T Bool )) 83 | ,("()", p (test :: T () )) 84 | ] 85 | ) 86 | 87 | -- atomic character types 88 | 89 | atomicCharacterTypes = 90 | ("Atomic string types", 91 | 92 | [("String", p (test :: T JSString )) 93 | ,("Strict ByteString", p (test :: T S.ByteString )) 94 | ,("Lazy ByteString", p (test :: T L.ByteString )) 95 | ,("Char", p (test :: T Char )) 96 | ] 97 | ) 98 | 99 | -- basic numeric types 100 | numbers = 101 | ("Numeric types", 102 | [("Integer", p (test :: T Integer )) 103 | ,("Int", p (test :: T Int )) 104 | ,("Word", p (test :: T Word )) 105 | 106 | -- words 107 | 108 | ,("Word8", p (test :: T Word8 )) 109 | ,("Word16", p (test :: T Word16 )) 110 | ,("Word32", p (test :: T Word32 )) 111 | ,("Word64", p (test :: T Word64 )) 112 | 113 | -- integers 114 | 115 | ,("Int8", p (test :: T Int8 )) 116 | ,("Int16", p (test :: T Int16 )) 117 | ,("Int32", p (test :: T Int32 )) 118 | ,("Int64", p (test :: T Int64 )) 119 | 120 | -- rationals 121 | 122 | ,("Double", p (test :: T Double)) 123 | ,("Float", p (test :: T Float)) 124 | ]) 125 | 126 | -- lists 127 | 128 | listlikes = 129 | ("List like types", 130 | [("[()]", p (test :: T [()])) 131 | ,("[Int]", p (test :: T [Int])) 132 | ,("[Bool]", p (test :: T [Bool])) 133 | ,("[Integer]", p (test :: T [Integer])) 134 | ,("[Int]", p (test :: T [Int])) 135 | ,("[Word]", p (test :: T [Word])) 136 | ,("[S.ByteString]", p (test :: T [S.ByteString] )) 137 | ,("[L.ByteString]", p (test :: T [L.ByteString] )) 138 | 139 | ]) 140 | -- containers 141 | 142 | containers = 143 | ("Container types", 144 | [("IntSet", p (test :: T IntSet )) 145 | ,("Map String Int", p (test :: T (M.Map String Int) )) 146 | ,("Map Int String", p (test :: T (M.Map Int String) )) 147 | 148 | -- ,("Maybe Bool", p (test :: T (Maybe Bool) )) 149 | -- ,("Rational", p (test :: T Rational )) 150 | 151 | ] 152 | ) 153 | 154 | sumtypes = 155 | ("Sum types", 156 | [("Ordering", p (test :: T Ordering)) 157 | ,("Maybe Int", p (test :: T (Maybe Int))) 158 | ,("Maybe String", p (test :: T (Maybe String))) 159 | ,("Either Bool String", p (test :: T (Either Bool String))) 160 | ,("Either Int (Either Int Word32)", 161 | p (test :: T (Either Int (Either Int Word32)))) 162 | ]) 163 | 164 | products = 165 | ("Products", 166 | [("((),())", 167 | p (test :: T ((),()) 168 | )) 169 | 170 | ,("(Bool,Int)", 171 | p (test :: T (Bool,Int) 172 | )) 173 | 174 | ,("(Bool,(Int, String))", 175 | p (test :: T (Bool,(Int,String)) 176 | )) 177 | 178 | ,("(Maybe String,(Either Int Bool, String))", 179 | p (test :: T (Bool,(Either Int Bool,String)) 180 | )) 181 | 182 | ,("(Bool,Int,String)", 183 | p (test :: T (Bool,Int,String) 184 | )) 185 | 186 | ,("(Bool,Int,String,Char)", 187 | p (test :: T (Bool,Int,String,Char) 188 | )) 189 | 190 | ] 191 | 192 | ) 193 | -------------------------------------------------------------------------------- /Text/JSON/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | -- | JSON serializer and deserializer using Data.Generics. 3 | -- The functions here handle algebraic data types and primitive types. 4 | -- It uses the same representation as "Text.JSON" for "Prelude" types. 5 | module Text.JSON.Generic 6 | ( module Text.JSON 7 | , Data 8 | , Typeable 9 | , toJSON 10 | , fromJSON 11 | , encodeJSON 12 | , decodeJSON 13 | 14 | , toJSON_generic 15 | , fromJSON_generic 16 | ) where 17 | 18 | import Control.Monad.State 19 | import Text.JSON 20 | import Text.JSON.String ( runGetJSON ) 21 | import Data.Generics 22 | import Data.Word 23 | import Data.Int 24 | 25 | import qualified Data.ByteString.Char8 as S 26 | import qualified Data.ByteString.Lazy.Char8 as L 27 | import qualified Data.IntSet as I 28 | -- FIXME: The JSON library treats this specially, needs ext2Q 29 | -- import qualified Data.Map as M 30 | 31 | type T a = a -> JSValue 32 | 33 | -- |Convert anything to a JSON value. 34 | toJSON :: (Data a) => a -> JSValue 35 | toJSON = toJSON_generic 36 | `ext1Q` jList 37 | -- Use the standard encoding for all base types. 38 | `extQ` (showJSON :: T Integer) 39 | `extQ` (showJSON :: T Int) 40 | `extQ` (showJSON :: T Word8) 41 | `extQ` (showJSON :: T Word16) 42 | `extQ` (showJSON :: T Word32) 43 | `extQ` (showJSON :: T Word64) 44 | `extQ` (showJSON :: T Int8) 45 | `extQ` (showJSON :: T Int16) 46 | `extQ` (showJSON :: T Int32) 47 | `extQ` (showJSON :: T Int64) 48 | `extQ` (showJSON :: T Double) 49 | `extQ` (showJSON :: T Float) 50 | `extQ` (showJSON :: T Char) 51 | `extQ` (showJSON :: T String) 52 | -- Bool has a special encoding. 53 | `extQ` (showJSON :: T Bool) 54 | `extQ` (showJSON :: T ()) 55 | `extQ` (showJSON :: T Ordering) 56 | -- More special cases. 57 | `extQ` (showJSON :: T I.IntSet) 58 | `extQ` (showJSON :: T S.ByteString) 59 | `extQ` (showJSON :: T L.ByteString) 60 | where 61 | -- Lists are simply coded as arrays. 62 | jList vs = JSArray $ map toJSON vs 63 | 64 | 65 | toJSON_generic :: (Data a) => a -> JSValue 66 | toJSON_generic = generic 67 | where 68 | -- Generic encoding of an algebraic data type. 69 | -- No constructor, so it must be an error value. Code it anyway as JSNull. 70 | -- Elide a single constructor and just code the arguments. 71 | -- For multiple constructors, make an object with a field name that is the 72 | -- constructor (except lower case) and the data is the arguments encoded. 73 | generic a = 74 | case dataTypeRep (dataTypeOf a) of 75 | AlgRep [] -> JSNull 76 | AlgRep [c] -> encodeArgs c (gmapQ toJSON a) 77 | AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a) 78 | rep -> err (dataTypeOf a) rep 79 | where 80 | err dt r = error $ "toJSON: not AlgRep " ++ show r ++ "(" ++ show dt ++ ")" 81 | -- Encode nullary constructor as a string. 82 | -- Encode non-nullary constructors as an object with the constructor 83 | -- name as the single field and the arguments as the value. 84 | -- Use an array if the are no field names, but elide singleton arrays, 85 | -- and use an object if there are field names. 86 | encodeConstr c [] = JSString $ toJSString $ constrString c 87 | encodeConstr c as = jsObject [(constrString c, encodeArgs c as)] 88 | 89 | constrString = showConstr 90 | 91 | encodeArgs c = encodeArgs' (constrFields c) 92 | encodeArgs' [] [j] = j 93 | encodeArgs' [] js = JSArray js 94 | encodeArgs' ns js = jsObject $ zip (map mungeField ns) js 95 | 96 | -- Skip leading '_' in field name so we can use keywords etc. as field names. 97 | mungeField ('_':cs) = cs 98 | mungeField cs = cs 99 | 100 | jsObject :: [(String, JSValue)] -> JSValue 101 | jsObject = JSObject . toJSObject 102 | 103 | 104 | type F a = Result a 105 | 106 | -- |Convert a JSON value to anything (fails if the types do not match). 107 | fromJSON :: (Data a) => JSValue -> Result a 108 | fromJSON j = fromJSON_generic j 109 | `ext1R` jList 110 | 111 | `extR` (value :: F Integer) 112 | `extR` (value :: F Int) 113 | `extR` (value :: F Word8) 114 | `extR` (value :: F Word16) 115 | `extR` (value :: F Word32) 116 | `extR` (value :: F Word64) 117 | `extR` (value :: F Int8) 118 | `extR` (value :: F Int16) 119 | `extR` (value :: F Int32) 120 | `extR` (value :: F Int64) 121 | `extR` (value :: F Double) 122 | `extR` (value :: F Float) 123 | `extR` (value :: F Char) 124 | `extR` (value :: F String) 125 | 126 | `extR` (value :: F Bool) 127 | `extR` (value :: F ()) 128 | `extR` (value :: F Ordering) 129 | 130 | `extR` (value :: F I.IntSet) 131 | `extR` (value :: F S.ByteString) 132 | `extR` (value :: F L.ByteString) 133 | where value :: (JSON a) => Result a 134 | value = readJSON j 135 | 136 | jList :: (Data e) => Result [e] 137 | jList = case j of 138 | JSArray js -> mapM fromJSON js 139 | _ -> Error $ "fromJSON: Prelude.[] bad data: " ++ show j 140 | 141 | 142 | 143 | fromJSON_generic :: (Data a) => JSValue -> Result a 144 | fromJSON_generic j = generic 145 | where 146 | typ = dataTypeOf $ resType generic 147 | generic = case dataTypeRep typ of 148 | AlgRep [] -> case j of JSNull -> return (error "Empty type"); _ -> Error $ "fromJSON: no-constr bad data" 149 | AlgRep [_] -> decodeArgs (indexConstr typ 1) j 150 | AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j' 151 | rep -> Error $ "fromJSON: " ++ show rep ++ "(" ++ show typ ++ ")" 152 | getConstr t (JSObject o) | [(s, j')] <- fromJSObject o = do c <- readConstr' t s; return (c, j') 153 | getConstr t (JSString js) = do c <- readConstr' t (fromJSString js); return (c, JSNull) -- handle nullare constructor 154 | getConstr _ _ = Error "fromJSON: bad constructor encoding" 155 | readConstr' t s = 156 | maybe (Error $ "fromJSON: unknown constructor: " ++ s ++ " " ++ show t) 157 | return $ readConstr t s 158 | 159 | decodeArgs c = decodeArgs' (numConstrArgs (resType generic) c) c (constrFields c) 160 | decodeArgs' 0 c _ JSNull = construct c [] -- nullary constructor 161 | decodeArgs' 1 c [] jd = construct c [jd] -- unary constructor 162 | decodeArgs' n c [] (JSArray js) | n > 1 = construct c js -- no field names 163 | -- FIXME? We could allow reading an array into a constructor with field names. 164 | decodeArgs' _ c fs@(_:_) (JSObject o) = selectFields (fromJSObject o) fs >>= construct c -- field names 165 | decodeArgs' _ c _ jd = Error $ "fromJSON: bad decodeArgs data " ++ show (c, jd) 166 | 167 | -- Build the value by stepping through the list of subparts. 168 | construct c = evalStateT $ fromConstrM f c 169 | where f :: (Data a) => StateT [JSValue] Result a 170 | f = do js <- get; case js of [] -> lift $ Error "construct: empty list"; j' : js' -> do put js'; lift $ fromJSON j' 171 | 172 | -- Select the named fields from a JSON object. FIXME? Should this use a map? 173 | selectFields fjs = mapM sel 174 | where sel f = maybe (Error $ "fromJSON: field does not exist " ++ f) Ok $ lookup f fjs 175 | 176 | -- Count how many arguments a constructor has. The value x is used to determine what type the constructor returns. 177 | numConstrArgs :: (Data a) => a -> Constr -> Int 178 | numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0 179 | where f = do modify (+1); return undefined 180 | 181 | resType :: Result a -> a 182 | resType _ = error "resType" 183 | 184 | -- |Encode a value as a string. 185 | encodeJSON :: (Data a) => a -> String 186 | encodeJSON x = showJSValue (toJSON x) "" 187 | 188 | -- |Decode a string as a value. 189 | decodeJSON :: (Data a) => String -> a 190 | decodeJSON s = 191 | case runGetJSON readJSValue s of 192 | Left msg -> error msg 193 | Right j -> 194 | case fromJSON j of 195 | Error msg -> error msg 196 | Ok x -> x 197 | -------------------------------------------------------------------------------- /tests/QuickCheckUtils.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fglasgow-exts #-} 2 | -- 3 | -- Uses multi-param type classes 4 | -- 5 | module QuickCheckUtils where 6 | 7 | import Control.Monad 8 | 9 | import Test.QuickCheck.Batch 10 | import Test.QuickCheck 11 | import Text.Show.Functions 12 | import Data.Ratio 13 | 14 | import qualified Data.ByteString as B 15 | import qualified Data.ByteString.Lazy as L 16 | import qualified Data.Map as Map 17 | import qualified Data.Set as Set 18 | import qualified Data.IntMap as IntMap 19 | import qualified Data.IntSet as IntSet 20 | 21 | import qualified Control.Exception as C (evaluate) 22 | 23 | import Control.Monad ( liftM2 ) 24 | import Data.Char 25 | import Data.List 26 | import Data.Word 27 | import Data.Int 28 | import System.Random 29 | import System.IO 30 | 31 | -- import Control.Concurrent 32 | import System.Mem 33 | import System.CPUTime 34 | import Text.Printf 35 | 36 | import qualified Data.ByteString as P 37 | import qualified Data.ByteString.Lazy as L 38 | 39 | #if __GLASGOW_HASKELL__ >= 608 40 | import qualified Data.ByteString.Lazy.Internal as L 41 | import qualified Data.ByteString.Unsafe as B 42 | import qualified Data.ByteString.Internal as B 43 | #else 44 | import qualified Data.ByteString.Base as B 45 | #endif 46 | 47 | -- import qualified Data.Sequence as Seq 48 | 49 | -- Enable this to get verbose test output. Including the actual tests. 50 | debug = False 51 | 52 | mytest :: Testable a => a -> Int -> IO () 53 | mytest a n = mycheck defaultConfig 54 | { configMaxTest=n 55 | , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a 56 | 57 | mycheck :: Testable a => Config -> a -> IO () 58 | mycheck config a = do 59 | rnd <- newStdGen 60 | performGC -- >> threadDelay 100 61 | t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0 62 | printf " %0.3f seconds\n" (t :: Double) 63 | hFlush stdout 64 | 65 | time :: a -> IO (a , Double) 66 | time a = do 67 | start <- getCPUTime 68 | v <- C.evaluate a 69 | v `seq` return () 70 | end <- getCPUTime 71 | return (v, ( (fromIntegral (end - start)) / (10^12))) 72 | 73 | mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double 74 | mytests config gen rnd0 ntest nfail stamps t0 75 | | ntest == configMaxTest config = do done "OK," ntest stamps 76 | return t0 77 | 78 | | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps 79 | return t0 80 | 81 | | otherwise = do 82 | (result,t1) <- time (generate (configSize config ntest) rnd2 gen) 83 | 84 | putStr (configEvery config ntest (arguments result)) >> hFlush stdout 85 | case ok result of 86 | Nothing -> 87 | mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1) 88 | Just True -> 89 | mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1) 90 | Just False -> do 91 | putStr ( "Falsifiable after " 92 | ++ show ntest 93 | ++ " tests:\n" 94 | ++ unlines (arguments result) 95 | ) >> hFlush stdout 96 | return t0 97 | 98 | where 99 | (rnd1,rnd2) = split rnd0 100 | 101 | done :: String -> Int -> [[String]] -> IO () 102 | done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) 103 | where 104 | table = display 105 | . map entry 106 | . reverse 107 | . sort 108 | . map pairLength 109 | . group 110 | . sort 111 | . filter (not . null) 112 | $ stamps 113 | 114 | display [] = ". " 115 | display [x] = " (" ++ x ++ "). " 116 | display xs = ".\n" ++ unlines (map (++ ".") xs) 117 | 118 | pairLength xss@(xs:_) = (length xss, xs) 119 | entry (n, xs) = percentage n ntest 120 | ++ " " 121 | ++ concat (intersperse ", " xs) 122 | 123 | percentage n m = show ((100 * n) `div` m) ++ "%" 124 | 125 | ------------------------------------------------------------------------ 126 | 127 | instance Random Word8 where 128 | randomR = integralRandomR 129 | random = randomR (minBound,maxBound) 130 | 131 | instance Random Int8 where 132 | randomR = integralRandomR 133 | random = randomR (minBound,maxBound) 134 | 135 | instance Random Word16 where 136 | randomR = integralRandomR 137 | random = randomR (minBound,maxBound) 138 | 139 | instance Random Int16 where 140 | randomR = integralRandomR 141 | random = randomR (minBound,maxBound) 142 | 143 | instance Random Word where 144 | randomR = integralRandomR 145 | random = randomR (minBound,maxBound) 146 | 147 | instance Random Word32 where 148 | randomR = integralRandomR 149 | random = randomR (minBound,maxBound) 150 | 151 | instance Random Int32 where 152 | randomR = integralRandomR 153 | random = randomR (minBound,maxBound) 154 | 155 | instance Random Word64 where 156 | randomR = integralRandomR 157 | random = randomR (minBound,maxBound) 158 | 159 | instance Random Int64 where 160 | randomR = integralRandomR 161 | random = randomR (minBound,maxBound) 162 | 163 | ------------------------------------------------------------------------ 164 | 165 | integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) 166 | integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, 167 | fromIntegral b :: Integer) g of 168 | (x,g) -> (fromIntegral x, g) 169 | 170 | ------------------------------------------------------------------------ 171 | 172 | instance Arbitrary Word8 where 173 | arbitrary = choose (0, 2^8-1) 174 | coarbitrary w = variant 0 175 | 176 | instance Arbitrary (Ratio Integer) where 177 | arbitrary = do n <- arbitrary 178 | m <- arbitrary 179 | if m /= 0 180 | then return (n % m) 181 | else arbitrary 182 | coarbitrary w = undefined 183 | 184 | instance Arbitrary Word16 where 185 | arbitrary = choose (0, 2^16-1) 186 | coarbitrary = undefined 187 | 188 | instance Arbitrary Word32 where 189 | -- arbitrary = choose (0, 2^32-1) 190 | arbitrary = choose (minBound, maxBound) 191 | coarbitrary = undefined 192 | 193 | instance Arbitrary Word64 where 194 | -- arbitrary = choose (0, 2^64-1) 195 | arbitrary = choose (minBound, maxBound) 196 | coarbitrary = undefined 197 | 198 | instance Arbitrary Int8 where 199 | -- arbitrary = choose (0, 2^8-1) 200 | arbitrary = choose (minBound, maxBound) 201 | coarbitrary w = variant 0 202 | 203 | instance Arbitrary Int16 where 204 | -- arbitrary = choose (0, 2^16-1) 205 | arbitrary = choose (minBound, maxBound) 206 | coarbitrary = undefined 207 | 208 | instance Arbitrary Int32 where 209 | -- arbitrary = choose (0, 2^32-1) 210 | arbitrary = choose (minBound, maxBound) 211 | coarbitrary = undefined 212 | 213 | instance Arbitrary Int64 where 214 | -- arbitrary = choose (0, 2^64-1) 215 | arbitrary = choose (minBound, maxBound) 216 | coarbitrary = undefined 217 | 218 | instance Arbitrary Word where 219 | arbitrary = choose (minBound, maxBound) 220 | coarbitrary w = variant 0 221 | 222 | ------------------------------------------------------------------------ 223 | 224 | instance Arbitrary Char where 225 | arbitrary = choose (maxBound, minBound) 226 | coarbitrary = undefined 227 | 228 | {- 229 | instance Arbitrary a => Arbitrary (Maybe a) where 230 | arbitrary = oneof [ return Nothing, liftM Just arbitrary] 231 | coarbitrary = undefined 232 | -} 233 | 234 | instance Arbitrary Ordering where 235 | arbitrary = oneof [ return LT,return GT,return EQ ] 236 | coarbitrary = undefined 237 | 238 | {- 239 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where 240 | arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary] 241 | coarbitrary = undefined 242 | -} 243 | 244 | instance Arbitrary IntSet.IntSet where 245 | arbitrary = fmap IntSet.fromList arbitrary 246 | coarbitrary = undefined 247 | 248 | instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where 249 | arbitrary = fmap IntMap.fromList arbitrary 250 | coarbitrary = undefined 251 | 252 | instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where 253 | arbitrary = fmap Set.fromList arbitrary 254 | coarbitrary = undefined 255 | 256 | instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where 257 | arbitrary = fmap Map.fromList arbitrary 258 | coarbitrary = undefined 259 | 260 | {- 261 | instance (Arbitrary a) => Arbitrary (Seq.Seq a) where 262 | arbitrary = fmap Seq.fromList arbitrary 263 | coarbitrary = undefined 264 | -} 265 | 266 | instance Arbitrary L.ByteString where 267 | arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. 268 | coarbitrary s = coarbitrary (L.unpack s) 269 | 270 | instance Arbitrary B.ByteString where 271 | arbitrary = B.pack `fmap` arbitrary 272 | coarbitrary s = coarbitrary (B.unpack s) 273 | -------------------------------------------------------------------------------- /Text/JSON/String.hs: -------------------------------------------------------------------------------- 1 | -- | Basic support for working with JSON values. 2 | 3 | module Text.JSON.String 4 | ( 5 | -- * Parsing 6 | -- 7 | GetJSON 8 | , runGetJSON 9 | 10 | -- ** Reading JSON 11 | , readJSNull 12 | , readJSBool 13 | , readJSString 14 | , readJSRational 15 | , readJSArray 16 | , readJSObject 17 | 18 | , readJSValue 19 | , readJSTopType 20 | 21 | -- ** Writing JSON 22 | , showJSNull 23 | , showJSBool 24 | , showJSArray 25 | , showJSObject 26 | , showJSRational 27 | , showJSRational' 28 | 29 | , showJSValue 30 | , showJSTopType 31 | ) where 32 | 33 | import Prelude hiding (fail) 34 | import Text.JSON.Types (JSValue(..), 35 | JSString, toJSString, fromJSString, 36 | JSObject, toJSObject, fromJSObject) 37 | 38 | import Control.Monad (liftM, ap) 39 | import Control.Monad.Fail (MonadFail (..)) 40 | import Control.Applicative((<$>)) 41 | import qualified Control.Applicative as A 42 | import Data.Char (isSpace, isDigit, digitToInt) 43 | import Data.Ratio (numerator, denominator, (%)) 44 | import Numeric (readHex, readDec, showHex, readSigned, readFloat) 45 | 46 | -- ----------------------------------------------------------------- 47 | -- | Parsing JSON 48 | 49 | -- | The type of JSON parsers for String 50 | newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) } 51 | 52 | instance Functor GetJSON where fmap = liftM 53 | instance A.Applicative GetJSON where 54 | pure = return 55 | (<*>) = ap 56 | 57 | instance Monad GetJSON where 58 | return x = GetJSON (\s -> Right (x,s)) 59 | GetJSON m >>= f = GetJSON (\s -> case m s of 60 | Left err -> Left err 61 | Right (a,s1) -> un (f a) s1) 62 | 63 | instance MonadFail GetJSON where 64 | fail x = GetJSON (\_ -> Left x) 65 | 66 | -- | Run a JSON reader on an input String, returning some Haskell value. 67 | -- All input will be consumed. 68 | runGetJSON :: GetJSON a -> String -> Either String a 69 | runGetJSON (GetJSON m) s = case m s of 70 | Left err -> Left err 71 | Right (a,t) -> case t of 72 | [] -> Right a 73 | _ -> Left $ "Invalid tokens at end of JSON string: "++ show (take 10 t) 74 | 75 | getInput :: GetJSON String 76 | getInput = GetJSON (\s -> Right (s,s)) 77 | 78 | setInput :: String -> GetJSON () 79 | setInput s = GetJSON (\_ -> Right ((),s)) 80 | 81 | ------------------------------------------------------------------------- 82 | 83 | -- | Find 8 chars context, for error messages 84 | context :: String -> String 85 | context s = take 8 s 86 | 87 | -- | Read the JSON null type 88 | readJSNull :: GetJSON JSValue 89 | readJSNull = do 90 | xs <- getInput 91 | case xs of 92 | 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull 93 | _ -> fail $ "Unable to parse JSON null: " ++ context xs 94 | 95 | tryJSNull :: GetJSON JSValue -> GetJSON JSValue 96 | tryJSNull k = do 97 | xs <- getInput 98 | case xs of 99 | 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull 100 | _ -> k 101 | 102 | -- | Read the JSON Bool type 103 | readJSBool :: GetJSON JSValue 104 | readJSBool = do 105 | xs <- getInput 106 | case xs of 107 | 't':'r':'u':'e':xs1 -> setInput xs1 >> return (JSBool True) 108 | 'f':'a':'l':'s':'e':xs1 -> setInput xs1 >> return (JSBool False) 109 | _ -> fail $ "Unable to parse JSON Bool: " ++ context xs 110 | 111 | -- | Read the JSON String type 112 | readJSString :: GetJSON JSValue 113 | readJSString = do 114 | x <- getInput 115 | case x of 116 | '"' : cs -> parse [] cs 117 | _ -> fail $ "Malformed JSON: expecting string: " ++ context x 118 | where 119 | parse rs cs = 120 | case cs of 121 | '\\' : c : ds -> esc rs c ds 122 | '"' : ds -> do setInput ds 123 | return (JSString (toJSString (reverse rs))) 124 | c : ds 125 | | c >= '\x20' && c <= '\xff' -> parse (c:rs) ds 126 | | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ context cs 127 | | i <= 0x10ffff -> parse (c:rs) ds 128 | | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs 129 | where 130 | i = (fromIntegral (fromEnum c) :: Integer) 131 | _ -> fail $ "Unable to parse JSON String: unterminated String: " ++ context cs 132 | 133 | esc rs c cs = case c of 134 | '\\' -> parse ('\\' : rs) cs 135 | '"' -> parse ('"' : rs) cs 136 | 'n' -> parse ('\n' : rs) cs 137 | 'r' -> parse ('\r' : rs) cs 138 | 't' -> parse ('\t' : rs) cs 139 | 'f' -> parse ('\f' : rs) cs 140 | 'b' -> parse ('\b' : rs) cs 141 | '/' -> parse ('/' : rs) cs 142 | 'u' -> case cs of 143 | d1 : d2 : d3 : d4 : cs' -> 144 | case readHex [d1,d2,d3,d4] of 145 | [(n,"")] -> parse (toEnum n : rs) cs' 146 | 147 | x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x) 148 | _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs 149 | _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ show c 150 | 151 | 152 | -- | Read an Integer or Double in JSON format, returning a Rational 153 | readJSRational :: GetJSON Rational 154 | readJSRational = do 155 | cs <- getInput 156 | case (reads cs, readSigned readFloat cs) of 157 | ([(x,_)], _) 158 | | isInfinite (x :: Double) -> 159 | fail ("JSON Rational out of range: " ++ context cs) 160 | (_, [(y,cs')]) -> setInput cs' >> return y 161 | _ -> fail ("Unable to parse JSON Rational: " ++ context cs) 162 | 163 | 164 | -- | Read a list in JSON format 165 | readJSArray :: GetJSON JSValue 166 | readJSArray = readSequence '[' ']' ',' >>= return . JSArray 167 | 168 | -- | Read an object in JSON format 169 | readJSObject :: GetJSON JSValue 170 | readJSObject = readAssocs '{' '}' ',' >>= return . JSObject . toJSObject 171 | 172 | 173 | -- | Read a sequence of items 174 | readSequence :: Char -> Char -> Char -> GetJSON [JSValue] 175 | readSequence start end sep = do 176 | zs <- getInput 177 | case dropWhile isSpace zs of 178 | c : cs | c == start -> 179 | case dropWhile isSpace cs of 180 | d : ds | d == end -> setInput (dropWhile isSpace ds) >> return [] 181 | ds -> setInput ds >> parse [] 182 | _ -> fail $ "Unable to parse JSON sequence: sequence stars with invalid character: " ++ context zs 183 | 184 | where parse rs = rs `seq` do 185 | a <- readJSValue 186 | ds <- getInput 187 | case dropWhile isSpace ds of 188 | e : es | e == sep -> do setInput (dropWhile isSpace es) 189 | parse (a:rs) 190 | | e == end -> do setInput (dropWhile isSpace es) 191 | return (reverse (a:rs)) 192 | _ -> fail $ "Unable to parse JSON array: unterminated array: " ++ context ds 193 | 194 | 195 | -- | Read a sequence of JSON labelled fields 196 | readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)] 197 | readAssocs start end sep = do 198 | zs <- getInput 199 | case dropWhile isSpace zs of 200 | c:cs | c == start -> case dropWhile isSpace cs of 201 | d:ds | d == end -> setInput (dropWhile isSpace ds) >> return [] 202 | ds -> setInput ds >> parsePairs [] 203 | _ -> fail "Unable to parse JSON object: unterminated object" 204 | 205 | where parsePairs rs = rs `seq` do 206 | a <- do k <- do x <- readJSString ; case x of 207 | JSString s -> return (fromJSString s) 208 | _ -> fail $ "Malformed JSON field labels: object keys must be quoted strings." 209 | ds <- getInput 210 | case dropWhile isSpace ds of 211 | ':':es -> do setInput (dropWhile isSpace es) 212 | v <- readJSValue 213 | return (k,v) 214 | _ -> fail $ "Malformed JSON labelled field: " ++ context ds 215 | 216 | ds <- getInput 217 | case dropWhile isSpace ds of 218 | e : es | e == sep -> do setInput (dropWhile isSpace es) 219 | parsePairs (a:rs) 220 | | e == end -> do setInput (dropWhile isSpace es) 221 | return (reverse (a:rs)) 222 | _ -> fail $ "Unable to parse JSON object: unterminated sequence: " 223 | ++ context ds 224 | 225 | -- | Read one of several possible JS types 226 | readJSValue :: GetJSON JSValue 227 | readJSValue = do 228 | cs <- getInput 229 | case cs of 230 | '"' : _ -> readJSString 231 | '[' : _ -> readJSArray 232 | '{' : _ -> readJSObject 233 | 't' : _ -> readJSBool 234 | 'f' : _ -> readJSBool 235 | (x:_) | isDigit x || x == '-' -> JSRational False <$> readJSRational 236 | xs -> tryJSNull 237 | (fail $ "Malformed JSON: invalid token in this context " ++ context xs) 238 | 239 | -- | Top level JSON can only be Arrays or Objects 240 | readJSTopType :: GetJSON JSValue 241 | readJSTopType = do 242 | cs <- getInput 243 | case cs of 244 | '[' : _ -> readJSArray 245 | '{' : _ -> readJSObject 246 | _ -> fail "Invalid JSON: a JSON text a serialized object or array at the top level." 247 | 248 | -- ----------------------------------------------------------------- 249 | -- | Writing JSON 250 | 251 | -- | Show strict JSON top level types. Values not permitted 252 | -- at the top level are wrapped in a singleton array. 253 | showJSTopType :: JSValue -> ShowS 254 | showJSTopType (JSArray a) = showJSArray a 255 | showJSTopType (JSObject o) = showJSObject o 256 | showJSTopType x = showJSTopType $ JSArray [x] 257 | 258 | -- | Show JSON values 259 | showJSValue :: JSValue -> ShowS 260 | showJSValue jv = 261 | case jv of 262 | JSNull{} -> showJSNull 263 | JSBool b -> showJSBool b 264 | JSRational asF r -> showJSRational' asF r 265 | JSArray a -> showJSArray a 266 | JSString s -> showJSString s 267 | JSObject o -> showJSObject o 268 | 269 | -- | Write the JSON null type 270 | showJSNull :: ShowS 271 | showJSNull = showString "null" 272 | 273 | -- | Write the JSON Bool type 274 | showJSBool :: Bool -> ShowS 275 | showJSBool True = showString "true" 276 | showJSBool False = showString "false" 277 | 278 | -- | Write the JSON String type 279 | showJSString :: JSString -> ShowS 280 | showJSString x xs = quote (encJSString x (quote xs)) 281 | where 282 | quote = showChar '"' 283 | 284 | -- | Show a Rational in JSON format 285 | showJSRational :: Rational -> ShowS 286 | showJSRational r = showJSRational' False r 287 | 288 | showJSRational' :: Bool -> Rational -> ShowS 289 | showJSRational' asFloat r 290 | | denominator r == 1 = shows $ numerator r 291 | | isInfinite x || isNaN x = showJSNull 292 | | asFloat = shows xf 293 | | otherwise = shows x 294 | where 295 | x :: Double 296 | x = realToFrac r 297 | 298 | xf :: Float 299 | xf = realToFrac r 300 | 301 | 302 | 303 | -- | Show a list in JSON format 304 | showJSArray :: [JSValue] -> ShowS 305 | showJSArray = showSequence '[' ']' ',' 306 | 307 | -- | Show an association list in JSON format 308 | showJSObject :: JSObject JSValue -> ShowS 309 | showJSObject = showAssocs '{' '}' ',' . fromJSObject 310 | 311 | -- | Show a generic sequence of pairs in JSON format 312 | showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS 313 | showAssocs start end sep xs rest = start : go xs 314 | where 315 | go [(k,v)] = '"' : encJSString (toJSString k) 316 | ('"' : ':' : showJSValue v (go [])) 317 | go ((k,v):kvs) = '"' : encJSString (toJSString k) 318 | ('"' : ':' : showJSValue v (sep : go kvs)) 319 | go [] = end : rest 320 | 321 | -- | Show a generic sequence in JSON format 322 | showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS 323 | showSequence start end sep xs rest = start : go xs 324 | where 325 | go [y] = showJSValue y (go []) 326 | go (y:ys) = showJSValue y (sep : go ys) 327 | go [] = end : rest 328 | 329 | encJSString :: JSString -> ShowS 330 | encJSString jss ss = go (fromJSString jss) 331 | where 332 | go s1 = 333 | case s1 of 334 | (x :xs) | x < '\x20' -> '\\' : encControl x (go xs) 335 | ('"' :xs) -> '\\' : '"' : go xs 336 | ('\\':xs) -> '\\' : '\\' : go xs 337 | (x :xs) -> x : go xs 338 | "" -> ss 339 | 340 | encControl x xs = case x of 341 | '\b' -> 'b' : xs 342 | '\f' -> 'f' : xs 343 | '\n' -> 'n' : xs 344 | '\r' -> 'r' : xs 345 | '\t' -> 't' : xs 346 | _ | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs 347 | | x < '\x100' -> 'u' : '0' : '0' : hexxs 348 | | x < '\x1000' -> 'u' : '0' : hexxs 349 | | otherwise -> 'u' : hexxs 350 | where hexxs = showHex (fromEnum x) xs 351 | 352 | -------------------------------------------------------------------------------- /Text/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-} 2 | -- | Serialising Haskell values to and from JSON values. 3 | module Text.JSON ( 4 | -- * JSON Types 5 | JSValue(..) 6 | 7 | -- * Serialization to and from JSValues 8 | , JSON(..) 9 | 10 | -- * Encoding and Decoding 11 | , Result(..) 12 | , encode -- :: JSON a => a -> String 13 | , decode -- :: JSON a => String -> Either String a 14 | , encodeStrict -- :: JSON a => a -> String 15 | , decodeStrict -- :: JSON a => String -> Either String a 16 | 17 | -- * Wrapper Types 18 | , JSString 19 | , toJSString 20 | , fromJSString 21 | 22 | , JSObject 23 | , toJSObject 24 | , fromJSObject 25 | , resultToEither 26 | 27 | -- * Serialization to and from Strings. 28 | -- ** Reading JSON 29 | , readJSNull, readJSBool, readJSString, readJSRational 30 | , readJSArray, readJSObject, readJSValue 31 | 32 | -- ** Writing JSON 33 | , showJSNull, showJSBool, showJSArray 34 | , showJSRational, showJSRational' 35 | , showJSObject, showJSValue 36 | 37 | -- ** Instance helpers 38 | , makeObj, valFromObj 39 | , JSKey(..), encJSDict, decJSDict 40 | 41 | ) where 42 | 43 | import Text.JSON.Types 44 | import Text.JSON.String 45 | 46 | import Data.Int 47 | import Data.Word 48 | import Control.Monad.Fail (MonadFail (..)) 49 | import Control.Monad(liftM,ap,MonadPlus(..)) 50 | import Control.Applicative 51 | 52 | import qualified Data.ByteString.Char8 as S 53 | import qualified Data.ByteString.Lazy.Char8 as L 54 | import qualified Data.IntSet as I 55 | import qualified Data.Set as Set 56 | import qualified Data.Map as M 57 | import qualified Data.IntMap as IntMap 58 | 59 | import qualified Data.Array as Array 60 | import qualified Data.Text as T 61 | 62 | ------------------------------------------------------------------------ 63 | 64 | -- | Decode a String representing a JSON value 65 | -- (either an object, array, bool, number, null) 66 | -- 67 | -- This is a superset of JSON, as types other than 68 | -- Array and Object are allowed at the top level. 69 | -- 70 | decode :: (JSON a) => String -> Result a 71 | decode s = case runGetJSON readJSValue s of 72 | Right a -> readJSON a 73 | Left err -> Error err 74 | 75 | -- | Encode a Haskell value into a string, in JSON format. 76 | -- 77 | -- This is a superset of JSON, as types other than 78 | -- Array and Object are allowed at the top level. 79 | -- 80 | encode :: (JSON a) => a -> String 81 | encode = (flip showJSValue [] . showJSON) 82 | 83 | ------------------------------------------------------------------------ 84 | 85 | -- | Decode a String representing a strict JSON value. 86 | -- This follows the spec, and requires top level 87 | -- JSON types to be an Array or Object. 88 | decodeStrict :: (JSON a) => String -> Result a 89 | decodeStrict s = case runGetJSON readJSTopType s of 90 | Right a -> readJSON a 91 | Left err -> Error err 92 | 93 | -- | Encode a value as a String in strict JSON format. 94 | -- This follows the spec, and requires all values 95 | -- at the top level to be wrapped in either an Array or Object. 96 | -- JSON types to be an Array or Object. 97 | encodeStrict :: (JSON a) => a -> String 98 | encodeStrict = (flip showJSTopType [] . showJSON) 99 | 100 | ------------------------------------------------------------------------ 101 | 102 | -- | The class of types serialisable to and from JSON 103 | class JSON a where 104 | readJSON :: JSValue -> Result a 105 | showJSON :: a -> JSValue 106 | 107 | readJSONs :: JSValue -> Result [a] 108 | readJSONs (JSArray as) = mapM readJSON as 109 | readJSONs _ = mkError "Unable to read list" 110 | 111 | showJSONs :: [a] -> JSValue 112 | showJSONs = JSArray . map showJSON 113 | 114 | -- | A type for parser results 115 | data Result a = Ok a | Error String 116 | deriving (Eq,Show) 117 | 118 | -- | Map Results to Eithers 119 | resultToEither :: Result a -> Either String a 120 | resultToEither (Ok a) = Right a 121 | resultToEither (Error s) = Left s 122 | 123 | instance Functor Result where fmap = liftM 124 | 125 | instance Applicative Result where 126 | (<*>) = ap 127 | pure = return 128 | 129 | instance Alternative Result where 130 | Ok a <|> _ = Ok a 131 | Error _ <|> b = b 132 | empty = Error "empty" 133 | 134 | instance MonadPlus Result where 135 | Ok a `mplus` _ = Ok a 136 | _ `mplus` x = x 137 | mzero = Error "Result: MonadPlus.empty" 138 | 139 | instance Monad Result where 140 | return x = Ok x 141 | Ok a >>= f = f a 142 | Error x >>= _ = Error x 143 | 144 | instance MonadFail Result where 145 | fail x = Error x 146 | 147 | -- | Convenient error generation 148 | mkError :: String -> Result a 149 | mkError s = Error s 150 | 151 | -------------------------------------------------------------------- 152 | -- 153 | -- | To ensure we generate valid JSON, we map Haskell types to JSValue 154 | -- internally, then pretty print that. 155 | -- 156 | instance JSON JSValue where 157 | showJSON = id 158 | readJSON = return 159 | 160 | second :: (a -> b) -> (x,a) -> (x,b) 161 | second f (a,b) = (a, f b) 162 | 163 | -------------------------------------------------------------------- 164 | -- Some simple JSON wrapper types, to avoid overlapping instances 165 | 166 | instance JSON JSString where 167 | readJSON (JSString s) = return s 168 | readJSON _ = mkError "Unable to read JSString" 169 | showJSON = JSString 170 | 171 | instance (JSON a) => JSON (JSObject a) where 172 | readJSON (JSObject o) = 173 | let f (x,y) = do y' <- readJSON y; return (x,y') 174 | in toJSObject `fmap` mapM f (fromJSObject o) 175 | readJSON _ = mkError "Unable to read JSObject" 176 | showJSON = JSObject . toJSObject . map (second showJSON) . fromJSObject 177 | 178 | 179 | -- ----------------------------------------------------------------- 180 | -- Instances 181 | -- 182 | 183 | instance JSON Bool where 184 | showJSON = JSBool 185 | readJSON (JSBool b) = return b 186 | readJSON _ = mkError "Unable to read Bool" 187 | 188 | instance JSON Char where 189 | showJSON = JSString . toJSString . (:[]) 190 | showJSONs = JSString . toJSString 191 | 192 | readJSON (JSString s) = case fromJSString s of 193 | [c] -> return c 194 | _ -> mkError "Unable to read Char" 195 | readJSON _ = mkError "Unable to read Char" 196 | 197 | readJSONs (JSString s) = return (fromJSString s) 198 | readJSONs (JSArray a) = mapM readJSON a 199 | readJSONs _ = mkError "Unable to read String" 200 | 201 | instance JSON Ordering where 202 | showJSON = encJSString show 203 | readJSON = decJSString "Ordering" readOrd 204 | where 205 | readOrd x = 206 | case x of 207 | "LT" -> return Prelude.LT 208 | "EQ" -> return Prelude.EQ 209 | "GT" -> return Prelude.GT 210 | _ -> mkError ("Unable to read Ordering") 211 | 212 | -- ----------------------------------------------------------------- 213 | -- Integral types 214 | 215 | instance JSON Integer where 216 | showJSON = JSRational False . fromIntegral 217 | readJSON (JSRational _ i) = return $ round i 218 | readJSON _ = mkError "Unable to read Integer" 219 | 220 | -- constrained: 221 | instance JSON Int where 222 | showJSON = JSRational False . fromIntegral 223 | readJSON (JSRational _ i) = return $ round i 224 | readJSON _ = mkError "Unable to read Int" 225 | 226 | -- constrained: 227 | instance JSON Word where 228 | showJSON = JSRational False . toRational 229 | readJSON (JSRational _ i) = return $ truncate i 230 | readJSON _ = mkError "Unable to read Word" 231 | 232 | -- ----------------------------------------------------------------- 233 | 234 | instance JSON Word8 where 235 | showJSON = JSRational False . fromIntegral 236 | readJSON (JSRational _ i) = return $ truncate i 237 | readJSON _ = mkError "Unable to read Word8" 238 | 239 | instance JSON Word16 where 240 | showJSON = JSRational False . fromIntegral 241 | readJSON (JSRational _ i) = return $ truncate i 242 | readJSON _ = mkError "Unable to read Word16" 243 | 244 | instance JSON Word32 where 245 | showJSON = JSRational False . fromIntegral 246 | readJSON (JSRational _ i) = return $ truncate i 247 | readJSON _ = mkError "Unable to read Word32" 248 | 249 | instance JSON Word64 where 250 | showJSON = JSRational False . fromIntegral 251 | readJSON (JSRational _ i) = return $ truncate i 252 | readJSON _ = mkError "Unable to read Word64" 253 | 254 | instance JSON Int8 where 255 | showJSON = JSRational False . fromIntegral 256 | readJSON (JSRational _ i) = return $ truncate i 257 | readJSON _ = mkError "Unable to read Int8" 258 | 259 | instance JSON Int16 where 260 | showJSON = JSRational False . fromIntegral 261 | readJSON (JSRational _ i) = return $ truncate i 262 | readJSON _ = mkError "Unable to read Int16" 263 | 264 | instance JSON Int32 where 265 | showJSON = JSRational False . fromIntegral 266 | readJSON (JSRational _ i) = return $ truncate i 267 | readJSON _ = mkError "Unable to read Int32" 268 | 269 | instance JSON Int64 where 270 | showJSON = JSRational False . fromIntegral 271 | readJSON (JSRational _ i) = return $ truncate i 272 | readJSON _ = mkError "Unable to read Int64" 273 | 274 | -- ----------------------------------------------------------------- 275 | 276 | instance JSON Double where 277 | showJSON = JSRational False . toRational 278 | readJSON (JSRational _ r) = return $ fromRational r 279 | readJSON _ = mkError "Unable to read Double" 280 | -- can't use JSRational here, due to ambiguous '0' parse 281 | -- it will parse as Integer. 282 | 283 | instance JSON Float where 284 | showJSON = JSRational True . toRational 285 | readJSON (JSRational _ r) = return $ fromRational r 286 | readJSON _ = mkError "Unable to read Float" 287 | 288 | -- ----------------------------------------------------------------- 289 | -- Sums 290 | 291 | instance (JSON a) => JSON (Maybe a) where 292 | readJSON (JSObject o) = case "Just" `lookup` as of 293 | Just x -> Just <$> readJSON x 294 | _ -> case ("Nothing" `lookup` as) of 295 | Just JSNull -> return Nothing 296 | _ -> mkError "Unable to read Maybe" 297 | where as = fromJSObject o 298 | readJSON _ = mkError "Unable to read Maybe" 299 | showJSON (Just x) = JSObject $ toJSObject [("Just", showJSON x)] 300 | showJSON Nothing = JSObject $ toJSObject [("Nothing", JSNull)] 301 | 302 | instance (JSON a, JSON b) => JSON (Either a b) where 303 | readJSON (JSObject o) = case "Left" `lookup` as of 304 | Just a -> Left <$> readJSON a 305 | Nothing -> case "Right" `lookup` as of 306 | Just b -> Right <$> readJSON b 307 | Nothing -> mkError "Unable to read Either" 308 | where as = fromJSObject o 309 | readJSON _ = mkError "Unable to read Either" 310 | showJSON (Left a) = JSObject $ toJSObject [("Left", showJSON a)] 311 | showJSON (Right b) = JSObject $ toJSObject [("Right", showJSON b)] 312 | 313 | -- ----------------------------------------------------------------- 314 | -- Products 315 | 316 | instance JSON () where 317 | showJSON _ = JSArray [] 318 | readJSON (JSArray []) = return () 319 | readJSON _ = mkError "Unable to read ()" 320 | 321 | instance (JSON a, JSON b) => JSON (a,b) where 322 | showJSON (a,b) = JSArray [ showJSON a, showJSON b ] 323 | readJSON (JSArray [a,b]) = (,) `fmap` readJSON a `ap` readJSON b 324 | readJSON _ = mkError "Unable to read Pair" 325 | 326 | instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where 327 | showJSON (a,b,c) = JSArray [ showJSON a, showJSON b, showJSON c ] 328 | readJSON (JSArray [a,b,c]) = (,,) `fmap` 329 | readJSON a `ap` 330 | readJSON b `ap` 331 | readJSON c 332 | readJSON _ = mkError "Unable to read Triple" 333 | 334 | instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where 335 | showJSON (a,b,c,d) = JSArray [showJSON a, showJSON b, showJSON c, showJSON d] 336 | readJSON (JSArray [a,b,c,d]) = (,,,) `fmap` 337 | readJSON a `ap` 338 | readJSON b `ap` 339 | readJSON c `ap` 340 | readJSON d 341 | 342 | readJSON _ = mkError "Unable to read 4 tuple" 343 | 344 | -- ----------------------------------------------------------------- 345 | -- List-like types 346 | 347 | 348 | instance JSON a => JSON [a] where 349 | showJSON = showJSONs 350 | readJSON = readJSONs 351 | 352 | -- container types: 353 | 354 | #if !defined(MAP_AS_DICT) 355 | instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where 356 | showJSON = encJSArray M.toList 357 | readJSON = decJSArray "Map" M.fromList 358 | 359 | instance (JSON a) => JSON (IntMap.IntMap a) where 360 | showJSON = encJSArray IntMap.toList 361 | readJSON = decJSArray "IntMap" IntMap.fromList 362 | 363 | #else 364 | instance (Ord a, JSKey a, JSON b) => JSON (M.Map a b) where 365 | showJSON = encJSDict . M.toList 366 | readJSON o = M.fromList <$> decJSDict "Map" o 367 | 368 | instance (JSON a) => JSON (IntMap.IntMap a) where 369 | {- alternate (dict) mapping: -} 370 | showJSON = encJSDict . IntMap.toList 371 | readJSON o = IntMap.fromList <$> decJSDict "IntMap" o 372 | #endif 373 | 374 | 375 | instance (Ord a, JSON a) => JSON (Set.Set a) where 376 | showJSON = encJSArray Set.toList 377 | readJSON = decJSArray "Set" Set.fromList 378 | 379 | instance (Array.Ix i, JSON i, JSON e) => JSON (Array.Array i e) where 380 | showJSON = encJSArray Array.assocs 381 | readJSON = decJSArray "Array" arrayFromList 382 | 383 | instance JSON I.IntSet where 384 | showJSON = encJSArray I.toList 385 | readJSON = decJSArray "IntSet" I.fromList 386 | 387 | -- helper functions for array / object serializers: 388 | arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e 389 | arrayFromList [] = Array.array undefined [] 390 | arrayFromList ls@((i,_):xs) = Array.array bnds ls 391 | where 392 | bnds = foldr step (i,i) xs 393 | 394 | step (ix,_) (mi,ma) = 395 | let mi1 = min ix mi 396 | ma1 = max ix ma 397 | in mi1 `seq` ma1 `seq` (mi1,ma1) 398 | 399 | 400 | -- ----------------------------------------------------------------- 401 | -- ByteStrings 402 | 403 | instance JSON S.ByteString where 404 | showJSON = encJSString S.unpack 405 | readJSON = decJSString "ByteString" (return . S.pack) 406 | 407 | instance JSON L.ByteString where 408 | showJSON = encJSString L.unpack 409 | readJSON = decJSString "Lazy.ByteString" (return . L.pack) 410 | 411 | -- ----------------------------------------------------------------- 412 | -- Data.Text 413 | 414 | instance JSON T.Text where 415 | readJSON (JSString s) = return (T.pack . fromJSString $ s) 416 | readJSON _ = mkError "Unable to read JSString" 417 | showJSON = JSString . toJSString . T.unpack 418 | 419 | 420 | -- ----------------------------------------------------------------- 421 | -- Instance Helpers 422 | 423 | makeObj :: [(String, JSValue)] -> JSValue 424 | makeObj = JSObject . toJSObject 425 | 426 | -- | Pull a value out of a JSON object. 427 | valFromObj :: JSON a => String -> JSObject JSValue -> Result a 428 | valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k) 429 | readJSON 430 | (lookup k (fromJSObject o)) 431 | 432 | encJSString :: (a -> String) -> a -> JSValue 433 | encJSString f v = JSString (toJSString (f v)) 434 | 435 | decJSString :: String -> (String -> Result a) -> JSValue -> Result a 436 | decJSString _ f (JSString s) = f (fromJSString s) 437 | decJSString l _ _ = mkError ("readJSON{"++l++"}: unable to parse string value") 438 | 439 | encJSArray :: (JSON a) => (b-> [a]) -> b -> JSValue 440 | encJSArray f v = showJSON (f v) 441 | 442 | decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b 443 | decJSArray _ f a@JSArray{} = f <$> readJSON a 444 | decJSArray l _ _ = mkError ("readJSON{"++l++"}: unable to parse array value") 445 | 446 | -- | Haskell types that can be used as keys in JSON objects. 447 | class JSKey a where 448 | toJSKey :: a -> String 449 | fromJSKey :: String -> Maybe a 450 | 451 | instance JSKey JSString where 452 | toJSKey x = fromJSString x 453 | fromJSKey x = Just (toJSString x) 454 | 455 | instance JSKey Int where 456 | toJSKey = show 457 | fromJSKey key = case reads key of 458 | [(a,"")] -> Just a 459 | _ -> Nothing 460 | 461 | -- NOTE: This prevents us from making other instances for lists but, 462 | -- our guess is that strings are used as keys more often then other list types. 463 | instance JSKey String where 464 | toJSKey = id 465 | fromJSKey = Just 466 | 467 | -- | Encode an association list as 'JSObject' value. 468 | encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue 469 | encJSDict v = makeObj [ (toJSKey x, showJSON y) | (x,y) <- v ] 470 | 471 | -- | Decode a 'JSObject' value into an association list. 472 | decJSDict :: (JSKey a, JSON b) 473 | => String 474 | -> JSValue 475 | -> Result [(a,b)] 476 | decJSDict l (JSObject o) = mapM rd (fromJSObject o) 477 | where rd (a,b) = case fromJSKey a of 478 | Just pa -> readJSON b >>= \pb -> return (pa,pb) 479 | Nothing -> mkError ("readJSON{" ++ l ++ "}:" ++ 480 | "unable to read dict; invalid object key") 481 | 482 | decJSDict l _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object") 483 | 484 | 485 | --------------------------------------------------------------------------------