aeson 0.3.2.11 → 0.3.2.12
raw patch · 7 files changed
+1073/−316 lines, 7 filesdep +template-haskelldep ~basedep ~containersdep ~deepseqPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: template-haskell
Dependency ranges changed: base, containers, deepseq
API changes (from Hackage documentation)
+ Data.Aeson.Parser: jstring :: Parser Text
+ Data.Aeson.TH: deriveFromJSON :: (String -> String) -> Name -> Q [Dec]
+ Data.Aeson.TH: deriveJSON :: (String -> String) -> Name -> Q [Dec]
+ Data.Aeson.TH: deriveToJSON :: (String -> String) -> Name -> Q [Dec]
+ Data.Aeson.TH: mkParseJSON :: (String -> String) -> Name -> Q Exp
+ Data.Aeson.TH: mkToJSON :: (String -> String) -> Name -> Q Exp
+ Data.Aeson.Types: genericFromJSON :: Data a => Value -> Result a
+ Data.Aeson.Types: genericToJSON :: Data a => a -> Value
+ Data.Aeson.Types: instance [incoherent] (Prim a, FromJSON a) => FromJSON (Vector a)
+ Data.Aeson.Types: instance [incoherent] (Prim a, ToJSON a) => ToJSON (Vector a)
+ Data.Aeson.Types: instance [incoherent] (Storable a, FromJSON a) => FromJSON (Vector a)
+ Data.Aeson.Types: instance [incoherent] (Storable a, ToJSON a) => ToJSON (Vector a)
+ Data.Aeson.Types: instance [incoherent] (Vector Vector a, FromJSON a) => FromJSON (Vector a)
+ Data.Aeson.Types: instance [incoherent] (Vector Vector a, ToJSON a) => ToJSON (Vector a)
Files
- Data/Aeson/Generic.hs +5/−307
- Data/Aeson/Parser.hs +1/−0
- Data/Aeson/TH.hs +611/−0
- Data/Aeson/Types.hs +365/−7
- aeson.cabal +8/−2
- examples/Demo.hs +70/−0
- tests/Properties.hs +13/−0
Data/Aeson/Generic.hs view
@@ -20,313 +20,11 @@ , toJSON ) where -import Control.Applicative ((<$>))-import Control.Arrow (first)-import Control.Monad.State.Strict-import Data.Aeson.Functions-import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)-import Data.Attoparsec.Number (Number)-import Data.Generics-import Data.Hashable (Hashable)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.IntSet (IntSet)-import Data.Maybe (fromJust)-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding (encodeUtf8)-import Data.Time.Clock (UTCTime)-import Data.Word (Word, Word8, Word16, Word32, Word64)-import qualified Data.Aeson.Types as T-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.HashMap.Strict as H-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as DT-import qualified Data.Text.Lazy as LT-import qualified Data.Traversable as T-import qualified Data.Vector as V--type T a = a -> Value--toJSON :: (Data a) => a -> Value-toJSON = toJSON_generic- `ext1Q` list- `ext1Q` vector- `ext1Q` set- `ext2Q'` mapAny- `ext2Q'` hashMapAny- -- Use the standard encoding for all base types.- `extQ` (T.toJSON :: T Integer)- `extQ` (T.toJSON :: T Int)- `extQ` (T.toJSON :: T Int8)- `extQ` (T.toJSON :: T Int16)- `extQ` (T.toJSON :: T Int32)- `extQ` (T.toJSON :: T Int64)- `extQ` (T.toJSON :: T Word)- `extQ` (T.toJSON :: T Word8)- `extQ` (T.toJSON :: T Word16)- `extQ` (T.toJSON :: T Word32)- `extQ` (T.toJSON :: T Word64)- `extQ` (T.toJSON :: T Double)- `extQ` (T.toJSON :: T Number)- `extQ` (T.toJSON :: T Float)- `extQ` (T.toJSON :: T Rational)- `extQ` (T.toJSON :: T Char)- `extQ` (T.toJSON :: T Text)- `extQ` (T.toJSON :: T LT.Text)- `extQ` (T.toJSON :: T String)- `extQ` (T.toJSON :: T B.ByteString)- `extQ` (T.toJSON :: T L.ByteString)- `extQ` (T.toJSON :: T T.Value)- `extQ` (T.toJSON :: T DotNetTime)- `extQ` (T.toJSON :: T UTCTime)- `extQ` (T.toJSON :: T IntSet)- `extQ` (T.toJSON :: T Bool)- `extQ` (T.toJSON :: T ())- --`extQ` (T.toJSON :: T Ordering)- where- list xs = Array . V.fromList . map toJSON $ xs- vector v = Array . V.map toJSON $ v- set s = Array . V.fromList . map toJSON . Set.toList $ s-- mapAny m- | tyrep == typeOf DT.empty = remap id- | tyrep == typeOf LT.empty = remap LT.toStrict- | tyrep == typeOf "" = remap pack- | tyrep == typeOf B.empty = remap decode- | tyrep == typeOf L.empty = remap strict- | otherwise = modError "toJSON" $- "cannot convert map keyed by type " ++ show tyrep- where tyrep = typeOf . head . Map.keys $ m- remap f = Object . transformMap (f . fromJust . cast) toJSON $ m-- hashMapAny m- | tyrep == typeOf DT.empty = remap id- | tyrep == typeOf LT.empty = remap LT.toStrict- | tyrep == typeOf "" = remap pack- | tyrep == typeOf B.empty = remap decode- | tyrep == typeOf L.empty = remap strict- | otherwise = modError "toJSON" $- "cannot convert map keyed by type " ++ show tyrep- where tyrep = typeOf . head . H.keys $ m- remap f = Object . hashMap (f . fromJust . cast) toJSON $ m---toJSON_generic :: (Data a) => a -> Value-toJSON_generic = generic- where- -- Generic encoding of an algebraic data type.- generic a =- case dataTypeRep (dataTypeOf a) of- -- No constructor, so it must be an error value. Code- -- it anyway as Null.- AlgRep [] -> Null- -- Elide a single constructor and just code the arguments.- AlgRep [c] -> encodeArgs c (gmapQ toJSON a)- -- For multiple constructors, make an object with a- -- field name that is the constructor (except lower- -- case) and the data is the arguments encoded.- AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a)- rep -> err (dataTypeOf a) rep- where- err dt r = modError "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 [] = String . constrString $ c- encodeConstr c as = object [(constrString c, encodeArgs c as)]-- constrString = pack . showConstr-- encodeArgs c = encodeArgs' (constrFields c)- encodeArgs' [] [j] = j- encodeArgs' [] js = Array . V.fromList $ js- encodeArgs' ns js = object $ zip (map mungeField ns) js-- -- Skip leading '_' in field name so we can use keywords- -- etc. as field names.- mungeField ('_':cs) = pack cs- mungeField cs = pack cs+import Data.Aeson.Types (Value, Result, genericFromJSON, genericToJSON)+import Data.Data (Data) fromJSON :: (Data a) => Value -> Result a-fromJSON = parse parseJSON--type F a = Parser a--parseJSON :: (Data a) => Value -> Parser a-parseJSON j = parseJSON_generic j- `ext1R` list- `ext1R` vector- `ext2R'` mapAny- `ext2R'` hashMapAny- -- Use the standard encoding for all base types.- `extR` (value :: F Integer)- `extR` (value :: F Int)- `extR` (value :: F Int8)- `extR` (value :: F Int16)- `extR` (value :: F Int32)- `extR` (value :: F Int64)- `extR` (value :: F Word)- `extR` (value :: F Word8)- `extR` (value :: F Word16)- `extR` (value :: F Word32)- `extR` (value :: F Word64)- `extR` (value :: F Double)- `extR` (value :: F Number)- `extR` (value :: F Float)- `extR` (value :: F Rational)- `extR` (value :: F Char)- `extR` (value :: F Text)- `extR` (value :: F LT.Text)- `extR` (value :: F String)- `extR` (value :: F B.ByteString)- `extR` (value :: F L.ByteString)- `extR` (value :: F T.Value)- `extR` (value :: F DotNetTime)- `extR` (value :: F UTCTime)- `extR` (value :: F IntSet)- `extR` (value :: F Bool)- `extR` (value :: F ())- where- value :: (T.FromJSON a) => Parser a- value = T.parseJSON j- list :: (Data a) => Parser [a]- list = V.toList <$> parseJSON j- vector :: (Data a) => Parser (V.Vector a)- vector = case j of- Array js -> V.mapM parseJSON js- _ -> myFail- mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)- mapAny- | tyrep `elem` stringyTypes = res- | otherwise = myFail- where res = case j of- Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js- _ -> myFail- trans- | tyrep == typeOf DT.empty = remap id- | tyrep == typeOf LT.empty = remap LT.fromStrict- | tyrep == typeOf "" = remap DT.unpack- | tyrep == typeOf B.empty = remap encodeUtf8- | tyrep == typeOf L.empty = remap lazy- | otherwise = modError "parseJSON"- "mapAny -- should never happen"- tyrep = typeOf (undefined :: f)- remap f = fromJust . cast . f- hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)- hashMapAny- | tyrep == typeOf "" = process DT.unpack- | tyrep == typeOf LT.empty = process LT.fromStrict- | tyrep == typeOf DT.empty = process id- | otherwise = myFail- where- process f = maybe myFail return . cast =<< parseWith f- parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)- parseWith f = case j of- Object js -> H.fromList . map (first f) . Map.toList <$>- T.mapM parseJSON js- _ -> myFail- tyrep = typeOf (undefined :: f)- myFail = modFail "parseJSON" $ "bad data: " ++ show j- stringyTypes = [typeOf LT.empty, typeOf DT.empty, typeOf B.empty, - typeOf L.empty, typeOf ""]--parseJSON_generic :: (Data a) => Value -> Parser a-parseJSON_generic j = generic- where- typ = dataTypeOf $ resType generic- generic = case dataTypeRep typ of- AlgRep [] -> case j of- Null -> return (modError "parseJSON" "empty type")- _ -> modFail "parseJSON" "no-constr bad data"- AlgRep [_] -> decodeArgs (indexConstr typ 1) j- AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'- rep -> modFail "parseJSON" $- show rep ++ "(" ++ show typ ++ ")"- getConstr t (Object o) | [(s, j')] <- fromJSObject o = do- c <- readConstr' t s- return (c, j')- getConstr t (String js) = do c <- readConstr' t (unpack js)- return (c, Null) -- handle nullary ctor- getConstr _ _ = modFail "parseJSON" "bad constructor encoding"- readConstr' t s =- maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++- show t)- return $ readConstr t s-- decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0- (constrFields c0)- where- go 0 c _ Null = construct c [] -- nullary constructor- go 1 c [] jd = construct c [jd] -- unary constructor- go n c [] (Array js)- | n > 1 = construct c (V.toList js) -- no field names- -- FIXME? We could allow reading an array into a constructor- -- with field names.- go _ c fs@(_:_) (Object o) = selectFields o fs >>=- construct c -- field names- go _ c _ jd = modFail "parseJSON" $- "bad decodeArgs data " ++ show (c, jd)-- fromJSObject = map (first unpack) . Map.toList-- -- Build the value by stepping through the list of subparts.- construct c = evalStateT $ fromConstrM f c- where f :: (Data a) => StateT [Value] Parser a- f = do js <- get- case js of- [] -> lift $ modFail "construct" "empty list"- (j':js') -> do put js'; lift $ parseJSON j'-- -- Select the named fields from a JSON object.- selectFields fjs = mapM sel- where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++- f) return $ Map.lookup (pack 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 :: MonadPlus m => m a -> a- resType _ = modError "parseJSON" "resType"--modFail :: (Monad m) => String -> String -> m a-modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err--modError :: String -> String -> a-modError func err = error $ "Data.Aeson.Generic." ++ func ++ ": " ++ err----- Type extension for binary type constructors.---- | Flexible type extension-ext2' :: (Data a, Typeable2 t)- => c a- -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))- -> c a-ext2' def ext = maybe def id (dataCast2 ext)---- | Type extension of queries for type constructors-ext2Q' :: (Data d, Typeable2 t)- => (d -> q)- -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)- -> d -> q-ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))---- | Type extension of readers for type constructors-ext2R' :: (Monad m, Data d, Typeable2 t)- => m d- -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))- -> m d-ext2R' def ext = unR ((R def) `ext2'` (R ext))---- | The type constructor for queries-newtype Q q x = Q { unQ :: x -> q }+fromJSON = genericFromJSON --- | The type constructor for readers-newtype R m x = R { unR :: m x }+toJSON :: (Data a) => a -> Value+toJSON = genericToJSON
Data/Aeson/Parser.hs view
@@ -15,6 +15,7 @@ ( json , value+ , jstring ) where import Blaze.ByteString.Builder (fromByteString, toByteString)
+ Data/Aeson/TH.hs view
@@ -0,0 +1,611 @@+{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}++{-|+Module: Data.Aeson.TH+License: Apache+Stability: experimental+Portability: portable++Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that+you need to enable the @TemplateHaskell@ language extension in order to use this+module.++An example shows how instances are generated for arbitrary data types. First we+define a data type:++@+data D a = Nullary+ | Unary Int+ | Product String Char a+ | Record { testOne :: Double+ , testTwo :: Bool+ , testThree :: D a+ } deriving Eq+@++Next we derive the necessary instances. Note that we make use of the feature to+change record field names. In this case we drop the first 4 characters of every+field name.++@+$('deriveJSON' ('drop' 4) ''D)+@++This will result in the following (simplified) code to be spliced in your program:++@+import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Aeson.TH+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Vector as V++instance 'ToJSON' a => 'ToJSON' (D a) where+ 'toJSON' =+ \value ->+ case value of+ Nullary ->+ 'object' ['T.pack' \"Nullary\" .= 'toJSON' ([] :: [()])]+ Unary arg1 ->+ 'object' ['T.pack' \"Unary\" .= 'toJSON' arg1]+ Product arg1 arg2 arg3 ->+ 'object' [ 'T.pack' \"Product\"+ .= 'toJSON' [ 'toJSON' arg1+ , 'toJSON' arg2+ , 'toJSON' arg3+ ]+ ]+ Record arg1 arg2 arg3 ->+ 'object' [ 'T.pack' \"Record\"+ .= 'object' [ 'T.pack' \"One\" '.=' arg1+ , 'T.pack' \"Two\" '.=' arg2+ , 'T.pack' \"Three\" '.=' arg3+ ]+ ]+@++@+instance 'FromJSON' a => 'FromJSON' (D a) where+ 'parseJSON' =+ \value ->+ case value of+ 'Object' obj ->+ case 'M.toList' obj of+ [(conKey, conVal)] ->+ case conKey of+ _ | (conKey '==' 'T.pack' \"Nullary\") ->+ case conVal of+ 'Array' arr | 'V.null' arr -> 'pure' Nullary+ _ -> 'mzero'+ | (conKey '==' 'T.pack' \"Unary\") ->+ case conVal of+ arg -> Unary '<$>' 'parseJSON' arg+ | (conKey '==' 'T.pack' \"Product\") ->+ case conVal of+ 'Array' arr | 'V.length' arr '==' 3 ->+ 'Product' '<$>' 'parseJSON' (arr 'V.!' 0)+ '<*>' 'parseJSON' (arr 'V.!' 1)+ '<*>' 'parseJSON' (arr 'V.!' 2)+ _ -> 'mzero'+ | (conKey '==' 'T.pack' \"Record\") ->+ case conVal of+ 'Object' obj ->+ Record '<$>' (obj '.:' 'T.pack' \"One\")+ '<*>' (obj '.:' 'T.pack' \"Two\")+ '<*>' (obj '.:' 'T.pack' \"Three\")+ _ -> 'mzero'+ | 'otherwise' -> 'mzero'+ _ -> 'mzero'+ _ -> 'mzero'+@++Now we can use the newly created instances.++@+d :: D 'Int'+d = Record { testOne = 3.14159+ , testTwo = 'True'+ , testThree = Product \"test\" \'A\' 123+ }+@++>>> fromJSON (toJSON d) == Success d+> True++-}++module Data.Aeson.TH+ ( deriveJSON++ , deriveToJSON+ , deriveFromJSON++ , mkToJSON+ , mkParseJSON+ ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from aeson:+import Data.Aeson ( toJSON, object, (.=), (.:)+ , ToJSON, toJSON+ , FromJSON, parseJSON+ )+import Data.Aeson.Types ( Value(..) )+-- from base:+import Control.Applicative ( pure, (<$>), (<*>) )+import Control.Monad ( return, mapM, mzero, liftM2 )+import Data.Bool ( otherwise )+import Data.Eq ( (==) )+import Data.Function ( ($), (.), id )+import Data.Functor ( fmap )+import Data.List ( (++), foldl', map, zip, genericLength )+import Prelude ( String, (-), Integer, error )+import Text.Show ( show )+#if __GLASGOW_HASKELL__ < 700+import Control.Monad ( (>>=), fail )+import Prelude ( fromInteger )+#endif+-- from containers:+import qualified Data.Map as M ( toList )+-- from template-haskell:+import Language.Haskell.TH+-- from text:+import qualified Data.Text as T ( pack )+-- from vector:+import qualified Data.Vector as V ( (!), null, length )++++--------------------------------------------------------------------------------+-- Convenience+--------------------------------------------------------------------------------++-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given+-- data type.+--+-- This is a convienience function which is equivalent to calling both+-- 'deriveToJSON' and 'deriveFromJSON'.+deriveJSON :: (String -> String)+ -- ^ Function to change field names.+ -> Name+ -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'+ -- instances.+ -> Q [Dec]+deriveJSON withField name =+ liftM2 (++)+ (deriveToJSON withField name)+ (deriveFromJSON withField name)+++--------------------------------------------------------------------------------+-- ToJSON+--------------------------------------------------------------------------------++{-+TODO: Don't constrain phantom type variables.++data Foo a = Foo Int+instance (ToJSON a) ⇒ ToJSON Foo where ...++The above (ToJSON a) constraint is not necessary and perhaps undesirable.+-}++-- | Generates a 'ToJSON' instance declaration for the given data type.+--+-- Example:+--+-- @+-- data Foo = Foo 'Char' 'Int'+-- $('deriveToJSON' 'id' ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- instance 'ToJSON' Foo where+-- 'toJSON' =+-- \value -> case value of+-- Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]+-- @+deriveToJSON :: (String -> String)+ -- ^ Function to change field names.+ -> Name+ -- ^ Name of the type for which to generate a 'ToJSON' instance+ -- declaration.+ -> Q [Dec]+deriveToJSON withField name =+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec+ fromCons tvbs cons =+ instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)+ (classType `appT` instanceType)+ [ funD 'toJSON+ [ clause []+ (normalB $ consToJSON withField cons)+ []+ ]+ ]+ where+ classType = conT ''ToJSON+ typeNames = map tvbName tvbs+ instanceType = foldl' appT (conT name) $ map varT typeNames++-- | Generates a lambda expression which encodes the given data type as JSON.+--+-- Example:+--+-- @+-- data Foo = Foo 'Int'+-- @+--+-- @+-- encodeFoo :: Foo -> 'Value'+-- encodeFoo = $('mkToJSON' 'id' ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- \value -> case value of Foo arg1 -> 'toJSON' arg1+-- @+mkToJSON :: (String -> String) -- ^ Function to change field names.+ -> Name -- ^ Name of the type to encode.+ -> Q Exp+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)++-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code+-- to generate the JSON encoding of a number of constructors. All constructors+-- must be from the same type.+consToJSON :: (String -> String)+ -- ^ Function to change field names.+ -> [Con]+ -- ^ Constructors for which to generate JSON generating code.+ -> Q Exp+consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "+ ++ "Not a single constructor given!"+-- A single constructor is directly encoded. The constructor itself may be+-- forgotten.+consToJSON withField [con] = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ [encodeArgs id withField con]+-- With multiple constructors we need to remember which constructor is+-- encoded. This is done by generating a JSON object which maps to constructor's+-- name to the JSON encoding of its contents.+consToJSON withField cons = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ [ encodeArgs (wrap $ getConName con) withField con+ | con <- cons+ ]+ where+ wrap :: Name -> Q Exp -> Q Exp+ wrap name exp =+ let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)+ in [e|object|] `appE` listE [ infixApp fieldName+ [e|(.=)|]+ exp+ ]++-- | Generates code to generate the JSON encoding of a single constructor.+encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match+-- Nullary constructors. Generates code that explicitly matches against the+-- constructor even though it doesn't contain data. This is useful to prevent+-- type errors.+encodeArgs withExp _ (NormalC conName []) =+ match (conP conName [])+ (normalB $ withExp [e|toJSON ([] :: [()])|])+ []+-- Polyadic constructors with special case for unary constructors.+encodeArgs withExp _ (NormalC conName ts) = do+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]+ let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of+ -- Single argument is directly converted.+ [e] -> e+ -- Multiple arguments are converted to a JSON array.+ es -> [e|toJSON|] `appE` listE es+ match (conP conName $ map varP args)+ (normalB $ withExp js)+ []+-- Records.+encodeArgs withExp withField (RecC conName ts) = do+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]+ let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)+ [e|(.=)|]+ (varE arg)+ | (arg, (field, _, _)) <- zip args ts+ ]+ match (conP conName $ map varP args)+ (normalB $ withExp $ [e|object|] `appE` listE js)+ []+-- Infix constructors.+encodeArgs withExp _ (InfixC _ conName _) = do+ al <- newName "argL"+ ar <- newName "argR"+ match (infixP (varP al) conName (varP ar))+ ( normalB+ $ withExp+ $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a+ | a <- [al,ar]+ ]+ )+ []+-- Existentially quantified constructors.+encodeArgs withExp withField (ForallC _ _ con) =+ encodeArgs withExp withField con+++--------------------------------------------------------------------------------+-- FromJSON+--------------------------------------------------------------------------------++-- | Generates a 'FromJSON' instance declaration for the given data type.+--+-- Example:+--+-- @+-- data Foo = Foo 'Char' 'Int'+-- $('deriveFromJSON' 'id' ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- instance 'FromJSON' Foo where+-- 'parseJSON' =+-- \value -> case value of+-- 'Array' arr | ('V.length' arr '==' 2) ->+-- Foo '<$>' 'parseJSON' (arr 'V.!' 0)+-- '<*>' 'parseJSON' (arr 'V.!' 1)+-- _ -> 'mzero'+-- @+deriveFromJSON :: (String -> String)+ -- ^ Function to change field names.+ -> Name+ -- ^ Name of the type for which to generate a 'FromJSON' instance+ -- declaration.+ -> Q [Dec]+deriveFromJSON withField name =+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec+ fromCons tvbs cons =+ instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)+ (classType `appT` instanceType)+ [ funD 'parseJSON+ [ clause []+ (normalB $ consFromJSON withField cons)+ []+ ]+ ]+ where+ classType = conT ''FromJSON+ typeNames = map tvbName tvbs+ instanceType = foldl' appT (conT name) $ map varT typeNames++-- | Generates a lambda expression which parses the JSON encoding of the given+-- data type.+--+-- Example:+--+-- @+-- data Foo = Foo 'Int'+-- @+--+-- @+-- parseFoo :: 'Value' -> 'Parser' Foo+-- parseFoo = $('mkParseJSON' 'id' ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- \\value -> case value of arg -> Foo '<$>' 'parseJSON' arg+-- @+mkParseJSON :: (String -> String) -- ^ Function to change field names.+ -> Name -- ^ Name of the encoded type.+ -> Q Exp+mkParseJSON withField name =+ withType name (\_ cons -> consFromJSON withField cons)++-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates+-- code to parse the JSON encoding of a number of constructors. All constructors+-- must be from the same type.+consFromJSON :: (String -> String)+ -- ^ Function to change field names.+ -> [Con]+ -- ^ Constructors for which to generate JSON parsing code.+ -> Q Exp+consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: "+ ++ "Not a single constructor given!"+consFromJSON withField [con] = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ (parseArgs withField con)+consFromJSON withField cons = do+ value <- newName "value"+ obj <- newName "obj"+ conKey <- newName "conKey"+ conVal <- newName "conVal"++ let -- Convert the Data.Map inside the Object to a list and pattern match+ -- against it. It must contain a single element otherwise the parse will+ -- fail.+ caseLst = caseE ([e|M.toList|] `appE` varE obj)+ [ match (listP [tupP [varP conKey, varP conVal]])+ (normalB caseKey)+ []+ , errorMatch+ ]+ caseKey = caseE (varE conKey)+ [match wildP (guardedB guards) []]+ guards = [ do g <- normalG $ infixApp (varE conKey)+ [|(==)|]+ ( [|T.pack|]+ `appE` conNameExp con+ )+ e <- caseE (varE conVal)+ (parseArgs withField con)+ return (g, e)+ | con <- cons+ ]+ +++ [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]]++ lam1E (varP value)+ $ caseE (varE value)+ [ match (conP 'Object [varP obj])+ (normalB caseLst)+ []+ , errorMatch+ ]+ where+ -- Makes a string literal expression from a constructor's name.+ conNameExp :: Con -> Q Exp+ conNameExp = litE . stringL . nameBase . getConName++-- | Generates code to parse the JSON encoding of a single+-- constructor.+parseArgs :: (String -> String) -- ^ Function to change field names.+ -> Con -- ^ Constructor for which to generate JSON parsing code.+ -> [Q Match]+-- Nullary constructors.+parseArgs _ (NormalC conName []) =+ [ do arr <- newName "arr"+ g <- normalG $ [|V.null|] `appE` varE arr+ e <- [e|pure|] `appE` conE conName+ -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e']+ -- But first need to have "instance Applicative Q".+ match (conP 'Array [varP arr])+ (guardedB [return (g, e)])+ []+ , errorMatch+ ]+-- Unary constructors.+parseArgs _ (NormalC conName [_]) =+ [ do arg <- newName "arg"+ match (varP arg)+ ( normalB $ infixApp (conE conName)+ [e|(<$>)|]+ ([e|parseJSON|] `appE` varE arg)+ )+ []+ ]++-- Polyadic constructors.+parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts+-- Records.+parseArgs withField (RecC conName ts) =+ [ do obj <- newName "obj"+ -- List of: "obj .: "<FIELD>""+ let x:xs = [ infixApp (varE obj)+ [|(.:)|]+ ( [e|T.pack|]+ `appE`+ fieldNameExp withField field+ )+ | (field, _, _) <- ts+ ]+ match (conP 'Object [varP obj])+ ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b)+ (infixApp (conE conName) [|(<$>)|] x)+ xs+ )+ []+ , errorMatch+ ]+-- Infix constructors. Apart from syntax these are the same as+-- polyadic constructors.+parseArgs _ (InfixC _ conName _) = parseProduct conName 2+-- Existentially quantified constructors. We ignore the quantifiers+-- and proceed with the contained constructor.+parseArgs withField (ForallC _ _ con) = parseArgs withField con++-- | Generates code to parse the JSON encoding of an n-ary+-- constructor.+parseProduct :: Name -- ^ 'Con'structor name.+ -> Integer -- ^ 'Con'structor arity.+ -> [Q Match]+parseProduct conName numArgs =+ [ do arr <- newName "arr"+ g <- normalG $ infixApp ([|V.length|] `appE` varE arr)+ [|(==)|]+ (litE $ integerL numArgs)+ -- List of: "parseJSON (arr V.! <IX>)"+ let x:xs = [ [|parseJSON|]+ `appE`+ infixApp (varE arr)+ [|(V.!)|]+ (litE $ integerL ix)+ | ix <- [0 .. numArgs - 1]+ ]+ e <- foldl' (\a b -> infixApp a [|(<*>)|] b)+ (infixApp (conE conName) [|(<$>)|] x)+ xs+ match (conP 'Array [varP arr])+ (guardedB [return (g, e)])+ []+ , errorMatch+ ]++-- |+-- @+-- _ -> 'mzero'+-- @+errorMatch :: Q Match+errorMatch = match wildP (normalB [|mzero|]) []+++--------------------------------------------------------------------------------+-- Utility functions+--------------------------------------------------------------------------------++-- | Boilerplate for top level splices.+--+-- The given 'Name' must be from a type constructor. Furthermore, the+-- type constructor must be either a data type or a newtype. Any other+-- value will result in an exception.+withType :: Name+ -> ([TyVarBndr] -> [Con] -> Q a)+ -- ^ Function that generates the actual code. Will be applied+ -- to the type variable binders and constructors extracted+ -- from the given 'Name'.+ -> Q a+ -- ^ Resulting value in the 'Q'uasi monad.+withType name f = do+ info <- reify name+ case info of+ TyConI dec ->+ case dec of+ DataD _ _ tvbs cons _ -> f tvbs cons+ NewtypeD _ _ tvbs con _ -> f tvbs [con]+ other -> error $ "Data.Aeson.TH.withType: Unsupported type: "+ ++ show other+ _ -> error "Data.Aeson.TH.withType: I need the name of a type."++-- | Extracts the name from a constructor.+getConName :: Con -> Name+getConName (NormalC name _) = name+getConName (RecC name _) = name+getConName (InfixC _ name _) = name+getConName (ForallC _ _ con) = getConName con++-- | Extracts the name from a type variable binder.+tvbName :: TyVarBndr -> Name+tvbName (PlainTV name ) = name+tvbName (KindedTV name _) = name++-- | Creates a string literal expression from a record field name.+fieldNameExp :: (String -> String) -- ^ Function to change the field name.+ -> Name+ -> Q Exp+fieldNameExp f = litE . stringL . f . nameBase
Data/Aeson/Types.hs view
@@ -1,6 +1,13 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,- IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types #-}+ IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,+ ViewPatterns, FlexibleContexts, UndecidableInstances,+ ScopedTypeVariables, PatternGuards #-} +{-# LANGUAGE CPP #-}+#ifdef DEFAULT_SIGNATURES+{-# LANGUAGE DefaultSignatures #-}+#endif+ -- | -- Module: Data.Aeson.Types -- Copyright: (c) 2011 MailRank, Inc.@@ -37,18 +44,24 @@ , (.:) , (.:?) , object+ -- * Generic toJSON and fromJSON+ , genericToJSON+ , genericFromJSON ) where import Control.Applicative+import Control.Arrow (first)+import Control.Monad.State.Strict import Control.DeepSeq (NFData(..))-import Control.Monad (MonadPlus(..), ap) import Data.Aeson.Functions import Data.Attoparsec.Char8 (Number(..))-import Data.Data (Data)+import Data.Generics import Data.Hashable (Hashable(..)) import Data.Int (Int8, Int16, Int32, Int64)+import Data.IntSet (IntSet) import Data.List (foldl') import Data.Map (Map)+import Data.Maybe (fromJust) import Data.Monoid (Dual(..), First(..), Last(..)) import Data.Monoid (Monoid(..)) import Data.Ratio (Ratio)@@ -57,9 +70,9 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Format (FormatTime, formatTime, parseTime)-import Data.Typeable (Typeable) import Data.Vector (Vector) import Data.Word (Word, Word8, Word16, Word32, Word64)+import Foreign.Storable (Storable) import System.Locale (defaultTimeLocale) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB@@ -70,8 +83,14 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Lazy as LT+import qualified Data.Traversable as T import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Generic as VG + -- | The result of running a 'Parser'. data Result a = Error String | Success a@@ -289,9 +308,16 @@ -- instance ToJSON Coord where -- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y] -- @+--+-- This example assumes the OverloadedStrings language option is enabled. class ToJSON a where toJSON :: a -> Value +#ifdef DEFAULT_SIGNATURES+ default toJSON :: Data a => a -> Value+ toJSON = genericToJSON+#endif+ -- | A type that can be converted from JSON, with the possibility of -- failure. --@@ -311,9 +337,16 @@ -- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail. -- parseJSON _ = 'mzero' -- @+--+-- This example assumes the OverloadedStrings language option is enabled. class FromJSON a where parseJSON :: Value -> Parser a +#ifdef DEFAULT_SIGNATURES+ default parseJSON :: Data a => Value -> Parser a+ parseJSON = genericParseJSON+#endif+ instance (ToJSON a) => ToJSON (Maybe a) where toJSON (Just a) = toJSON a toJSON Nothing = Null@@ -325,14 +358,21 @@ {-# INLINE parseJSON #-} instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where- toJSON (Left a) = toJSON a- toJSON (Right b) = toJSON b+ toJSON (Left a) = object [left .= a]+ toJSON (Right b) = object [right .= b] {-# INLINE toJSON #-} instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where- parseJSON a = Left <$> parseJSON a <|> Right <$> parseJSON a+ parseJSON (Object (M.toList -> [(key, value)]))+ | key == left = Left <$> parseJSON value+ | key == right = Right <$> parseJSON value+ parseJSON _ = mzero {-# INLINE parseJSON #-} +left, right :: Text+left = "Left"+right = "Right"+ instance ToJSON Bool where toJSON = Bool {-# INLINE toJSON #-}@@ -562,6 +602,33 @@ parseJSON v = typeMismatch "Vector a" v {-# INLINE parseJSON #-} +vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value+vectorToJSON = Array . V.map toJSON . V.convert+{-# INLINE vectorToJSON #-}++vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)+vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a+vectorParseJSON s v = typeMismatch s v+{-# INLINE vectorParseJSON #-}++instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where+ toJSON = vectorToJSON++instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"++instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where+ toJSON = vectorToJSON++instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"++instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where+ toJSON = vectorToJSON++instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"+ instance (ToJSON a) => ToJSON (Set.Set a) where toJSON = toJSON . Set.toList {-# INLINE toJSON #-}@@ -766,3 +833,294 @@ Number _ -> "Number" Bool _ -> "Boolean" Null -> "Null"+++--------------------------------------------------------------------------------+-- Generic toJSON and fromJSON++type T a = a -> Value++genericToJSON :: (Data a) => a -> Value+genericToJSON = toJSON_generic+ `ext1Q` list+ `ext1Q` vector+ `ext1Q` set+ `ext2Q'` mapAny+ `ext2Q'` hashMapAny+ -- Use the standard encoding for all base types.+ `extQ` (toJSON :: T Integer)+ `extQ` (toJSON :: T Int)+ `extQ` (toJSON :: T Int8)+ `extQ` (toJSON :: T Int16)+ `extQ` (toJSON :: T Int32)+ `extQ` (toJSON :: T Int64)+ `extQ` (toJSON :: T Word)+ `extQ` (toJSON :: T Word8)+ `extQ` (toJSON :: T Word16)+ `extQ` (toJSON :: T Word32)+ `extQ` (toJSON :: T Word64)+ `extQ` (toJSON :: T Double)+ `extQ` (toJSON :: T Number)+ `extQ` (toJSON :: T Float)+ `extQ` (toJSON :: T Rational)+ `extQ` (toJSON :: T Char)+ `extQ` (toJSON :: T Text)+ `extQ` (toJSON :: T LT.Text)+ `extQ` (toJSON :: T String)+ `extQ` (toJSON :: T B.ByteString)+ `extQ` (toJSON :: T LB.ByteString)+ `extQ` (toJSON :: T Value)+ `extQ` (toJSON :: T DotNetTime)+ `extQ` (toJSON :: T UTCTime)+ `extQ` (toJSON :: T IntSet)+ `extQ` (toJSON :: T Bool)+ `extQ` (toJSON :: T ())+ --`extQ` (T.toJSON :: T Ordering)+ where+ list xs = Array . V.fromList . map genericToJSON $ xs+ vector v = Array . V.map genericToJSON $ v+ set s = Array . V.fromList . map genericToJSON . Set.toList $ s++ mapAny m+ | tyrep == typeOf T.empty = remap id+ | tyrep == typeOf LT.empty = remap LT.toStrict+ | tyrep == typeOf string = remap pack+ | tyrep == typeOf B.empty = remap decode+ | tyrep == typeOf LB.empty = remap strict+ | otherwise = modError "genericToJSON" $+ "cannot convert map keyed by type " ++ show tyrep+ where tyrep = typeOf . head . M.keys $ m+ remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m++ hashMapAny m+ | tyrep == typeOf T.empty = remap id+ | tyrep == typeOf LT.empty = remap LT.toStrict+ | tyrep == typeOf string = remap pack+ | tyrep == typeOf B.empty = remap decode+ | tyrep == typeOf LB.empty = remap strict+ | otherwise = modError "genericToJSON" $+ "cannot convert map keyed by type " ++ show tyrep+ where tyrep = typeOf . head . H.keys $ m+ remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m+++toJSON_generic :: (Data a) => a -> Value+toJSON_generic = generic+ where+ -- Generic encoding of an algebraic data type.+ generic a =+ case dataTypeRep (dataTypeOf a) of+ -- No constructor, so it must be an error value. Code+ -- it anyway as Null.+ AlgRep [] -> Null+ -- Elide a single constructor and just code the arguments.+ AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)+ -- For multiple constructors, make an object with a+ -- field name that is the constructor (except lower+ -- case) and the data is the arguments encoded.+ AlgRep _ -> encodeConstr (toConstr a) (gmapQ genericToJSON a)+ rep -> err (dataTypeOf a) rep+ where+ err dt r = modError "genericToJSON" $ "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 [] = String . constrString $ c+ encodeConstr c as = object [(constrString c, encodeArgs c as)]++ constrString = pack . showConstr++ encodeArgs c = encodeArgs' (constrFields c)+ encodeArgs' [] [j] = j+ encodeArgs' [] js = Array . V.fromList $ js+ encodeArgs' ns js = object $ zip (map mungeField ns) js++ -- Skip leading '_' in field name so we can use keywords+ -- etc. as field names.+ mungeField ('_':cs) = pack cs+ mungeField cs = pack cs++genericFromJSON :: (Data a) => Value -> Result a+genericFromJSON = parse genericParseJSON++type F a = Parser a++genericParseJSON :: (Data a) => Value -> Parser a+genericParseJSON j = parseJSON_generic j+ `ext1R` list+ `ext1R` vector+ `ext2R'` mapAny+ `ext2R'` hashMapAny+ -- Use the standard encoding for all base types.+ `extR` (value :: F Integer)+ `extR` (value :: F Int)+ `extR` (value :: F Int8)+ `extR` (value :: F Int16)+ `extR` (value :: F Int32)+ `extR` (value :: F Int64)+ `extR` (value :: F Word)+ `extR` (value :: F Word8)+ `extR` (value :: F Word16)+ `extR` (value :: F Word32)+ `extR` (value :: F Word64)+ `extR` (value :: F Double)+ `extR` (value :: F Number)+ `extR` (value :: F Float)+ `extR` (value :: F Rational)+ `extR` (value :: F Char)+ `extR` (value :: F Text)+ `extR` (value :: F LT.Text)+ `extR` (value :: F String)+ `extR` (value :: F B.ByteString)+ `extR` (value :: F LB.ByteString)+ `extR` (value :: F Value)+ `extR` (value :: F DotNetTime)+ `extR` (value :: F UTCTime)+ `extR` (value :: F IntSet)+ `extR` (value :: F Bool)+ `extR` (value :: F ())+ where+ value :: (FromJSON a) => Parser a+ value = parseJSON j+ list :: (Data a) => Parser [a]+ list = V.toList <$> genericParseJSON j+ vector :: (Data a) => Parser (V.Vector a)+ vector = case j of+ Array js -> V.mapM genericParseJSON js+ _ -> myFail+ mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)+ mapAny+ | tyrep `elem` stringyTypes = res+ | otherwise = myFail+ where res = case j of+ Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js+ _ -> myFail+ trans+ | tyrep == typeOf T.empty = remap id+ | tyrep == typeOf LT.empty = remap LT.fromStrict+ | tyrep == typeOf string = remap T.unpack+ | tyrep == typeOf B.empty = remap encodeUtf8+ | tyrep == typeOf LB.empty = remap lazy+ | otherwise = modError "genericParseJSON"+ "mapAny -- should never happen"+ tyrep = typeOf (undefined :: f)+ remap f = fromJust . cast . f+ hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)+ hashMapAny+ | tyrep == typeOf string = process T.unpack+ | tyrep == typeOf LT.empty = process LT.fromStrict+ | tyrep == typeOf T.empty = process id+ | otherwise = myFail+ where+ process f = maybe myFail return . cast =<< parseWith f+ parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)+ parseWith f = case j of+ Object js -> H.fromList . map (first f) . M.toList <$>+ T.mapM genericParseJSON js+ _ -> myFail+ tyrep = typeOf (undefined :: f)+ myFail = modFail "genericParseJSON" $ "bad data: " ++ show j+ stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,+ typeOf LB.empty, typeOf string]++parseJSON_generic :: (Data a) => Value -> Parser a+parseJSON_generic j = generic+ where+ typ = dataTypeOf $ resType generic+ generic = case dataTypeRep typ of+ AlgRep [] -> case j of+ Null -> return (modError "genericParseJSON" "empty type")+ _ -> modFail "genericParseJSON" "no-constr bad data"+ AlgRep [_] -> decodeArgs (indexConstr typ 1) j+ AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'+ rep -> modFail "genericParseJSON" $+ show rep ++ "(" ++ show typ ++ ")"+ getConstr t (Object o) | [(s, j')] <- fromJSObject o = do+ c <- readConstr' t s+ return (c, j')+ getConstr t (String js) = do c <- readConstr' t (unpack js)+ return (c, Null) -- handle nullary ctor+ getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"+ readConstr' t s =+ maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " +++ show t)+ return $ readConstr t s++ decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0+ (constrFields c0)+ where+ go 0 c _ Null = construct c [] -- nullary constructor+ go 1 c [] jd = construct c [jd] -- unary constructor+ go n c [] (Array js)+ | n > 1 = construct c (V.toList js) -- no field names+ -- FIXME? We could allow reading an array into a constructor+ -- with field names.+ go _ c fs@(_:_) (Object o) = selectFields o fs >>=+ construct c -- field names+ go _ c _ jd = modFail "genericParseJSON" $+ "bad decodeArgs data " ++ show (c, jd)++ fromJSObject = map (first unpack) . M.toList++ -- Build the value by stepping through the list of subparts.+ construct c = evalStateT $ fromConstrM f c+ where f :: (Data a) => StateT [Value] Parser a+ f = do js <- get+ case js of+ [] -> lift $ modFail "construct" "empty list"+ (j':js') -> do put js'; lift $ genericParseJSON j'++ -- Select the named fields from a JSON object.+ selectFields fjs = mapM sel+ where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " +++ f) return $ M.lookup (pack 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 :: MonadPlus m => m a -> a+ resType _ = modError "genericParseJSON" "resType"++modFail :: (Monad m) => String -> String -> m a+modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err++modError :: String -> String -> a+modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err++string :: String+string = ""++-- Type extension for binary type constructors.++-- | Flexible type extension+ext2' :: (Data a, Typeable2 t)+ => c a+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+ -> c a+ext2' def ext = maybe def id (dataCast2 ext)++-- | Type extension of queries for type constructors+ext2Q' :: (Data d, Typeable2 t)+ => (d -> q)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+ -> d -> q+ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))++-- | Type extension of readers for type constructors+ext2R' :: (Monad m, Data d, Typeable2 t)+ => m d+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))+ -> m d+ext2R' def ext = unR ((R def) `ext2'` (R ext))++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | The type constructor for readers+newtype R m x = R { unR :: m x }
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 0.3.2.11+version: 0.3.2.12 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -96,6 +96,7 @@ benchmarks/json-data/twitter100.json tests/Makefile tests/Properties.hs+ examples/Demo.hs flag developer description: operate in developer mode@@ -108,6 +109,7 @@ Data.Aeson.Generic Data.Aeson.Parser Data.Aeson.Types+ Data.Aeson.TH other-modules: Data.Aeson.Functions@@ -119,12 +121,13 @@ blaze-textual >= 0.2.0.2, bytestring, containers,- deepseq,+ deepseq < 1.2, hashable >= 1.1.2.0, mtl, old-locale, syb, text >= 0.11.0.2,+ template-haskell >= 2.5, time, unordered-containers >= 0.1.3.0, vector >= 0.7@@ -132,6 +135,9 @@ if flag(developer) ghc-options: -Werror ghc-prof-options: -auto-all++ if(impl(ghc >= 7.2.1))+ cpp-options: -DDEFAULT_SIGNATURES ghc-options: -Wall
+ examples/Demo.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}++-- Simplest example of parsing and encoding JSON with Aeson.++-- Above, we enable OverloadedStrings to allow a literal string (e.g. "name")+-- to be automatically converted to Data.Text.+-- This is useful when using Aeson's functions such as (.:) which expect Text.+-- Without it we'd need to use pack.++import Data.Aeson+import qualified Data.Aeson.Types as T++import Data.Attoparsec (parse, Result(..))+import Data.Text (Text)+import Control.Applicative ((<$>))+import Control.Monad (mzero)+import qualified Data.ByteString.Char8 as BS+-- Aeson's "encode" to JSON generates lazy bytestrings+import qualified Data.ByteString.Lazy.Char8 as BSL++-- In main we'll parse a JSON message into a Msg and display that,+-- then we'll encode a different Msg as JSON, and display it.+main ::IO ()+main = do+ print $ parseMsgFromString exampleJSONMessage+ let reply = Msg "hello Aeson!"+ putStrLn $ "Encoded reply: " ++ BSL.unpack (encode reply)++-- this is the type we'll be converting to and from JSON+data Msg = Msg Text deriving (Show)++-- here's how we should parse JSON and construct a Msg+instance FromJSON Msg where+ parseJSON (Object v) = Msg <$> v .: "message"+ parseJSON _ = mzero++-- here's how we should encode a Msg as JSON+instance ToJSON Msg where+ toJSON (Msg s) = object [ "message" .= s]++-- Here's one way to actually run the parsers.+--+-- Note that we do two parses:+-- once into JSON then one more into our final type.+-- There are a number of choices when dealing with parse failures.+-- Here we've chosen to parse to Maybe Msg, and a Nothing will be returned+-- if parseJSON fails. (More informative options are available.)+--+-- This should take us (depending on success or failure)+-- from {"message": "hello world"} to Just (Msg "hello world")+-- or to Nothing+--+-- Note also that we have not checked here that the input has been completely+-- consumed, so:+-- {"message": "hello world"} foo BIG mistake+-- would yield the same successfully translated message!+-- We could look in "rest" for the remainder.+parseMsgFromString :: String -> Maybe Msg+parseMsgFromString s =+ let bs = BS.pack s+ in case parse json bs of+ (Done rest r) -> T.parseMaybe parseJSON r :: Maybe Msg+ _ -> Nothing++-- Here's the example JSON message we're going to try to parse:+-- {"message": "hello world"}+-- It's a JSON object with a single pair, having key 'message', and a string value.+-- It could have more fields and structure, but that's all we're going to parse out of it.+exampleJSONMessage :: String+exampleJSONMessage = "{\"message\":\"hello world\"}"
tests/Properties.hs view
@@ -6,6 +6,7 @@ import Data.Attoparsec.Number import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Attoparsec.Lazy as L @@ -39,6 +40,11 @@ maxAbsoluteError = 1e-15 maxRelativeError = 1e-15 +toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool+toFromJSON x = case fromJSON . toJSON $ x of+ Error _ -> False+ Success x' -> x == x'+ main :: IO () main = defaultMain tests @@ -52,5 +58,12 @@ testProperty "roundTripBool" roundTripBool , testProperty "roundTripDouble" roundTripDouble , testProperty "roundTripInteger" roundTripInteger+ ],+ testGroup "toFromJSON" [+ testProperty "Integer" (toFromJSON :: Integer -> Bool)+ , testProperty "Double" (toFromJSON :: Double -> Bool)+ , testProperty "Maybe Integer" (toFromJSON :: Maybe Integer -> Bool)+ , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Bool)+ , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Bool) ] ]