Commits

Bryan O'Sullivan  committed eece2c3

Partially implement generic JSON support.

Borrowed from the json package's implementation.

  • Participants
  • Parent commits 6e57a75

Comments (0)

Files changed (4)

File Data/Aeson/Functions.hs

+module Data.Aeson.Functions
+    (
+      transformMap
+    ) where
+
+import Control.Arrow ((***))
+import qualified Data.Map as M
+
+-- | Transform one map into another.  The ordering of keys must be
+-- preserved.
+transformMap :: (Ord k1, Ord k2) => (k1 -> k2) -> (v1 -> v2)
+             -> M.Map k1 v1 -> M.Map k2 v2
+transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList

File Data/Aeson/Generic.hs

+module Data.Aeson.Generic
+    (
+      fromJSON
+    , toJSON
+    ) where
+
+import Control.Applicative (Alternative)
+import Data.Aeson.Functions
+import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..))
+import Data.Generics
+import Data.Int
+import Data.IntSet (IntSet)
+import Data.Text (Text, pack)
+import Data.Time.Clock (UTCTime)
+import Data.Word
+import qualified Data.Aeson.Types as T
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text.Lazy as L
+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
+         `ext1Q` mapText
+         `ext1Q` mapLazyText
+         `ext1Q` mapString
+         -- 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 Float)
+         `extQ` (T.toJSON :: T Rational)
+         `extQ` (T.toJSON :: T Char)
+         `extQ` (T.toJSON :: T Text)
+         `extQ` (T.toJSON :: T L.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 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
+    mapText m = Object . Map.map toJSON $ m
+    mapLazyText m = Object . transformMap L.toStrict toJSON $ m
+    mapString m = Object . transformMap pack 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 = error $ "Data.Aeson.Generic.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
+
+fromJSON :: (Alternative f, Data a) => Value -> f a
+fromJSON = undefined

File Data/Aeson/Types.hs

-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, IncoherentInstances,
+    OverlappingInstances #-}
 
 -- Module:      Data.Aeson.Types
 -- Copyright:   (c) 2011 MailRank, Inc.
     , object
     ) where
 
-import Control.Arrow ((***))
 import Control.Applicative
 import Control.DeepSeq (NFData(..))
 import Data.Data (Data)
+import Data.Int (Int8, Int16, Int32, Int64)
+import qualified Data.IntSet as IntSet
 import Data.Map (Map)
 import Data.Monoid (Dual(..), First(..), Last(..))
+import Data.Ratio (Ratio)
 import Data.Text (Text, pack, unpack)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (formatTime, parseTime)
 import Data.Typeable (Typeable)
 import Data.Vector (Vector)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
 import System.Locale (defaultTimeLocale)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.Map as M
 import qualified Data.Set as Set
+import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
 import qualified Data.Vector as V
+import Data.Aeson.Functions
 
 -- | A JSON \"object\" (key\/value map).
 type Object = Map Text Value
 emptyObject = Object M.empty
 
 -- | A key\/value pair for an 'Object'.
-newtype Pair = Pair { unPair :: (Text, Value) }
-    deriving (Eq, Typeable)
-
-instance Show Pair where
-    show = show . unPair
+type Pair = (Text, Value)
 
 -- | Construct a 'Pair' from a key and a value.
 (.=) :: ToJSON a => Text -> a -> Pair
-name .= value = Pair (name, toJSON value)
+name .= value = (name, toJSON value)
 {-# INLINE (.=) #-}
 
 -- | Retrieve the value associated with the given key of an 'Object'.
                Just v  -> fromJSON v
 {-# INLINE (.:?) #-}
 
--- | Create a 'Value' from a list of 'Pair's.  If duplicate
+-- | Create a 'Value' from a list of name\/value 'Pair's.  If duplicate
 -- keys arise, earlier keys and their associated values win.
 object :: [Pair] -> Value
-object = Object . M.fromList . map unPair
+object = Object . M.fromList
 {-# INLINE object #-}
 
 -- | A type that can be converted to JSON.
     fromJSON _        = empty
     {-# INLINE fromJSON #-}
 
+instance ToJSON () where
+    toJSON _ = emptyArray
+    {-# INLINE toJSON #-}
+
+instance FromJSON () where
+    fromJSON (Array v) | V.null v = pure ()
+    fromJSON _                    = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON [Char] where
+    toJSON = String . T.pack
+    {-# INLINE toJSON #-}
+
+instance FromJSON [Char] where
+    fromJSON (String t) = pure (T.unpack t)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Char where
+    toJSON = String . T.singleton
+    {-# INLINE toJSON #-}
+
+instance FromJSON Char where
+    fromJSON (String t)
+        | T.compareLength t 1 == EQ = pure (T.head t)
+    fromJSON _                      = empty
+    {-# INLINE fromJSON #-}
+
 instance ToJSON Double where
     toJSON = Number
     {-# INLINE toJSON #-}
     fromJSON _          = empty
     {-# INLINE fromJSON #-}
 
+instance ToJSON Float where
+    toJSON = Number . fromRational . toRational
+    {-# INLINE toJSON #-}
+
+instance FromJSON Float where
+    fromJSON (Number n) = pure . fromRational . toRational $ n
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON (Ratio Integer) where
+    toJSON = Number . fromRational
+    {-# INLINE toJSON #-}
+
+instance FromJSON (Ratio Integer) where
+    fromJSON (Number n) = pure . toRational $ n
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
 instance ToJSON Int where
     toJSON = Number . fromIntegral
     {-# INLINE toJSON #-}
     fromJSON _          = empty
     {-# INLINE fromJSON #-}
 
+instance ToJSON Int8 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int8 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Int16 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int16 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Int32 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int32 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Int64 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int64 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Word where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Word8 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word8 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Word16 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word16 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Word32 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word32 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance ToJSON Word64 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word64 where
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
 instance ToJSON Text where
     toJSON = String
     {-# INLINE toJSON #-}
     fromJSON = fmap Set.fromList . fromJSON
     {-# INLINE fromJSON #-}
 
+instance ToJSON IntSet.IntSet where
+    toJSON = toJSON . IntSet.toList
+    {-# INLINE toJSON #-}
+    
+instance FromJSON IntSet.IntSet where
+    fromJSON = fmap IntSet.fromList . fromJSON
+    {-# INLINE fromJSON #-}
+
 instance (ToJSON v) => ToJSON (M.Map Text v) where
     toJSON = Object . M.map toJSON
     {-# INLINE toJSON #-}
     fromJSON = fmap Last . fromJSON
     {-# INLINE fromJSON #-}
 
--- | Transform one map into another.  The ordering of keys must be
--- preserved.
-transformMap :: (Ord k1, Ord k2) => (k1 -> k2) -> (v1 -> v2)
-             -> M.Map k1 v1 -> M.Map k2 v2
-transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList
-
 mapA :: (Alternative m) => (t -> m a) -> [t] -> m [a]
 mapA f = go
   where
   exposed-modules:
     Data.Aeson
     Data.Aeson.Encode
+    Data.Aeson.Generic
     Data.Aeson.Parser
     Data.Aeson.Types
 
+  other-modules:
+    Data.Aeson.Functions
+
   build-depends:
     attoparsec >= 0.8.4.0,
     base == 4.*,
     containers,
     deepseq,
     old-locale,
+    syb,
     text >= 0.11.0.2,
     time,
     vector >= 0.7