diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,21 @@ + +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 + diff --git a/Text/JSON.hs b/Text/JSON.hs --- a/Text/JSON.hs +++ b/Text/JSON.hs @@ -1,10 +1,11 @@ +{-# OPTIONS_GHC -XCPP -XMultiParamTypeClasses -XTypeSynonymInstances #-} -------------------------------------------------------------------- -- | -- Module : Text.JSON --- Copyright : (c) Galois, Inc. 2007 +-- Copyright : (c) Galois, Inc. 2007-2009 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- @@ -43,30 +44,35 @@ , readJSArray, readJSObject, readJSValue -- ** Writing JSON - , showJSNull, showJSBool, showJSRational, showJSArray + , showJSNull, showJSBool, showJSArray + , showJSRational, showJSRational' , showJSObject, showJSValue -- ** Instance helpers , makeObj, valFromObj - + ) where import Text.JSON.Types import Text.JSON.String -import Data.Char import Data.List import Data.Int import Data.Word import Data.Either import Control.Monad(liftM,ap,MonadPlus(..)) import Control.Applicative +import Control.Monad.Error ( MonadError(..) ) 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 + ------------------------------------------------------------------------ -- | Decode a String representing a JSON value @@ -150,8 +156,14 @@ Ok a >>= f = f a Error x >>= _ = Error x +instance MonadError String Result where + throwError x = Error x + + catchError (Error e) h = h e + catchError x _ = x + -- | Convenient error generation -mkError :: (JSON a) => String -> Result a +mkError :: String -> Result a mkError s = Error s -------------------------------------------------------------------- @@ -205,114 +217,116 @@ readJSONs _ = mkError "Unable to read String" instance JSON Ordering where - showJSON LT = JSRational (-1) - showJSON EQ = JSRational 0 - showJSON GT = JSRational 1 - readJSON (JSRational (-1)) = return LT - readJSON (JSRational 0) = return EQ - readJSON (JSRational 1) = return GT - readJSON _ = mkError "Unable to read Ordering" + 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 . fromIntegral - readJSON (JSRational i) = return $ round i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ round i readJSON _ = mkError "Unable to read Integer" -- constrained: instance JSON Int where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ round i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ round i readJSON _ = mkError "Unable to read Int" -- constrained: instance JSON Word where - showJSON = JSRational . toRational - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . toRational + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word" -- ----------------------------------------------------------------- instance JSON Word8 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word8" instance JSON Word16 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word16" instance JSON Word32 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word32" instance JSON Word64 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Word64" instance JSON Int8 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int8" instance JSON Int16 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int16" instance JSON Int32 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i readJSON _ = mkError "Unable to read Int32" instance JSON Int64 where - showJSON = JSRational . fromIntegral - readJSON (JSRational i) = return $ truncate i - readJSON _ = mkError "Unable to read Int64" + showJSON = JSRational False . fromIntegral + readJSON (JSRational _ i) = return $ truncate i + readJSON _ = mkError "Unable to read Int64" -- ----------------------------------------------------------------- instance JSON Double where - showJSON = JSRational . toRational - readJSON (JSRational r) = return $ fromRational r - readJSON _ = mkError "Unable to read Double" + 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 . toRational - readJSON (JSRational r) = return $ fromRational r - readJSON _ = mkError "Unable to read Float" + 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 + readJSON (JSObject o) = case "Just" `lookup` as of Just x -> Just <$> readJSON x - _ -> case "nothing" `lookup` as of + _ -> 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)] + 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 + readJSON (JSObject o) = case "Left" `lookup` as of Just a -> Left <$> readJSON a - Nothing -> case "right" `lookup` as of + 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)] + showJSON (Left a) = JSObject $ toJSObject [("Left", showJSON a)] + showJSON (Right b) = JSObject $ toJSObject [("Right", showJSON b)] -- ----------------------------------------------------------------- -- Products @@ -353,40 +367,66 @@ showJSON = showJSONs readJSON = readJSONs +-- container types: + instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where --- the previous version: showJSON = showJSON . M.toList - showJSON m = JSObject $ toJSObject $ - map (\ (x,y) -> (showJSValue (showJSON x) "", showJSON y)) (M.toList m) +#if !defined(MAP_AS_DICT) + showJSON = encJSArray M.toList + readJSON = decJSArray "Map" M.fromList +#else + showJSON = encJSDict M.toList + -- backwards compatibility.. + readJSON a@JSArray{} = M.fromList <$> readJSON a + readJSON o = decJSDict "Map" M.fromList o +#endif - readJSON (JSObject o) = - mapM rd (fromJSObject o) >>= return . M.fromList - where - rd (a,b) = do - f <- decode a - g <- readJSON b - return (f,g) +instance (JSON a) => JSON (IntMap.IntMap a) where +#if !defined(MAP_AS_DICT) + showJSON = encJSArray IntMap.toList + readJSON = decJSArray "IntMap" IntMap.fromList +#else +{- alternate (dict) mapping: -} + showJSON = encJSDict IntMap.toList + readJSON = decJSDict "IntMap" IntMap.fromList +#endif - -- backwards compatibility.. - readJSON a@(JSArray _) = M.fromList <$> readJSON a - readJSON _ = mkError "Unable to read Map" +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 = showJSON . I.toList - readJSON a@(JSArray _) = I.fromList <$> readJSON a - readJSON _ = mkError "Unable to read IntSet" + 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 (\ (ix,_) (mi,ma) -> + let + mi1 = min ix mi + ma1 = max ix ma + in + mi1 `seq` ma1 `seq` (mi1,ma1)) + (i,i) + xs + -- ----------------------------------------------------------------- -- ByteStrings instance JSON S.ByteString where - showJSON = JSString . toJSString . S.unpack - readJSON (JSString s) = return $ S.pack $ fromJSString s - readJSON _ = mkError "Unable to read ByteString" + showJSON = encJSString S.unpack + readJSON = decJSString "ByteString" (return . S.pack) instance JSON L.ByteString where - showJSON = JSString . toJSString . L.unpack - readJSON (JSString s) = return $ L.pack $ fromJSString s - readJSON _ = mkError "Unable to read ByteString" + showJSON = encJSString L.unpack + readJSON = decJSString "Lazy.ByteString" (return . L.pack) -- ----------------------------------------------------------------- -- Instance Helpers @@ -399,3 +439,37 @@ 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") + +#if defined(MAP_AS_DICT) +encJSDict :: (JSON a, JSON b) => (c -> [(a,b)]) -> c -> JSValue +encJSDict f v = makeObj $ + map (\ (x,y) -> (showJSValue (showJSON x) "", showJSON y)) (f v) + +decJSDict :: (JSON a, JSON b) + => String + -> ([(a,b)] -> c) + -> JSValue + -> Result c +decJSDict _ f (JSObject o) = mapM rd (fromJSObject o) >>= return . f + where + rd (a,b) = do + pa <- decode a + pb <- readJSON b + return (pa,pb) +decJSDict l _ _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object") +#endif + diff --git a/Text/JSON/Generic.hs b/Text/JSON/Generic.hs new file mode 100644 --- /dev/null +++ b/Text/JSON/Generic.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE PatternGuards #-} +-------------------------------------------------------------------- +-- | +-- Module : Text.JSON.Generic +-- Copyright : (c) Lennart Augustsson, 2008-2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- 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 Control.Monad.Identity +import Data.Maybe +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 diff --git a/Text/JSON/Parsec.hs b/Text/JSON/Parsec.hs --- a/Text/JSON/Parsec.hs +++ b/Text/JSON/Parsec.hs @@ -1,9 +1,9 @@ -------------------------------------------------------------------- -- | -- Module : Text.JSON.Parsec --- Copyright : (c) Galois, Inc. 2007 +-- Copyright : (c) Galois, Inc. 2007-2009 -- --- Maintainer: Don Stewart +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- @@ -37,7 +37,7 @@ <|> (JSArray <$> p_array) <|> (JSString <$> p_js_string) <|> (JSObject <$> p_js_object) - <|> (JSRational <$> p_number) + <|> (JSRational False <$> p_number) "JSON value" p_null :: CharParser () () diff --git a/Text/JSON/Pretty.hs b/Text/JSON/Pretty.hs --- a/Text/JSON/Pretty.hs +++ b/Text/JSON/Pretty.hs @@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module : Text.JSON.Pretty --- Copyright : (c) Galois, Inc. 2007 +-- Copyright : (c) Galois, Inc. 2007-2009 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- @@ -25,7 +25,7 @@ pp_value v = case v of JSNull -> pp_null JSBool x -> pp_boolean x - JSRational x -> pp_number 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 @@ -37,9 +37,10 @@ pp_boolean True = text "true" pp_boolean False = text "false" -pp_number :: Rational -> Doc -pp_number x | denominator x == 1 = integer (numerator x) -pp_number x = double (fromRational x) +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 diff --git a/Text/JSON/ReadP.hs b/Text/JSON/ReadP.hs --- a/Text/JSON/ReadP.hs +++ b/Text/JSON/ReadP.hs @@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module : Text.JSON.ReadP --- Copyright : (c) Galois, Inc. 2007 +-- Copyright : (c) Galois, Inc. 2007-2009 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- @@ -38,7 +38,7 @@ <|> (JSArray <$> p_array) <|> (JSString <$> p_js_string) <|> (JSObject <$> p_js_object) - <|> (JSRational <$> p_number) + <|> (JSRational False <$> p_number) p_null :: ReadP () p_null = token (string "null") >> return () diff --git a/Text/JSON/String.hs b/Text/JSON/String.hs --- a/Text/JSON/String.hs +++ b/Text/JSON/String.hs @@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module : Text.JSON.String --- Copyright : (c) Galois, Inc. 2007 +-- Copyright : (c) Galois, Inc. 2007-2009 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- @@ -25,8 +25,8 @@ , readJSValue, readJSTopType -- ** Writing JSON - , showJSNull, showJSBool, showJSRational, showJSArray - , showJSObject + , showJSNull, showJSBool, showJSArray + , showJSObject, showJSRational, showJSRational' , showJSValue, showJSTopType @@ -81,11 +81,15 @@ context :: String -> String context s = take 8 s +isNullLexeme :: String -> Bool +isNullLexeme ('n':'u':'l':'l':_) = True +isNullLexeme _ = False + -- | Read the JSON null type readJSNull :: GetJSON JSValue readJSNull = do xs <- getInput - if "null" `isPrefixOf` xs + if isNullLexeme xs then setInput (drop 4 xs) >> return JSNull else fail $ "Unable to parse JSON null: " ++ context xs @@ -245,8 +249,8 @@ '{' : _ -> readJSObject 't' : _ -> readJSBool 'f' : _ -> readJSBool - xs | "null" `isPrefixOf` xs -> readJSNull - (x:_) | x == '-' || isDigit x -> JSRational <$> readJSRational + _ | isNullLexeme cs -> readJSNull + (x:_) | x == '-' || isDigit x -> JSRational False <$> readJSRational xs -> fail $ "Malformed JSON: invalid token in this context " ++ context xs @@ -271,12 +275,14 @@ -- | Show JSON values showJSValue :: JSValue -> ShowS -showJSValue (JSNull) = showJSNull -showJSValue (JSBool b) = showJSBool b -showJSValue (JSRational r) = showJSRational r -showJSValue (JSArray a) = showJSArray a -showJSValue (JSString s) = showJSString s -showJSValue (JSObject o) = showJSObject o +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 @@ -295,11 +301,22 @@ -- | Show a Rational in JSON format showJSRational :: Rational -> ShowS -showJSRational r | denominator r == 1 = shows $ numerator r - | otherwise = if isInfinite x || isNaN x then showJSNull - else shows x - where x :: Double - x = realToFrac r +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 diff --git a/Text/JSON/Types.hs b/Text/JSON/Types.hs --- a/Text/JSON/Types.hs +++ b/Text/JSON/Types.hs @@ -2,10 +2,10 @@ -------------------------------------------------------------------- -- | -- Module : Text.JSON.Types --- Copyright : (c) Galois, Inc. 2007 +-- Copyright : (c) Galois, Inc. 2007-2009 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- @@ -57,7 +57,7 @@ data JSValue = JSNull | JSBool !Bool - | JSRational !Rational + | JSRational Bool{-as Float?-} !Rational | JSString JSString | JSArray [JSValue] | JSObject (JSObject JSValue) @@ -74,7 +74,7 @@ -- | As can association lists newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] } - deriving (Eq, Ord, Show, Read, Typeable) + deriving (Eq, Ord, Show, Read, Typeable ) -- | Make JSON object out of an association list. toJSObject :: [(String,a)] -> JSObject a diff --git a/json.cabal b/json.cabal --- a/json.cabal +++ b/json.cabal @@ -1,5 +1,5 @@ name: json -version: 0.3.6 +version: 0.4.1 synopsis: Support for serialising Haskell to and from JSON description: JSON (JavaScript Object Notation) is a lightweight data-interchange @@ -15,10 +15,12 @@ license-file: LICENSE author: Galois Inc. maintainer: Sigbjorn Finne -Copyright: (c) 2007-2008 Galois Inc. +Copyright: (c) 2007-2009 Galois Inc. cabal-version: >= 1.2.0 build-type: Simple extra-source-files: + CHANGES + tests/GenericTest.hs tests/HUnit.hs tests/Makefile tests/Parallel.hs @@ -71,7 +73,14 @@ 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, @@ -80,7 +89,10 @@ ghc-options: -Wall -O2 if flag(split-base) - build-depends: base >= 3, array, containers, bytestring + build-depends: base >= 3, array, containers, bytestring, mtl + if flag(generic) + build-depends: mtl, syb + exposed-modules: Text.JSON.Generic if flag(parsec) build-depends: parsec exposed-modules: Text.JSON.Parsec @@ -89,3 +101,6 @@ exposed-modules: Text.JSON.Pretty else build-depends: base < 3 + + if flag(mapdict) + cpp-options: -DMAP_AS_DICT diff --git a/tests/GenericTest.hs b/tests/GenericTest.hs new file mode 100644 --- /dev/null +++ b/tests/GenericTest.hs @@ -0,0 +1,81 @@ +{-# 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" diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -4,9 +4,13 @@ mkdir $(ODIR) all: $(ODIR) - ghc -cpp -O QC.hs --make -o QC -no-recomp -odir=$(ODIR) -hidir=$(ODIR) + ghc -cpp -O QC.hs --make -o QC -no-recomp -i.. -odir=$(ODIR) -hidir=$(ODIR) time ./QC - runhaskell HUnit.hs + runhaskell -i.. HUnit.hs + +generic: $(ODIR) + ghc -i.. --make -fforce-recomp -odir=$(ODIR) -hidir=$(ODIR) GenericTest.hs -o GenericTest + ./GenericTest clean: $(RM) -r $(ODIR)