json-0.9.3/0000755000000000000000000000000007346545000010665 5ustar0000000000000000json-0.9.3/CHANGES0000755000000000000000000000255207346545000011667 0ustar0000000000000000Version 0.9.1 * Merge-in contributions from Neil Mitchell to support GHC 7.10 Version 0.9 * Merge-in contributions from Neil Mitchell to accomodate working with HEAD. Version 0.8 * Add `Applicative` instance for `GetJSON` Version 0.4.4: released 2009-01-17; changes from 0.4.2 * Fixes handling of unterminated strings. Version 0.4.3: released 2009-01-17; changes from 0.4.2 * optimize some common cases..string and int literals. Reduces parse times by > 2x on larger dict inputs containing both kinds of lits. Version 0.4.2: released 2009-01-17; changes from 0.4.1 * fixed Cabal build issues with various versions of 'base' and Data.Generic * fixed whitespace-handling bug in Parsec-based frontend. Version 0.4.1: released 2009-01-12; changes from 0.3.6 * Addition of extra JSON instances: - IntMap, Set, Array, IntSet * Dropped initial letter case-lowering for constructors: - Maybe's constructors are mapped to "Nothing","Just". - Either's constructors are mapped to "Left", "Right". * Ordering's are represented by their constructor names (was funky int-mapping.) * JSON.Text.Result is now an instance of MonadError; contributed by Andy Gimblett. * Included Lennart Augustsson's contributed generic JSON encoder, in Text.JSON.Generic * Optional JSON dict-mapping for Data.Map and Data.IntMap json-0.9.3/LICENSE0000644000000000000000000000265407346545000011701 0ustar0000000000000000Copyright (c) Galois, Inc. 2007 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. json-0.9.3/Setup.hs0000644000000000000000000000010107346545000012311 0ustar0000000000000000module Main where import Distribution.Simple main = defaultMain json-0.9.3/Text/0000755000000000000000000000000007346545000011611 5ustar0000000000000000json-0.9.3/Text/JSON.hs0000644000000000000000000003616707346545000012733 0ustar0000000000000000{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-} -- | Serialising Haskell values to and from JSON values. module Text.JSON ( -- * JSON Types JSValue(..) -- * Serialization to and from JSValues , JSON(..) -- * Encoding and Decoding , Result(..) , encode -- :: JSON a => a -> String , decode -- :: JSON a => String -> Either String a , encodeStrict -- :: JSON a => a -> String , decodeStrict -- :: JSON a => String -> Either String a -- * Wrapper Types , JSString , toJSString , fromJSString , JSObject , toJSObject , fromJSObject , resultToEither -- * Serialization to and from Strings. -- ** Reading JSON , readJSNull, readJSBool, readJSString, readJSRational , readJSArray, readJSObject, readJSValue -- ** Writing JSON , showJSNull, showJSBool, showJSArray , showJSRational, showJSRational' , showJSObject, showJSValue -- ** Instance helpers , makeObj, valFromObj , JSKey(..), encJSDict, decJSDict ) where import Text.JSON.Types import Text.JSON.String import Data.Int import Data.Word import Control.Monad(liftM,ap,MonadPlus(..)) import Control.Applicative import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.IntSet as I import qualified Data.Set as Set import qualified Data.Map as M import qualified Data.IntMap as IntMap import qualified Data.Array as Array import qualified Data.Text as T ------------------------------------------------------------------------ -- | Decode a String representing a JSON value -- (either an object, array, bool, number, null) -- -- This is a superset of JSON, as types other than -- Array and Object are allowed at the top level. -- decode :: (JSON a) => String -> Result a decode s = case runGetJSON readJSValue s of Right a -> readJSON a Left err -> Error err -- | Encode a Haskell value into a string, in JSON format. -- -- This is a superset of JSON, as types other than -- Array and Object are allowed at the top level. -- encode :: (JSON a) => a -> String encode = (flip showJSValue [] . showJSON) ------------------------------------------------------------------------ -- | Decode a String representing a strict JSON value. -- This follows the spec, and requires top level -- JSON types to be an Array or Object. decodeStrict :: (JSON a) => String -> Result a decodeStrict s = case runGetJSON readJSTopType s of Right a -> readJSON a Left err -> Error err -- | Encode a value as a String in strict JSON format. -- This follows the spec, and requires all values -- at the top level to be wrapped in either an Array or Object. -- JSON types to be an Array or Object. encodeStrict :: (JSON a) => a -> String encodeStrict = (flip showJSTopType [] . showJSON) ------------------------------------------------------------------------ -- | The class of types serialisable to and from JSON class JSON a where readJSON :: JSValue -> Result a showJSON :: a -> JSValue readJSONs :: JSValue -> Result [a] readJSONs (JSArray as) = mapM readJSON as readJSONs _ = mkError "Unable to read list" showJSONs :: [a] -> JSValue showJSONs = JSArray . map showJSON -- | A type for parser results data Result a = Ok a | Error String deriving (Eq,Show) -- | Map Results to Eithers resultToEither :: Result a -> Either String a resultToEither (Ok a) = Right a resultToEither (Error s) = Left s instance Functor Result where fmap = liftM instance Applicative Result where (<*>) = ap pure = return instance Alternative Result where Ok a <|> _ = Ok a Error _ <|> b = b empty = Error "empty" instance MonadPlus Result where Ok a `mplus` _ = Ok a _ `mplus` x = x mzero = Error "Result: MonadPlus.empty" instance Monad Result where return x = Ok x fail x = Error x Ok a >>= f = f a Error x >>= _ = Error x -- | Convenient error generation mkError :: String -> Result a mkError s = Error s -------------------------------------------------------------------- -- -- | To ensure we generate valid JSON, we map Haskell types to JSValue -- internally, then pretty print that. -- instance JSON JSValue where showJSON = id readJSON = return second :: (a -> b) -> (x,a) -> (x,b) second f (a,b) = (a, f b) -------------------------------------------------------------------- -- Some simple JSON wrapper types, to avoid overlapping instances instance JSON JSString where readJSON (JSString s) = return s readJSON _ = mkError "Unable to read JSString" showJSON = JSString instance (JSON a) => JSON (JSObject a) where readJSON (JSObject o) = let f (x,y) = do y' <- readJSON y; return (x,y') in toJSObject `fmap` mapM f (fromJSObject o) readJSON _ = mkError "Unable to read JSObject" showJSON = JSObject . toJSObject . map (second showJSON) . fromJSObject -- ----------------------------------------------------------------- -- Instances -- instance JSON Bool where showJSON = JSBool readJSON (JSBool b) = return b readJSON _ = mkError "Unable to read Bool" instance JSON Char where showJSON = JSString . toJSString . (:[]) showJSONs = JSString . toJSString readJSON (JSString s) = case fromJSString s of [c] -> return c _ -> mkError "Unable to read Char" readJSON _ = mkError "Unable to read Char" readJSONs (JSString s) = return (fromJSString s) readJSONs (JSArray a) = mapM readJSON a readJSONs _ = mkError "Unable to read String" instance JSON Ordering where showJSON = encJSString show readJSON = decJSString "Ordering" readOrd where readOrd x = case x of "LT" -> return Prelude.LT "EQ" -> return Prelude.EQ "GT" -> return Prelude.GT _ -> mkError ("Unable to read Ordering") -- ----------------------------------------------------------------- -- Integral types instance JSON Integer where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ round i readJSON _ = mkError "Unable to read Integer" -- constrained: instance JSON Int where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ round i readJSON _ = mkError "Unable to read Int" -- constrained: instance JSON Word where showJSON = JSRational False . toRational readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word" -- ----------------------------------------------------------------- instance JSON Word8 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word8" instance JSON Word16 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word16" instance JSON Word32 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word32" instance JSON Word64 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word64" instance JSON Int8 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int8" instance JSON Int16 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int16" instance JSON Int32 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int32" instance JSON Int64 where showJSON = JSRational False . fromIntegral readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int64" -- ----------------------------------------------------------------- instance JSON Double where showJSON = JSRational False . toRational readJSON (JSRational _ r) = return $ fromRational r readJSON _ = mkError "Unable to read Double" -- can't use JSRational here, due to ambiguous '0' parse -- it will parse as Integer. instance JSON Float where showJSON = JSRational True . toRational readJSON (JSRational _ r) = return $ fromRational r readJSON _ = mkError "Unable to read Float" -- ----------------------------------------------------------------- -- Sums instance (JSON a) => JSON (Maybe a) where readJSON (JSObject o) = case "Just" `lookup` as of Just x -> Just <$> readJSON x _ -> case ("Nothing" `lookup` as) of Just JSNull -> return Nothing _ -> mkError "Unable to read Maybe" where as = fromJSObject o readJSON _ = mkError "Unable to read Maybe" showJSON (Just x) = JSObject $ toJSObject [("Just", showJSON x)] showJSON Nothing = JSObject $ toJSObject [("Nothing", JSNull)] instance (JSON a, JSON b) => JSON (Either a b) where readJSON (JSObject o) = case "Left" `lookup` as of Just a -> Left <$> readJSON a Nothing -> case "Right" `lookup` as of Just b -> Right <$> readJSON b Nothing -> mkError "Unable to read Either" where as = fromJSObject o readJSON _ = mkError "Unable to read Either" showJSON (Left a) = JSObject $ toJSObject [("Left", showJSON a)] showJSON (Right b) = JSObject $ toJSObject [("Right", showJSON b)] -- ----------------------------------------------------------------- -- Products instance JSON () where showJSON _ = JSArray [] readJSON (JSArray []) = return () readJSON _ = mkError "Unable to read ()" instance (JSON a, JSON b) => JSON (a,b) where showJSON (a,b) = JSArray [ showJSON a, showJSON b ] readJSON (JSArray [a,b]) = (,) `fmap` readJSON a `ap` readJSON b readJSON _ = mkError "Unable to read Pair" instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where showJSON (a,b,c) = JSArray [ showJSON a, showJSON b, showJSON c ] readJSON (JSArray [a,b,c]) = (,,) `fmap` readJSON a `ap` readJSON b `ap` readJSON c readJSON _ = mkError "Unable to read Triple" instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where showJSON (a,b,c,d) = JSArray [showJSON a, showJSON b, showJSON c, showJSON d] readJSON (JSArray [a,b,c,d]) = (,,,) `fmap` readJSON a `ap` readJSON b `ap` readJSON c `ap` readJSON d readJSON _ = mkError "Unable to read 4 tuple" -- ----------------------------------------------------------------- -- List-like types instance JSON a => JSON [a] where showJSON = showJSONs readJSON = readJSONs -- container types: #if !defined(MAP_AS_DICT) instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where showJSON = encJSArray M.toList readJSON = decJSArray "Map" M.fromList instance (JSON a) => JSON (IntMap.IntMap a) where showJSON = encJSArray IntMap.toList readJSON = decJSArray "IntMap" IntMap.fromList #else instance (Ord a, JSKey a, JSON b) => JSON (M.Map a b) where showJSON = encJSDict . M.toList readJSON o = M.fromList <$> decJSDict "Map" o instance (JSON a) => JSON (IntMap.IntMap a) where {- alternate (dict) mapping: -} showJSON = encJSDict . IntMap.toList readJSON o = IntMap.fromList <$> decJSDict "IntMap" o #endif instance (Ord a, JSON a) => JSON (Set.Set a) where showJSON = encJSArray Set.toList readJSON = decJSArray "Set" Set.fromList instance (Array.Ix i, JSON i, JSON e) => JSON (Array.Array i e) where showJSON = encJSArray Array.assocs readJSON = decJSArray "Array" arrayFromList instance JSON I.IntSet where showJSON = encJSArray I.toList readJSON = decJSArray "IntSet" I.fromList -- helper functions for array / object serializers: arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e arrayFromList [] = Array.array undefined [] arrayFromList ls@((i,_):xs) = Array.array bnds ls where bnds = foldr step (i,i) xs step (ix,_) (mi,ma) = let mi1 = min ix mi ma1 = max ix ma in mi1 `seq` ma1 `seq` (mi1,ma1) -- ----------------------------------------------------------------- -- ByteStrings instance JSON S.ByteString where showJSON = encJSString S.unpack readJSON = decJSString "ByteString" (return . S.pack) instance JSON L.ByteString where showJSON = encJSString L.unpack readJSON = decJSString "Lazy.ByteString" (return . L.pack) -- ----------------------------------------------------------------- -- Data.Text instance JSON T.Text where readJSON (JSString s) = return (T.pack . fromJSString $ s) readJSON _ = mkError "Unable to read JSString" showJSON = JSString . toJSString . T.unpack -- ----------------------------------------------------------------- -- Instance Helpers makeObj :: [(String, JSValue)] -> JSValue makeObj = JSObject . toJSObject -- | Pull a value out of a JSON object. valFromObj :: JSON a => String -> JSObject JSValue -> Result a valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k) readJSON (lookup k (fromJSObject o)) encJSString :: (a -> String) -> a -> JSValue encJSString f v = JSString (toJSString (f v)) decJSString :: String -> (String -> Result a) -> JSValue -> Result a decJSString _ f (JSString s) = f (fromJSString s) decJSString l _ _ = mkError ("readJSON{"++l++"}: unable to parse string value") encJSArray :: (JSON a) => (b-> [a]) -> b -> JSValue encJSArray f v = showJSON (f v) decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b decJSArray _ f a@JSArray{} = f <$> readJSON a decJSArray l _ _ = mkError ("readJSON{"++l++"}: unable to parse array value") -- | Haskell types that can be used as keys in JSON objects. class JSKey a where toJSKey :: a -> String fromJSKey :: String -> Maybe a instance JSKey JSString where toJSKey x = fromJSString x fromJSKey x = Just (toJSString x) instance JSKey Int where toJSKey = show fromJSKey key = case reads key of [(a,"")] -> Just a _ -> Nothing -- NOTE: This prevents us from making other instances for lists but, -- our guess is that strings are used as keys more often then other list types. instance JSKey String where toJSKey = id fromJSKey = Just -- | Encode an association list as 'JSObject' value. encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue encJSDict v = makeObj [ (toJSKey x, showJSON y) | (x,y) <- v ] -- | Decode a 'JSObject' value into an association list. decJSDict :: (JSKey a, JSON b) => String -> JSValue -> Result [(a,b)] decJSDict l (JSObject o) = mapM rd (fromJSObject o) where rd (a,b) = case fromJSKey a of Just pa -> readJSON b >>= \pb -> return (pa,pb) Nothing -> mkError ("readJSON{" ++ l ++ "}:" ++ "unable to read dict; invalid object key") decJSDict l _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object") json-0.9.3/Text/JSON/0000755000000000000000000000000007346545000012362 5ustar0000000000000000json-0.9.3/Text/JSON/Generic.hs0000644000000000000000000001740307346545000014277 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | JSON serializer and deserializer using Data.Generics. -- The functions here handle algebraic data types and primitive types. -- It uses the same representation as "Text.JSON" for "Prelude" types. module Text.JSON.Generic ( module Text.JSON , Data , Typeable , toJSON , fromJSON , encodeJSON , decodeJSON , toJSON_generic , fromJSON_generic ) where import Control.Monad.State import Text.JSON import Text.JSON.String ( runGetJSON ) import Data.Generics import Data.Word import Data.Int import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.IntSet as I -- FIXME: The JSON library treats this specially, needs ext2Q -- import qualified Data.Map as M type T a = a -> JSValue -- |Convert anything to a JSON value. toJSON :: (Data a) => a -> JSValue toJSON = toJSON_generic `ext1Q` jList -- Use the standard encoding for all base types. `extQ` (showJSON :: T Integer) `extQ` (showJSON :: T Int) `extQ` (showJSON :: T Word8) `extQ` (showJSON :: T Word16) `extQ` (showJSON :: T Word32) `extQ` (showJSON :: T Word64) `extQ` (showJSON :: T Int8) `extQ` (showJSON :: T Int16) `extQ` (showJSON :: T Int32) `extQ` (showJSON :: T Int64) `extQ` (showJSON :: T Double) `extQ` (showJSON :: T Float) `extQ` (showJSON :: T Char) `extQ` (showJSON :: T String) -- Bool has a special encoding. `extQ` (showJSON :: T Bool) `extQ` (showJSON :: T ()) `extQ` (showJSON :: T Ordering) -- More special cases. `extQ` (showJSON :: T I.IntSet) `extQ` (showJSON :: T S.ByteString) `extQ` (showJSON :: T L.ByteString) where -- Lists are simply coded as arrays. jList vs = JSArray $ map toJSON vs toJSON_generic :: (Data a) => a -> JSValue toJSON_generic = generic where -- Generic encoding of an algebraic data type. -- No constructor, so it must be an error value. Code it anyway as JSNull. -- Elide a single constructor and just code the arguments. -- For multiple constructors, make an object with a field name that is the -- constructor (except lower case) and the data is the arguments encoded. generic a = case dataTypeRep (dataTypeOf a) of AlgRep [] -> JSNull AlgRep [c] -> encodeArgs c (gmapQ toJSON a) AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a) rep -> err (dataTypeOf a) rep where err dt r = error $ "toJSON: not AlgRep " ++ show r ++ "(" ++ show dt ++ ")" -- Encode nullary constructor as a string. -- Encode non-nullary constructors as an object with the constructor -- name as the single field and the arguments as the value. -- Use an array if the are no field names, but elide singleton arrays, -- and use an object if there are field names. encodeConstr c [] = JSString $ toJSString $ constrString c encodeConstr c as = jsObject [(constrString c, encodeArgs c as)] constrString = showConstr encodeArgs c = encodeArgs' (constrFields c) encodeArgs' [] [j] = j encodeArgs' [] js = JSArray js encodeArgs' ns js = jsObject $ zip (map mungeField ns) js -- Skip leading '_' in field name so we can use keywords etc. as field names. mungeField ('_':cs) = cs mungeField cs = cs jsObject :: [(String, JSValue)] -> JSValue jsObject = JSObject . toJSObject type F a = Result a -- |Convert a JSON value to anything (fails if the types do not match). fromJSON :: (Data a) => JSValue -> Result a fromJSON j = fromJSON_generic j `ext1R` jList `extR` (value :: F Integer) `extR` (value :: F Int) `extR` (value :: F Word8) `extR` (value :: F Word16) `extR` (value :: F Word32) `extR` (value :: F Word64) `extR` (value :: F Int8) `extR` (value :: F Int16) `extR` (value :: F Int32) `extR` (value :: F Int64) `extR` (value :: F Double) `extR` (value :: F Float) `extR` (value :: F Char) `extR` (value :: F String) `extR` (value :: F Bool) `extR` (value :: F ()) `extR` (value :: F Ordering) `extR` (value :: F I.IntSet) `extR` (value :: F S.ByteString) `extR` (value :: F L.ByteString) where value :: (JSON a) => Result a value = readJSON j jList :: (Data e) => Result [e] jList = case j of JSArray js -> mapM fromJSON js _ -> Error $ "fromJSON: Prelude.[] bad data: " ++ show j fromJSON_generic :: (Data a) => JSValue -> Result a fromJSON_generic j = generic where typ = dataTypeOf $ resType generic generic = case dataTypeRep typ of AlgRep [] -> case j of JSNull -> return (error "Empty type"); _ -> Error $ "fromJSON: no-constr bad data" AlgRep [_] -> decodeArgs (indexConstr typ 1) j AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j' rep -> Error $ "fromJSON: " ++ show rep ++ "(" ++ show typ ++ ")" getConstr t (JSObject o) | [(s, j')] <- fromJSObject o = do c <- readConstr' t s; return (c, j') getConstr t (JSString js) = do c <- readConstr' t (fromJSString js); return (c, JSNull) -- handle nullare constructor getConstr _ _ = Error "fromJSON: bad constructor encoding" readConstr' t s = maybe (Error $ "fromJSON: unknown constructor: " ++ s ++ " " ++ show t) return $ readConstr t s decodeArgs c = decodeArgs' (numConstrArgs (resType generic) c) c (constrFields c) decodeArgs' 0 c _ JSNull = construct c [] -- nullary constructor decodeArgs' 1 c [] jd = construct c [jd] -- unary constructor decodeArgs' n c [] (JSArray js) | n > 1 = construct c js -- no field names -- FIXME? We could allow reading an array into a constructor with field names. decodeArgs' _ c fs@(_:_) (JSObject o) = selectFields (fromJSObject o) fs >>= construct c -- field names decodeArgs' _ c _ jd = Error $ "fromJSON: bad decodeArgs data " ++ show (c, jd) -- Build the value by stepping through the list of subparts. construct c = evalStateT $ fromConstrM f c where f :: (Data a) => StateT [JSValue] Result a f = do js <- get; case js of [] -> lift $ Error "construct: empty list"; j' : js' -> do put js'; lift $ fromJSON j' -- Select the named fields from a JSON object. FIXME? Should this use a map? selectFields fjs = mapM sel where sel f = maybe (Error $ "fromJSON: field does not exist " ++ f) Ok $ lookup f fjs -- Count how many arguments a constructor has. The value x is used to determine what type the constructor returns. numConstrArgs :: (Data a) => a -> Constr -> Int numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0 where f = do modify (+1); return undefined resType :: Result a -> a resType _ = error "resType" -- |Encode a value as a string. encodeJSON :: (Data a) => a -> String encodeJSON x = showJSValue (toJSON x) "" -- |Decode a string as a value. decodeJSON :: (Data a) => String -> a decodeJSON s = case runGetJSON readJSValue s of Left msg -> error msg Right j -> case fromJSON j of Error msg -> error msg Ok x -> x json-0.9.3/Text/JSON/Parsec.hs0000644000000000000000000000672007346545000014140 0ustar0000000000000000-- | Parse JSON values using the Parsec combinators. module Text.JSON.Parsec ( p_value , p_null , p_boolean , p_array , p_string , p_object , p_number , p_js_string , p_js_object , p_jvalue , module Text.ParserCombinators.Parsec ) where import Text.JSON.Types import Text.ParserCombinators.Parsec import Control.Monad import Data.Char import Numeric p_value :: CharParser () JSValue p_value = spaces **> p_jvalue tok :: CharParser () a -> CharParser () a tok p = p <** spaces p_jvalue :: CharParser () JSValue p_jvalue = (JSNull <$$ p_null) <|> (JSBool <$$> p_boolean) <|> (JSArray <$$> p_array) <|> (JSString <$$> p_js_string) <|> (JSObject <$$> p_js_object) <|> (JSRational False <$$> p_number) "JSON value" p_null :: CharParser () () p_null = tok (string "null") >> return () p_boolean :: CharParser () Bool p_boolean = tok ( (True <$$ string "true") <|> (False <$$ string "false") ) p_array :: CharParser () [JSValue] p_array = between (tok (char '[')) (tok (char ']')) $ p_jvalue `sepBy` tok (char ',') p_string :: CharParser () String p_string = between (tok (char '"')) (tok (char '"')) (many p_char) where p_char = (char '\\' >> p_esc) <|> (satisfy (\x -> x /= '"' && x /= '\\')) p_esc = ('"' <$$ char '"') <|> ('\\' <$$ char '\\') <|> ('/' <$$ char '/') <|> ('\b' <$$ char 'b') <|> ('\f' <$$ char 'f') <|> ('\n' <$$ char 'n') <|> ('\r' <$$ char 'r') <|> ('\t' <$$ char 't') <|> (char 'u' **> p_uni) "escape character" p_uni = check =<< count 4 (satisfy isHexDigit) where check x | code <= max_char = return (toEnum code) | otherwise = mzero where code = fst $ head $ readHex x max_char = fromEnum (maxBound :: Char) p_object :: CharParser () [(String,JSValue)] p_object = between (tok (char '{')) (tok (char '}')) $ p_field `sepBy` tok (char ',') where p_field = (,) <$$> (p_string <** tok (char ':')) <**> p_jvalue p_number :: CharParser () Rational p_number = tok $ do s <- getInput case readSigned readFloat s of [(n,s1)] -> n <$$ setInput s1 _ -> mzero p_js_string :: CharParser () JSString p_js_string = toJSString <$$> p_string p_js_object :: CharParser () (JSObject JSValue) p_js_object = toJSObject <$$> p_object -------------------------------------------------------------------------------- -- XXX: Because Parsec is not Applicative yet... (<**>) :: CharParser () (a -> b) -> CharParser () a -> CharParser () b (<**>) = ap (**>) :: CharParser () a -> CharParser () b -> CharParser () b (**>) = (>>) (<**) :: CharParser () a -> CharParser () b -> CharParser () a m <** n = do x <- m; _ <- n; return x (<$$>) :: (a -> b) -> CharParser () a -> CharParser () b (<$$>) = fmap (<$$) :: a -> CharParser () b -> CharParser () a x <$$ m = m >> return x json-0.9.3/Text/JSON/Pretty.hs0000644000000000000000000000356307346545000014214 0ustar0000000000000000-- | Display JSON values using pretty printing combinators. module Text.JSON.Pretty ( module Text.JSON.Pretty , module Text.PrettyPrint.HughesPJ ) where import Text.JSON.Types import Text.PrettyPrint.HughesPJ import qualified Text.PrettyPrint.HughesPJ as PP import Data.Ratio import Data.Char import Numeric pp_value :: JSValue -> Doc pp_value v = case v of JSNull -> pp_null JSBool x -> pp_boolean x JSRational asf x -> pp_number asf x JSString x -> pp_js_string x JSArray vs -> pp_array vs JSObject xs -> pp_js_object xs pp_null :: Doc pp_null = text "null" pp_boolean :: Bool -> Doc pp_boolean True = text "true" pp_boolean False = text "false" pp_number :: Bool -> Rational -> Doc pp_number _ x | denominator x == 1 = integer (numerator x) pp_number True x = float (fromRational x) pp_number _ x = double (fromRational x) pp_array :: [JSValue] -> Doc pp_array xs = brackets $ fsep $ punctuate comma $ map pp_value xs pp_string :: String -> Doc pp_string x = doubleQuotes $ hcat $ map pp_char x where pp_char '\\' = text "\\\\" pp_char '"' = text "\\\"" pp_char c | isControl c = uni_esc c pp_char c = char c uni_esc c = text "\\u" PP.<> text (pad 4 (showHex (fromEnum c) "")) pad n cs | len < n = replicate (n-len) '0' ++ cs | otherwise = cs where len = length cs pp_object :: [(String,JSValue)] -> Doc pp_object xs = braces $ fsep $ punctuate comma $ map pp_field xs where pp_field (k,v) = pp_string k PP.<> colon <+> pp_value v pp_js_string :: JSString -> Doc pp_js_string x = pp_string (fromJSString x) pp_js_object :: JSObject JSValue -> Doc pp_js_object x = pp_object (fromJSObject x) json-0.9.3/Text/JSON/ReadP.hs0000644000000000000000000000605707346545000013721 0ustar0000000000000000-- | Parse JSON values using the ReadP combinators. module Text.JSON.ReadP ( p_value , p_null , p_boolean , p_array , p_string , p_object , p_number , p_js_string , p_js_object , module Text.ParserCombinators.ReadP ) where import Text.JSON.Types import Text.ParserCombinators.ReadP import Control.Monad import Data.Char import Numeric token :: ReadP a -> ReadP a token p = skipSpaces **> p p_value :: ReadP JSValue p_value = (JSNull <$$ p_null) <||> (JSBool <$$> p_boolean) <||> (JSArray <$$> p_array) <||> (JSString <$$> p_js_string) <||> (JSObject <$$> p_js_object) <||> (JSRational False <$$> p_number) p_null :: ReadP () p_null = token (string "null") >> return () p_boolean :: ReadP Bool p_boolean = token ( (True <$$ string "true") <||> (False <$$ string "false") ) p_array :: ReadP [JSValue] p_array = between (token (char '[')) (token (char ']')) $ p_value `sepBy` token (char ',') p_string :: ReadP String p_string = between (token (char '"')) (char '"') (many p_char) where p_char = (char '\\' >> p_esc) <||> (satisfy (\x -> x /= '"' && x /= '\\')) p_esc = ('"' <$$ char '"') <||> ('\\' <$$ char '\\') <||> ('/' <$$ char '/') <||> ('\b' <$$ char 'b') <||> ('\f' <$$ char 'f') <||> ('\n' <$$ char 'n') <||> ('\r' <$$ char 'r') <||> ('\t' <$$ char 't') <||> (char 'u' **> p_uni) p_uni = check =<< count 4 (satisfy isHexDigit) where check x | code <= max_char = return (toEnum code) | otherwise = pfail where code = fst $ head $ readHex x max_char = fromEnum (maxBound :: Char) p_object :: ReadP [(String,JSValue)] p_object = between (token (char '{')) (token (char '}')) $ p_field `sepBy` token (char ',') where p_field = (,) <$$> (p_string <** token (char ':')) <**> p_value p_number :: ReadP Rational p_number = readS_to_P (readSigned readFloat) p_js_string :: ReadP JSString p_js_string = toJSString <$$> p_string p_js_object :: ReadP (JSObject JSValue) p_js_object = toJSObject <$$> p_object -------------------------------------------------------------------------------- -- XXX: Because ReadP is not Applicative yet... (<**>) :: ReadP (a -> b) -> ReadP a -> ReadP b (<**>) = ap (**>) :: ReadP a -> ReadP b -> ReadP b (**>) = (>>) (<**) :: ReadP a -> ReadP b -> ReadP a m <** n = do x <- m; _ <- n; return x (<||>) :: ReadP a -> ReadP a -> ReadP a (<||>) = (+++) (<$$>) :: (a -> b) -> ReadP a -> ReadP b (<$$>) = fmap (<$$) :: a -> ReadP b -> ReadP a x <$$ m = m >> return x json-0.9.3/Text/JSON/String.hs0000644000000000000000000003074107346545000014171 0ustar0000000000000000-- | Basic support for working with JSON values. module Text.JSON.String ( -- * Parsing -- GetJSON , runGetJSON -- ** Reading JSON , readJSNull , readJSBool , readJSString , readJSRational , readJSArray , readJSObject , readJSValue , readJSTopType -- ** Writing JSON , showJSNull , showJSBool , showJSArray , showJSObject , showJSRational , showJSRational' , showJSValue , showJSTopType ) where import Text.JSON.Types (JSValue(..), JSString, toJSString, fromJSString, JSObject, toJSObject, fromJSObject) import Control.Monad (liftM, ap) import Control.Applicative((<$>)) import qualified Control.Applicative as A import Data.Char (isSpace, isDigit, digitToInt) import Data.Ratio (numerator, denominator, (%)) import Numeric (readHex, readDec, showHex) -- ----------------------------------------------------------------- -- | Parsing JSON -- | The type of JSON parsers for String newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) } instance Functor GetJSON where fmap = liftM instance A.Applicative GetJSON where pure = return (<*>) = ap instance Monad GetJSON where return x = GetJSON (\s -> Right (x,s)) fail x = GetJSON (\_ -> Left x) GetJSON m >>= f = GetJSON (\s -> case m s of Left err -> Left err Right (a,s1) -> un (f a) s1) -- | Run a JSON reader on an input String, returning some Haskell value. -- All input will be consumed. runGetJSON :: GetJSON a -> String -> Either String a runGetJSON (GetJSON m) s = case m s of Left err -> Left err Right (a,t) -> case t of [] -> Right a _ -> Left $ "Invalid tokens at end of JSON string: "++ show (take 10 t) getInput :: GetJSON String getInput = GetJSON (\s -> Right (s,s)) setInput :: String -> GetJSON () setInput s = GetJSON (\_ -> Right ((),s)) ------------------------------------------------------------------------- -- | Find 8 chars context, for error messages context :: String -> String context s = take 8 s -- | Read the JSON null type readJSNull :: GetJSON JSValue readJSNull = do xs <- getInput case xs of 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull _ -> fail $ "Unable to parse JSON null: " ++ context xs tryJSNull :: GetJSON JSValue -> GetJSON JSValue tryJSNull k = do xs <- getInput case xs of 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull _ -> k -- | Read the JSON Bool type readJSBool :: GetJSON JSValue readJSBool = do xs <- getInput case xs of 't':'r':'u':'e':xs1 -> setInput xs1 >> return (JSBool True) 'f':'a':'l':'s':'e':xs1 -> setInput xs1 >> return (JSBool False) _ -> fail $ "Unable to parse JSON Bool: " ++ context xs -- | Read the JSON String type readJSString :: GetJSON JSValue readJSString = do x <- getInput case x of '"' : cs -> parse [] cs _ -> fail $ "Malformed JSON: expecting string: " ++ context x where parse rs cs = case cs of '\\' : c : ds -> esc rs c ds '"' : ds -> do setInput ds return (JSString (toJSString (reverse rs))) c : ds | c >= '\x20' && c <= '\xff' -> parse (c:rs) ds | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ context cs | i <= 0x10ffff -> parse (c:rs) ds | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs where i = (fromIntegral (fromEnum c) :: Integer) _ -> fail $ "Unable to parse JSON String: unterminated String: " ++ context cs esc rs c cs = case c of '\\' -> parse ('\\' : rs) cs '"' -> parse ('"' : rs) cs 'n' -> parse ('\n' : rs) cs 'r' -> parse ('\r' : rs) cs 't' -> parse ('\t' : rs) cs 'f' -> parse ('\f' : rs) cs 'b' -> parse ('\b' : rs) cs '/' -> parse ('/' : rs) cs 'u' -> case cs of d1 : d2 : d3 : d4 : cs' -> case readHex [d1,d2,d3,d4] of [(n,"")] -> parse (toEnum n : rs) cs' x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x) _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ show c -- | Read an Integer or Double in JSON format, returning a Rational readJSRational :: GetJSON Rational readJSRational = do cs <- getInput case cs of '-' : ds -> negate <$> pos ds _ -> pos cs where pos [] = fail $ "Unable to parse JSON Rational: " ++ context [] pos (c:cs) = case c of '0' -> frac 0 cs _ | not (isDigit c) -> fail $ "Unable to parse JSON Rational: " ++ context cs | otherwise -> readDigits (digitToIntI c) cs readDigits acc [] = frac (fromInteger acc) [] readDigits acc (x:xs) | isDigit x = let acc' = 10*acc + digitToIntI x in acc' `seq` readDigits acc' xs | otherwise = frac (fromInteger acc) (x:xs) frac n ('.' : ds) = case span isDigit ds of ([],_) -> setInput ds >> return n (as,bs) -> let x = read as :: Integer y = 10 ^ (fromIntegral (length as) :: Integer) in exponent' (n + (x % y)) bs frac n cs = exponent' n cs exponent' n (c:cs) | c == 'e' || c == 'E' = (n*) <$> exp_num cs exponent' n cs = setInput cs >> return n exp_num :: String -> GetJSON Rational exp_num ('+':cs) = exp_digs cs exp_num ('-':cs) = recip <$> exp_digs cs exp_num cs = exp_digs cs exp_digs :: String -> GetJSON Rational exp_digs cs = case readDec cs of [(a,ds)] -> do setInput ds return (fromIntegral ((10::Integer) ^ (a::Integer))) _ -> fail $ "Unable to parse JSON exponential: " ++ context cs digitToIntI :: Char -> Integer digitToIntI ch = fromIntegral (digitToInt ch) -- | Read a list in JSON format readJSArray :: GetJSON JSValue readJSArray = readSequence '[' ']' ',' >>= return . JSArray -- | Read an object in JSON format readJSObject :: GetJSON JSValue readJSObject = readAssocs '{' '}' ',' >>= return . JSObject . toJSObject -- | Read a sequence of items readSequence :: Char -> Char -> Char -> GetJSON [JSValue] readSequence start end sep = do zs <- getInput case dropWhile isSpace zs of c : cs | c == start -> case dropWhile isSpace cs of d : ds | d == end -> setInput (dropWhile isSpace ds) >> return [] ds -> setInput ds >> parse [] _ -> fail $ "Unable to parse JSON sequence: sequence stars with invalid character: " ++ context zs where parse rs = rs `seq` do a <- readJSValue ds <- getInput case dropWhile isSpace ds of e : es | e == sep -> do setInput (dropWhile isSpace es) parse (a:rs) | e == end -> do setInput (dropWhile isSpace es) return (reverse (a:rs)) _ -> fail $ "Unable to parse JSON array: unterminated array: " ++ context ds -- | Read a sequence of JSON labelled fields readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)] readAssocs start end sep = do zs <- getInput case dropWhile isSpace zs of c:cs | c == start -> case dropWhile isSpace cs of d:ds | d == end -> setInput (dropWhile isSpace ds) >> return [] ds -> setInput ds >> parsePairs [] _ -> fail "Unable to parse JSON object: unterminated object" where parsePairs rs = rs `seq` do a <- do k <- do x <- readJSString ; case x of JSString s -> return (fromJSString s) _ -> fail $ "Malformed JSON field labels: object keys must be quoted strings." ds <- getInput case dropWhile isSpace ds of ':':es -> do setInput (dropWhile isSpace es) v <- readJSValue return (k,v) _ -> fail $ "Malformed JSON labelled field: " ++ context ds ds <- getInput case dropWhile isSpace ds of e : es | e == sep -> do setInput (dropWhile isSpace es) parsePairs (a:rs) | e == end -> do setInput (dropWhile isSpace es) return (reverse (a:rs)) _ -> fail $ "Unable to parse JSON object: unterminated sequence: " ++ context ds -- | Read one of several possible JS types readJSValue :: GetJSON JSValue readJSValue = do cs <- getInput case cs of '"' : _ -> readJSString '[' : _ -> readJSArray '{' : _ -> readJSObject 't' : _ -> readJSBool 'f' : _ -> readJSBool (x:_) | isDigit x || x == '-' -> JSRational False <$> readJSRational xs -> tryJSNull (fail $ "Malformed JSON: invalid token in this context " ++ context xs) -- | Top level JSON can only be Arrays or Objects readJSTopType :: GetJSON JSValue readJSTopType = do cs <- getInput case cs of '[' : _ -> readJSArray '{' : _ -> readJSObject _ -> fail "Invalid JSON: a JSON text a serialized object or array at the top level." -- ----------------------------------------------------------------- -- | Writing JSON -- | Show strict JSON top level types. Values not permitted -- at the top level are wrapped in a singleton array. showJSTopType :: JSValue -> ShowS showJSTopType (JSArray a) = showJSArray a showJSTopType (JSObject o) = showJSObject o showJSTopType x = showJSTopType $ JSArray [x] -- | Show JSON values showJSValue :: JSValue -> ShowS showJSValue jv = case jv of JSNull{} -> showJSNull JSBool b -> showJSBool b JSRational asF r -> showJSRational' asF r JSArray a -> showJSArray a JSString s -> showJSString s JSObject o -> showJSObject o -- | Write the JSON null type showJSNull :: ShowS showJSNull = showString "null" -- | Write the JSON Bool type showJSBool :: Bool -> ShowS showJSBool True = showString "true" showJSBool False = showString "false" -- | Write the JSON String type showJSString :: JSString -> ShowS showJSString x xs = quote (encJSString x (quote xs)) where quote = showChar '"' -- | Show a Rational in JSON format showJSRational :: Rational -> ShowS showJSRational r = showJSRational' False r showJSRational' :: Bool -> Rational -> ShowS showJSRational' asFloat r | denominator r == 1 = shows $ numerator r | isInfinite x || isNaN x = showJSNull | asFloat = shows xf | otherwise = shows x where x :: Double x = realToFrac r xf :: Float xf = realToFrac r -- | Show a list in JSON format showJSArray :: [JSValue] -> ShowS showJSArray = showSequence '[' ']' ',' -- | Show an association list in JSON format showJSObject :: JSObject JSValue -> ShowS showJSObject = showAssocs '{' '}' ',' . fromJSObject -- | Show a generic sequence of pairs in JSON format showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS showAssocs start end sep xs rest = start : go xs where go [(k,v)] = '"' : encJSString (toJSString k) ('"' : ':' : showJSValue v (go [])) go ((k,v):kvs) = '"' : encJSString (toJSString k) ('"' : ':' : showJSValue v (sep : go kvs)) go [] = end : rest -- | Show a generic sequence in JSON format showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS showSequence start end sep xs rest = start : go xs where go [y] = showJSValue y (go []) go (y:ys) = showJSValue y (sep : go ys) go [] = end : rest encJSString :: JSString -> ShowS encJSString jss ss = go (fromJSString jss) where go s1 = case s1 of (x :xs) | x < '\x20' -> '\\' : encControl x (go xs) ('"' :xs) -> '\\' : '"' : go xs ('\\':xs) -> '\\' : '\\' : go xs (x :xs) -> x : go xs "" -> ss encControl x xs = case x of '\b' -> 'b' : xs '\f' -> 'f' : xs '\n' -> 'n' : xs '\r' -> 'r' : xs '\t' -> 't' : xs _ | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs | x < '\x100' -> 'u' : '0' : '0' : hexxs | x < '\x1000' -> 'u' : '0' : hexxs | otherwise -> 'u' : hexxs where hexxs = showHex (fromEnum x) xs json-0.9.3/Text/JSON/Types.hs0000644000000000000000000000444107346545000014025 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- | Basic support for working with JSON values. module Text.JSON.Types ( -- * JSON Types JSValue(..) -- * Wrapper Types , JSString({-fromJSString-}..) , toJSString , JSObject({-fromJSObject-}..) , toJSObject , get_field , set_field ) where import Data.Typeable ( Typeable ) import Data.String(IsString(..)) -- -- | JSON values -- -- The type to which we encode Haskell values. There's a set -- of primitives, and a couple of heterogenous collection types. -- -- Objects: -- -- An object structure is represented as a pair of curly brackets -- surrounding zero or more name\/value pairs (or members). A name is a -- string. A single colon comes after each name, separating the name -- from the value. A single comma separates a value from a -- following name. -- -- Arrays: -- -- An array structure is represented as square brackets surrounding -- zero or more values (or elements). Elements are separated by commas. -- -- Only valid JSON can be constructed this way -- data JSValue = JSNull | JSBool !Bool | JSRational Bool{-as Float?-} !Rational | JSString JSString | JSArray [JSValue] | JSObject (JSObject JSValue) deriving (Show, Read, Eq, Ord, Typeable) -- | Strings can be represented a little more efficiently in JSON newtype JSString = JSONString { fromJSString :: String } deriving (Eq, Ord, Show, Read, Typeable) -- | Turn a Haskell string into a JSON string. toJSString :: String -> JSString toJSString = JSONString -- Note: we don't encode the string yet, that's done when serializing. instance IsString JSString where fromString = toJSString instance IsString JSValue where fromString = JSString . fromString -- | As can association lists newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] } deriving (Eq, Ord, Show, Read, Typeable ) -- | Make JSON object out of an association list. toJSObject :: [(String,a)] -> JSObject a toJSObject = JSONObject -- | Get the value of a field, if it exist. get_field :: JSObject a -> String -> Maybe a get_field (JSONObject xs) x = lookup x xs -- | Set the value of a field. Previous values are overwritten. set_field :: JSObject a -> String -> a -> JSObject a set_field (JSONObject xs) k v = JSONObject ((k,v) : filter ((/= k).fst) xs) json-0.9.3/json.cabal0000644000000000000000000000616507346545000012632 0ustar0000000000000000name: json version: 0.9.3 synopsis: Support for serialising Haskell to and from JSON description: JSON (JavaScript Object Notation) is a lightweight data-interchange format. It is easy for humans to read and write. It is easy for machines to parse and generate. It is based on a subset of the JavaScript Programming Language, Standard ECMA-262 3rd Edition - December 1999. . This library provides a parser and pretty printer for converting between Haskell values and JSON. category: Web license: BSD3 license-file: LICENSE author: Galois Inc. maintainer: Iavor S. Diatchki (iavor.diatchki@gmail.com) Copyright: (c) 2007-2018 Galois Inc. cabal-version: >= 1.6 build-type: Simple extra-source-files: CHANGES tests/GenericTest.hs tests/HUnit.hs tests/Makefile tests/Parallel.hs tests/QC.hs tests/QuickCheckUtils.hs tests/Unit.hs tests/unit/fail1.json tests/unit/fail10.json tests/unit/fail11.json tests/unit/fail12.json tests/unit/fail13.json tests/unit/fail14.json tests/unit/fail15.json tests/unit/fail16.json tests/unit/fail17.json tests/unit/fail18.json tests/unit/fail19.json tests/unit/fail2.json tests/unit/fail20.json tests/unit/fail21.json tests/unit/fail22.json tests/unit/fail23.json tests/unit/fail24.json tests/unit/fail25.json tests/unit/fail26.json tests/unit/fail27.json tests/unit/fail28.json tests/unit/fail29.json tests/unit/fail3.json tests/unit/fail30.json tests/unit/fail31.json tests/unit/fail32.json tests/unit/fail33.json tests/unit/fail4.json tests/unit/fail5.json tests/unit/fail6.json tests/unit/fail7.json tests/unit/fail8.json tests/unit/fail9.json tests/unit/pass1.json tests/unit/pass2.json tests/unit/pass3.json source-repository head type: git location: https://github.com/GaloisInc/json.git flag split-base default: True description: Use the new split base package. flag parsec default: True description: Add support for parsing with Parsec. flag pretty default: True description: Add support for using pretty printing combinators. flag generic default: True description: Add support for generic encoder. flag mapdict default: False description: Encode Haskell maps as JSON dicts library exposed-modules: Text.JSON, Text.JSON.Types, Text.JSON.String, Text.JSON.ReadP ghc-options: -Wall -O2 if flag(split-base) if flag(generic) build-depends: base >=4 && <5, syb >= 0.3.3 exposed-modules: Text.JSON.Generic Cpp-Options: -DBASE_4 else build-depends: base >= 3 build-depends: array, containers, bytestring, mtl, text if flag(parsec) build-depends: parsec exposed-modules: Text.JSON.Parsec if flag(pretty) build-depends: pretty exposed-modules: Text.JSON.Pretty else build-depends: base < 3 if flag(mapdict) cpp-options: -DMAP_AS_DICT json-0.9.3/tests/0000755000000000000000000000000007346545000012027 5ustar0000000000000000json-0.9.3/tests/GenericTest.hs0000755000000000000000000000410507346545000014602 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, ExtendedDefaultRules, EmptyDataDecls #-} module Main where import Text.JSON.Generic import Data.Word import Data.Int data Foo = Foo { a :: Int, b :: Bool, c :: Baz } | None deriving (Typeable, Data, Show, Eq) data Baz = Baz Int deriving (Typeable, Data, Show, Eq) data Bar = Int :+: Int | Zero deriving (Typeable, Data, Show, Eq) newtype New a = New a deriving (Typeable, Data, Show, Eq) newtype Apples = Apples { noApples :: Int } deriving (Typeable, Data, Show, Eq) data Record = Record { x :: Int, y :: Double, z :: Float, s :: String, t :: (Bool, Int) } deriving (Typeable, Data, Show, Eq) rec = Record { x = 1, y = 2, z = 3.5, s = "hello", t = (True, 0) } data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Typeable, Data, Show, Eq) atree = build 4 where build 0 = Leaf build 1 = Node Leaf 100 Leaf build n = Node (build (n-1)) n (build (n-2)) data Color = Red | Green | Blue deriving (Typeable, Data, Show, Eq, Enum) from (Ok x) = x from (Error s) = error s viaJSON :: (Data a) => a -> a viaJSON = from . fromJSON . toJSON testJSON :: (Data a, Eq a) => a -> Bool testJSON x = --x == viaJSON x x == decodeJSON (encodeJSON x) tests = and [ testJSON (1::Integer), testJSON (42::Int), testJSON (100::Word8), testJSON (-1000::Int64), testJSON (4.2::Double), testJSON (4.1::Float), testJSON True, testJSON 'q', testJSON "Hello, World\n", testJSON (Nothing :: Maybe Int), testJSON (Just "aa"), testJSON [], testJSON [1,2,3,4], testJSON (Left 1 :: Either Int Bool), testJSON (Right True :: Either Int Bool), testJSON (1,True), testJSON (1,2,True,'a',"apa",(4.5,99)), testJSON $ Baz 11, testJSON $ Foo 1 True (Baz 42), testJSON None, testJSON $ 2 :+: 3, testJSON Zero, testJSON $ New (2 :+: 3), testJSON rec, testJSON [LT,EQ,GT], testJSON atree, testJSON (), testJSON $ Apples 42, testJSON [Red .. Blue] ] main :: IO () main = if tests then return () else error "Generic test failed" json-0.9.3/tests/HUnit.hs0000755000000000000000000001005707346545000013420 0ustar0000000000000000{-# OPTIONS -fglasgow-exts #-} import Text.JSON import Test.HUnit import System.Exit (exitFailure) import Control.Monad (when) import System.IO import Data.Either import qualified Data.Map as M isError (Error _) = True isError _ = False main = do counts <- runTestTT tests when (errors counts > 0 || failures counts > 0) exitFailure tests = TestList [shouldFail "non-array top level" "fail1" (undefined :: String) ,shouldFail "unclosed array" "fail2" (undefined :: JSValue) ,shouldFail "object keys must be quoted" "fail3" (undefined :: JSValue) ,shouldFail "extra comma" "fail4" (undefined :: JSValue) ,shouldFail "double extra comma" "fail5" (undefined :: JSValue) ,shouldFail "missing value" "fail6" (undefined :: JSValue) ,shouldFail "comma after close" "fail7" (undefined :: JSValue) ,shouldFail "extra close" "fail8" (undefined :: JSValue) ,shouldFail "extra comma" "fail9" (undefined :: JSValue) ,shouldFail "extra value" "fail10" (undefined :: JSValue) ,shouldFail "illegal expression" "fail11" (undefined :: JSValue) ,shouldFail "illegal expression" "fail12" (undefined :: JSValue) ,shouldFail "numbers with leading zeroes" "fail13" (undefined :: JSValue) ,shouldFail "numbers in hex" "fail14" (undefined :: JSValue) ,shouldFail "illegal backslash" "fail15" (undefined :: JSValue) ,shouldFail "unquoted char" "fail16" (undefined :: JSValue) ,shouldFail "illegal escape" "fail17" (undefined :: JSValue) ,shouldPass "deep objects" "fail18" (undefined :: JSValue) -- depth is allowed to be limited, but why bother? ,shouldFail "missing colon" "fail19" (undefined :: JSValue) ,shouldFail "double colon" "fail20" (undefined :: JSValue) ,shouldFail "comma instead of colon" "fail21" (undefined :: JSValue) ,shouldFail "colon intead of comma" "fail22" (undefined :: JSValue) ,shouldFail "invalid token" "fail23" (undefined :: JSValue) ,shouldFail "single quotes" "fail24" (undefined :: JSValue) ,shouldFail "literal tabs" "fail25" (undefined :: JSValue) ,shouldFail "tabs in strings" "fail26" (undefined :: JSValue) ,shouldFail "newline in strings" "fail27" (undefined :: JSValue) ,shouldFail "escaped newline in strings" "fail28" (undefined :: JSValue) ,shouldFail "funny number" "fail29" (undefined :: JSValue) ,shouldFail "funny number 2" "fail30" (undefined :: JSValue) ,shouldFail "funny number 3" "fail31" (undefined :: JSValue) ,shouldFail "unterminated array" "fail32" (undefined :: JSValue) ,shouldFail "unterminated array" "fail33" (undefined :: JSValue) , shouldPass "complex valid input 1" "pass1" (undefined :: JSValue) , shouldPass "complex valid input 2" "pass2" (undefined :: JSValue) , shouldPass "complex valid input 3" "pass3" (undefined :: JSValue) ] ------------------------------------------------------------------------ load n = readFile ("unit/" ++ n ++ ".json") shouldFail :: JSON a => String -> String -> a -> Test shouldFail s n (x :: a) = TestLabel ("Should fail: " ++ s) $ TestCase $ do -- hPutStrLn stderr $ ("\t\tShould fail: " ++ s) s <- load n assert =<< case decodeStrict s :: Result a of Ok _ -> return False Error s -> -- do hPrint stderr s return True shouldPass :: JSON a => String -> String -> a -> Test shouldPass s n (x :: a) = TestLabel ("Should pass: " ++ s) $ TestCase $ do -- hPutStrLn stderr $ ("\t\tShould pass: " ++ s) s <- load n assert =<< case decodeStrict s :: Result a of Ok _ -> return True Error s -> do hPrint stderr s return False json-0.9.3/tests/Makefile0000755000000000000000000000052007346545000013467 0ustar0000000000000000ODIR=.ghc $(ODIR): mkdir $(ODIR) all: $(ODIR) ghc -cpp -O QC.hs --make -o QC -no-recomp -i.. -odir=$(ODIR) -hidir=$(ODIR) time ./QC runhaskell -i.. HUnit.hs generic: $(ODIR) ghc -i.. --make -fforce-recomp -odir=$(ODIR) -hidir=$(ODIR) GenericTest.hs -o GenericTest ./GenericTest clean: $(RM) -r $(ODIR) $(RM) *.html *.tix QC json-0.9.3/tests/Parallel.hs0000755000000000000000000001125607346545000014127 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Test.QuickCheck.Parallel -- Copyright : (c) Don Stewart 2006 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : dons@cse.unsw.edu.au -- Stability : experimental -- Portability : non-portable (uses Control.Exception, Control.Concurrent) -- -- A parallel batch driver for running QuickCheck on threaded or SMP systems. -- See the /Example.hs/ file for a complete overview. -- module Parallel ( pRun, pDet, pNon ) where import Test.QuickCheck import Data.List import Control.Concurrent (forkIO) import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Exception hiding (evaluate) import System.Random import System.IO (hFlush,stdout) import Text.Printf type Name = String type Depth = Int type Test = (Name, Depth -> IO String) -- | Run a list of QuickCheck properties in parallel chunks, using -- 'n' Haskell threads (first argument), and test to a depth of 'd' -- (second argument). Compile your application with '-threaded' and run -- with the SMP runtime's '-N4' (or however many OS threads you want to -- donate), for best results. -- -- > import Test.QuickCheck.Parallel -- > -- > do n <- getArgs >>= readIO . head -- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] -- -- Will run 'n' threads over the property list, to depth 1000. -- pRun :: Int -> Int -> [Test] -> IO () pRun n depth tests = do chan <- newChan ps <- getChanContents chan work <- newMVar tests forM_ [1..n] $ forkIO . thread work chan let wait xs i | i >= n = return () -- done | otherwise = case xs of Nothing : xs -> wait xs $! i+1 Just s : xs -> putStr s >> hFlush stdout >> wait xs i wait ps 0 where thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () thread work chan me = loop where loop = do job <- modifyMVar work $ \jobs -> return $ case jobs of [] -> ([], Nothing) (j:js) -> (js, Just j) case job of Nothing -> writeChan chan Nothing -- done Just (name,prop) -> do v <- prop depth writeChan chan . Just $ printf "%d: %-25s: %s" me name v loop -- | Wrap a property, and run it on a deterministic set of data pDet :: Testable a => a -> Int -> IO String pDet a n = mycheck Det defaultConfig { configMaxTest = n , configEvery = \n args -> unlines args } a -- | Wrap a property, and run it on a non-deterministic set of data pNon :: Testable a => a -> Int -> IO String pNon a n = mycheck NonDet defaultConfig { configMaxTest = n , configEvery = \n args -> unlines args } a data Mode = Det | NonDet ------------------------------------------------------------------------ mycheck :: Testable a => Mode -> Config -> a -> IO String mycheck Det config a = do let rnd = mkStdGen 99 -- deterministic mytests config (evaluate a) rnd 0 0 [] mycheck NonDet config a = do rnd <- newStdGen -- different each run mytests config (evaluate a) rnd 0 0 [] mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String mytests config gen rnd0 ntest nfail stamps | ntest == configMaxTest config = do done "OK," ntest stamps | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps | otherwise = do case ok result of Nothing -> mytests config gen rnd1 ntest (nfail+1) stamps Just True -> mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) Just False -> return ( "Falsifiable after " ++ show ntest ++ " tests:\n" ++ unlines (arguments result) ) where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 done :: String -> Int -> [[String]] -> IO String done mesg ntest stamps = return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) where table = display . map entry . reverse . sort . map pairLength . group . sort . filter (not . null) $ stamps display [] = ".\n" display [x] = " (" ++ x ++ ").\n" display xs = ".\n" ++ unlines (map (++ ".") xs) pairLength xss@(xs:_) = (length xss, xs) entry (n, xs) = percentage n ntest ++ " " ++ concat (intersperse ", " xs) percentage n m = show ((100 * n) `div` m) ++ "%" forM_ = flip mapM_ json-0.9.3/tests/QC.hs0000755000000000000000000001163307346545000012675 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} module Main where import Text.JSON import Parallel import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Control.Exception as C (catch,evaluate) import Control.Monad import Foreign import System.Environment import System.IO import System.IO.Unsafe import Data.Word import Data.Int import Test.QuickCheck hiding (test) import QuickCheckUtils import Debug.Trace import Text.Printf import Data.IntSet ( IntSet ) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Sequence as Seq import qualified Data.Map as M import qualified Data.IntMap as I ------------------------------------------------------------------------ -- low level ones: main :: IO () main = do hSetBuffering stdout NoBuffering s <- getArgs let n = if null s then 100 else read (head s) k = doIt n k basics k atomicCharacterTypes k numbers k listlikes k containers k sumtypes k products doIt n (s,x) = putStrLn (" *** " ++ s) >> pRun 2 n x type T a = a -> Property type B a = a -> Bool p :: Testable a => a -> Int -> IO String p = pNon test :: forall a. (Show a,Arbitrary a, Eq a, JSON a) => a -> Property test _ = forAll (arbitrary :: Gen a) $ \a -> Ok a == decode (encode a) instance Arbitrary JSString where arbitrary = liftM toJSString arbitrary coarbitrary = undefined instance (Ord e, Arbitrary e) => Arbitrary (JSObject e) where arbitrary = do ks <- arbitrary vs <- arbitrary return . toJSObject . M.toList . M.fromList . zip ks $ vs coarbitrary = undefined ------------------------------------------------------------------------ -- tests :: [(String, Int -> IO String)] basics = ("Basic types", [("Bool", p (test :: T Bool )) ,("()", p (test :: T () )) ] ) -- atomic character types atomicCharacterTypes = ("Atomic string types", [("String", p (test :: T JSString )) ,("Strict ByteString", p (test :: T S.ByteString )) ,("Lazy ByteString", p (test :: T L.ByteString )) ,("Char", p (test :: T Char )) ] ) -- basic numeric types numbers = ("Numeric types", [("Integer", p (test :: T Integer )) ,("Int", p (test :: T Int )) ,("Word", p (test :: T Word )) -- words ,("Word8", p (test :: T Word8 )) ,("Word16", p (test :: T Word16 )) ,("Word32", p (test :: T Word32 )) ,("Word64", p (test :: T Word64 )) -- integers ,("Int8", p (test :: T Int8 )) ,("Int16", p (test :: T Int16 )) ,("Int32", p (test :: T Int32 )) ,("Int64", p (test :: T Int64 )) -- rationals ,("Double", p (test :: T Double)) ,("Float", p (test :: T Float)) ]) -- lists listlikes = ("List like types", [("[()]", p (test :: T [()])) ,("[Int]", p (test :: T [Int])) ,("[Bool]", p (test :: T [Bool])) ,("[Integer]", p (test :: T [Integer])) ,("[Int]", p (test :: T [Int])) ,("[Word]", p (test :: T [Word])) ,("[S.ByteString]", p (test :: T [S.ByteString] )) ,("[L.ByteString]", p (test :: T [L.ByteString] )) ]) -- containers containers = ("Container types", [("IntSet", p (test :: T IntSet )) ,("Map String Int", p (test :: T (M.Map String Int) )) ,("Map Int String", p (test :: T (M.Map Int String) )) -- ,("Maybe Bool", p (test :: T (Maybe Bool) )) -- ,("Rational", p (test :: T Rational )) ] ) sumtypes = ("Sum types", [("Ordering", p (test :: T Ordering)) ,("Maybe Int", p (test :: T (Maybe Int))) ,("Maybe String", p (test :: T (Maybe String))) ,("Either Bool String", p (test :: T (Either Bool String))) ,("Either Int (Either Int Word32)", p (test :: T (Either Int (Either Int Word32)))) ]) products = ("Products", [("((),())", p (test :: T ((),()) )) ,("(Bool,Int)", p (test :: T (Bool,Int) )) ,("(Bool,(Int, String))", p (test :: T (Bool,(Int,String)) )) ,("(Maybe String,(Either Int Bool, String))", p (test :: T (Bool,(Either Int Bool,String)) )) ,("(Bool,Int,String)", p (test :: T (Bool,Int,String) )) ,("(Bool,Int,String,Char)", p (test :: T (Bool,Int,String,Char) )) ] ) json-0.9.3/tests/QuickCheckUtils.hs0000755000000000000000000001750207346545000015426 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} -- -- Uses multi-param type classes -- module QuickCheckUtils where import Control.Monad import Test.QuickCheck.Batch import Test.QuickCheck import Text.Show.Functions import Data.Ratio import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Control.Exception as C (evaluate) import Control.Monad ( liftM2 ) import Data.Char import Data.List import Data.Word import Data.Int import System.Random import System.IO -- import Control.Concurrent import System.Mem import System.CPUTime import Text.Printf import qualified Data.ByteString as P import qualified Data.ByteString.Lazy as L #if __GLASGOW_HASKELL__ >= 608 import qualified Data.ByteString.Lazy.Internal as L import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Internal as B #else import qualified Data.ByteString.Base as B #endif -- import qualified Data.Sequence as Seq -- Enable this to get verbose test output. Including the actual tests. debug = False mytest :: Testable a => a -> Int -> IO () mytest a n = mycheck defaultConfig { configMaxTest=n , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a mycheck :: Testable a => Config -> a -> IO () mycheck config a = do rnd <- newStdGen performGC -- >> threadDelay 100 t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0 printf " %0.3f seconds\n" (t :: Double) hFlush stdout time :: a -> IO (a , Double) time a = do start <- getCPUTime v <- C.evaluate a v `seq` return () end <- getCPUTime return (v, ( (fromIntegral (end - start)) / (10^12))) mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double mytests config gen rnd0 ntest nfail stamps t0 | ntest == configMaxTest config = do done "OK," ntest stamps return t0 | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps return t0 | otherwise = do (result,t1) <- time (generate (configSize config ntest) rnd2 gen) putStr (configEvery config ntest (arguments result)) >> hFlush stdout case ok result of Nothing -> mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1) Just True -> mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1) Just False -> do putStr ( "Falsifiable after " ++ show ntest ++ " tests:\n" ++ unlines (arguments result) ) >> hFlush stdout return t0 where (rnd1,rnd2) = split rnd0 done :: String -> Int -> [[String]] -> IO () done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) where table = display . map entry . reverse . sort . map pairLength . group . sort . filter (not . null) $ stamps display [] = ". " display [x] = " (" ++ x ++ "). " display xs = ".\n" ++ unlines (map (++ ".") xs) pairLength xss@(xs:_) = (length xss, xs) entry (n, xs) = percentage n ntest ++ " " ++ concat (intersperse ", " xs) percentage n m = show ((100 * n) `div` m) ++ "%" ------------------------------------------------------------------------ instance Random Word8 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Int8 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Word16 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Int16 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Word where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Word32 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Int32 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Word64 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Int64 where randomR = integralRandomR random = randomR (minBound,maxBound) ------------------------------------------------------------------------ integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, fromIntegral b :: Integer) g of (x,g) -> (fromIntegral x, g) ------------------------------------------------------------------------ instance Arbitrary Word8 where arbitrary = choose (0, 2^8-1) coarbitrary w = variant 0 instance Arbitrary (Ratio Integer) where arbitrary = do n <- arbitrary m <- arbitrary if m /= 0 then return (n % m) else arbitrary coarbitrary w = undefined instance Arbitrary Word16 where arbitrary = choose (0, 2^16-1) coarbitrary = undefined instance Arbitrary Word32 where -- arbitrary = choose (0, 2^32-1) arbitrary = choose (minBound, maxBound) coarbitrary = undefined instance Arbitrary Word64 where -- arbitrary = choose (0, 2^64-1) arbitrary = choose (minBound, maxBound) coarbitrary = undefined instance Arbitrary Int8 where -- arbitrary = choose (0, 2^8-1) arbitrary = choose (minBound, maxBound) coarbitrary w = variant 0 instance Arbitrary Int16 where -- arbitrary = choose (0, 2^16-1) arbitrary = choose (minBound, maxBound) coarbitrary = undefined instance Arbitrary Int32 where -- arbitrary = choose (0, 2^32-1) arbitrary = choose (minBound, maxBound) coarbitrary = undefined instance Arbitrary Int64 where -- arbitrary = choose (0, 2^64-1) arbitrary = choose (minBound, maxBound) coarbitrary = undefined instance Arbitrary Word where arbitrary = choose (minBound, maxBound) coarbitrary w = variant 0 ------------------------------------------------------------------------ instance Arbitrary Char where arbitrary = choose (maxBound, minBound) coarbitrary = undefined {- instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = oneof [ return Nothing, liftM Just arbitrary] coarbitrary = undefined -} instance Arbitrary Ordering where arbitrary = oneof [ return LT,return GT,return EQ ] coarbitrary = undefined {- instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary] coarbitrary = undefined -} instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary coarbitrary = undefined instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where arbitrary = fmap IntMap.fromList arbitrary coarbitrary = undefined instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where arbitrary = fmap Set.fromList arbitrary coarbitrary = undefined instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where arbitrary = fmap Map.fromList arbitrary coarbitrary = undefined {- instance (Arbitrary a) => Arbitrary (Seq.Seq a) where arbitrary = fmap Seq.fromList arbitrary coarbitrary = undefined -} instance Arbitrary L.ByteString where arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. coarbitrary s = coarbitrary (L.unpack s) instance Arbitrary B.ByteString where arbitrary = B.pack `fmap` arbitrary coarbitrary s = coarbitrary (B.unpack s) json-0.9.3/tests/Unit.hs0000755000000000000000000000044007346545000013303 0ustar0000000000000000 import Text.JSON import Network.RPC.JSON import System.Exit main = do case (decode test1 :: Result JSRequest) of Ok _ -> exitWith ExitSuccess test1 = "{\"method\":\"feed.add\",\"params\":{\"uri\":\"http://rss.slashdot.org/Slashdot/slashdot\"},\"version\":\"1.1\" }" json-0.9.3/tests/unit/0000755000000000000000000000000007346545000013006 5ustar0000000000000000json-0.9.3/tests/unit/fail1.json0000755000000000000000000000007407346545000014701 0ustar0000000000000000"A JSON payload should be an object or array, not a string."json-0.9.3/tests/unit/fail10.json0000755000000000000000000000007207346545000014757 0ustar0000000000000000{"Extra value after close": true} "misplaced quoted value"json-0.9.3/tests/unit/fail11.json0000755000000000000000000000003507346545000014757 0ustar0000000000000000{"Illegal expression": 1 + 2}json-0.9.3/tests/unit/fail12.json0000755000000000000000000000003707346545000014762 0ustar0000000000000000{"Illegal invocation": alert()}json-0.9.3/tests/unit/fail13.json0000755000000000000000000000005307346545000014761 0ustar0000000000000000{"Numbers cannot have leading zeroes": 013}json-0.9.3/tests/unit/fail14.json0000755000000000000000000000003707346545000014764 0ustar0000000000000000{"Numbers cannot be hex": 0x14}json-0.9.3/tests/unit/fail15.json0000755000000000000000000000004207346545000014761 0ustar0000000000000000["Illegal backslash escape: \x15"]json-0.9.3/tests/unit/fail16.json0000755000000000000000000000001007346545000014755 0ustar0000000000000000[\naked]json-0.9.3/tests/unit/fail17.json0000755000000000000000000000004207346545000014763 0ustar0000000000000000["Illegal backslash escape: \017"]json-0.9.3/tests/unit/fail18.json0000755000000000000000000000006207346545000014766 0ustar0000000000000000[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]]json-0.9.3/tests/unit/fail19.json0000755000000000000000000000002607346545000014767 0ustar0000000000000000{"Missing colon" null}json-0.9.3/tests/unit/fail2.json0000755000000000000000000000002107346545000014672 0ustar0000000000000000["Unclosed array"json-0.9.3/tests/unit/fail20.json0000755000000000000000000000002707346545000014760 0ustar0000000000000000{"Double colon":: null}json-0.9.3/tests/unit/fail21.json0000755000000000000000000000004007346545000014754 0ustar0000000000000000{"Comma instead of colon", null}json-0.9.3/tests/unit/fail22.json0000755000000000000000000000004107346545000014756 0ustar0000000000000000["Colon instead of comma": false]json-0.9.3/tests/unit/fail23.json0000755000000000000000000000002407346545000014760 0ustar0000000000000000["Bad value", truth]json-0.9.3/tests/unit/fail24.json0000755000000000000000000000002007346545000014755 0ustar0000000000000000['single quote']json-0.9.3/tests/unit/fail25.json0000755000000000000000000000003507346545000014764 0ustar0000000000000000[" tab character in string "]json-0.9.3/tests/unit/fail26.json0000755000000000000000000000004607346545000014767 0ustar0000000000000000["tab\ character\ in\ string\ "]json-0.9.3/tests/unit/fail27.json0000755000000000000000000000001607346545000014765 0ustar0000000000000000["line break"]json-0.9.3/tests/unit/fail28.json0000755000000000000000000000001707346545000014767 0ustar0000000000000000["line\ break"]json-0.9.3/tests/unit/fail29.json0000755000000000000000000000000407346545000014764 0ustar0000000000000000[0e]json-0.9.3/tests/unit/fail3.json0000755000000000000000000000004507346545000014701 0ustar0000000000000000{unquoted_key: "keys must be quoted"}json-0.9.3/tests/unit/fail30.json0000755000000000000000000000000507346545000014755 0ustar0000000000000000[0e+]json-0.9.3/tests/unit/fail31.json0000755000000000000000000000000707346545000014760 0ustar0000000000000000[0e+-1]json-0.9.3/tests/unit/fail32.json0000755000000000000000000000005007346545000014757 0ustar0000000000000000{"Comma instead if closing brace": true,json-0.9.3/tests/unit/fail33.json0000755000000000000000000000001407346545000014760 0ustar0000000000000000["mismatch"}json-0.9.3/tests/unit/fail4.json0000755000000000000000000000002007346545000014673 0ustar0000000000000000["extra comma",]json-0.9.3/tests/unit/fail5.json0000755000000000000000000000003007346545000014675 0ustar0000000000000000["double extra comma",,]json-0.9.3/tests/unit/fail6.json0000755000000000000000000000003207346545000014700 0ustar0000000000000000[ , "<-- missing value"]json-0.9.3/tests/unit/fail7.json0000755000000000000000000000003207346545000014701 0ustar0000000000000000["Comma after the close"],json-0.9.3/tests/unit/fail8.json0000755000000000000000000000002007346545000014677 0ustar0000000000000000["Extra close"]]json-0.9.3/tests/unit/fail9.json0000755000000000000000000000002607346545000014706 0ustar0000000000000000{"Extra comma": true,}json-0.9.3/tests/unit/pass1.json0000755000000000000000000000264107346545000014736 0ustar0000000000000000[ "JSON Test Pattern pass1", {"object with 1 member":["array with 1 element"]}, {}, [], -42, true, false, null, { "integer": 1234567890, "real": -9876.543210, "e": 0.123456789e-12, "E": 1.234567890E+34, "": 23456789012E66, "zero": 0, "one": 1, "space": " ", "quote": "\"", "backslash": "\\", "controls": "\b\f\n\r\t", "slash": "/ & \/", "alpha": "abcdefghijklmnopqrstuvwyz", "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ", "digit": "0123456789", "0123456789": "digit", "special": "`1~!@#$%^&*()_+-={':[,]}|;.?", "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A", "true": true, "false": false, "null": null, "array":[ ], "object":{ }, "address": "50 St. James Street", "url": "http://www.JSON.org/", "comment": "// /* */": " ", " s p a c e d " :[1,2 , 3 , 4 , 5 , 6 ,7 ],"compact":[1,2,3,4,5,6,7], "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}", "quotes": "" \u0022 %22 0x22 034 "", "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" : "A key can be any string" }, 0.5 ,98.6 , 99.44 , 1066, 1e1, 0.1e1, 1e-1, 1e00,2e+00,2e-00 ,"rosebud"]json-0.9.3/tests/unit/pass2.json0000755000000000000000000000006407346545000014734 0ustar0000000000000000[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]]json-0.9.3/tests/unit/pass3.json0000755000000000000000000000022407346545000014733 0ustar0000000000000000{ "JSON Test Pattern pass3": { "The outermost value": "must be an object or array.", "In this test": "It is an object." } }