Resolve #842: Add instances for network-uri's URI

Author: phadej

aeson.cabal

@@ -115,6 +115,7 @@ library
     , hashable              >=1.3.5.0  && <1.5
     , indexed-traversable   >=0.1.2    && <0.2
     , integer-conversion    >=0.1      && <0.2
+    , network-uri           >=2.6.4.1  && <2.7
     , OneTuple              >=0.4.1.1  && <0.5
     , primitive             >=0.8.0.0  && <0.9
     , QuickCheck            >=2.14.3   && <2.15
@@ -202,6 +203,7 @@ test-suite aeson-tests
     , hashable
     , indexed-traversable
     , integer-logarithms    >=1      && <1.1
+    , network-uri
     , OneTuple
     , primitive
     , QuickCheck            >=2.14.2 && <2.15

changelog.md

@@ -32,6 +32,7 @@ For the latest version of this document, please see [https://github.com/haskell/
   The new native Haskell implementation (introduced in version 2.0.3.0) is at least as fast.
 * Drop instances for `Number` from `attoparsec` package.
 * Improve `Arbitrary Value` instance.
+* Add instances for `URI` from `network-uri`.
 
 ### 2.1.2.1
 

src/Data/Aeson/Types/FromJSON.hs

@@ -151,6 +151,7 @@ import qualified Data.Vector.Generic as VG
 import qualified Data.Vector.Primitive as VP
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Unboxed as VU
+import qualified Network.URI as URI
 
 import qualified GHC.Exts as Exts
 import qualified Data.Primitive.Array as PM
@@ -2423,6 +2424,23 @@ instance (FromJSON1 f, Functor f) => FromJSON (F.Mu f) where
 instance (FromJSON1 f, Functor f) => FromJSON (F.Nu f) where
     parseJSON = fmap (F.unfoldNu F.unFix) . parseJSON
 
+-------------------------------------------------------------------------------
+-- network-uri
+-------------------------------------------------------------------------------
+
+-- | @since 2.2.0.0
+instance FromJSON URI.URI where
+    parseJSON = withText "URI" parseURI
+
+-- | @since 2.2.0.0
+instance FromJSONKey URI.URI where
+    fromJSONKey = FromJSONKeyTextParser parseURI
+
+parseURI :: Text -> Parser URI.URI
+parseURI t = case URI.parseURI (T.unpack t) of
+    Nothing -> fail "Invalid URI"
+    Just x  -> return x
+
 -------------------------------------------------------------------------------
 -- strict
 -------------------------------------------------------------------------------

src/Data/Aeson/Types/ToJSON.hs

@@ -124,6 +124,7 @@ import qualified Data.Vector.Mutable as VM
 import qualified Data.Vector.Primitive as VP
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Unboxed as VU
+import qualified Network.URI as URI
 
 import qualified Data.Aeson.Encoding.Builder as EB
 import qualified Data.ByteString.Builder as B
@@ -2188,6 +2189,22 @@ instance (ToJSON1 f, Functor f) => ToJSON (F.Nu f) where
     toJSON     = F.foldNu (liftToJSON (const False) id (listValue id))
     toEncoding = F.foldNu (liftToEncoding (const False) id (listEncoding id))
 
+-------------------------------------------------------------------------------
+-- network-uri
+-------------------------------------------------------------------------------
+
+-- | @since 2.2.0.0
+instance ToJSON URI.URI where
+    toJSON uri = toJSON (URI.uriToString id uri "")
+    toEncoding = encodeURI
+
+-- | @since 2.2.0.0
+instance ToJSONKey URI.URI where
+    toJSONKey = toJSONKeyTextEnc encodeURI
+
+encodeURI :: URI.URI -> Encoding' a
+encodeURI uri = E.string (URI.uriToString id uri "")
+
 -------------------------------------------------------------------------------
 -- strict
 -------------------------------------------------------------------------------

tests/Instances.hs

@@ -13,15 +13,17 @@ import Prelude.Compat
 
 import Control.Applicative (empty)
 import Control.Monad
+import Data.Maybe (mapMaybe)
 import Data.Aeson.Types
 import Data.Function (on)
 import Data.Time (ZonedTime(..), TimeZone(..))
 import Data.Time.Clock (UTCTime(..))
 import Functions
-import Test.QuickCheck (Arbitrary(..), elements,  oneof)
+import Test.QuickCheck (Arbitrary(..), elements, oneof)
 import Types
 import qualified Data.DList as DList
 import qualified Data.HashMap.Strict as HM
+import qualified Network.URI as URI
 
 import Data.Orphans ()
 import Test.QuickCheck.Instances ()
@@ -167,3 +169,9 @@ instance (ApproxEq a) => ApproxEq [a] where
 
 instance Arbitrary a => Arbitrary (DList.DList a) where
     arbitrary = DList.fromList <$> arbitrary
+
+instance Arbitrary URI.URI where
+    arbitrary = elements $ mapMaybe URI.parseURI
+        [ "https://haskell.org"
+        , "foo://[email protected]:42/ghc?query#frag"
+        ]

tests/PropertyRoundTrip.hs

@@ -23,6 +23,7 @@ import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek)
 import Data.Time.LocalTime.Compat (CalendarDiffTime)
 import Data.Time.Clock.System.Compat (SystemTime)
 import Data.Tuple.Solo (Solo)
+import Network.URI (URI)
 import Numeric.Natural (Natural)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
@@ -92,6 +93,7 @@ roundTripTests =
     , testProperty "Strict Maybe" $ roundTripEq @(S.Maybe Int)
     , testProperty "Solo Int" $ roundTripEq @(Solo Int)
     , testProperty "ShortText" $ roundTripEq @ST.ShortText
+    , testProperty "URI" $ roundTripEq @URI
     , roundTripFunctorsTests
     , testGroup "ghcGenerics" [
         testProperty "OneConstructor" $ roundTripEq OneConstructor