Merge

ozataman · Mar 12, 2011 · 644c9ae · 644c9ae
2 parents 5b83269 + 055a7f7
commit 644c9ae
Show file tree

Hide file tree

Showing 6 changed files with 81 additions and 34 deletions.
diff --git a/.hgignore b/.hgignore
@@ -1,6 +1,6 @@
 ^(?:dist|\.DS_Store)$
 ^benchmarks/(?:AesonParse|EncodeFile|JsonParse|.*_p)$
-.*\.(?:h[ip]|o|orig|out|pdf|prof|ps|rej)$
+.*\.(?:aux|h[ip]|o|orig|out|pdf|prof|ps|rej)$
 
 syntax: glob
 *~

diff --git a/.hgtags b/.hgtags
@@ -1,2 +1,3 @@
 05d9437b2280648ae25ac170697ec1c48eda7af0 0.1.0.0
 f4cf6abd5a81affb08c6563d51e38ac4f8451217 0.2.0.0
+fe4084e5615941d9822834239e4c32a036291327 0.3.0.0
diff --git a/Data/Aeson/Functions.hs b/Data/Aeson/Functions.hs
@@ -3,10 +3,18 @@ module Data.Aeson.Functions
       hashMap
     , mapHash
     , transformMap
+    -- * String conversions
+    , decode
+    , strict
+    , lazy
     ) where
 
 import Control.Arrow ((***), first)
 import Data.Hashable (Hashable)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+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 M
 
