Commits

basvandijk  committed 064ee0d

Parameterize the gParseJSON and gToJSON with encoding Options

  • Participants
  • Parent commits 00890f0

Comments (0)

Files changed (6)

File Data/Aeson.hs

+{-# LANGUAGE CPP #-}
+
 -- |
 -- Module:      Data.Aeson
 -- Copyright:   (c) 2011, 2012 Bryan O'Sullivan
     , Result(..)
     , fromJSON
     , ToJSON(..)
+#ifdef GENERICS
+    -- ** Generic JSON classes
+    , GFromJSON(..)
+    , GToJSON(..)
+#endif
     -- * Inspecting @'Value's@
     , withObject
     , withText

File Data/Aeson/TH.hs

 -}
 
 module Data.Aeson.TH
-    ( Options(..), SumEncoding(..), defaultOptions, defaultObjectWithType
+    ( -- * Encoding configuration
+      Options(..), SumEncoding(..), defaultOptions, defaultObjectWithType
 
+     -- * FromJSON and ToJSON derivation
     , deriveJSON
 
     , deriveToJSON
                   , ToJSON, toJSON
                   , FromJSON, parseJSON
                   )
-import Data.Aeson.Types ( Value(..), Parser )
+import Data.Aeson.Types ( Value(..), Parser
+                        , Options(..)
+                        , SumEncoding(..)
+                        , defaultOptions
+                        , defaultObjectWithType
+                        )
 -- from base:
 import Control.Applicative ( pure, (<$>), (<*>) )
 import Control.Monad       ( return, mapM, liftM2, fail )
 import Data.Bool           ( Bool(False, True), otherwise, (&&) )
 import Data.Eq             ( (==) )
-import Data.Function       ( ($), (.), id )
+import Data.Function       ( ($), (.) )
 import Data.Functor        ( fmap )
 import Data.Int            ( Int )
 import Data.Either         ( Either(Left, Right) )
 
 
 --------------------------------------------------------------------------------
--- Configuration
---------------------------------------------------------------------------------
-
--- | Options that specify how to encode your datatype to JSON.
-data Options = Options
-    { fieldNameModifier :: String -> String
-      -- ^ Function applied to field names.
-      -- Handy for removing common record prefixes for example.
-    , constructorNameModifier :: String -> String
-      -- ^ Function applied to constructor names.
-      -- Handy for lower-casing constructor names for example.
-    , nullaryToString   :: Bool
-      -- ^ If 'True' the constructors of a datatypes, with all nullary
-      -- constructors, will be encoded to a string with the
-      -- constructor name. If 'False' the encoding will always follow
-      -- the `sumEncoding`.
-    , sumEncoding       :: SumEncoding
-      -- ^ Specifies how to encode constructors of a sum datatype.
-    }
-
--- | Specifies how to encode constructors of a sum datatype.
-data SumEncoding =
-    TwoElemArray -- ^ A constructor will be encoded to a 2-element
-                 -- array where the first element is the name of the
-                 -- constructor (modified by the
-                 -- 'constructorNameModifier') and the second element
-                 -- the content of the constructor.
-  | ObjectWithType { typeFieldName  :: String
-                   , valueFieldName :: String
-                   }
-    -- ^ A constructor will be encoded to an object with a field
-    -- 'typeFieldName' which specifies the constructor name (modified
-    -- by the 'constructorNameModifier'). If the constructor is not a
-    -- record the constructor content will be stored under the
-    -- 'valueFieldName' field.
-  | ObjectWithSingleField
-    -- ^ A constructor will be encoded to an object with a single
-    -- field named after the constructor (modified by the
-    -- 'constructorNameModifier') and the value will be the contents
-    -- of the constructor.
-
--- | Default encoding options which specify to not modify field and
--- constructor names, encode the constructors of a datatype with all
--- nullary constructors to just strings with the name of the
--- constructor and use a 2-element array for other sum datatypes.
-defaultOptions :: Options
-defaultOptions = Options
-                 { fieldNameModifier       = id
-                 , constructorNameModifier = id
-                 , nullaryToString         = True
-                 , sumEncoding             = TwoElemArray
-                 }
-
--- | Note that:
---
--- @
--- defaultObjectWithType = 'ObjectWithType'
---                         { 'typeFieldName'  = \"type\"
---                         , 'valueFieldName' = \"value\"
---                         }
--- @
-defaultObjectWithType :: SumEncoding
-defaultObjectWithType = ObjectWithType
-                        { typeFieldName  = "type"
-                        , valueFieldName = "value"
-                        }
-
---------------------------------------------------------------------------------
 -- Convenience
 --------------------------------------------------------------------------------
 

File Data/Aeson/Types.hs

     , ToJSON(..)
     , modifyFailure
 
+#ifdef GENERICS
+    -- ** Generic JSON classes
+    , GFromJSON(..)
+    , GToJSON(..)
+#endif
+
     -- * Inspecting @'Value's@
     , withObject
     , withText
     , (.:?)
     , (.!=)
     , object
+
+    -- * Generic and TH encoding configuration
+    , Options(..)
+    , SumEncoding(..)
+    , defaultOptions
+    , defaultObjectWithType
     ) where
 
 import Data.Aeson.Types.Class

