Bryan O'Sullivan avatar Bryan O'Sullivan committed 5caabfc

Improve error reporting on type mismatches

Comments (0)

Files changed (2)

Data/Aeson/Types.hs

     , Pair
     , Object
     , emptyObject
-    -- * Convenience types
+    -- * Convenience types and functions
     , DotNetTime(..)
+    , typeMismatch
     -- * Type conversion
     , Parser
     , Result(..)
 -- optional, use '(.:?)' instead.
 (.:) :: (FromJSON a) => Object -> Text -> Parser a
 obj .: key = case M.lookup key obj of
-               Nothing -> empty
+               Nothing -> fail $ "key " ++ show key ++ " not present"
                Just v  -> parseJSON v
 {-# INLINE (.:) #-}
 
 
 instance FromJSON Bool where
     parseJSON (Bool b) = pure b
-    parseJSON _        = empty
+    parseJSON v        = typeMismatch "Bool" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON () where
 
 instance FromJSON () where
     parseJSON (Array v) | V.null v = pure ()
-    parseJSON _                    = empty
+    parseJSON v        = typeMismatch "()" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON [Char] where
 
 instance FromJSON [Char] where
     parseJSON (String t) = pure (T.unpack t)
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "String" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON Char where
 instance FromJSON Char where
     parseJSON (String t)
         | T.compareLength t 1 == EQ = pure (T.head t)
-    parseJSON _                      = empty
+    parseJSON v          = typeMismatch "Char" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON Double where
     parseJSON (Number n) = case n of
                              D d -> pure d
                              I i -> pure (fromIntegral i)
-    parseJSON _              = empty
+    parseJSON v          = typeMismatch "Double" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON Number where
 
 instance FromJSON Number where
     parseJSON (Number n) = pure n
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Number" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON Float where
     parseJSON (Number n) = case n of
                              D d -> pure . fromRational . toRational $ d
                              I i -> pure (fromIntegral i)
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Float" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON (Ratio Integer) where
     parseJSON (Number n) = case n of
                              D d -> pure . toRational $ d
                              I i -> pure (fromIntegral i)
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Ratio Integer" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON Int where
 
 parseIntegral :: Integral a => Value -> Parser a
 parseIntegral (Number n) = pure (floor n)
-parseIntegral _          = empty
+parseIntegral v          = typeMismatch "Integral" v
 {-# INLINE parseIntegral #-}
 
 instance ToJSON Integer where
 
 instance FromJSON Text where
     parseJSON (String t) = pure t
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Text" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON LT.Text where
 
 instance FromJSON LT.Text where
     parseJSON (String t) = pure (LT.fromStrict t)
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Lazy Text" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON B.ByteString where
 
 instance FromJSON B.ByteString where
     parseJSON (String t) = pure . encodeUtf8 $ t
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "ByteString" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON LB.ByteString where
 
 instance FromJSON LB.ByteString where
     parseJSON (String t) = pure . lazy $ t
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Lazy ByteString" v
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON [a] where
     
 instance (FromJSON a) => FromJSON [a] where
     parseJSON (Array a) = mapM parseJSON (V.toList a)
-    parseJSON _         = empty
+    parseJSON v         = typeMismatch "[a]" v
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON (Vector a) where
     
 instance (FromJSON a) => FromJSON (Vector a) where
     parseJSON (Array a) = V.mapM parseJSON a
-    parseJSON _         = empty
+    parseJSON v         = typeMismatch "Vector a" v
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON (Set.Set a) where
 instance (FromJSON v) => FromJSON (M.Map Text v) where
     parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o)
       where go (k,v)     = ((,) k) <$> parseJSON v
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "Map Text a" v
 
 instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
     toJSON = Object . transformMap LT.toStrict toJSON
 instance (FromJSON v) => FromJSON (H.HashMap Text v) where
     parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
       where go (k,v)     = ((,) k) <$> parseJSON v
-    parseJSON _          = empty
+    parseJSON v          = typeMismatch "HashMap Text a" v
 
 instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
     toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
     parseJSON (String t) =
         case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
           Just d -> pure (DotNetTime d)
-          _      -> empty
-    parseJSON _          = empty
+          _      -> fail "could not parse .NET time"
+    parseJSON v   = typeMismatch "DotNetTime" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON UTCTime where
 
 instance FromJSON UTCTime where
     parseJSON (String t) =
-        case parseTime defaultTimeLocale "%FT%X%QZ" (unpack t) of
+        case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
           Just d -> pure d
-          _      -> empty
-    parseJSON _          = empty
+          _      -> fail "could not parse ISO-8601 date"
+    parseJSON v   = typeMismatch "UTCTime" v
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
-    parseJSON (Array ab) = case V.toList ab of
-                            [a,b] -> (,) <$> parseJSON a <*> parseJSON b
-                            _     -> empty
-    parseJSON _          = empty
+    parseJSON (Array ab) =
+      case V.toList ab of
+        [a,b] -> (,) <$> parseJSON a <*> parseJSON b
+        _     -> fail $ "cannot unpack array of length " ++
+                        show (V.length ab) ++ " into a pair"
+    parseJSON v          = typeMismatch "(a,b)" v
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
+    toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
+    parseJSON (Array abc) =
+      case V.toList abc of
+        [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
+        _       -> fail $ "cannot unpack array of length " ++
+                          show (V.length abc) ++ " into a 3-tuple"
+    parseJSON v          = typeMismatch "(a,b,c)" v
     {-# INLINE parseJSON #-}
 
 instance ToJSON a => ToJSON (Dual a) where
 instance FromJSON a => FromJSON (Last a) where
     parseJSON = fmap Last . parseJSON
     {-# INLINE parseJSON #-}
+
+-- | Fail parsing due to a type mismatch, with a descriptive message.
+typeMismatch :: String -- ^ The name of the type you are trying to parse.
+             -> Value  -- ^ The actual value encountered.
+             -> Parser a
+typeMismatch expected actual =
+    fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
+           " instead"
+  where
+    name = case actual of
+             Object _ -> "Object"
+             Array _  -> "Array"
+             String _ -> "String"
+             Number _ -> "Number"
+             Bool _   -> "Boolean"
+             Null     -> "Null"
 name:            aeson
-version:         0.3.0.0
+version:         0.3.0.1
 license:         BSD3
 license-file:    LICENSE
 category:        Text, Web, JSON
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.