RJson (empty) → 0.1
raw patch · 4 files changed
+808/−0 lines, 4 filesdep +arraydep +basedep +bytestringbuild-type:Customsetup-changed
Dependencies added: array, base, bytestring, containers, iconv, mtl, parsec, syb-with-class
Files
- LICENSE +27/−0
- RJson.cabal +29/−0
- Setup.hs +2/−0
- Text/RJson.hs +750/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2008, Alex Drummond.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer. 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. The name of the author+may not be used to endorse or promote products derived from this+software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ RJson.cabal view
@@ -0,0 +1,29 @@+Name: RJson+Version: 0.1+Cabal-Version: >= 1.2+License: BSD3+License-File: LICENSE+Author: Alex Drummond+Maintainer: a.d.drummond@gmail.com+Category: Text+Synopsis: A reflective JSON serializer/parser.+Stability: experimental++Description:+ This package uses the Scrap Your Boilerplate With Class approach+ to generics to implement a reflective Json serializer and deserializer.+ Nested record types can be automatically converted to corresponding+ JSON objects and vice versa. In both cases, various aspects of+ serializing and deserializing can be customized by implementing instances of+ type classes. Note that only Haskell 98 types can be+ serialized and deserialized, and that the use of strict constructors will lead+ to runtime errors with the current implemetation. Apart from the+ reflective stuff, the package also provides a straightforward+ Haskell representation of JSON data, together with a unicode-safe+ parser and a suitable implementation of 'show'. The code hasn't yet+ been tested for performance; it might be quite slow.++Library+ Build-Depends: base, mtl, parsec, bytestring, iconv, array, containers, syb-with-class+ Exposed-modules: Text.RJson+ Extensions: FlexibleInstances OverlappingInstances MultiParamTypeClasses FlexibleContexts UndecidableInstances
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/RJson.hs view
@@ -0,0 +1,750 @@+module Text.RJson (TranslateField,+ TranslateFieldD,+ translateField,+ ToJson,+ ToJsonD,+ toJson,+ exclude,+ arrayPrepend,+ arrayAppend,+ objectExtras,+ genericToJson,+ JsonData(..),+ FromJson,+ FromJsonD,+ objectDefaults,+ parseJsonString,+ parseJsonByteString,+ fromJsonString,+ fromJsonByteString,+ genericFromJson,+ stripInitialUnderscores,+ toJsonString,+ Union(..), Union3, Union4, Union5, Union6,+ Union7,Union8,Union9,Union10)+where++import Data.Generics.SYB.WithClass.Basics+import Data.Generics.SYB.WithClass.Instances+import Data.Generics.SYB.WithClass.Context+import Data.Generics.SYB.WithClass.Derive+import qualified Data.Map as M+import qualified Text.Printf as Printf+import Data.Char+import Data.Ratio+import Data.Array+import Data.Maybe+import Control.Monad.State.Strict+import Control.Monad.Trans+import Control.Monad.Error+import qualified Text.ParserCombinators.Parsec as P+import qualified Data.ByteString.Lazy as B+import System.IO.Unsafe+import qualified Control.Exception as E+import Codec.Text.IConv+import qualified Data.Word as W+++-- | A Haskell representation of a JSON+-- data structure.+data JsonData = JDString String |+ JDNumber Double |+ JDArray [JsonData] |+ JDBool Bool |+ JDObject (M.Map String JsonData)++listJoin :: a -> [a] -> [a]+listJoin _ [] = []+listJoin _ l@[x] = l+listJoin k (x:ys) = x : k : (listJoin k ys)++concatJoin :: String -> [String] -> String+concatJoin k l = concat (listJoin k l)++alistToJsonDict :: [(String, String)] -> String+alistToJsonDict l =+ "{" +++ concatJoin "," (map (\(k,v) -> (escapeString k) ++ ":" ++ v) l)+ ++ "}"++-- Special characters which will be pretty printed.+escapeMap :: M.Map Char String+escapeMap = M.fromList [+ ('\\', "\\"), ('"', "\""), ('\'', "'"), ('\n', "n"),+ ('\r', "r"), ('\f', "f"), ('\t', "t"), ('\b', "\b")]+escape :: Char -> Maybe String+escape c = M.lookup c escapeMap++-- Characters which can safely be printed as literals.+allowed' c o+ | o > 127 = True -- Any unicode char is OK.+ | o >= 32 && o < 127 {- exclude DEL == 127 -} && c /= '"' = True+ | True = False+allowed c = allowed' c (ord c)++hexEscape :: Char -> String+hexEscape c = Printf.printf "\\u%04x" (ord c)++escapeString' :: String -> String+escapeString' [] = "\""+escapeString' (c:cs)+ | allowed c =+ c : (escapeString' cs)+ | True =+ (maybe (hexEscape c) (\s -> "\\" ++ s) (escape c)) +++ (escapeString' cs)++escapeString s = '"' : escapeString' s++instance Show JsonData where+ show (JDString s) = escapeString s+ show (JDNumber n)+ -- Show as an integer if possible, otherwise as a Double.+ -- TODO: Not sure if this is the proper way of testing whether a+ -- double is an integer value +/- epsilon.+ | (fromIntegral (floor n)) == n = show (floor n)+ | True = show n+ show (JDBool True) = "true"+ show (JDBool False) = "false"+ show (JDArray l) = "[" ++ concatJoin "," (map show l) ++ "]"+ show (JDObject o) = alistToJsonDict (map (\(k,v) -> (k, show v)) (M.toList o))+++--+-- TranslateField class.+--+class TranslateField a where+ -- | By default, Haskell record field names are converted into+ -- JSON object field names by stripping any initial underscores.+ -- Specialize this method to define a different behavior.+ translateField :: a -> String -> String++data TranslateFieldD a = TranslateFieldD { translateFieldD :: a -> String -> String }++translateFieldProxy :: Proxy TranslateFieldD+translateFieldProxy = error "'translateFieldProxy' value should never be evaluated!"++instance (TranslateField t) => Sat (TranslateFieldD t) where+ dict = TranslateFieldD { translateFieldD = translateField }++-- | Removes initial underscores from a string.+stripInitialUnderscores "" = ""+stripInitialUnderscores ('_':s) = stripInitialUnderscores s+stripInitialUnderscores s = s++instance (Data TranslateFieldD a) => TranslateField a where+ translateField _ x = stripInitialUnderscores x+++--+-- ToJson class plus SYB boilerplate.+--+-- | New instances can be added to this class to customize+-- JSON serialization.+class ToJson a where+ toJson :: a -> JsonData++ -- For lists (same trick used by the Prelude to allow special+ -- handling of list types for Show).+ lToJson :: [a] -> JsonData+ lToJson l = JDArray (map toJson l)++ -- | You can specialize this method to prevent fields from being serialized.+ -- The method should return a list of the Haskell names of the fields to+ -- be excluded.+ exclude :: a -> String -> Bool+ exclude _ _ = False++ -- | Types that will be converted to JSON arrays can override+ -- this method to specify additional elements to be prepended to the array.+ arrayPrepend :: a -> [JsonData]+ arrayPrepend _ = []++ -- | Types that will be converted to JSON arrays can override+ -- this method to specify additional elements to be appended to the array.+ arrayAppend :: a -> [JsonData]+ arrayAppend _ = []++ -- | Types that will be converted to JSON objects can override+ -- this method to specify additional fields of the object.+ objectExtras :: a -> [(String, JsonData)]+ objectExtras _ = []++-- Note the inclusion of translateField from TranslateField.+data ToJsonD a = ToJsonD { toJsonD :: a -> JsonData,+ excludeD :: a -> String -> Bool,+ arrayPrependD :: a -> [JsonData],+ arrayAppendD :: a -> [JsonData],+ objectExtrasD :: a -> [(String, JsonData)],+ translateFieldD' :: a -> String -> String }++toJsonProxy :: Proxy ToJsonD+toJsonProxy = error "'toJsonProxy' value should never be evaluated!"++-- Again, note inclusion of translateField from TranslateField,+-- and TranslateField qualification on variable 't' (in addition+-- to the expected ToJson qualification).+instance (TranslateField t, ToJson t) => Sat (ToJsonD t) where+ dict = ToJsonD { toJsonD = toJson,+ excludeD = exclude,+ arrayPrependD = arrayPrepend,+ arrayAppendD = arrayAppend,+ objectExtrasD = objectExtras,+ translateFieldD' = translateField }+++--+-- Implementations of toJson for different data types.+--+instance ToJson Bool where+ toJson b = JDBool b++instance ToJson Int where+ toJson i = JDNumber (fromIntegral i)+instance ToJson Integer where+ toJson i = JDNumber (fromIntegral i)+--instance Json Float where+-- toJson i = JDNumber (floatToDouble i)+instance ToJson Double where+ toJson i = JDNumber i+instance Integral a => ToJson (Ratio a) where+ toJson i = JDNumber $ (fromIntegral (numerator i)) / (fromIntegral (denominator i))+ +instance ToJson Char where+ lToJson s = JDString s+ toJson c = JDString [c]++instance ToJson a => ToJson (M.Map String a) where+ toJson x = JDObject (M.map toJson x)++instance (Typeable a, ToJson a) => ToJson [a] where+ toJson = lToJson++-- TODO: Add instances for the other array types supported by GHC.+instance (Typeable a, ToJson a, Ix i) => ToJson (Array i a) where+ toJson a = toJson (elems a)++-- | Use this for merging two or more records together.+-- Sensible instances of FromJson and ToJson are already defined for this type.+data Union a b = Union a b deriving Show+-- | Nested Unions are left-branching by convention (since this is what you get+-- by using the constructor as an infix operator).+type Union3 a b c = (Union (Union a b) c)+type Union4 a b c d = (Union (Union3 a b c) d)+type Union5 a b c d e = (Union (Union4 a b c d) e)+type Union6 a b c d e f = (Union (Union5 a b c d e) f)+type Union7 a b c d e f g = (Union (Union6 a b c d e f) g)+type Union8 a b c d e f g h = (Union (Union7 a b c d e f g) h)+type Union9 a b c d e f g h i = (Union (Union8 a b c d e f g h) i)+type Union10 a b c d e f g h i j = (Union (Union9 a b c d e f g h i) j)++-- Used by the (ToJson Union) instance below.+isJDObject (JDObject _) = True+isJDObject _ = False+jdObjectMap (JDObject m) = m++instance (ToJson a, ToJson b) => ToJson (Union a b) where+ toJson (Union x y) =+ let jx = toJson x+ jy = toJson y+ in+ if isJDObject jx && isJDObject jy+ then JDObject (M.union (jdObjectMap jx) (jdObjectMap jy))+ else error "Bad toJson conversion: Attempt to unify JSON values which aren't both objects"++getFields :: Data ToJsonD a => a -> [String]+getFields = constrFields . (toConstr toJsonProxy)++typename x = dataTypeName (dataTypeOf toJsonProxy x)++-- | This is the implementation of 'toJson' for the generic instance declaration,+-- but it's useful to be able to use the same implentation for+-- other instance declarations which override the default implementation+-- of 'exclude'.+genericToJson :: (Data ToJsonD a, ToJson a, TranslateField a) => a -> JsonData+genericToJson x+ | isAlgType (dataTypeOf toJsonProxy x) =+ case (map (translateFieldD' dict x) (filter (not . (excludeD dict x)) (getFields x))) of+ [] -> JDArray $+ arrayPrependD dict x +++ (JDString (dataTypeName (dataTypeOf toJsonProxy x)) :+ (gmapQ toJsonProxy (toJsonD dict) x)) +++ arrayAppendD dict x+ fs -> JDObject (M.fromList (objectExtrasD dict x ++ (zip fs (gmapQ toJsonProxy (toJsonD dict) x))))+ | True =+ error ("Unable to serialize the primitive type '" ++ typename x ++ "'")++instance (Data ToJsonD t, TranslateField t) => ToJson t where+ toJson = genericToJson++-- Instances for tuples up to n=10.+-- Tuples are converted to (hetrogenous) JSON lists.+instance (ToJson a, ToJson b) => ToJson (a, b) where+ toJson (a,b) = JDArray [toJson a, toJson b]+instance (ToJson a, ToJson b, ToJson c) => ToJson (a,b,c) where+ toJson (a,b,c) = JDArray [toJson a, toJson b, toJson c]+instance (ToJson a, ToJson b, ToJson c, ToJson d) => ToJson (a,b,c,d) where+ toJson (a,b,c,d) = JDArray [toJson a, toJson b, toJson c, toJson d]+instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e) => ToJson (a,b,c,d,e) where+ toJson (a,b,c,d,e) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e]+instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f) =>+ ToJson (a,b,c,d,e,f) where+ toJson (a,b,c,d,e,f) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,+ toJson f]+instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g) =>+ ToJson (a,b,c,d,e,f,g) where+ toJson (a,b,c,d,e,f,g) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,+ toJson f, toJson g]+instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g, ToJson h) =>+ ToJson (a,b,c,d,e,f,g,h) where+ toJson (a,b,c,d,e,f,g,h) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,+ toJson f, toJson g, toJson h]+instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g, ToJson h, ToJson i) =>+ ToJson (a,b,c,d,e,f,g,h,i) where+ toJson (a,b,c,d,e,f,g,h,i) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,+ toJson f, toJson g, toJson h, toJson i]+instance (ToJson a, ToJson b, ToJson c, ToJson d, ToJson e, ToJson f, ToJson g, ToJson h, ToJson i, ToJson j) =>+ ToJson (a,b,c,d,e,f,g,h,i,j) where+ toJson (a,b,c,d,e,f,g,h,i,j) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,+ toJson f, toJson g, toJson h, toJson i, toJson j]+++--+-- FromJson+--+class FromJson a where+ fromJson :: a -> JsonData -> Either String a++ -- For lists (same trick used by the Prelude to allow special+ -- handling of list types for Show).+ lFromJson :: a -> JsonData -> Either String [a]+ lFromJson dummy (JDArray l) = mapM (fromJson dummy) l++ -- | In order to specify default values for required fields of a JSON object,+ -- specialize this method in the instance definition for the relevant+ -- datatype.+ objectDefaults :: a -> M.Map String JsonData+ objectDefaults _ = M.empty++data FromJsonD a = FromJsonD { fromJsonD :: a -> JsonData -> Either String a,+ objectDefaultsD :: a -> M.Map String JsonData,+ translateFieldD'' :: a -> String -> String }++fromJsonProxy :: Proxy FromJsonD+fromJsonProxy = error "'fromJsonProxy' should never be evaluated!"++instance (FromJson t, TranslateField t) => Sat (FromJsonD t) where+ dict = FromJsonD { fromJsonD = fromJson,+ objectDefaultsD = objectDefaults,+ translateFieldD'' = translateField }++instance FromJson Char where+ fromJson _ (JDString [c]) = Right c+ fromJson _ _ = Left "Bad fromJson conversion: JSON string not of length 1 to 'Char'"++ lFromJson _ (JDString s) = Right s+ lFromJson _ _ = Left "Bad fromJson conversion: Non-string to 'String'"++instance FromJson a => FromJson [a] where+ fromJson _ x = lFromJson undefined x++instance FromJson Int where+ fromJson _ (JDNumber n)+ | (fromIntegral (floor n)) == n = Right (floor n)+ | True =+ Left "Bad fromJson conversion: number does not approximate an integer ('Int')"+ fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Int'"++instance FromJson Integer where+ fromJson _ (JDNumber n)+ | (fromIntegral (floor n)) == n = Right (floor n)+ | True =+ Left "Bad fromJson conversion: number does not approximate an integer ('Integer')"+ fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Integer'"++instance FromJson Double where+ fromJson _ (JDNumber d) = Right d+ fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Double'"++instance Integral a => FromJson (Ratio a) where+ fromJson _ (JDNumber i) = Right (fromRational (toRational i))+ fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to instance of 'Ratio'"++instance FromJson Bool where+ fromJson _ (JDBool b) = Right b+ fromJson _ _ = Left "Bad fromJson conversion: Non-boolean to 'Bool'"++isRight (Right _) = True+isRight _ = False+fromRight (Right x) = x+-- TODO: Use monads instead of 'ifs' if possible (funky type errors+-- which I haven't figured out yet, something to do with monomorphism+-- in let bindings vs. lambda abstraction?).+instance (FromJson a, FromJson b) => FromJson (Union a b) where+ fromJson _ o@(JDObject _) =+ let r1 = fromJson undefined o+ r2 = fromJson undefined o+ in+ if isRight r1 && isRight r2+ then Right $ Union (fromRight r1) (fromRight r2)+ else Left "Bad fromJson conversion: error constructing subpart of union"+ fromJson _ _ = Left "Bad fromJson conversion: attempt to convert non-object to Union"++tuperror :: Int -> Either String a+tuperror n = Left $ Printf.printf "Bad fromJson conversion: attempt to convert something that was not a list of length %i to a %i-tuple" n n++instance (FromJson a, FromJson b) => FromJson (a,b) where+ fromJson _ (JDArray [x1,x2]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ return (r1,r2)+ fromJson _ _ = tuperror 2+instance (FromJson a, FromJson b, FromJson c) => FromJson (a,b,c) where+ fromJson _ (JDArray [x1,x2,x3]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ return (r1,r2,r3)+ fromJson _ _ = tuperror 3+instance (FromJson a, FromJson b, FromJson c, FromJson d) => FromJson(a,b,c,d) where+ fromJson _ (JDArray [x1,x2,x3,x4]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ return (r1,r2,r3,r4)+ fromJson _ _ = tuperror 4+instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e) => FromJson (a,b,c,d,e) where+ fromJson _ (JDArray [x1,x2,x3,x4,x5]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ r5 <- fromJson undefined x5+ return (r1,r2,r3,r4,r5)+ fromJson _ _ = tuperror 5+instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f) =>+ FromJson (a,b,c,d,e,f) where+ fromJson _ (JDArray [x1,x2,x3,x4,x5,x6]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ r5 <- fromJson undefined x5+ r6 <- fromJson undefined x6+ return (r1,r2,r3,r4,r5,r6)+ fromJson _ _ = tuperror 6+instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g) =>+ FromJson (a,b,c,d,e,f,g) where+ fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ r5 <- fromJson undefined x5+ r6 <- fromJson undefined x6+ r7 <- fromJson undefined x7+ return (r1,r2,r3,r4,r5,r6,r7)+ fromJson _ _ = tuperror 7+instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g, FromJson h) =>+ FromJson (a,b,c,d,e,f,g,h) where+ fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7,x8]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ r5 <- fromJson undefined x5+ r6 <- fromJson undefined x6+ r7 <- fromJson undefined x7+ r8 <- fromJson undefined x8+ return (r1,r2,r3,r4,r5,r6,r7,r8)+ fromJson _ _ = tuperror 8+instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g, FromJson h, FromJson i) =>+ FromJson (a,b,c,d,e,f,g,h,i) where+ fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7,x8,x9]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ r5 <- fromJson undefined x5+ r6 <- fromJson undefined x6+ r7 <- fromJson undefined x7+ r8 <- fromJson undefined x8+ r9 <- fromJson undefined x9+ return (r1,r2,r3,r4,r5,r6,r7,r8,r9)+ fromJson _ _ = tuperror 9+instance (FromJson a, FromJson b, FromJson c, FromJson d, FromJson e, FromJson f, FromJson g, FromJson h, FromJson i, FromJson j) =>+ FromJson (a,b,c,d,e,f,g,h,i,j) where+ fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10]) = do+ r1 <- fromJson undefined x1+ r2 <- fromJson undefined x2+ r3 <- fromJson undefined x3+ r4 <- fromJson undefined x4+ r5 <- fromJson undefined x5+ r6 <- fromJson undefined x6+ r7 <- fromJson undefined x7+ r8 <- fromJson undefined x8+ r9 <- fromJson undefined x9+ r10 <- fromJson undefined x10+ return (r1,r2,r3,r4,r5,r6,r7,r8,r9,r10)+ fromJson _ _ = tuperror 10++elemsOfMap :: Ord k => M.Map k v -> [k] -> Maybe [v]+elemsOfMap _ [] = Just []+elemsOfMap m (x:xs) = do+ r <- M.lookup x m+ rs <- elemsOfMap m xs+ return (r : rs)++type ErrorWithState e s a = ErrorT e (State s) a++-- TODO: Not a very descriptive name. Oh well...+m1 :: (Data FromJsonD a) => a -> ErrorWithState String [JsonData] a+m1 dummy = do+ jvl <- lift get+ (case jvl of+ [] -> throwError "Bad fromJson conversion: Not enough elements in JSON array to satisfy constructor"+ (jv:jvs) -> do+ lift $ put jvs+ (case fromJsonD dict dummy jv of+ Left e -> throwError e+ Right x -> return x))++-- TODO: Again, uninformative name.+-- TODO: Some code duplication here.+m2 :: (Data FromJsonD a) => M.Map String JsonData -> a -> ErrorWithState String (M.Map String JsonData, [String]) a+m2 defaults dummy = do+ (m, sl) <- lift get+ (case sl of+ [] -> throwError "Bad fromJson conversion: Not enough fields in JSON object to satisfy constructor"+ (f:fs) -> do+ lift $ put (m, fs)+ let stripped = translateFieldD'' dict dummy f+ (case M.lookup stripped m of+ Nothing ->+ case M.lookup stripped defaults of+ Nothing -> throwError $ "Bad fromJson conversion: Required field not present in JSON object" ++ stripped+ Just v ->+ case fromJsonD dict dummy v of+ Left e -> throwError e+ Right x -> return x+ Just v ->+ case fromJsonD dict dummy v of+ Left e -> throwError e+ Right x -> return x))++genericFromJson :: Data FromJsonD a => a -> JsonData -> Either String a+genericFromJson _ (JDArray []) = Left "Bad fromJson conversion: JSON array must contain at least one element"+genericFromJson dummy (JDArray l) =+ case datarep (dataTypeOf fromJsonProxy dummy) of+ AlgRep (c:_) ->+ evalState (runErrorT (gmapM fromJsonProxy m1 (fromConstr fromJsonProxy c))) (tail l)+ AlgRep _ -> Left "Bad fromJson conversion: Type with no constructors!"+ _ -> Left "Bad fromJson conversion: Non-algebraic datatype given to 'genericFromJson'"+genericFromJson dummy (JDObject m) =+ case datarep (dataTypeOf fromJsonProxy dummy) of+ AlgRep (c:_) ->+ case constrFields c of+ [] -> Left "Bad fromJson conversion: Attempt to convert JDObect to a non-record algebraic type"+ fs -> evalState (runErrorT (gmapM fromJsonProxy (m2 (objectDefaultsD dict dummy)) (fromConstr fromJsonProxy c))) (m, fs)+ AlgRep _ -> Left "Bad fromJson conversion: Type with no constructors!"+ _ -> Left "Bad fromJson conversion: Non-algebraic datatype given to 'genericFromJson'"+ +instance (Data FromJsonD t) => FromJson t where+ fromJson = genericFromJson+++--+-- JSON parser.+--++-- Determine the unicode encoding of a byte stream+-- on the assumption that it begins with two ASCII characters.+getEncoding :: B.ByteString -> EncodingName+getEncoding s+ | B.length s < 4 = "UTF-8" -- If the string is shorter than 4 bytes,+ -- we have no way of determining the encoding.+ | True =+ let bs1 = B.index s 0+ bs2 = B.index s 1+ bs3 = B.index s 2+ bs4 = B.index s 3+ in+ -- Little endian UTF 32/16.+ if bs1 /= 0 && bs2 == 0 && bs3 == 0 && bs4 == 0+ then "UTF-32LE"+ else if bs1 /= 0 && bs2 == 0 && bs3 /= 0 && bs4 == 0+ then "UTF-16LE"+ -- Big endian UTF 32/16.+ else if bs1 == 0 && bs2 == 0 && bs3 == 0 && bs4 /= 0+ then "UTF-32BE"+ else if bs1 == 0 && bs2 /= 0 && bs3 == 0 && bs4 /= 0+ then "UTF-16BE"+ -- UTF-8+ else if bs1 /= 0 && bs2 /= 0 && bs3 /= 0 && bs4 /= 0+ then "UTF-8" -- BOM allowed but not required for UTF-8.+ -- If we can't figure it out, guess at UTF-8.+ else "UTF-8"++-- Converts a String of byte values of given encoding to a String of unicode code points.+toHaskellString :: EncodingName -> B.ByteString -> String+toHaskellString enc source =+ stripBOM $ map chr (pairBytes (B.unpack bs))+ where+ pairBytes :: [W.Word8] -> [Int]+ pairBytes [] = []+ pairBytes (c:c':cs) = ((fromIntegral c) + (fromIntegral c')*256) : (pairBytes cs)+ bs = convertFuzzy Discard enc "UTF-16LE" source++stripBOM :: String -> String+stripBOM ('\0':'\0':'\xFE':'\xFF':cs) = cs+stripBOM ('\xFF':'\xFE':'\0':'\0':cs) = cs+stripBOM ('\xFE':'\xFF':cs) = cs+stripBOM ('\xFF':'\xFE':cs) = cs+stripBOM ('\xEF':'\xBB':'\xBF':cs) = cs+stripBOM cs = cs++(<|>) = (P.<|>)++-- | Converts a ByteString to an instance of JsonData (unicode encoding+-- is detected automatically).+parseJsonByteString :: B.ByteString -> Either String JsonData+parseJsonByteString bs =+ let+ decoded = toHaskellString (getEncoding bs) bs+ in+ case P.runParser (ws >> jsonValue) () "" decoded of+ Left e -> Left (show e)+ Right x -> Right x++-- | Converts a String (interpreted as a true unicode String) to an instance+-- of JsonData.+parseJsonString :: String -> Either String JsonData+parseJsonString s =+ case P.runParser (ws >> jsonValue) () "" s of+ Left e -> Left (show e)+ Right x -> Right x++apply f p = do+ r <- p+ return (f r)++pconcat p1 p2 = do+ l1 <- p1+ l2 <- p2+ return $ l1 ++ l2++listify :: P.Parser x -> P.Parser [x]+listify = apply (:[])++ws = P.many (P.oneOf [' ','\r','\n','\t','\f','\v'])++-- Could use the ParsecToken module, but trying a floating point number+-- then an integer is a bit inefficient (especially since integers will+-- be more common).+number :: P.Parser JsonData+number = do+ i <- P.many1 P.digit+ point <- P.option Nothing (apply Just (P.char '.' >> P.many1 P.digit))+ exponent <- P.option Nothing (apply Just (P.char 'e' >> pconcat (P.option "" (listify (P.char '-'))) (P.many1 P.digit)))+ (if point == Nothing && exponent == Nothing+ then return (JDNumber (read i :: Double))+ else return (+ JDNumber (+ read (i ++ (if point == Nothing then "" else "." ++ fromJust point) +++ (if exponent == Nothing then "" else "e" ++ fromJust exponent))+ :: Double+ )))++stringChar :: Char -> P.Parser Char+stringChar opener = do+ -- Fail immediately on either single or double quotes or+ -- on control characters.+ c <- P.satisfy (\c -> c /= opener && (ord c) > 31)+ (case c of+ '\\' ->+ (P.char '"' >> return '"') <|>+ (P.char '\'' >> return '\'') <|>+ (P.char 'b' >> return '\b') <|>+ (P.char 'f' >> return '\f') <|>+ (P.char 'n' >> return '\n') <|>+ (P.char 'r' >> return '\r') <|>+ (P.char 't' >> return '\t') <|>+ (do+ P.char 'u'+ ds <- P.count 4 P.hexDigit+ return $ chr (read ("0x" ++ ds) :: Int)) <|>+ (P.satisfy allowed >>= return) -- "\X" == "X" by default.+ c -> return c)++string :: P.Parser String+string = do+ opener <- P.char '"' <|> P.char '\'' -- JSON spec requires double quotes, but we'll be lenient.+ cs <- P.many (stringChar opener)+ P.char opener+ return cs++jsonString = apply JDString string++kvp :: P.Parser (String, JsonData)+kvp = do+ s <- string+ ws+ P.char ':'+ ws+ v <- jsonValue+ return (s, v)++jsonArray :: P.Parser JsonData+jsonArray = do+ P.char '['+ ws+ vs <- P.sepBy jsonValue (ws >> P.char ',' >> ws)+ ws+ P.char ']'+ return $ JDArray vs++object :: P.Parser JsonData+object = do+ P.char '{'+ ws+ kvps <- P.sepBy kvp (ws >> P.char ',' >> ws)+ ws+ P.char '}'+ return $ JDObject $ M.fromList kvps++boolean :: P.Parser JsonData+boolean = (P.try (P.string "true") >> return (JDBool True)) <|>+ (P.string "false" >> return (JDBool False))++jsonValue = number <|> jsonString <|> jsonArray <|> object <|> boolean+++--+-- Some other utilities.+--+-- | Converts a JSON String (interpreted as a true unicode string) to+-- a value of the type given by the first (dummy) argument.+fromJsonString :: FromJson a => a -> String -> Either String a+fromJsonString dummy s =+ case parseJsonString s of+ Left e -> Left (show e)+ Right js ->+ case fromJson dummy js of+ Left e -> Left e+ Right js -> Right js++-- | Converts a JSON ByteString (with unicode encoding automatically detected)+-- to a value of the type given by the first (dummy) argument.+fromJsonByteString :: FromJson a => a -> B.ByteString -> Either String a+fromJsonByteString dummy s =+ case parseJsonByteString s of+ Left e -> Left (show e)+ Right js ->+ case fromJson dummy js of+ Left e -> Left e+ Right js -> Right js++-- | Converts a value to an ASCII-only JSON String.+toJsonString :: ToJson a => a -> String+toJsonString = show . toJson