File Data/Aeson/Types/Class.hs

 #ifdef GENERICS
 import GHC.Generics
 
+-- | Class of generic representation types ('Rep') that can be converted to JSON.
 class GToJSON f where
-    gToJSON :: f a -> Value
+    -- | This method (applied to 'defaultOptions') is used as the
+    -- default generic implementation of 'toJSON'.
+    gToJSON :: Options -> f a -> Value
 
+-- | Class of generic representation types ('Rep') that can be converted from JSON.
 class GFromJSON f where
-    gParseJSON :: Value -> Parser (f a)
+    -- | This method (applied to 'defaultOptions') is used as the
+    -- default generic implementation of 'parseJSON'.
+    gParseJSON :: Options -> Value -> Parser (f a)
 #endif
 
 -- | A type that can be converted to JSON.
 
 #ifdef GENERICS
     default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
-    toJSON = gToJSON . from
+    toJSON = gToJSON defaultOptions . from
 #endif
 
 -- | A type that can be converted from JSON, with the possibility of
 
 #ifdef GENERICS
     default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
-    parseJSON = fmap to . gParseJSON
+    parseJSON = fmap to . gParseJSON defaultOptions
 #endif
 
 instance (ToJSON a) => ToJSON (Maybe a) where

File Data/Aeson/Types/Generic.hs

 -- Generic toJSON
 
 instance (GToJSON a) => GToJSON (M1 i c a) where
