Bryan O'Sullivan avatar Bryan O'Sullivan committed d1ba999

Small cleanups to the generic code

Comments (0)

Files changed (2)

Data/Aeson/Functions.hs

 
 -- | Transform one map into another.  The ordering of keys must be
 -- preserved.
-transformMap :: (Ord k1, Ord k2) => (k1 -> k2) -> (v1 -> v2)
+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

Data/Aeson/Generic.hs

     ) where
 
 import Control.Applicative ((<$>))
-import Control.Arrow (first,(***))
+import Control.Arrow (first)
 import Control.Monad.State.Strict
+import Data.Aeson.Functions (transformMap)
 import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
 import Data.Attoparsec.Number (Number)
 import Data.Generics
     set s = Array . V.fromList . map toJSON . Set.toList $ s
 
     mapAny m
-        | tyrep == typeOf "" = Object . Map.fromAscList . map ((pack . fromJust . cast) *** toJSON) . Map.toList $ m
-        | tyrep == typeOf DT.empty = Object . Map.fromAscList . map ((fromJust . cast) *** toJSON) . Map.toList $ m
-        | tyrep == typeOf LT.empty = Object . Map.fromAscList . map ((LT.toStrict . fromJust . cast) *** toJSON) . Map.toList $ m
-        | otherwise = error $ "toJSON cannot convert map keyed by type: " ++ show tyrep
+      | 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
 
 
 toJSON_generic :: (Data a) => a -> Value
                 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.
             trans
                | tyrep == typeOf DT.empty = fromJust . cast . id
                | tyrep == typeOf LT.empty = fromJust . cast . LT.fromStrict
-               | tyrep == typeOf "" = fromJust . cast . DT.unpack
-               | otherwise = error "parseJSON: mapAny -- should never happen"
+               | tyrep == typeOf ""       = fromJust . cast . DT.unpack
+               | otherwise = modError "parseJSON"
+                                      "mapAny -- should never happen"
             tyrep = typeOf (undefined :: f)
     myFail = modFail "parseJSON" $ "bad data: " ++ show j
 
         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'
           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
-------------------------------------------------------------------------------
+
+-- Type extension for binary type constructors.
 
 -- | Flexible type extension
 ext2' :: (Data a, Typeable2 t)
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.