diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Modern URI 0.3.0.0 + +* Uses Megaparsec 7. Visible API changes amount to an adjustment in + definition of the `ParseException` type. + ## Modern URI 0.2.2.0 * Removed a potentially overlapping instance `Arbitrary (NonEmpty (RText diff --git a/Text/URI/Parser/ByteString.hs b/Text/URI/Parser/ByteString.hs --- a/Text/URI/Parser/ByteString.hs +++ b/Text/URI/Parser/ByteString.hs @@ -91,17 +91,17 @@ ipLiteral = between (char 91) (char 93) $ try ipv6Address <|> ipvFuture octet = do - pos <- getNextTokenPosition + o <- getOffset (toks, x) <- match L.decimal when (x >= (256 :: Integer)) $ do - mapM_ setPosition pos + setOffset o failure (fmap Tokens . NE.nonEmpty . B.unpack $ toks) (E.singleton . Label . NE.fromList $ "decimal number from 0 to 255") ipv4Address = count 3 (octet <* char 46) *> octet ipv6Address = do - pos <- getNextTokenPosition + o <- getOffset (toks, xs) <- match $ do xs' <- maybeToList <$> optional ([] <$ string "::") xs <- flip sepBy1 (char 58) $ do @@ -117,7 +117,7 @@ let nskips = length (filter null xs) npieces = length xs unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do - mapM_ setPosition pos + setOffset o failure (fmap Tokens . NE.nonEmpty . B.unpack $ toks) (E.singleton . Label . NE.fromList $ "valid IPv6 address") diff --git a/Text/URI/Parser/Text.hs b/Text/URI/Parser/Text.hs --- a/Text/URI/Parser/Text.hs +++ b/Text/URI/Parser/Text.hs @@ -52,8 +52,8 @@ mkURI :: MonadThrow m => Text -> m URI mkURI input = case runParser (parser <* eof :: Parsec Void Text URI) "" input of - Left err -> throwM (ParseException input err) - Right x -> return x + Left b -> throwM (ParseException b) + Right x -> return x -- | This parser can be used to parse 'URI' from strict 'Text'. Remember to -- use a concrete non-polymorphic parser type for efficiency. diff --git a/Text/URI/Parser/Text/Utils.hs b/Text/URI/Parser/Text/Utils.hs --- a/Text/URI/Parser/Text/Utils.hs +++ b/Text/URI/Parser/Text/Utils.hs @@ -50,17 +50,17 @@ ipLiteral = between (char '[') (char ']') $ try ipv6Address <|> ipvFuture octet = do - pos <- getNextTokenPosition + o <- getOffset (toks, x) <- match L.decimal when (x >= (256 :: Integer)) $ do - mapM_ setPosition pos + setOffset o failure (fmap Tokens . NE.nonEmpty . T.unpack $ toks) (E.singleton . Label . NE.fromList $ "decimal number from 0 to 255") ipv4Address = count 3 (octet <* char '.') *> octet ipv6Address = do - pos <- getNextTokenPosition + pos <- getOffset (toks, xs) <- match $ do xs' <- maybeToList <$> optional ([] <$ string "::") xs <- flip sepBy1 (char ':') $ do @@ -76,7 +76,7 @@ let nskips = length (filter null xs) npieces = length xs unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do - mapM_ setPosition pos + setOffset pos failure (fmap Tokens . NE.nonEmpty . T.unpack $ toks) (E.singleton . Label . NE.fromList $ "valid IPv6 address") diff --git a/Text/URI/Types.hs b/Text/URI/Types.hs --- a/Text/URI/Types.hs +++ b/Text/URI/Types.hs @@ -63,7 +63,6 @@ import Numeric (showInt, showHex) import Test.QuickCheck import Text.Megaparsec -import Text.Megaparsec.Char import Text.URI.Parser.Text.Utils (pHost) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T @@ -183,12 +182,12 @@ -- | Parse exception thrown by 'mkURI' when a given 'Text' value cannot be -- parsed as a 'URI'. -data ParseException = ParseException Text (ParseError Char Void) +newtype ParseException = ParseException (ParseErrorBundle Text Void) -- ^ Arguments are: original input and parse error deriving (Show, Eq, Data, Typeable, Generic) instance Exception ParseException where - displayException (ParseException s e) = parseErrorPretty' s e + displayException (ParseException b) = errorBundlePretty b instance NFData ParseException diff --git a/bench/memory/Main.hs b/bench/memory/Main.hs --- a/bench/memory/Main.hs +++ b/bench/memory/Main.hs @@ -10,9 +10,7 @@ import Text.Megaparsec import Text.URI (URI) import Weigh -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text as T -import qualified Text.URI as URI +import qualified Text.URI as URI main :: IO () main = mainWith $ do @@ -39,36 +37,28 @@ -- | Benchmark memory usage of the 'URI' parser with given input. bparser :: Text -> Weigh () -bparser txt = func name (parse p "") txt +bparser = func "text parser" (parse p "") where - name = "text parser: " ++ T.unpack txt - p = URI.parser <* eof :: Parsec Void Text URI + p = URI.parser <* eof :: Parsec Void Text URI -- | Like 'bparser' but accepts a 'ByteString'. bparserBs :: ByteString -> Weigh () -bparserBs bs = func name (parse p "") bs +bparserBs = func "bs parser" (parse p "") where - name = "bs parser: " ++ B8.unpack bs - p = URI.parserBs <* eof :: Parsec Void ByteString URI + p = URI.parserBs <* eof :: Parsec Void ByteString URI -- | Benchmark memory usage of the 'URI' render with given input. brender :: URI -> Weigh () -brender uri = func name URI.render uri - where - name = "text render: " ++ T.unpack (URI.render uri) +brender = func "text render" URI.render -- | The same as 'brender' but for the 'URI.renderBs' render. brenderBs :: URI -> Weigh () -brenderBs uri = func name URI.renderBs uri - where - name = "bs render: " ++ T.unpack (URI.render uri) +brenderBs = func "bs render" URI.renderBs -- | The same as 'brender' but for the 'URI.renderString' render. brenderStr :: URI -> Weigh () -brenderStr uri = func name URI.renderStr uri - where - name = "str render: " ++ T.unpack (URI.render uri) +brenderStr = func "str render" URI.renderStr diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs --- a/bench/speed/Main.hs +++ b/bench/speed/Main.hs @@ -10,9 +10,7 @@ import Data.Void import Text.Megaparsec import Text.URI (URI) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text as T -import qualified Text.URI as URI +import qualified Text.URI as URI main :: IO () main = defaultMain @@ -38,36 +36,28 @@ -- | Benchmark speed of the 'URI' parser with given input. bparser :: Text -> Benchmark -bparser txt = env (return txt) (bench name . nf p) +bparser txt = env (return txt) (bench "text parser" . nf p) where - name = "text parser: " ++ T.unpack txt - p = parse (URI.parser <* eof :: Parsec Void Text URI) "" + p = parse (URI.parser <* eof :: Parsec Void Text URI) "" -- | Like 'bparser' but accepts a 'ByteString'. bparserBs :: ByteString -> Benchmark -bparserBs bs = env (return bs) (bench name . nf p) +bparserBs bs = env (return bs) (bench "bs parser" . nf p) where - name = "bs parser: " ++ B8.unpack bs - p = parse (URI.parserBs <* eof :: Parsec Void ByteString URI) "" + p = parse (URI.parserBs <* eof :: Parsec Void ByteString URI) "" -- | Benchmark speed of the 'URI' render with given input. brender :: URI -> Benchmark -brender uri = env (return uri) (bench name . nf URI.render) - where - name = "text render: " ++ T.unpack (URI.render uri) +brender uri = env (return uri) (bench "text render" . nf URI.render) -- | The same as 'brender' but for the 'URI.renderBs' render. brenderBs :: URI -> Benchmark -brenderBs uri = env (return uri) (bench name . nf URI.renderBs) - where - name = "bs render: " ++ T.unpack (URI.render uri) +brenderBs uri = env (return uri) (bench "bs render" . nf URI.renderBs) -- | The same as 'brender' but for the 'URI.renderString' render. brenderStr :: URI -> Benchmark -brenderStr uri = env (return uri) (bench name . nf URI.renderStr) - where - name = "str render: " ++ T.unpack (URI.render uri) +brenderStr uri = env (return uri) (bench "str render" . nf URI.renderStr) diff --git a/modern-uri.cabal b/modern-uri.cabal --- a/modern-uri.cabal +++ b/modern-uri.cabal @@ -1,5 +1,5 @@ name: modern-uri -version: 0.2.2.0 +version: 0.3.0.0 cabal-version: 1.18 tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 license: BSD3 @@ -32,7 +32,7 @@ , contravariant >= 1.3 && < 2.0 , deepseq >= 1.3 && < 1.5 , exceptions >= 0.6 && < 0.11 - , megaparsec >= 6.0 && < 7.0 + , megaparsec >= 7.0 && < 8.0 , mtl >= 2.0 && < 3.0 , profunctors >= 5.2.1 && < 6.0 , reflection >= 2.0 && < 3.0 @@ -69,8 +69,8 @@ , base >= 4.7 && < 5.0 , bytestring >= 0.2 && < 0.11 , hspec >= 2.0 && < 3.0 - , hspec-megaparsec >= 1.0 && < 2.0 - , megaparsec >= 6.0 && < 7.0 + , hspec-megaparsec >= 2.0 && < 3.0 + , megaparsec >= 7.0 && < 8.0 , modern-uri , text >= 0.2 && < 1.3 build-tools: hspec-discover >= 2.0 && < 3.0 @@ -90,7 +90,7 @@ build-depends: base >= 4.7 && < 5.0 , bytestring >= 0.2 && < 0.11 , criterion >= 0.6.2.1 && < 1.6 - , megaparsec >= 6.0 && < 7.0 + , megaparsec >= 7.0 && < 8.0 , modern-uri , text >= 0.2 && < 1.3 if flag(dev) @@ -106,7 +106,7 @@ build-depends: base >= 4.7 && < 5.0 , bytestring >= 0.2 && < 0.11 , deepseq >= 1.3 && < 1.5 - , megaparsec >= 6.0 && < 7.0 + , megaparsec >= 7.0 && < 8.0 , modern-uri , text >= 0.2 && < 1.3 , weigh >= 0.0.4 diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -30,7 +30,7 @@ uri <- mkTestURI URI.mkURI testURI `shouldReturn` uri it "rejects invalid URIs" $ do - let e = err posI . mconcat $ + let e = err 0 . mconcat $ [ utok 'ч' , etok '#' , etok '/' @@ -39,7 +39,12 @@ , elabel "ASCII alpha character" , elabel "path piece" , eeof ] - URI.mkURI "что-то" `shouldThrow` (== URI.ParseException "что-то" e) + b = ParseErrorBundle + { bundleErrors = e :| [] + , bundlePosState = initialPosState s + } + s = "что-то" + URI.mkURI s `shouldThrow` (== URI.ParseException b) describe "emptyURI" $ do it "parsing of empty input produces emptyURI" $ URI.mkURI "" `shouldReturn` URI.emptyURI @@ -159,7 +164,7 @@ shouldParseBs (URI.renderBs uri) uri describe "parse" $ do it "rejects Unicode in scheme" $ - parse urip "" "что:something" `shouldFailWith` err posI (mconcat + parse urip "" "что:something" `shouldFailWith` err 0 (mconcat [ utok 'ч' , etok '#' , etok '/' @@ -170,7 +175,7 @@ , eeof ] ) it "rejects Unicode in host" $ do let s = "https://юникод.рф" - parse urip "" s `shouldFailWith` err (posN 8 s) (mconcat + parse urip "" s `shouldFailWith` err 8 (mconcat [ utok 'ю' , etok '#' , etok '%' @@ -187,7 +192,7 @@ ] ) it "rejects Unicode in path" $ do let s = "https://github.com/марк" - parse urip "" s `shouldFailWith` err (posN 19 s) (mconcat + parse urip "" s `shouldFailWith` err 19 (mconcat [ utok 'м' , etok '#' , etok '/' @@ -316,7 +321,7 @@ case runParser urip "" s of Left e -> expectationFailure $ "the parser is expected to succeed, but it failed with:\n" ++ - parseErrorPretty' s e + errorBundlePretty e Right a' -> a' `shouldBe` a -- | Similar to 'shouldParse'' but uses 'URI.parserBs' under the hood. @@ -329,7 +334,7 @@ case runParser (URI.parserBs <* eof :: Parsec Void ByteString URI) "" s of Left e -> expectationFailure $ "the parser is expected to succeed, but it failed with:\n" ++ - parseErrorPretty' s e + errorBundlePretty e Right a' -> a' `shouldBe` a -- | Test cases from section 5.4.1 from RFC 3986.