diff --git a/Data/Aeson/Generic.hs b/Data/Aeson/Generic.hs --- a/Data/Aeson/Generic.hs +++ b/Data/Aeson/Generic.hs @@ -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 diff --git a/Data/Aeson/Parser.hs b/Data/Aeson/Parser.hs --- a/Data/Aeson/Parser.hs +++ b/Data/Aeson/Parser.hs @@ -15,6 +15,7 @@ ( json , value + , jstring ) where import Blaze.ByteString.Builder (fromByteString, toByteString) diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/TH.hs @@ -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 .: """ + 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.! )" + 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 diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs --- a/Data/Aeson/Types.hs +++ b/Data/Aeson/Types.hs @@ -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 } diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -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 diff --git a/examples/Demo.hs b/examples/Demo.hs new file mode 100644 --- /dev/null +++ b/examples/Demo.hs @@ -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\"}" diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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) ] ]