-    gToJSON = gToJSON . unM1
+    gToJSON opts = gToJSON opts . unM1
     {-# INLINE gToJSON #-}
 
 instance (ToJSON a) => GToJSON (K1 i a) where
-    gToJSON = toJSON . unK1
+    gToJSON _opts = toJSON . unK1
     {-# INLINE gToJSON #-}
 
 instance GToJSON U1 where
-    gToJSON _ = emptyArray
+    gToJSON _opts _ = emptyArray
     {-# INLINE gToJSON #-}
 
 instance (ConsToJSON a) => GToJSON (C1 c a) where
-    gToJSON = consToJSON . unM1
+    gToJSON opts = consToJSON opts . unM1
     {-# INLINE gToJSON #-}
 
 instance ( GProductToValues a, GProductToValues b
          , ProductSize      a, ProductSize      b) => GToJSON (a :*: b) where
-    gToJSON p = Array $ V.create $ do
-                  mv <- VM.unsafeNew lenProduct
-                  gProductToValues mv 0 lenProduct p
-                  return mv
+    gToJSON opts p =
+        Array $ V.create $ do
+          mv <- VM.unsafeNew lenProduct
+          gProductToValues opts mv 0 lenProduct p
+          return mv
         where
           lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
     {-# INLINE gToJSON #-}
 
 instance (GObject a, GObject b) => GToJSON (a :+: b) where
-    gToJSON (L1 x) = Object $ gObject x
-    gToJSON (R1 x) = Object $ gObject x
+    gToJSON opts (L1 x) = Object $ gObject opts x
+    gToJSON opts (R1 x) = Object $ gObject opts x
     {-# INLINE gToJSON #-}
 
 --------------------------------------------------------------------------------
 
-class ConsToJSON    f where consToJSON  ::           f a -> Value
-class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
+class ConsToJSON    f where consToJSON  ::           Options -> f a -> Value
+class ConsToJSON' b f where consToJSON' :: Tagged b (Options -> f a -> Value)
 
 newtype Tagged s b = Tagged {unTagged :: b}
 
 instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
-    consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
+    consToJSON = unTagged (consToJSON' :: Tagged b (Options -> f a -> Value))
     {-# INLINE consToJSON #-}
 
 instance (GRecordToPairs f) => ConsToJSON' True f where
-    consToJSON' = Tagged (object . toList . gRecordToPairs)
+    consToJSON' = Tagged (\opts -> object . toList . gRecordToPairs opts)
     {-# INLINE consToJSON' #-}
 
 instance GToJSON f => ConsToJSON' False f where
 --------------------------------------------------------------------------------
 
 class GRecordToPairs f where
-    gRecordToPairs :: f a -> DList Pair
+    gRecordToPairs :: Options -> f a -> DList Pair
 
 instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
-    gRecordToPairs (a :*: b) = gRecordToPairs a `mappend` gRecordToPairs b
+    gRecordToPairs opts (a :*: b) = gRecordToPairs opts a `mappend`
+                                    gRecordToPairs opts b
     {-# INLINE gRecordToPairs #-}
 
 instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
-    gRecordToPairs m1 = pure (pack (selName m1), gToJSON (unM1 m1))
+    gRecordToPairs opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
+                                  , gToJSON opts (unM1 m1)
+                                  )
     {-# INLINE gRecordToPairs #-}
 
 --------------------------------------------------------------------------------
 
 class GProductToValues f where
-    gProductToValues :: VM.MVector s Value -> Int -> Int -> f a -> ST s ()
+    gProductToValues :: Options
+                     -> VM.MVector s Value
+                     -> Int -- ^ index
+                     -> Int -- ^ length
+                     -> f a
+                     -> ST s ()
 
 instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
-    gProductToValues mv ix len (a :*: b) = do gProductToValues mv ix  lenL a
-                                              gProductToValues mv ixR lenR b
+    gProductToValues opts mv ix len (a :*: b) = do
+      gProductToValues opts mv ix  lenL a
+      gProductToValues opts mv ixR lenR b
         where
           lenL = len `shiftR` 1
           ixR  = ix + lenL
     {-# INLINE gProductToValues #-}
 
 instance (GToJSON a) => GProductToValues a where
-    gProductToValues mv ix _ = VM.unsafeWrite mv ix . gToJSON
+    gProductToValues opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
     {-# INLINE gProductToValues #-}
 
 --------------------------------------------------------------------------------
 
 class GObject f where
-    gObject :: f a -> Object
+    gObject :: Options -> f a -> Object
 
 instance (GObject a, GObject b) => GObject (a :+: b) where
-    gObject (L1 x) = gObject x
-    gObject (R1 x) = gObject x
+    gObject opts (L1 x) = gObject opts x
+    gObject opts (R1 x) = gObject opts x
     {-# INLINE gObject #-}
 
 instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
-    gObject = H.singleton (pack $ conName (undefined :: t c a p)) . gToJSON
+    gObject opts = H.singleton (pack $ constructorNameModifier opts
+                                     $ conName (undefined :: t c a p))
+                 . gToJSON opts
     {-# INLINE gObject #-}
 
 --------------------------------------------------------------------------------
 -- Generic parseJSON
 
 instance (GFromJSON a) => GFromJSON (M1 i c a) where
-    gParseJSON = fmap M1 . gParseJSON
+    gParseJSON opts = fmap M1 . gParseJSON opts
     {-# INLINE gParseJSON #-}
 
 instance (FromJSON a) => GFromJSON (K1 i a) where
-    gParseJSON = fmap K1 . parseJSON
+    gParseJSON _opts = fmap K1 . parseJSON
     {-# INLINE gParseJSON #-}
 
 instance GFromJSON U1 where
-    gParseJSON v
+    gParseJSON _opts v
         | isEmptyArray v = pure U1
         | otherwise      = typeMismatch "unit constructor (U1)" v
     {-# INLINE gParseJSON #-}
 
 instance (ConsFromJSON a) => GFromJSON (C1 c a) where
-    gParseJSON = fmap M1 . consParseJSON
+    gParseJSON opts = fmap M1 . consParseJSON opts
     {-# INLINE gParseJSON #-}
 
 instance ( GFromProduct a, GFromProduct b
          , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
-    gParseJSON (Array arr)
-        | lenArray == lenProduct = gParseProduct arr 0 lenProduct
+    gParseJSON opts (Array arr)
+        | lenArray == lenProduct = gParseProduct opts arr 0 lenProduct
         | otherwise =
             fail $ "When expecting a product of " ++ show lenProduct ++
                    " values, encountered an Array of " ++ show lenArray ++
           lenArray = V.length arr
           lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
 
-    gParseJSON v = typeMismatch "product (:*:)" v
+    gParseJSON _opts v = typeMismatch "product (:*:)" v
     {-# INLINE gParseJSON #-}
 
 instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
-    gParseJSON (Object (H.toList -> [keyVal@(key, _)])) =
-        case gParseSum keyVal of
+    gParseJSON opts (Object (H.toList -> [keyVal@(key, _)])) =
+        case gParseSum opts keyVal of
           Nothing -> notFound $ unpack key
           Just p  -> p
-    gParseJSON v = typeMismatch "sum (:+:)" v
+    gParseJSON _opts v = typeMismatch "sum (:+:)" v
     {-# INLINE gParseJSON #-}
 
 notFound :: String -> Parser a
 
 --------------------------------------------------------------------------------
 
-class ConsFromJSON    f where consParseJSON  ::           Value -> Parser (f a)
-class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
+class ConsFromJSON    f where
+    consParseJSON  ::           Options -> Value -> Parser (f a)
+class ConsFromJSON' b f where
+    consParseJSON' :: Tagged b (Options -> Value -> Parser (f a))
 
 instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
-    consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
+    consParseJSON =
+        unTagged (consParseJSON' :: Tagged b (Options -> Value -> Parser (f a)))
     {-# INLINE consParseJSON #-}
 
 instance (GFromRecord f) => ConsFromJSON' True f where
     consParseJSON' = Tagged parseRecord
         where
-          parseRecord (Object obj) = gParseRecord obj
-          parseRecord v = typeMismatch "record (:*:)" v
+          parseRecord  opts (Object obj) = gParseRecord opts obj
+          parseRecord _opts v = typeMismatch "record (:*:)" v
     {-# INLINE consParseJSON' #-}
 
 instance (GFromJSON f) => ConsFromJSON' False f where
 --------------------------------------------------------------------------------
 
 class GFromRecord f where
-    gParseRecord :: Object -> Parser (f a)
+    gParseRecord :: Options -> Object -> Parser (f a)
 
 instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
-    gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
+    gParseRecord opts obj = (:*:) <$> gParseRecord opts obj
+                                  <*> gParseRecord opts obj
     {-# INLINE gParseRecord #-}
 
 instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
-    gParseRecord = maybe (notFound key) gParseJSON . H.lookup (T.pack key)
+    gParseRecord opts = maybe (notFound key) (gParseJSON opts)
+                      . H.lookup (T.pack key)
         where
-          key = selName (undefined :: t s a p)
+          key = fieldNameModifier opts $ selName (undefined :: t s a p)
     {-# INLINE gParseRecord #-}
 
 --------------------------------------------------------------------------------
 --------------------------------------------------------------------------------
 
 class GFromProduct f where
-    gParseProduct :: Array -> Int -> Int -> Parser (f a)
+    gParseProduct :: Options -> Array -> Int -> Int -> Parser (f a)
 
 instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
-    gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix  lenL
-                                     <*> gParseProduct arr ixR lenR
+    gParseProduct opts arr ix len =
+        (:*:) <$> gParseProduct opts arr ix  lenL
+              <*> gParseProduct opts arr ixR lenR
         where
           lenL = len `shiftR` 1
           ixR  = ix + lenL
     {-# INLINE gParseProduct #-}
 
 instance (GFromJSON a) => GFromProduct (S1 s a) where
-    gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix
+    gParseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
     {-# INLINE gParseProduct #-}
 
 --------------------------------------------------------------------------------
 
 class GFromSum f where
-    gParseSum :: Pair -> Maybe (Parser (f a))
+    gParseSum :: Options -> Pair -> Maybe (Parser (f a))
 
 instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
-    gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|>
-                       (fmap R1 <$> gParseSum keyVal)
+    gParseSum opts keyVal = (fmap L1 <$> gParseSum opts keyVal) <|>
+                            (fmap R1 <$> gParseSum opts keyVal)
     {-# INLINE gParseSum #-}
 
 instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
-    gParseSum (key, value)
-        | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value
+    gParseSum opts (key, value)
+        | key == pack ( constructorNameModifier opts
+                      $ conName (undefined :: t c a p)
+                      )
+                    = Just $ gParseJSON opts value
         | otherwise = Nothing
     {-# INLINE gParseSum #-}
 

File Data/Aeson/Types/Internal.hs

     , modifyFailure
     -- * Constructors and accessors
     , object
+
+    -- * Generic and TH encoding configuration
+    , Options(..)
+    , SumEncoding(..)
+    , defaultOptions
+    , defaultObjectWithType
     ) where
 
 import Control.Applicative
 -- Since 0.6.2.0
 modifyFailure :: (String -> String) -> Parser a -> Parser a
 modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)
+
+--------------------------------------------------------------------------------
+-- Generic and TH encoding configuration
+--------------------------------------------------------------------------------
+
+-- | Options that specify how to encode your datatype to JSON.
+data Options = Options
+    { fieldNameModifier :: String -> String
+      -- ^ Function applied to field names.
+      -- Handy for removing common record prefixes for example.
+    , constructorNameModifier :: String -> String
+      -- ^ Function applied to constructor names.
+      -- Handy for lower-casing constructor names for example.
+    , nullaryToString   :: Bool
+      -- ^ If 'True' the constructors of a datatypes, with all nullary
+      -- constructors, will be encoded to a string with the
+      -- constructor name. If 'False' the encoding will always follow
+      -- the `sumEncoding`.
+    , sumEncoding       :: SumEncoding
+      -- ^ Specifies how to encode constructors of a sum datatype.
+    }
+
+-- | Specifies how to encode constructors of a sum datatype.
+data SumEncoding =
+    TwoElemArray -- ^ A constructor will be encoded to a 2-element
+                 -- array where the first element is the name of the
+                 -- constructor (modified by the
+                 -- 'constructorNameModifier') and the second element
+                 -- the content of the constructor.
+  | ObjectWithType { typeFieldName  :: String
+                   , valueFieldName :: String
+                   }
+    -- ^ A constructor will be encoded to an object with a field
+    -- 'typeFieldName' which specifies the constructor name (modified
+    -- by the 'constructorNameModifier'). If the constructor is not a
+    -- record the constructor content will be stored under the
+    -- 'valueFieldName' field.
+  | ObjectWithSingleField
+    -- ^ A constructor will be encoded to an object with a single
+    -- field named after the constructor (modified by the
+    -- 'constructorNameModifier') and the value will be the contents
+    -- of the constructor.
+
+-- | Default encoding options which specify to not modify field and
+-- constructor names, encode the constructors of a datatype with all
+-- nullary constructors to just strings with the name of the
+-- constructor and use a 2-element array for other sum datatypes.
+defaultOptions :: Options
+defaultOptions = Options
+                 { fieldNameModifier       = id
+                 , constructorNameModifier = id
+                 , nullaryToString         = True
+                 , sumEncoding             = TwoElemArray
+                 }
+
+-- | Note that:
+--
+-- @
+-- defaultObjectWithType = 'ObjectWithType'
+--                         { 'typeFieldName'  = \"type\"
+--                         , 'valueFieldName' = \"value\"
+--                         }
+-- @
+defaultObjectWithType :: SumEncoding
+defaultObjectWithType = ObjectWithType
+                        { typeFieldName  = "type"
+                        , valueFieldName = "value"
+                        }