Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Partially implement generic JSON support.

Borrowed from the json package's implementation.
  • Loading branch information...
commit a1ee5a523fa4745f502aad04859bacbeedfc76d4 1 parent c2019b6
@bos authored
View
13 Data/Aeson/Functions.hs
@@ -0,0 +1,13 @@
+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
View
109 Data/Aeson/Generic.hs
@@ -0,0 +1,109 @@
+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
View
163 Data/Aeson/Types.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, IncoherentInstances,
+ OverlappingInstances #-}
-- Module: Data.Aeson.Types
-- Copyright: (c) 2011 MailRank, Inc.
@@ -28,25 +29,30 @@ module Data.Aeson.Types
, 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
@@ -80,15 +86,11 @@ emptyObject :: 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'.
@@ -117,10 +119,10 @@ obj .:? key = case M.lookup key obj of
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.
@@ -185,6 +187,34 @@ instance FromJSON Bool where
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 #-}
@@ -194,6 +224,24 @@ instance FromJSON Double where
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 #-}
@@ -212,6 +260,87 @@ instance FromJSON Integer where
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 #-}
@@ -274,6 +403,14 @@ instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
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 #-}
@@ -354,12 +491,6 @@ instance FromJSON a => FromJSON (Last a) where
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
View
5 aeson.cabal
@@ -64,9 +64,13 @@ library
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.*,
@@ -75,6 +79,7 @@ library
containers,
deepseq,
old-locale,
+ syb,
text >= 0.11.0.2,
time,
vector >= 0.7
Please sign in to comment.
Something went wrong with that request. Please try again.