json 0.4.4 → 0.11
raw patch · 9 files changed
Files
- CHANGES +16/−0
- Text/JSON.hs +75/−66
- Text/JSON/Generic.hs +8/−20
- Text/JSON/Parsec.hs +43/−55
- Text/JSON/Pretty.hs +5/−14
- Text/JSON/ReadP.hs +48/−54
- Text/JSON/String.hs +20/−64
- Text/JSON/Types.hs +8/−14
- json.cabal +18/−9
CHANGES view
@@ -1,3 +1,19 @@+Version 0.11+ * Limit floating-point range to that of Double to avoid allocation+ overflows when constructing Rationals++Version 0.10+ * Use MonadFail, so that it works with GHC 8.8++Version 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.
Text/JSON.hs view
@@ -1,19 +1,5 @@-{-# OPTIONS_GHC -XCPP -XMultiParamTypeClasses -XTypeSynonymInstances #-}------------------------------------------------------------------------ |--- Module : Text.JSON--- Copyright : (c) Galois, Inc. 2007-2009--- License : BSD3------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------------------------------------------------------------------------------ Serialising Haskell values to and from JSON values.----+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}+-- | Serialising Haskell values to and from JSON values. module Text.JSON ( -- * JSON Types JSValue(..)@@ -50,19 +36,18 @@ -- ** Instance helpers , makeObj, valFromObj+ , JSKey(..), encJSDict, decJSDict ) where import Text.JSON.Types import Text.JSON.String -import Data.List import Data.Int import Data.Word-import Data.Either+import Control.Monad.Fail (MonadFail (..)) 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@@ -72,6 +57,7 @@ import qualified Data.IntMap as IntMap import qualified Data.Array as Array+import qualified Data.Text as T ------------------------------------------------------------------------ @@ -152,15 +138,11 @@ instance Monad Result where return x = Ok x- fail x = Error x 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+instance MonadFail Result where+ fail x = Error x -- | Convenient error generation mkError :: String -> Result a@@ -223,9 +205,9 @@ readOrd x = case x of "LT" -> return Prelude.LT- "EQ" -> return Prelude.EQ- "GT" -> return Prelude.GT- _ -> mkError ("Unable to read Ordering")+ "EQ" -> return Prelude.EQ+ "GT" -> return Prelude.GT+ _ -> mkError ("Unable to read Ordering") -- ----------------------------------------------------------------- -- Integral types@@ -369,27 +351,27 @@ -- container types: -instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where #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-#else- showJSON = encJSDict M.toList- -- backwards compatibility..- readJSON a@JSArray{} = M.fromList <$> readJSON a- readJSON o = decJSDict "Map" M.fromList o-#endif 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+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@@ -406,17 +388,15 @@ 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+ 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 @@ -429,6 +409,15 @@ 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@@ -438,7 +427,7 @@ 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))+ (lookup k (fromJSObject o)) encJSString :: (a -> String) -> a -> JSValue encJSString f v = JSString (toJSString (f v))@@ -454,22 +443,42 @@ 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)+-- | Haskell types that can be used as keys in JSON objects.+class JSKey a where+ toJSKey :: a -> String+ fromJSKey :: String -> Maybe a -decJSDict :: (JSON a, JSON b)+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- -> ([(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+ -> 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")+
Text/JSON/Generic.hs view
@@ -1,15 +1,5 @@ {-# LANGUAGE PatternGuards #-}------------------------------------------------------------------------ |--- Module : Text.JSON.Generic--- Copyright : (c) Lennart Augustsson, 2008-2009--- License : BSD3------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------ JSON serializer and deserializer using Data.Generics.+-- | 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 @@ -26,8 +16,6 @@ ) where import Control.Monad.State-import Control.Monad.Identity-import Data.Maybe import Text.JSON import Text.JSON.String ( runGetJSON ) import Data.Generics@@ -109,7 +97,7 @@ mungeField ('_':cs) = cs mungeField cs = cs - jsObject :: [(String, JSValue)] -> JSValue+ jsObject :: [(String, JSValue)] -> JSValue jsObject = JSObject . toJSObject @@ -119,7 +107,7 @@ 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)@@ -134,11 +122,11 @@ `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)@@ -164,9 +152,9 @@ 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+ 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
Text/JSON/Parsec.hs view
@@ -1,13 +1,4 @@------------------------------------------------------------------------ |--- Module : Text.JSON.Parsec--- Copyright : (c) Galois, Inc. 2007-2009------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------ Parse JSON values using the Parsec combinators.+-- | Parse JSON values using the Parsec combinators. module Text.JSON.Parsec ( p_value@@ -30,18 +21,18 @@ import Numeric p_value :: CharParser () JSValue-p_value = spaces *> p_jvalue+p_value = spaces **> p_jvalue tok :: CharParser () a -> CharParser () a-tok p = p <* spaces+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)+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 () ()@@ -49,8 +40,8 @@ p_boolean :: CharParser () Bool p_boolean = tok- ( (True <$ string "true")- <|> (False <$ string "false")+ ( (True <$$ string "true")+ <|> (False <$$ string "false") ) p_array :: CharParser () [JSValue]@@ -58,65 +49,62 @@ $ p_jvalue `sepBy` tok (char ',') p_string :: CharParser () String-p_string = between (tok (char '"')) (char '"') (many p_char)+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)+ 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 = pure (toEnum code)- | otherwise = empty+ 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+ where p_field = (,) <$$> (p_string <** tok (char ':')) <**> p_jvalue p_number :: CharParser () Rational-p_number = do s <- getInput- case readSigned readFloat s of- [(n,s1)] -> n <$ setInput s1- _ -> empty+p_number = tok+ $ do s <- getInput+ case (reads s, readSigned readFloat s) of+ ([(x,_)], _)+ | isInfinite (x :: Double) -> fail "number out of range"+ (_, [(y,s')]) -> y <$$ setInput s'+ _ -> mzero <?> "number" p_js_string :: CharParser () JSString-p_js_string = toJSString <$> p_string+p_js_string = toJSString <$$> p_string p_js_object :: CharParser () (JSObject JSValue)-p_js_object = toJSObject <$> p_object+p_js_object = toJSObject <$$> p_object -------------------------------------------------------------------------------- -- XXX: Because Parsec is not Applicative yet... -pure :: a -> CharParser () a-pure = return--(<*>) :: CharParser () (a -> b) -> CharParser () a -> CharParser () b-(<*>) = ap--(*>) :: CharParser () a -> CharParser () b -> CharParser () b-(*>) = (>>)+(<**>) :: CharParser () (a -> b) -> CharParser () a -> CharParser () b+(<**>) = ap -(<*) :: CharParser () a -> CharParser () b -> CharParser () a-m <* n = do x <- m; n; return x+(**>) :: CharParser () a -> CharParser () b -> CharParser () b+(**>) = (>>) -empty :: CharParser () a-empty = mzero+(<**) :: CharParser () a -> CharParser () b -> CharParser () a+m <** n = do x <- m; _ <- n; return x -(<$>) :: (a -> b) -> CharParser () a -> CharParser () b-(<$>) = fmap+(<$$>) :: (a -> b) -> CharParser () a -> CharParser () b+(<$$>) = fmap -(<$) :: a -> CharParser () b -> CharParser () a-x <$ m = m >> return x+(<$$) :: a -> CharParser () b -> CharParser () a+x <$$ m = m >> return x
Text/JSON/Pretty.hs view
@@ -1,14 +1,4 @@------------------------------------------------------------------------ |--- Module : Text.JSON.Pretty--- Copyright : (c) Galois, Inc. 2007-2009--- License : BSD3------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------ Display JSON values using pretty printing combinators.+-- | Display JSON values using pretty printing combinators. module Text.JSON.Pretty ( module Text.JSON.Pretty@@ -17,6 +7,7 @@ import Text.JSON.Types import Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJ as PP import Data.Ratio import Data.Char import Numeric@@ -49,10 +40,10 @@ pp_string x = doubleQuotes $ hcat $ map pp_char x where pp_char '\\' = text "\\\\" pp_char '"' = text "\\\""- pp_char c | isControl c || fromEnum c >= 0x7f = uni_esc c+ pp_char c | isControl c = uni_esc c pp_char c = char c - uni_esc c = text "\\u" <> text (pad 4 (showHex (fromEnum 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@@ -60,7 +51,7 @@ pp_object :: [(String,JSValue)] -> Doc pp_object xs = braces $ fsep $ punctuate comma $ map pp_field xs- where pp_field (k,v) = pp_string k <> colon <+> pp_value v+ 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)
Text/JSON/ReadP.hs view
@@ -1,14 +1,4 @@------------------------------------------------------------------------ |--- Module : Text.JSON.ReadP--- Copyright : (c) Galois, Inc. 2007-2009--- License : BSD3------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------ Parse JSON values using the ReadP combinators.+-- | Parse JSON values using the ReadP combinators. module Text.JSON.ReadP ( p_value@@ -30,23 +20,23 @@ import Numeric token :: ReadP a -> ReadP a-token p = skipSpaces *> p+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_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")+ ( (True <$$ string "true")+ <||> (False <$$ string "false") ) p_array :: ReadP [JSValue]@@ -56,62 +46,66 @@ p_string :: ReadP String p_string = between (token (char '"')) (char '"') (many p_char) where p_char = (char '\\' >> p_esc)- <|> (satisfy (\x -> x /= '"' && x /= '\\'))+ <||> (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_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 = pure (toEnum code)- | otherwise = empty+ 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+ where p_field = (,) <$$> (p_string <** token (char ':')) <**> p_value p_number :: ReadP Rational-p_number = readS_to_P (readSigned readFloat)+p_number = readS_to_P safeRationalReads +-- reading into a Double with reads is safe for huge floating-point literals+-- this will allow all floating-point literals that are small enough to fit+-- into a Double (and are thus compatible with most other json implementations)+-- to be parsed here without opening us to oversized Rational allocations+safeRationalReads :: ReadS Rational+safeRationalReads str =+ case reads str of+ [(d,_)] | not (isInfinite (d :: Double)) -> readSigned readFloat str+ _ -> []+ p_js_string :: ReadP JSString-p_js_string = toJSString <$> p_string+p_js_string = toJSString <$$> p_string p_js_object :: ReadP (JSObject JSValue)-p_js_object = toJSObject <$> p_object+p_js_object = toJSObject <$$> p_object -------------------------------------------------------------------------------- -- XXX: Because ReadP is not Applicative yet... -pure :: a -> ReadP a-pure = return--(<*>) :: ReadP (a -> b) -> ReadP a -> ReadP b-(<*>) = ap--(*>) :: ReadP a -> ReadP b -> ReadP b-(*>) = (>>)+(<**>) :: ReadP (a -> b) -> ReadP a -> ReadP b+(<**>) = ap -(<*) :: ReadP a -> ReadP b -> ReadP a-m <* n = do x <- m; n; return x+(**>) :: ReadP a -> ReadP b -> ReadP b+(**>) = (>>) -empty :: ReadP a-empty = pfail+(<**) :: ReadP a -> ReadP b -> ReadP a+m <** n = do x <- m; _ <- n; return x -(<|>) :: ReadP a -> ReadP a -> ReadP a-(<|>) = (+++)+(<||>) :: ReadP a -> ReadP a -> ReadP a+(<||>) = (+++) -(<$>) :: (a -> b) -> ReadP a -> ReadP b-(<$>) = fmap+(<$$>) :: (a -> b) -> ReadP a -> ReadP b+(<$$>) = fmap -(<$) :: a -> ReadP b -> ReadP a-x <$ m = m >> return x+(<$$) :: a -> ReadP b -> ReadP a+x <$$ m = m >> return x
Text/JSON/String.hs view
@@ -1,17 +1,4 @@------------------------------------------------------------------------ |--- Module : Text.JSON.String--- Copyright : (c) Galois, Inc. 2007-2009--- License : BSD3------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------------------------------------------------------------------------------ Basic support for working with JSON values.---+-- | Basic support for working with JSON values. module Text.JSON.String ( @@ -43,14 +30,18 @@ , showJSTopType ) where +import Prelude hiding (fail) import Text.JSON.Types (JSValue(..), JSString, toJSString, fromJSString, JSObject, toJSObject, fromJSObject) -import Control.Monad (liftM)+import Control.Monad (liftM, ap)+import Control.Monad.Fail (MonadFail (..))+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)+import Numeric (readHex, readDec, showHex, readSigned, readFloat) -- ----------------------------------------------------------------- -- | Parsing JSON@@ -59,13 +50,19 @@ 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) +instance MonadFail GetJSON where+ fail x = GetJSON (\_ -> Left x)+ -- | Run a JSON reader on an input String, returning some Haskell value. -- All input will be consumed. runGetJSON :: GetJSON a -> String -> Either String a@@ -81,9 +78,6 @@ setInput :: String -> GetJSON () setInput s = GetJSON (\_ -> Right ((),s)) -(<$>) :: Functor f => (a -> b) -> f a -> f b-x <$> y = fmap x y- ------------------------------------------------------------------------- -- | Find 8 chars context, for error messages@@ -159,50 +153,12 @@ 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)+ case (reads cs, readSigned readFloat cs) of+ ([(x,_)], _)+ | isInfinite (x :: Double) ->+ fail ("JSON Rational out of range: " ++ context cs)+ (_, [(y,cs')]) -> setInput cs' >> return y+ _ -> fail ("Unable to parse JSON Rational: " ++ context cs) -- | Read a list in JSON format
Text/JSON/Types.hs view
@@ -1,18 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}------------------------------------------------------------------------ |--- Module : Text.JSON.Types--- Copyright : (c) Galois, Inc. 2007-2009--- License : BSD3------ Maintainer: Sigbjorn Finne <sof@galois.com>--- Stability : provisional--- Portability: portable------------------------------------------------------------------------------ Basic support for working with JSON values.---+-- | Basic support for working with JSON values. module Text.JSON.Types ( @@ -32,6 +19,7 @@ ) where import Data.Typeable ( Typeable )+import Data.String(IsString(..)) -- -- | JSON values@@ -71,6 +59,12 @@ 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)] }
json.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.4 name: json-version: 0.4.4+version: 0.11 synopsis: Support for serialising Haskell to and from JSON description: JSON (JavaScript Object Notation) is a lightweight data-interchange@@ -11,15 +12,15 @@ This library provides a parser and pretty printer for converting between Haskell values and JSON. category: Web-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Galois Inc.-maintainer: Sigbjorn Finne <sof@galois.com>-Copyright: (c) 2007-2009 Galois Inc.-cabal-version: >= 1.2.0+maintainer: Iavor S. Diatchki (iavor.diatchki@gmail.com)+Copyright: (c) 2007-2018 Galois Inc. build-type: Simple-extra-source-files:+extra-doc-files: CHANGES+extra-source-files: tests/GenericTest.hs tests/HUnit.hs tests/Makefile@@ -64,6 +65,10 @@ 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.@@ -82,6 +87,7 @@ description: Encode Haskell maps as JSON dicts library+ default-language: Haskell2010 exposed-modules: Text.JSON, Text.JSON.Types, Text.JSON.String,@@ -90,14 +96,14 @@ if flag(split-base) if flag(generic)- build-depends: base >=4 && <5, syb+ build-depends: base >=4.9 && <5, syb >= 0.3.3 exposed-modules: Text.JSON.Generic Cpp-Options: -DBASE_4 else- build-depends: base >= 3+ build-depends: base >= 3 && <4 - build-depends: array, containers, bytestring, mtl+ build-depends: array, containers, bytestring, mtl, text if flag(parsec) build-depends: parsec@@ -110,3 +116,6 @@ if flag(mapdict) cpp-options: -DMAP_AS_DICT+++