Commits

Bryan O'Sullivan committed 5468537 Merge

Merge with Eduard

Comments (0)

Files changed (2)

Data/Aeson/Generic.hs

             remap f = Object . hashMap (f . fromJust . cast) toJSON $ m
 
 
+-- Skip leading '_' in field name so we can use keywords
+-- etc. as field names.
+mungeField :: String -> Text
+mungeField ('_':cs) = pack cs
+mungeField cs       = pack cs
+
+
 toJSON_generic :: (Data a) => a -> Value
 toJSON_generic = generic
   where
         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 :: (Data a) => Value -> Result a
 fromJSON = parse parseJSON
         -- Select the named fields from a JSON object.
         selectFields fjs = mapM sel
           where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++
-                               f) return $ Map.lookup (pack f) fjs
+                               f) return $ Map.lookup (mungeField f) fjs
 
         -- Count how many arguments a constructor has.  The value x is
         -- used to determine what type the constructor returns.

tests/Properties.hs

                 Error _ -> False
                 Success x' -> x == x'
 
+genericToFromJSON :: (Arbitrary a, Eq a, Data a) => a -> Bool
+genericToFromJSON x = case G.fromJSON . G.toJSON $ x of
+                Error _ -> False
+                Success x' -> x == x'
+
+
 data Foo = Foo {
       fooInt :: Int
     , fooDouble :: Double
 instance Arbitrary Foo where
     arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary
 
+
+{-
+   Test for Data.Aeson.Generic handling '_' names
+-}
+data UFoo = UFoo {
+      _UFooInt :: Int
+    , uFooInt :: Int
+    } deriving (Show, Eq, Data, Typeable)
+
+instance Arbitrary UFoo where
+    arbitrary = UFoo <$> arbitrary <*> arbitrary
+
+
+
 main :: IO ()
 main = defaultMain tests
 
     , testProperty "Maybe Integer" (toFromJSON :: Maybe Integer -> Bool)
     , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Bool)
     , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Bool)
+    ],
+  testGroup "genericToFromJSON" [
+      testProperty "_UFoo" (genericToFromJSON :: UFoo -> Bool)
     ]
   ]