diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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. diff --git a/Text/JSON.hs b/Text/JSON.hs --- a/Text/JSON.hs +++ b/Text/JSON.hs @@ -1,19 +1,5 @@ -{-# OPTIONS_GHC -XCPP -XMultiParamTypeClasses -XTypeSynonymInstances #-} --------------------------------------------------------------------- --- | --- Module : Text.JSON --- Copyright : (c) Galois, Inc. 2007-2009 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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") + diff --git a/Text/JSON/Generic.hs b/Text/JSON/Generic.hs --- a/Text/JSON/Generic.hs +++ b/Text/JSON/Generic.hs @@ -1,15 +1,5 @@ {-# 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. +-- | 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 diff --git a/Text/JSON/Parsec.hs b/Text/JSON/Parsec.hs --- a/Text/JSON/Parsec.hs +++ b/Text/JSON/Parsec.hs @@ -1,13 +1,4 @@ --------------------------------------------------------------------- --- | --- Module : Text.JSON.Parsec --- Copyright : (c) Galois, Inc. 2007-2009 --- --- Maintainer: Sigbjorn Finne --- 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 diff --git a/Text/JSON/Pretty.hs b/Text/JSON/Pretty.hs --- a/Text/JSON/Pretty.hs +++ b/Text/JSON/Pretty.hs @@ -1,14 +1,4 @@ --------------------------------------------------------------------- --- | --- Module : Text.JSON.Pretty --- Copyright : (c) Galois, Inc. 2007-2009 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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) diff --git a/Text/JSON/ReadP.hs b/Text/JSON/ReadP.hs --- a/Text/JSON/ReadP.hs +++ b/Text/JSON/ReadP.hs @@ -1,14 +1,4 @@ --------------------------------------------------------------------- --- | --- Module : Text.JSON.ReadP --- Copyright : (c) Galois, Inc. 2007-2009 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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 diff --git a/Text/JSON/String.hs b/Text/JSON/String.hs --- a/Text/JSON/String.hs +++ b/Text/JSON/String.hs @@ -1,17 +1,4 @@ --------------------------------------------------------------------- --- | --- Module : Text.JSON.String --- Copyright : (c) Galois, Inc. 2007-2009 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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 diff --git a/Text/JSON/Types.hs b/Text/JSON/Types.hs --- a/Text/JSON/Types.hs +++ b/Text/JSON/Types.hs @@ -1,18 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------------------- --- | --- Module : Text.JSON.Types --- Copyright : (c) Galois, Inc. 2007-2009 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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)] } diff --git a/json.cabal b/json.cabal --- a/json.cabal +++ b/json.cabal @@ -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 -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 + + +