diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Modern URI 0.3.5.0 + +* Added `Hashable` instances for `URI`, `Authority`, `UserInfo`, + `QueryParam`, `RText`. + ## Modern URI 0.3.4.4 * The `mailto` scheme does not escape `@` in its paths (fixes the regression diff --git a/Text/URI/Types.hs b/Text/URI/Types.hs --- a/Text/URI/Types.hs +++ b/Text/URI/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -8,7 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-} -- | @@ -58,6 +57,7 @@ import Data.Char import Data.Data (Data) import Data.Either (fromLeft) +import Data.Hashable (Hashable) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE @@ -107,6 +107,9 @@ } deriving (Show, Eq, Ord, Data, Typeable, Generic) +-- | @since 0.3.5.0 +instance Hashable URI + instance Arbitrary URI where arbitrary = URI @@ -125,12 +128,7 @@ -- | @since 0.3.1.0 instance TH.Lift URI where lift = liftData - -#if MIN_VERSION_template_haskell(2,17,0) liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped = TH.unsafeTExpCoerce . TH.lift -#endif -- | Make a given 'URI' reference absolute using the supplied @'RText' -- 'Scheme'@ if necessary. @@ -158,6 +156,9 @@ } deriving (Show, Eq, Ord, Data, Typeable, Generic) +-- | @since 0.3.5.0 +instance Hashable Authority + instance Arbitrary Authority where arbitrary = Authority @@ -170,12 +171,7 @@ -- | @since 0.3.1.0 instance TH.Lift Authority where lift = liftData - -#if MIN_VERSION_template_haskell(2,17,0) liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped = TH.unsafeTExpCoerce . TH.lift -#endif -- | User info as a combination of username and password. data UserInfo = UserInfo @@ -187,6 +183,9 @@ } deriving (Show, Eq, Ord, Data, Typeable, Generic) +-- | @since 0.3.5.0 +instance Hashable UserInfo + instance Arbitrary UserInfo where arbitrary = UserInfo @@ -198,12 +197,7 @@ -- | @since 0.3.1.0 instance TH.Lift UserInfo where lift = liftData - -#if MIN_VERSION_template_haskell(2,17,0) liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped = TH.unsafeTExpCoerce . TH.lift -#endif -- | Query parameter either in the form of flag or as a pair of key and -- value. A key cannot be empty, while a value can. @@ -214,6 +208,9 @@ QueryParam (RText 'QueryKey) (RText 'QueryValue) deriving (Show, Eq, Ord, Data, Typeable, Generic) +-- | @since 0.3.5.0 +instance Hashable QueryParam + instance Arbitrary QueryParam where arbitrary = oneof @@ -226,12 +223,7 @@ -- | @since 0.3.1.0 instance TH.Lift QueryParam where lift = liftData - -#if MIN_VERSION_template_haskell(2,17,0) liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped = TH.unsafeTExpCoerce . TH.lift -#endif -- | Parse exception thrown by 'mkURI' when a given 'Text' value cannot be -- parsed as a 'URI'. @@ -266,6 +258,9 @@ newtype RText (l :: RTextLabel) = RText Text deriving (Eq, Ord, Data, Typeable, Generic) +-- | @since 0.3.5.0 +instance Hashable (RText l) + instance Show (RText l) where show (RText txt) = show txt @@ -274,12 +269,7 @@ -- | @since 0.3.1.0 instance Typeable l => TH.Lift (RText l) where lift = liftData - -#if MIN_VERSION_template_haskell(2,17,0) liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped = TH.unsafeTExpCoerce . TH.lift -#endif -- | Refined text labels. data RTextLabel @@ -558,20 +548,8 @@ ---------------------------------------------------------------------------- -- TH lifting helpers -liftData - -#if MIN_VERSION_template_haskell(2,17,0) - :: (Data a, TH.Quote m) => a -> m TH.Exp -#else - :: Data a => a -> TH.Q TH.Exp -#endif +liftData :: (Data a, TH.Quote m) => a -> m TH.Exp liftData = TH.dataToExpQ (fmap liftText . cast) -liftText - -#if MIN_VERSION_template_haskell(2,17,0) - :: TH.Quote m => Text -> m TH.Exp -#else - :: Text -> TH.Q TH.Exp -#endif +liftText :: TH.Quote m => Text -> m TH.Exp liftText t = TH.AppE (TH.VarE 'T.pack) <$> TH.lift (T.unpack t) diff --git a/modern-uri.cabal b/modern-uri.cabal --- a/modern-uri.cabal +++ b/modern-uri.cabal @@ -1,11 +1,11 @@ cabal-version: 2.4 name: modern-uri -version: 0.3.4.4 +version: 0.3.5.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov author: Mark Karpov -tested-with: ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.1 +tested-with: ghc ==9.0.2 ghc ==9.2.4 ghc ==9.4.1 homepage: https://github.com/mrkkrp/modern-uri bug-reports: https://github.com/mrkkrp/modern-uri/issues synopsis: Modern library for working with URIs @@ -41,18 +41,19 @@ default-language: Haskell2010 build-depends: QuickCheck >=2.4 && <3.0, - base >=4.13 && <5.0, + base >=4.15 && <5.0, bytestring >=0.2 && <0.12, containers >=0.5 && <0.7, contravariant >=1.3 && <2.0, deepseq >=1.3 && <1.5, exceptions >=0.6 && <0.11, + hashable >=1.3 && <2.0, megaparsec >=7.0 && <10.0, mtl >=2.0 && <3.0, profunctors >=5.2.1 && <6.0, reflection >=2.0 && <3.0, tagged >=0.8 && <0.9, - template-haskell >=2.10 && <2.19, + template-haskell >=2.10 && <2.20, text >=0.2 && <2.1 if flag(dev) @@ -78,7 +79,7 @@ default-language: Haskell2010 build-depends: QuickCheck >=2.4 && <3.0, - base >=4.13 && <5.0, + base >=4.15 && <5.0, bytestring >=0.2 && <0.12, hspec >=2.0 && <3.0, hspec-megaparsec >=2.0 && <3.0, @@ -98,9 +99,9 @@ hs-source-dirs: bench/speed default-language: Haskell2010 build-depends: - base >=4.13 && <5.0, + base >=4.15 && <5.0, bytestring >=0.2 && <0.12, - criterion >=0.6.2.1 && <1.6, + criterion >=0.6.2.1 && <1.7, megaparsec >=8.0 && <10.0, modern-uri, text >=0.2 && <2.1 @@ -117,7 +118,7 @@ hs-source-dirs: bench/memory default-language: Haskell2010 build-depends: - base >=4.13 && <5.0, + base >=4.15 && <5.0, bytestring >=0.2 && <0.12, deepseq >=1.3 && <1.5, megaparsec >=8.0 && <10.0, diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -65,13 +65,13 @@ context "when given URI already has scheme" $ it "returns that URI unchanged" $ property $ \scheme uri -> - isJust (uriScheme uri) - ==> uriScheme (URI.makeAbsolute scheme uri) `shouldBe` uriScheme uri + isJust (uriScheme uri) ==> + uriScheme (URI.makeAbsolute scheme uri) `shouldBe` uriScheme uri context "when given URI has no scheme" $ it "sets the specified scheme" $ property $ \scheme uri -> - isNothing (uriScheme uri) - ==> uriScheme (URI.makeAbsolute scheme uri) `shouldBe` Just scheme + isNothing (uriScheme uri) ==> + uriScheme (URI.makeAbsolute scheme uri) `shouldBe` Just scheme describe "isPathAbsolute" $ do context "when URI has authority component" $ it "returns True" $ @@ -337,8 +337,8 @@ context "when base URI has no scheme" $ it "returns Nothing" $ property $ \reference base -> - isNothing (uriScheme base) - ==> URI.relativeTo reference base `shouldBe` Nothing + isNothing (uriScheme base) ==> + URI.relativeTo reference base `shouldBe` Nothing context "when base URI has scheme" $ it "the resulting URI always has scheme" $ property $ \reference base ->