@@ -27,3 +35,15 @@ hashMap fk kv = M.fromList . map (fk *** kv) . H.toList
 mapHash :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.Map k1 v -> H.HashMap k2 v
 mapHash fk = H.fromList . map (first fk) . M.toList
 {-# INLINE mapHash #-}
+
+strict :: L.ByteString -> Text
+strict = decode . B.concat . L.toChunks
+{-# INLINE strict #-}
+
+lazy :: Text -> L.ByteString
+lazy = L.fromChunks . (:[]) . encodeUtf8
+{-# INLINE lazy #-}
+
+decode :: B.ByteString -> Text
+decode = decodeUtf8
+{-# INLINE decode #-}
diff --git a/Data/Aeson/Generic.hs b/Data/Aeson/Generic.hs
@@ -22,7 +22,7 @@ module Data.Aeson.Generic
 import Control.Applicative ((<$>))
 import Control.Arrow (first)
 import Control.Monad.State.Strict
-import Data.Aeson.Functions (hashMap, transformMap)
+import Data.Aeson.Functions
 import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
 import Data.Attoparsec.Number (Number)
 import Data.Generics
@@ -31,6 +31,7 @@ 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
@@ -88,18 +89,22 @@ toJSON = toJSON_generic
     set s = Array . V.fromList . map toJSON . Set.toList $ s
 
     mapAny m
-      | tyrep == typeOf ""       = remap pack
       | 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 ""       = remap pack
       | 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
@@ -195,18 +200,21 @@ parseJSON j = parseJSON_generic j
                _        -> myFail
     mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)
     mapAny
-        | tyrep `elem` [typeOf LT.empty, typeOf DT.empty, typeOf ""] = res
+        | 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 = fromJust . cast . id
-               | tyrep == typeOf LT.empty = fromJust . cast . LT.fromStrict
-               | tyrep == typeOf ""       = fromJust . cast . DT.unpack
+               | 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
@@ -222,6 +230,8 @@ parseJSON j = parseJSON_generic j
                         _          -> 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

diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs
@@ -38,7 +38,7 @@ module Data.Aeson.Types
 import Control.Applicative
 import Control.DeepSeq (NFData(..))
 import Control.Monad (MonadPlus(..))
-import Data.Aeson.Functions (hashMap, mapHash, transformMap)
+import Data.Aeson.Functions
 import Data.Attoparsec.Char8 (Number(..))
 import Data.Data (Data)
 import Data.Int (Int8, Int16, Int32, Int64)
@@ -48,7 +48,7 @@ import Data.Monoid (Monoid(..))
 import Data.Ratio (Ratio)
 import Data.String (IsString(..))
 import Data.Text (Text, pack, unpack)
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
 import Data.Typeable (Typeable)
@@ -458,7 +458,7 @@ instance FromJSON LT.Text where
     {-# INLINE parseJSON #-}
 
 instance ToJSON B.ByteString where
-    toJSON = String . decodeUtf8
+    toJSON = String . decode
     {-# INLINE toJSON #-}
 
 instance FromJSON B.ByteString where
@@ -467,11 +467,11 @@ instance FromJSON B.ByteString where
     {-# INLINE parseJSON #-}
 
 instance ToJSON LB.ByteString where
-    toJSON = toJSON . B.concat . LB.toChunks
+    toJSON = toJSON . strict
     {-# INLINE toJSON #-}
 
 instance FromJSON LB.ByteString where
-    parseJSON (String t) = pure . LB.fromChunks . (:[]) . encodeUtf8 $ t
+    parseJSON (String t) = pure . lazy $ t
     parseJSON _          = empty
     {-# INLINE parseJSON #-}
 
@@ -480,7 +480,7 @@ instance (ToJSON a) => ToJSON [a] where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a) => FromJSON [a] where
-    parseJSON (Array a) = mapA parseJSON (V.toList a)
+    parseJSON (Array a) = mapM parseJSON (V.toList a)
     parseJSON _         = empty
     {-# INLINE parseJSON #-}
 
@@ -489,7 +489,7 @@ instance (ToJSON a) => ToJSON (Vector a) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a) => FromJSON (Vector a) where
-    parseJSON (Array a) = V.fromList <$> mapA parseJSON (V.toList a)
+    parseJSON (Array a) = V.mapM parseJSON a
     parseJSON _         = empty
     {-# INLINE parseJSON #-}
 
@@ -514,10 +514,8 @@ instance (ToJSON v) => ToJSON (M.Map Text v) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON v) => FromJSON (M.Map Text v) where
-    parseJSON (Object o) = M.fromAscList <$> go (M.toAscList o)
-      where
-        go ((k,v):kvs)  = ((:) . (,) k) <$> parseJSON v <*> go kvs
-        go _            = pure []
+    parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o)
+      where go (k,v)     = ((,) k) <$> parseJSON v
     parseJSON _          = empty
 
 instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
@@ -532,15 +530,25 @@ instance (ToJSON v) => ToJSON (M.Map String v) where
 instance (FromJSON v) => FromJSON (M.Map String v) where
     parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
 
+instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
+    toJSON = Object . transformMap decode toJSON
+
+instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
+    parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
+
+instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
+    toJSON = Object . transformMap strict toJSON
+
+instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
+    parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
+
 instance (ToJSON v) => ToJSON (H.HashMap Text v) where
     toJSON = Object . hashMap id toJSON
     {-# INLINE toJSON #-}
 
 instance (FromJSON v) => FromJSON (H.HashMap Text v) where
-    parseJSON (Object o) = H.fromList <$> go (M.toList o)
-      where
-        go ((k,v):kvs)   = ((:) . (,) k) <$> parseJSON v <*> go kvs
-        go _             = pure []
+    parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
+      where go (k,v)     = ((,) k) <$> parseJSON v
     parseJSON _          = empty
 
 instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
@@ -555,6 +563,18 @@ instance (ToJSON v) => ToJSON (H.HashMap String v) where
 instance (FromJSON v) => FromJSON (H.HashMap String v) where
     parseJSON = fmap (mapHash unpack) . parseJSON
 
+instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
+    toJSON = Object . hashMap decode toJSON
+
+instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
+    parseJSON = fmap (mapHash encodeUtf8) . parseJSON
+
+instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
+    toJSON = Object . hashMap strict toJSON
+
+instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
+    parseJSON = fmap (mapHash lazy) . parseJSON
+
 instance ToJSON Value where
     toJSON a = a
     {-# INLINE toJSON #-}
@@ -565,8 +585,9 @@ instance FromJSON Value where
 
 -- | A newtype wrapper for 'UTCTime' that uses the same non-standard
 -- serialization format as Microsoft .NET.
-newtype DotNetTime = DotNetTime UTCTime
-    deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
+newtype DotNetTime = DotNetTime {
+      fromDotNetTime :: UTCTime
+    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
 
 instance ToJSON DotNetTime where
     toJSON (DotNetTime t) =
@@ -582,7 +603,8 @@ instance FromJSON DotNetTime where
     {-# INLINE parseJSON #-}
 
 instance ToJSON UTCTime where
-    toJSON t = String (pack (formatTime defaultTimeLocale "%FT%X%QZ" t))
+    toJSON t = String (pack (take 23 str ++ "Z"))
+      where str = formatTime defaultTimeLocale "%FT%T%Q" t
     {-# INLINE toJSON #-}
 
 instance FromJSON UTCTime where
@@ -627,9 +649,3 @@ instance ToJSON a => ToJSON (Last a) where
 instance FromJSON a => FromJSON (Last a) where
     parseJSON = fmap Last . parseJSON
     {-# INLINE parseJSON #-}
-
-mapA :: (Alternative m) => (t -> m a) -> [t] -> m [a]
-mapA f = go
-  where
-    go (a:as) = (:) <$> f a <*> go as
-    go _      = pure []
diff --git a/aeson.cabal b/aeson.cabal
@@ -1,5 +1,5 @@
 name:            aeson
-version:         0.2.0.0
+version:         0.3.0.0
 license:         BSD3
 license-file:    LICENSE
 category:        Text, Web, JSON
@@ -99,7 +99,7 @@ library
     syb,
     text >= 0.11.0.2,
     time,
-    unordered-containers,
+    unordered-containers >= 0.1.2.0,
     vector >= 0.7
 
   if flag(developer)