diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +0.3.2.2 +* Loosen dependencies + 0.3.2.1 * Loosen upper bounds on template-haskell diff --git a/src/URI/ByteString/Internal.hs b/src/URI/ByteString/Internal.hs --- a/src/URI/ByteString/Internal.hs +++ b/src/URI/ByteString/Internal.hs @@ -26,9 +26,9 @@ sortBy, stripPrefix, (\\)) import qualified Data.Map.Strict as M import Data.Maybe -import Data.Monoid as Monoid +import Data.Monoid as Monoid (mempty) import Data.Ord (comparing) -import Data.Semigroup (Semigroup) +import Data.Semigroup as Semigroup import Data.Word import Text.Read (readMaybe) ------------------------------------------------------------------------------- @@ -795,7 +795,7 @@ , Alternative , Monad , MonadPlus - , Semigroup + , Semigroup.Semigroup , Monoid) @@ -810,7 +810,7 @@ ------------------------------------------------------------------------------- -- | Use with caution. Catch a parser failing and return Nothing. mParse :: Parser' e a -> Parser' e (Maybe a) -mParse p = option Nothing (Just <$> p) +mParse p = A.option Nothing (Just <$> p) ------------------------------------------------------------------------------- diff --git a/src/URI/ByteString/Types.hs b/src/URI/ByteString/Types.hs --- a/src/URI/ByteString/Types.hs +++ b/src/URI/ByteString/Types.hs @@ -12,20 +12,20 @@ module URI.ByteString.Types where ------------------------------------------------------------------------------- -import Data.ByteString (ByteString) -import qualified Data.Map.Strict as M +import Data.ByteString (ByteString) +import qualified Data.Map.Strict as M import Data.Monoid -import Data.Semigroup (Semigroup) +import Data.Semigroup as Semigroup import Data.Typeable import Data.Word import GHC.Generics -import Instances.TH.Lift() +import Instances.TH.Lift () ------------------------------------------------------------------------------- import Prelude ------------------------------------------------------------------------------- #ifdef LIFT_COMPAT -import Language.Haskell.TH.Syntax() import Language.Haskell.TH.Lift +import Language.Haskell.TH.Syntax () #else import Language.Haskell.TH.Syntax #endif @@ -90,7 +90,7 @@ ------------------------------------------------------------------------------- newtype Query = Query { queryPairs :: [(ByteString, ByteString)] } - deriving (Show, Eq, Semigroup, Monoid, Generic, Typeable, Ord) + deriving (Show, Eq, Semigroup.Semigroup, Monoid, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Query @@ -190,7 +190,7 @@ data SchemaError = NonAlphaLeading -- ^ Scheme must start with an alphabet character | InvalidChars -- ^ Subsequent characters in the schema were invalid | MissingColon -- ^ Schemas must be followed by a colon - deriving (Show, Eq, Read, Generic, Typeable) + deriving (Show, Eq, Read, Generic, Typeable, Enum, Bounded) ------------------------------------------------------------------------------- diff --git a/test/URI/ByteString/Arbitrary.hs b/test/URI/ByteString/Arbitrary.hs deleted file mode 100644 --- a/test/URI/ByteString/Arbitrary.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module URI.ByteString.Arbitrary where - - -------------------------------------------------------------------------------- -import Control.Applicative -import Data.Proxy (Proxy (..)) -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Constraint as SOP -import qualified Generics.SOP.GGP as SOP -import GHC.Generics (Generic) -import Test.QuickCheck -import Test.QuickCheck.Instances () -------------------------------------------------------------------------------- -import Prelude -------------------------------------------------------------------------------- -import URI.ByteString -------------------------------------------------------------------------------- - - --- this workaround can go away when --- is merged. -sopArbitrary - :: ( SOP.SListI (SOP.GCode b) - , Generic b - , SOP.GTo b - , SOP.AllF SOP.SListI (SOP.GCode b) - , SOP.AllF (SOP.All Arbitrary) (SOP.GCode b) - ) - => Gen b -sopArbitrary = fmap SOP.gto sopArbitrary' - - -sopArbitrary' - :: (SOP.SListI xs, SOP.AllF (SOP.All Arbitrary) xs, SOP.AllF SOP.SListI xs) - => Gen (SOP.SOP SOP.I xs) -sopArbitrary' = oneof (map SOP.hsequence $ SOP.apInjs_POP $ SOP.hcpure p arbitrary) - where - p :: Proxy Arbitrary - p = Proxy - - -instance Arbitrary UserInfo where - arbitrary = UserInfo <$> arbitrary - <*> arbitrary - - -instance Arbitrary Authority where - arbitrary = Authority <$> arbitrary - <*> arbitrary - <*> arbitrary - - -instance Arbitrary Host where - arbitrary = Host <$> arbitrary - - -instance Arbitrary Port where - arbitrary = Port <$> arbitrary - - -instance Arbitrary (URIRef Absolute) where - arbitrary = URI <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - - -instance Arbitrary (URIRef Relative) where - arbitrary = RelativeRef <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - - -instance Arbitrary Scheme where - arbitrary = Scheme <$> arbitrary - - -instance Arbitrary Query where - arbitrary = Query <$> arbitrary - - -instance Arbitrary URIParserOptions where - arbitrary = URIParserOptions <$> arbitrary - - -instance Arbitrary URINormalizationOptions where - arbitrary = URINormalizationOptions <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - - -instance Arbitrary SchemaError where - arbitrary = sopArbitrary - shrink = genericShrink - - -instance Arbitrary URIParseError where - arbitrary = sopArbitrary - shrink = genericShrink diff --git a/test/URI/ByteString/Generators.hs b/test/URI/ByteString/Generators.hs new file mode 100644 --- /dev/null +++ b/test/URI/ByteString/Generators.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module URI.ByteString.Generators where + + +------------------------------------------------------------------------------- +import Control.Applicative +import Data.ByteString (ByteString) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +------------------------------------------------------------------------------- +import Prelude +------------------------------------------------------------------------------- +import URI.ByteString +------------------------------------------------------------------------------- + + + +genUserInfo :: Gen UserInfo +genUserInfo = do + username <- Gen.utf8 (Range.linear 0 100) Gen.ascii + password <- Gen.utf8 (Range.linear 0 100) Gen.ascii + pure $ UserInfo + { uiUsername = username + , uiPassword = password + } + + +genAuthority :: Gen Authority +genAuthority = do + userInfo <- Gen.maybe genUserInfo + host <- genHost + port <- Gen.maybe genPort + pure $ Authority + { authorityUserInfo = userInfo + , authorityHost = host + , authorityPort = port + } + + +genHost :: Gen Host +genHost = Host <$> Gen.utf8 (Range.linear 0 100) Gen.ascii + + +genPort :: Gen Port +genPort = Port <$> genPositiveInt + + +genRelativeURIRef :: Gen (URIRef Relative) +genRelativeURIRef = do + authority <- Gen.maybe genAuthority + path <- Gen.utf8 (Range.linear 0 100) Gen.ascii + query <- genQuery + fragment <- Gen.maybe genAlphaNumBS + pure $ RelativeRef + { rrAuthority = authority + , rrPath = path + , rrQuery = query + , rrFragment = fragment + } + + +genAbsoluteURIRef :: Gen (URIRef Absolute) +genAbsoluteURIRef = do + scheme <- genScheme + authority <- Gen.maybe genAuthority + path <- Gen.utf8 (Range.linear 0 100) Gen.ascii + query <- genQuery + fragment <- Gen.maybe genAlphaNumBS + pure $ URI + { uriScheme = scheme + , uriAuthority = authority + , uriPath = path + , uriQuery = query + , uriFragment = fragment + } + + +genScheme :: Gen Scheme +genScheme = Scheme <$> genAlphaNumBS + + +genQuery :: Gen Query +genQuery = do + pairs <- Gen.list (Range.linear 0 10) ((,) <$> genAlphaNumBS <*> genAlphaNumBS) + pure $ Query + { queryPairs = pairs + } + + +genURIParserOptions :: Gen URIParserOptions +genURIParserOptions = do + cointoss <- Gen.bool + pure $ URIParserOptions + { upoValidQueryChar = const cointoss + } + + +genURINormalizationOptions :: Gen URINormalizationOptions +genURINormalizationOptions = do + dScheme <- Gen.bool + dHost <- Gen.bool + dPort <- Gen.bool + slashPath <- Gen.bool + dSlashes <- Gen.bool + dSort <- Gen.bool + dSegments <- Gen.bool + ports <- Gen.map (Range.linear 0 10) ((,) <$> genScheme <*> genPort) + pure $ URINormalizationOptions + { unoDowncaseScheme = dScheme + , unoDowncaseHost = dHost + , unoDropDefPort = dPort + , unoSlashEmptyPath = slashPath + , unoDropExtraSlashes = dSlashes + , unoSortParameters = dSort + , unoRemoveDotSegments = dSegments + , unoDefaultPorts = ports + } + + +genSchemaError :: Gen SchemaError +genSchemaError = Gen.enumBounded + + +genURIParseError :: Gen URIParseError +genURIParseError = Gen.choice + [ MalformedScheme <$> genSchemaError + , pure MalformedUserInfo + , pure MalformedQuery + , pure MalformedFragment + , pure MalformedHost + , pure MalformedPort + , pure MalformedPath + , OtherError <$> genString + ] + + +genString :: Gen String +genString = Gen.string (Range.linear 0 100) Gen.unicode + + +genAlphaNumBS :: Gen ByteString +genAlphaNumBS = Gen.utf8 (Range.linear 0 100) Gen.alphaNum + + +genBS :: Gen ByteString +genBS = Gen.utf8 (Range.linear 0 100) Gen.unicode + + +genPositiveInt :: Gen Int +genPositiveInt = Gen.int (Range.linear 0 maxBound) diff --git a/test/URI/ByteStringTests.hs b/test/URI/ByteStringTests.hs --- a/test/URI/ByteStringTests.hs +++ b/test/URI/ByteStringTests.hs @@ -4,25 +4,28 @@ module URI.ByteStringTests (tests) where ------------------------------------------------------------------------------- -import Control.Applicative (Const (..)) -import qualified Blaze.ByteString.Builder as BB -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 +import qualified Blaze.ByteString.Builder as BB +import Control.Applicative (Const (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 import Data.Either -import Data.Function.Compat ((&)) -import Data.Functor.Identity (Identity (..)) -import qualified Data.Map.Strict as M +import Data.Function.Compat ((&)) +import Data.Functor.Identity (Identity (..)) +import qualified Data.Map.Strict as M import Data.Monoid +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Safe (readMay) import Test.Tasty +import Test.Tasty.Hedgehog import Test.Tasty.HUnit -import Test.Tasty.QuickCheck ------------------------------------------------------------------------------- import Prelude ------------------------------------------------------------------------------- import URI.ByteString -import URI.ByteString.Arbitrary () +import URI.ByteString.Generators ------------------------------------------------------------------------------- -import URI.ByteStringQQTests () +import URI.ByteStringQQTests () infixr 4 .~ (.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t @@ -182,8 +185,9 @@ uriParseErrorInstancesTests :: TestTree uriParseErrorInstancesTests = testGroup "URIParseError instances" [ - testProperty "roundtrips between Show and Read" $ \(e :: URIParseError) -> - read (show e) == e + testProperty "roundtrips between Show and Read" $ property $ do + parseError <- forAll genURIParseError + trippingShow parseError ] @@ -191,68 +195,96 @@ lensTests :: TestTree lensTests = testGroup "lenses" [ - testProperty "schemeBSL Lens" $ \bs bs' -> - let wrapped = Scheme bs - in (wrapped ^. schemeBSL) === schemeBS wrapped .&&. - (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'} - , testProperty "hostBSL Lens" $ \bs bs' -> - let wrapped = Host bs - in (wrapped ^. hostBSL) === hostBS wrapped .&&. - (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'} - , testProperty "portNumberL Lens" $ \n n' -> - let wrapped = Port n - in (wrapped ^. portNumberL) === portNumber wrapped .&&. - (wrapped & portNumberL .~ n') === wrapped { portNumber = n'} - , testProperty "queryPairsL Lens" $ \ps ps' -> - let wrapped = Query ps - in wrapped ^. queryPairsL === queryPairs wrapped .&&. - (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'} - - , testProperty "authorityUserInfoL Lens" $ \a ui -> - (a ^. authorityUserInfoL === authorityUserInfo a) .&&. - ((a & authorityUserInfoL .~ ui) === a { authorityUserInfo = ui }) - , testProperty "authorityHostL Lens" $ \a host -> - (a ^. authorityHostL === authorityHost a) .&&. - ((a & authorityHostL .~ host) === a { authorityHost = host }) - , testProperty "authorityPortL Lens" $ \a port -> - (a ^. authorityPortL === authorityPort a) .&&. - ((a & authorityPortL .~ port) === a { authorityPort = port }) - - , testProperty "uiUsernameL Lens" $ \ui bs -> - (ui ^. uiUsernameL === uiUsername ui) .&&. - ((ui & uiUsernameL .~ bs) === ui { uiUsername = bs }) - , testProperty "uiPasswordL Lens" $ \ui bs -> - (ui ^. uiPasswordL === uiPassword ui) .&&. - ((ui & uiPasswordL .~ bs) === ui { uiPassword = bs }) - - , testProperty "uriSchemeL Lens" $ \uri x -> - (uri ^. uriSchemeL === uriScheme uri) .&&. - ((uri & uriSchemeL .~ x) === uri { uriScheme = x }) - , testProperty "authorityL Lens on URI" $ \uri x -> - (uri ^. authorityL === uriAuthority uri) .&&. - ((uri & authorityL .~ x) === uri { uriAuthority = x }) - , testProperty "pathL Lens on URI" $ \uri x -> - (uri ^. pathL === uriPath uri) .&&. - ((uri & pathL .~ x) === uri { uriPath = x }) - , testProperty "queryL Lens on URI" $ \uri x -> - (uri ^. queryL === uriQuery uri) .&&. - ((uri & queryL .~ x) === uri { uriQuery = x }) - , testProperty "fragmentL Lens on URI" $ \uri x -> - (uri ^. fragmentL === uriFragment uri) .&&. - ((uri & fragmentL .~ x) === uri { uriFragment = x }) - - , testProperty "authorityL Lens on relative ref" $ \rr x -> - (rr ^. authorityL === rrAuthority rr) .&&. - ((rr & authorityL .~ x) === rr { rrAuthority = x }) - , testProperty "pathL Lens on relative ref" $ \rr x -> - (rr ^. pathL === rrPath rr) .&&. - ((rr & pathL .~ x) === rr { rrPath = x }) - , testProperty "queryL Lens on relative ref" $ \rr x -> - (rr ^. queryL === rrQuery rr) .&&. - ((rr & queryL .~ x) === rr { rrQuery = x }) - , testProperty "fragmentL Lens on relative ref" $ \rr x -> - (rr ^. fragmentL === rrFragment rr) .&&. - ((rr & fragmentL .~ x) === rr { rrFragment = x }) + testProperty "schemeBSL Lens" $ property $ do + wrapped <- forAll genScheme + Scheme bs' <- forAll genScheme + (wrapped ^. schemeBSL) === schemeBS wrapped + (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'} + , testProperty "hostBSL Lens" $ property $ do + wrapped <- forAll genHost + Host bs' <- forAll genHost + (wrapped ^. hostBSL) === hostBS wrapped + (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'} + , testProperty "portNumberL Lens" $ property $ do + wrapped <- forAll genPort + Port n' <- forAll genPort + (wrapped ^. portNumberL) === portNumber wrapped + (wrapped & portNumberL .~ n') === wrapped { portNumber = n'} + , testProperty "queryPairsL Lens" $ property $ do + wrapped <- forAll genQuery + Query ps' <- forAll genQuery + wrapped ^. queryPairsL === queryPairs wrapped + (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'} + , testProperty "authorityUserInfoL Lens" $ property $ do + authority <- forAll genAuthority + userInfo <- forAll (Gen.maybe genUserInfo) + (authority ^. authorityUserInfoL === authorityUserInfo authority) + (authority & authorityUserInfoL .~ userInfo) === authority { authorityUserInfo = userInfo } + , testProperty "authorityHostL Lens" $ property $ do + authority <- forAll genAuthority + host <- forAll genHost + (authority ^. authorityHostL === authorityHost authority) + (authority & authorityHostL .~ host) === authority { authorityHost = host } + , testProperty "authorityPortL Lens" $ property $ do + authority <- forAll genAuthority + port <- forAll (Gen.maybe genPort) + (authority ^. authorityPortL === authorityPort authority) + (authority & authorityPortL .~ port) === authority { authorityPort = port } + , testProperty "uiUsernameL Lens" $ property $ do + ui <- forAll genUserInfo + bs <- forAll genBS + (ui ^. uiUsernameL === uiUsername ui) + (ui & uiUsernameL .~ bs) === ui { uiUsername = bs } + , testProperty "uiPasswordL Lens" $ property $ do + ui <- forAll genUserInfo + bs <- forAll genBS + (ui ^. uiPasswordL === uiPassword ui) + (ui & uiPasswordL .~ bs) === ui { uiPassword = bs } + , testProperty "uriSchemeL Lens" $ property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll genScheme + uri ^. uriSchemeL === uriScheme uri + (uri & uriSchemeL .~ x) === uri { uriScheme = x } + , testProperty "authorityL Lens on URI" $ property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll (Gen.maybe genAuthority) + uri ^. authorityL === uriAuthority uri + (uri & authorityL .~ x) === uri { uriAuthority = x } + , testProperty "pathL Lens on URI" $ property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll genBS + uri ^. pathL === uriPath uri + (uri & pathL .~ x) === uri { uriPath = x } + , testProperty "queryL Lens on URI" $ property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll genQuery + uri ^. queryL === uriQuery uri + (uri & queryL .~ x) === uri { uriQuery = x } + , testProperty "fragmentL Lens on URI" $ property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll (Gen.maybe genBS) + uri ^. fragmentL === uriFragment uri + (uri & fragmentL .~ x) === uri { uriFragment = x } + , testProperty "authorityL Lens on relative ref" $ property $ do + rr <- forAll genRelativeURIRef + x <- forAll (Gen.maybe genAuthority) + (rr ^. authorityL === rrAuthority rr) + (rr & authorityL .~ x) === rr { rrAuthority = x } + , testProperty "pathL Lens on relative ref" $ property $ do + rr <- forAll genRelativeURIRef + x <- forAll genBS + rr ^. pathL === rrPath rr + (rr & pathL .~ x) === rr { rrPath = x } + , testProperty "queryL Lens on relative ref" $ property $ do + rr <- forAll genRelativeURIRef + x <- forAll genQuery + rr ^. queryL === rrQuery rr + (rr & queryL .~ x) === rr { rrQuery = x } + , testProperty "fragmentL Lens on relative ref" $ property $ do + rr <- forAll genRelativeURIRef + x <- forAll (Gen.maybe genBS) + rr ^. fragmentL === rrFragment rr + (rr & fragmentL .~ x) === rr { rrFragment = x } ] @@ -438,3 +470,13 @@ o = noNormalization normalizeURIBS opts bs = let Right x = parseURI laxURIParserOptions bs in normalizeURIRef' opts x + +trippingShow + :: ( Show a + , Read a + , Eq a + , MonadTest m + ) + => a + -> m () +trippingShow a = tripping a show readMay diff --git a/uri-bytestring.cabal b/uri-bytestring.cabal --- a/uri-bytestring.cabal +++ b/uri-bytestring.cabal @@ -1,5 +1,5 @@ name: uri-bytestring -version: 0.3.2.1 +version: 0.3.2.2 synopsis: Haskell URI parsing as ByteStrings description: uri-bytestring aims to be an RFC3986 compliant URI parser that uses efficient ByteStrings for parsing and representing the URI data. license: BSD3 @@ -39,12 +39,12 @@ build-depends: - attoparsec >= 0.13.1.0 && < 0.14 + attoparsec >= 0.13.1.0 , base >= 4.6 && < 5 - , bytestring >= 0.9.1 && < 0.11 - , blaze-builder >= 0.3.0.0 && < 0.5 - , template-haskell >= 2.9 && < 2.15 - , th-lift-instances >= 0.1.8 && < 0.2 + , bytestring >= 0.9.1 + , blaze-builder >= 0.3.0.0 + , template-haskell >= 2.9 + , th-lift-instances >= 0.1.8 , containers hs-source-dirs: src @@ -69,27 +69,26 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - URI.ByteString.Arbitrary + URI.ByteString.Generators URI.ByteStringTests URI.ByteStringQQTests hs-source-dirs: test build-depends: uri-bytestring , HUnit - , QuickCheck , tasty , tasty-hunit - , tasty-quickcheck + , hedgehog + , tasty-hedgehog , attoparsec , base , base-compat >= 0.7.0 , blaze-builder , bytestring - , quickcheck-instances , semigroups , transformers , containers - , generics-sop >= 0.2 + , safe default-language: Haskell2010 if flag(lib-Werror)