Bryan O'Sullivan avatar Bryan O'Sullivan committed 3d6a62a Merge

Merge pull request #90 from basvandijk/with

Add functions for inspecting Values

Comments (0)

Files changed (3)

     , Result(..)
     , fromJSON
     , ToJSON(..)
+    -- * Inspecting @'Value's@
+    , withObject
+    , withText
+    , withArray
+    , withNumber
+    , withBool
     -- * Constructors and accessors
     , (.=)
     , (.:)

Data/Aeson/Types.hs

     , parseEither
     , parseMaybe
     , ToJSON(..)
+
+    -- * Inspecting @'Value's@
+    , withObject
+    , withText
+    , withArray
+    , withNumber
+    , withBool
+
     -- * Constructors and accessors
     , (.=)
     , (.:)

Data/Aeson/Types/Class.hs

 #endif
     -- * Types
     , DotNetTime(..)
+
+      -- * Inspecting @'Value's@
+    , withObject
+    , withText
+    , withArray
+    , withNumber
+    , withBool
+
     -- * Functions
     , fromJSON
     , (.:)
     {-# INLINE toJSON #-}
 
 instance FromJSON Bool where
-    parseJSON (Bool b) = pure b
-    parseJSON v        = typeMismatch "Bool" v
+    parseJSON = withBool "Bool" pure
     {-# INLINE parseJSON #-}
 
 instance ToJSON () where
     {-# INLINE toJSON #-}
 
 instance FromJSON () where
-    parseJSON (Array v) | V.null v = pure ()
-    parseJSON v        = typeMismatch "()" v
+    parseJSON = withArray "()" $ \v ->
+                  if V.null v
+                    then pure ()
+                    else fail "Expected an empty array"
     {-# INLINE parseJSON #-}
 
 instance ToJSON [Char] where
     {-# INLINE toJSON #-}
 
 instance FromJSON [Char] where
-    parseJSON (String t) = pure (T.unpack t)
-    parseJSON v          = typeMismatch "String" v
+    parseJSON = withText "String" $ pure . T.unpack
     {-# INLINE parseJSON #-}
 
 instance ToJSON Char where
     {-# INLINE toJSON #-}
 
 instance FromJSON Char where
-    parseJSON (String t)
-        | T.compareLength t 1 == EQ = pure (T.head t)
-    parseJSON v          = typeMismatch "Char" v
+    parseJSON = withText "Char" $ \t ->
+                  if T.compareLength t 1 == EQ
+                    then pure $ T.head t
+                    else fail "Expected a string of length 1"
     {-# INLINE parseJSON #-}
 
 instance ToJSON Double where
     {-# INLINE toJSON #-}
 
 instance FromJSON (Ratio Integer) where
-    parseJSON (Number n) = pure $ case n of
-                                    D d -> toRational d
-                                    I i -> fromIntegral i
-    parseJSON v          = typeMismatch "Ratio Integer" v
+    parseJSON = withNumber "Ration Integer" $ \n ->
+                  pure $ case n of
+                           D d -> toRational d
+                           I i -> fromIntegral i
     {-# INLINE parseJSON #-}
 
 instance HasResolution a => ToJSON (Fixed a) where
     {-# INLINE parseJSON #-}
 
 parseIntegral :: Integral a => Value -> Parser a
-parseIntegral (Number n) = pure (floor n)
-parseIntegral v          = typeMismatch "Integral" v
+parseIntegral = withNumber "Integral" $ pure . floor
 {-# INLINE parseIntegral #-}
 
 instance ToJSON Integer where
     {-# INLINE toJSON #-}
 
 instance FromJSON Text where
-    parseJSON (String t) = pure t
-    parseJSON v          = typeMismatch "Text" v
+    parseJSON = withText "Text" pure
     {-# INLINE parseJSON #-}
 
 instance ToJSON LT.Text where
     {-# INLINE toJSON #-}
 
 instance FromJSON LT.Text where
-    parseJSON (String t) = pure (LT.fromStrict t)
-    parseJSON v          = typeMismatch "Lazy Text" v
+    parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
     {-# INLINE parseJSON #-}
 
 instance ToJSON B.ByteString where
     {-# INLINE toJSON #-}
 
 instance FromJSON B.ByteString where
-    parseJSON (String t) = pure . encodeUtf8 $ t
-    parseJSON v          = typeMismatch "ByteString" v
+    parseJSON = withText "ByteString" $ pure . encodeUtf8
     {-# INLINE parseJSON #-}
 
 instance ToJSON LB.ByteString where
     {-# INLINE toJSON #-}
 
 instance FromJSON LB.ByteString where
-    parseJSON (String t) = pure . lazy $ t
-    parseJSON v          = typeMismatch "Lazy ByteString" v
+    parseJSON = withText "Lazy ByteString" $ pure . lazy
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON [a] where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a) => FromJSON [a] where
-    parseJSON (Array a) = mapM parseJSON (V.toList a)
-    parseJSON v         = typeMismatch "[a]" v
+    parseJSON = withArray "[a]" $ mapM parseJSON . V.toList
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON (Vector a) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a) => FromJSON (Vector a) where
-    parseJSON (Array a) = V.mapM parseJSON a
-    parseJSON v         = typeMismatch "Vector a" v
+    parseJSON = withArray "Vector a" $ V.mapM parseJSON
     {-# INLINE parseJSON #-}
 
 vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
 {-# INLINE vectorToJSON #-}
 
 vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
-vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a
-vectorParseJSON s v         = typeMismatch s v
+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON
 {-# INLINE vectorParseJSON #-}
 
 instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON v) => FromJSON (M.Map Text v) where
-    parseJSON (Object o) = H.foldrWithKey M.insert M.empty <$> traverse parseJSON o
-    parseJSON v          = typeMismatch "Map Text a" v
+    parseJSON = withObject "Map Text a" $
+                  fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON
 
 instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
     toJSON = Object . mapHashKeyVal LT.toStrict toJSON
     {-# INLINE toJSON #-}
 
 instance (FromJSON v) => FromJSON (H.HashMap Text v) where
-    parseJSON (Object o) = traverse parseJSON o
-    parseJSON v          = typeMismatch "HashMap Text a" v
+    parseJSON = withObject "HashMap Text a" $ traverse parseJSON
 
 instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
     toJSON = Object . mapKeyVal LT.toStrict toJSON
     {-# INLINE toJSON #-}
 
 instance FromJSON DotNetTime where
-    parseJSON (String t) =
-        case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
-          Just d -> pure (DotNetTime d)
-          _      -> fail "could not parse .NET time"
-      where (s,m) = T.splitAt (T.length t - 5) t
+    parseJSON = withText "DotNetTime" $ \t ->
+        let (s,m) = T.splitAt (T.length t - 5) t
             t'    = T.concat [s,".",m]
-    parseJSON v   = typeMismatch "DotNetTime" v
+        in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
+             Just d -> pure (DotNetTime d)
+             _      -> fail "could not parse .NET time"
     {-# INLINE parseJSON #-}
 
 instance ToJSON ZonedTime where
     {-# INLINE toJSON #-}
 
 instance FromJSON UTCTime where
-    parseJSON (String t) =
+    parseJSON = withText "UTCTime" $ \t ->
         case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
           Just d -> pure d
           _      -> 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)
-        | n == 2    = (,) <$> parseJSON (V.unsafeIndex ab 0)
-                          <*> parseJSON (V.unsafeIndex ab 1)
-        | otherwise = fail $ "cannot unpack array of length " ++
-                        show n ++ " into a pair"
-          where
-            n = V.length ab
-    parseJSON v = typeMismatch "(a,b)" v
+    parseJSON = withArray "(a,b)" $ \ab ->
+        let n = V.length ab
+        in if n == 2
+             then (,) <$> parseJSON (V.unsafeIndex ab 0)
+                      <*> parseJSON (V.unsafeIndex ab 1)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a pair"
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
-    parseJSON (Array abc)
-        | n == 3    = (,,) <$> parseJSON (V.unsafeIndex abc 0)
-                           <*> parseJSON (V.unsafeIndex abc 1)
-                           <*> parseJSON (V.unsafeIndex abc 2)
-        | otherwise = fail $ "cannot unpack array of length " ++
-                        show n ++ " into a 3-tuple"
-          where
-            n = V.length abc
-    parseJSON v = typeMismatch "(a,b,c)" v
+    parseJSON = withArray "(a,b,c)" $ \abc ->
+        let n = V.length abc
+        in if n == 3
+             then (,,) <$> parseJSON (V.unsafeIndex abc 0)
+                       <*> parseJSON (V.unsafeIndex abc 1)
+                       <*> parseJSON (V.unsafeIndex abc 2)
+             else fail $ "cannot unpack array of length " ++
+                          show n ++ " into a 3-tuple"
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
     {-# INLINE toJSON #-}
 
 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
-    parseJSON (Array abcd)
-        | n == 4    = (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
-                            <*> parseJSON (V.unsafeIndex abcd 1)
-                            <*> parseJSON (V.unsafeIndex abcd 2)
-                            <*> parseJSON (V.unsafeIndex abcd 3)
-        | otherwise = fail $ "cannot unpack array of length " ++
-                        show n ++ " into a 4-tuple"
-          where
-            n = V.length abcd
-    parseJSON v = typeMismatch "(a,b,c,d)" v
+    parseJSON = withArray "(a,b,c,d)" $ \abcd ->
+        let n = V.length abcd
+        in if n == 4
+             then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
+                        <*> parseJSON (V.unsafeIndex abcd 1)
+                        <*> parseJSON (V.unsafeIndex abcd 2)
+                        <*> parseJSON (V.unsafeIndex abcd 3)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a 4-tuple"
     {-# INLINE parseJSON #-}
 
 instance ToJSON a => ToJSON (Dual a) where
     parseJSON = fmap Last . parseJSON
     {-# INLINE parseJSON #-}
 
+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withObject :: String -> (Object -> Parser a) -> Value -> Parser a
+withObject _        f (Object obj) = f obj
+withObject expected _ v            = typeMismatch expected v
+{-# INLINE withObject #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withText :: String -> (Text -> Parser a) -> Value -> Parser a
+withText _        f (String txt) = f txt
+withText expected _ v            = typeMismatch expected v
+{-# INLINE withText #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withArray :: String -> (Array -> Parser a) -> Value -> Parser a
+withArray _        f (Array arr) = f arr
+withArray expected _ v           = typeMismatch expected v
+{-# INLINE withArray #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
+withNumber _        f (Number num) = f num
+withNumber expected _ v            = typeMismatch expected v
+{-# INLINE withNumber #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
+withBool _        f (Bool arr) = f arr
+withBool expected _ v          = typeMismatch expected v
+{-# INLINE withBool #-}
+
 -- | Construct a 'Pair' from a key and a value.
 (.=) :: ToJSON a => Text -> a -> Pair
 name .= value = (name, toJSON value)
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.