Commits

Bryan O'Sullivan committed 7917d7e Merge

Merge

Comments (0)

Files changed (5)

Data/Aeson/Encode.hs

 import Blaze.ByteString.Builder
 import Blaze.ByteString.Builder.Char.Utf8
 import Data.Aeson.Types (ToJSON(..), Value(..))
+import Data.Attoparsec.Number (Number(..))
 import Data.Monoid (mappend)
 import Numeric (showHex)
-import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Vector as V
+import qualified Text.Show.ByteString as S
 
 -- | Encode a JSON value to a 'Builder'.
 fromValue :: Value -> Builder
 fromValue Null = fromByteString "null"
 fromValue (Bool b) = fromByteString $ if b then "true" else "false"
-fromValue (Number n) = fromByteString (B.pack (show n))
+fromValue (Number (I n)) = fromLazyByteString (S.show n)
+fromValue (Number (D n)) = fromLazyByteString (S.show n)
 fromValue (String s) = string s
 fromValue (Array v)
     | V.null v = fromByteString "[]"
   where
     quote q = case T.uncons t of
                 Just (c,t') -> fromText h `mappend` escape c `mappend` quote t'
-                Nothing -> fromText h
+                Nothing     -> fromText h
         where (h,t) = T.break isEscape q
     isEscape c = c == '\"' || c == '\\' || c < '\x20'
     escape '\"' = fromByteString "\\\""

Data/Aeson/Functions.hs

 module Data.Aeson.Functions
     (
-      transformMap
+      hashMap
+    , mapHash
+    , transformMap
     ) where
 
-import Control.Arrow ((***))
+import Control.Arrow ((***), first)
+import Data.Hashable (Hashable)
+import qualified Data.HashMap.Strict as H
 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)
+-- preserved by the key transformation function.
+transformMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2)
              -> M.Map k1 v1 -> M.Map k2 v2
 transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList
+{-# INLINE transformMap #-}
+
+-- | Transform a 'H.HashMap' into a 'M.Map'.
+hashMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2)
+        -> H.HashMap k1 v1 -> M.Map k2 v2
+hashMap fk kv = M.fromList . map (fk *** kv) . H.toList
+{-# INLINE hashMap #-}
+
+-- | Transform a 'M.Map' into a 'H.HashMap'.
+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 #-}

Data/Aeson/Generic.hs

-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards, RankNTypes, ScopedTypeVariables  #-}
 
 -- Module:      Data.Aeson.Generic
 -- Copyright:   (c) 2011 MailRank, Inc.
 import Control.Applicative ((<$>))
 import Control.Arrow (first)
 import Control.Monad.State.Strict
-import Data.Aeson.Functions (transformMap)
+import Data.Aeson.Functions (hashMap, transformMap)
 import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
 import Data.Attoparsec.Number (Number)
 import Data.Generics
 import Data.Int (Int8, Int16, Int32, Int64)
 import Data.IntSet (IntSet)
+import Data.Maybe (fromJust)
 import Data.Text (Text, pack, unpack)
 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.Set as Set
-import qualified Data.Text.Lazy as L
 import qualified Data.Vector as V
 
 type T a = a -> Value
          `ext1Q` list
          `ext1Q` vector
          `ext1Q` set
-         `ext1Q` mapText
-         `ext1Q` mapLazyText
-         `ext1Q` mapString
+         `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 Rational)
          `extQ` (T.toJSON :: T Char)
          `extQ` (T.toJSON :: T Text)
-         `extQ` (T.toJSON :: T L.Text)
+         `extQ` (T.toJSON :: T LT.Text)
          `extQ` (T.toJSON :: T String)
          `extQ` (T.toJSON :: T B.ByteString)
          `extQ` (T.toJSON :: T L.ByteString)
     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
+
+    mapAny m
+      | tyrep == typeOf ""       = remap pack
+      | tyrep == typeOf DT.empty = remap id
+      | tyrep == typeOf LT.empty = remap LT.toStrict
+      | 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
+      | 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
                 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 ++ ")"
+              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.
 parseJSON j = parseJSON_generic j
              `ext1R` list
              `ext1R` vector
-             `ext1R` mapText
-             `ext1R` mapLazyText
-             `ext1R` mapString
+             `ext2R'` mapAny
+             -- Don't know how to support parsing HashMaps :-(
              -- Use the standard encoding for all base types.
              `extR` (value :: F Integer)
              `extR` (value :: F Int)
              `extR` (value :: F Rational)
              `extR` (value :: F Char)
              `extR` (value :: F Text)
-             `extR` (value :: F L.Text)
+             `extR` (value :: F LT.Text)
              `extR` (value :: F String)
              `extR` (value :: F B.ByteString)
              `extR` (value :: F L.ByteString)
     vector :: (Data a) => Parser (V.Vector a)
     vector = case j of
                Array js -> V.mapM parseJSON js
-               _        -> modFail "parseJSON" $ "bad data: " ++ show j
-    mapText :: (Data a) => Parser (Map.Map Text a)
-    mapText = case j of
-                Object js -> T.mapM parseJSON js
-                _         -> modFail "parseJSON" $ "bad data: " ++ show j
-    mapLazyText :: (Data a) => Parser (Map.Map L.Text a)
-    mapLazyText = Map.mapKeysMonotonic L.fromStrict <$> parseJSON j
-    mapString :: (Data a) => Parser (Map.Map String a)
-    mapString = Map.mapKeysMonotonic unpack <$> parseJSON 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
+        | 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
+               | otherwise = modError "parseJSON"
+                                      "mapAny -- should never happen"
+            tyrep = typeOf (undefined :: f)
+    myFail = modFail "parseJSON" $ "bad data: " ++ show j
+
 
 parseJSON_generic :: (Data a) => Value -> Parser a
 parseJSON_generic j = generic
         typ = dataTypeOf $ resType generic
         generic = case dataTypeRep typ of
                     AlgRep []  -> case j of
-                                    Null -> return (error "Empty type")
+                                    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'
         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
+        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 f = do modify (+1); return undefined
 
         resType :: MonadPlus m => m a -> a
-        resType _ = error "resType"
+        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 }
+
+-- | The type constructor for readers
+newtype R m x = R { unR :: m x }

Data/Aeson/Types.hs

     ) where
 
 import Control.Applicative
+import Control.DeepSeq (NFData(..))
 import Control.Monad (MonadPlus(..))
-import Data.Monoid (Monoid(..))
-import Control.DeepSeq (NFData(..))
+import Data.Aeson.Functions (hashMap, mapHash, transformMap)
+import Data.Attoparsec.Char8 (Number(..))
 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.Monoid (Monoid(..))
 import Data.Ratio (Ratio)
 import Data.String (IsString(..))
 import Data.Text (Text, pack, unpack)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
-import Data.Attoparsec.Char8 (Number(..))
 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.HashMap.Strict as H
+import qualified Data.IntSet as IntSet
 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
 
 -- | The result of running a 'Parser'.
 data Result a = Error String
 instance (FromJSON v) => FromJSON (M.Map String v) where
     parseJSON = fmap (M.mapKeysMonotonic unpack) . 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 _          = empty
+
+instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
+    toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
+
+instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
+    parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
+
+instance (ToJSON v) => ToJSON (H.HashMap String v) where
+    toJSON = Object . hashMap pack toJSON
+
+instance (FromJSON v) => FromJSON (H.HashMap String v) where
+    parseJSON = fmap (mapHash unpack) . parseJSON
+
 instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
     toJSON = Object . transformMap decode toJSON
 
     base == 4.*,
     blaze-builder >= 0.2.1.4,
     bytestring,
+    bytestring-show,
     containers,
     deepseq,
+    hashable,
     monads-fd,
     old-locale,
     syb,
     text >= 0.11.0.2,
     time,
+    unordered-containers,
     vector >= 0.7
 
   if flag(developer)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.