diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Modern URI 0.3.2.0 + +* Quasi-quoters from `Text.URI.QQ` now can be used in pattern context when + the `ViewPatterns` extension is enabled. + +* Dropped support for GHC 8.2.x. + ## Modern URI 0.3.1.0 * Dropped support for GHC 8.0 and 7.10. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,11 +14,11 @@ The `modern-uri` package features: -* Correct by construction `URI` data type. Correctness is ensured by - guaranteeing that every sub-component of the `URI` record is by itself +* Correct by construction `URI` data type. The correctness is ensured by + making sure that every sub-component of the `URI` record is by itself cannot be invalid. This boils down to careful use of types and a set of - smart constructors for things like scheme, host, etc. -* Textual components in the `URI` data type represented as `Text` rather + smart constructors. +* Textual components in the `URI` data type are represented as `Text` rather than `ByteString`, because they are percent-decoded and so they can contain characters outside of ASCII range (i.e. Unicode). This allows for easier manipulation of `URI`s, while encoding and decoding headaches are @@ -82,10 +82,9 @@ In this library we use quite a few refined text values. They only can be constructed by using smart constructors like `mkScheme :: MonadThrow m => Text -> m (RText 'Scheme)`. For example, if argument to `mkScheme` is not a -valid scheme, an exception will be thrown. Actually this is not necessarily -so because there are pure monads that are instances of the `MonadThrow` type -class, and so the smart constructors may be used in e.g. the `Maybe` monad -as well. +valid scheme, an exception will be thrown. Note that monads such as `Maybe` +are also instances of the `MonadThrow` type class, and so the smart +constructors may be used in pure setting as well. There is a smart constructor that can make an entire `URI` too, it's called (unsurprisingly) `mkURI`: @@ -105,8 +104,8 @@ , uriFragment = Nothing } ``` -If argument of `mkURI` is not a valid URI, then an exception will be thrown. -The exception will contain full context and the actual parse error. +If the argument of `mkURI` is not a valid URI, then an exception will be +thrown. The exception will contain full context and the actual parse error. If some refined text value or `URI` is known statically at compile time, we can use Template Haskell, namely the “quasi quotes” feature. To do so import @@ -132,16 +131,13 @@ Note how the value returned by the `url` quasi quote is pure, its construction cannot fail because when there is an invalid URI inside the -quote it's a compilation error. - -The `Text.URI.QQ` module has quasi quoters for scheme, host, and other -things, check it out. +quote it's a compilation error. The `Text.URI.QQ` module has quasi-quoters +for scheme, host, and other components. -Finally the package provides two Megaparsec parsers: `parser` and +Finally, the package provides two Megaparsec parsers: `parser` and `parserBs`. The first works on strict `Text`, while other one works on strict `ByteString`s. You can use the parsers in a bigger Megaparsec parser -to parse `URI`s. To get started with Megaparsec, see [its Hackage -page](https://hackage.haskell.org/package/megaparsec). +to parse `URI`s. ### Inspection and manipulation @@ -211,7 +207,7 @@ Issues, bugs, and questions may be reported in [the GitHub issue tracker for this project](https://github.com/mrkkrp/modern-uri/issues). -Pull requests are also welcome and will be reviewed quickly. +Pull requests are also welcome. ## License diff --git a/Text/URI.hs b/Text/URI.hs --- a/Text/URI.hs +++ b/Text/URI.hs @@ -20,6 +20,7 @@ -- "Text.URI.QQ" for quasi-quoters for compile-time validation of URIs and -- refined text components. +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -67,12 +68,15 @@ import Data.Either (isLeft) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust, isNothing) -import Data.Semigroup ((<>)) import Text.URI.Parser.ByteString import Text.URI.Parser.Text import Text.URI.Render import Text.URI.Types import qualified Data.List.NonEmpty as NE + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif -- | The empty 'URI'. -- diff --git a/Text/URI/QQ.hs b/Text/URI/QQ.hs --- a/Text/URI/QQ.hs +++ b/Text/URI/QQ.hs @@ -9,6 +9,10 @@ -- -- Quasi-quoters for compile-time construction of URIs and refined text -- values. +-- +-- All of the quasi-quoters in this module can be used in an expression +-- context. With the @ViewPatterns@ language extension enabled, they may +-- also be used in a pattern context (since /0.3.2.0/). {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,6 +31,7 @@ import Control.Exception (SomeException, Exception (..)) import Data.Text (Text) +import Language.Haskell.TH.Lib (appE, viewP) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax (Lift (..)) import Text.URI.Parser.Text @@ -82,13 +87,19 @@ -- Helpers -- | Lift a smart constructor for refined text into a 'QuasiQuoter'. +-- +-- The 'Eq' constraint is technically unnecessary here, but the pattern +-- generated by 'quotePat' will only work if the type has an 'Eq' instance. -liftToQQ :: Lift a => (Text -> Either SomeException a) -> QuasiQuoter +liftToQQ :: (Eq a, Lift a) => (Text -> Either SomeException a) -> QuasiQuoter liftToQQ f = QuasiQuoter { quoteExp = \str -> case f (T.pack str) of Left err -> fail (displayException err) Right x -> lift x - , quotePat = error "This usage is not supported" + , quotePat = \str -> + case f (T.pack str) of + Left err -> fail (displayException err) + Right x -> appE [|(==)|] (lift x) `viewP` [p|True|] , quoteType = error "This usage is not supported" , quoteDec = error "This usage is not supported" } diff --git a/Text/URI/Render.hs b/Text/URI/Render.hs --- a/Text/URI/Render.hs +++ b/Text/URI/Render.hs @@ -9,7 +9,6 @@ -- -- URI renders, an internal module. -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -32,11 +31,11 @@ import Data.ByteString (ByteString) import Data.Char (chr, intToDigit) +import Data.Kind (Type) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Data.Reflection -import Data.Semigroup (Semigroup) import Data.String (IsString (..)) import Data.Tagged import Data.Text (Text) @@ -54,10 +53,6 @@ import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder.Int as TLB -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid -#endif - ---------------------------------------------------------------------------- -- High-level wrappers @@ -115,7 +110,7 @@ equip :: forall b. (Word -> b) -> (forall l. RLabel l => RText l -> b) - -> (forall (s :: *). Reifies s (Renders b) => Tagged s b) + -> (forall (s :: Type). Reifies s (Renders b) => Tagged s b) -> b equip rWord rText f = reify Renders {..} $ \(Proxy :: Proxy s') -> unTagged (f :: Tagged s' b) @@ -133,7 +128,7 @@ ---------------------------------------------------------------------------- -- Generic render -type Render a b = forall (s :: *). +type Render a b = forall (s :: Type). (Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) => a -> Tagged s b diff --git a/modern-uri.cabal b/modern-uri.cabal --- a/modern-uri.cabal +++ b/modern-uri.cabal @@ -1,7 +1,7 @@ name: modern-uri -version: 0.3.1.0 +version: 0.3.2.0 cabal-version: 1.18 -tested-with: GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 +tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3 license: BSD3 license-file: LICENSE.md author: Mark Karpov @@ -26,18 +26,18 @@ library build-depends: QuickCheck >= 2.4 && < 3.0 - , base >= 4.10 && < 5.0 + , base >= 4.11 && < 5.0 , bytestring >= 0.2 && < 0.11 , containers >= 0.5 && < 0.7 , contravariant >= 1.3 && < 2.0 , deepseq >= 1.3 && < 1.5 , exceptions >= 0.6 && < 0.11 - , megaparsec >= 7.0 && < 8.0 + , megaparsec >= 7.0 && < 9.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.15 + , template-haskell >= 2.10 && < 2.16 , text >= 0.2 && < 1.3 exposed-modules: Text.URI , Text.URI.Lens @@ -56,7 +56,6 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite tests @@ -64,11 +63,11 @@ hs-source-dirs: tests type: exitcode-stdio-1.0 build-depends: QuickCheck >= 2.4 && < 3.0 - , base >= 4.10 && < 5.0 + , base >= 4.11 && < 5.0 , bytestring >= 0.2 && < 0.11 , hspec >= 2.0 && < 3.0 , hspec-megaparsec >= 2.0 && < 3.0 - , megaparsec >= 7.0 && < 8.0 + , megaparsec >= 7.0 && < 9.0 , modern-uri , text >= 0.2 && < 1.3 build-tools: hspec-discover >= 2.0 && < 3.0 @@ -84,10 +83,10 @@ main-is: Main.hs hs-source-dirs: bench/speed type: exitcode-stdio-1.0 - build-depends: base >= 4.10 && < 5.0 + build-depends: base >= 4.11 && < 5.0 , bytestring >= 0.2 && < 0.11 , criterion >= 0.6.2.1 && < 1.6 - , megaparsec >= 7.0 && < 8.0 + , megaparsec >= 7.0 && < 9.0 , modern-uri , text >= 0.2 && < 1.3 if flag(dev) @@ -100,10 +99,10 @@ main-is: Main.hs hs-source-dirs: bench/memory type: exitcode-stdio-1.0 - build-depends: base >= 4.10 && < 5.0 + build-depends: base >= 4.11 && < 5.0 , bytestring >= 0.2 && < 0.11 , deepseq >= 1.3 && < 1.5 - , megaparsec >= 7.0 && < 8.0 + , megaparsec >= 7.0 && < 9.0 , modern-uri , text >= 0.2 && < 1.3 , weigh >= 0.0.4 diff --git a/tests/Text/QQSpec.hs b/tests/Text/QQSpec.hs --- a/tests/Text/QQSpec.hs +++ b/tests/Text/QQSpec.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Text.QQSpec (spec) where @@ -10,39 +12,110 @@ spec :: Spec spec = do - describe "uri" . it "works" $ do - let uriQQ = [QQ.uri|https://markkarpov.com|] - uri <- mkURI "https://markkarpov.com" - uriQQ `shouldBe` uri - describe "scheme" . it "works" $ do - let schemeQQ = [QQ.scheme|https|] - scheme <- mkScheme "https" - schemeQQ `shouldBe` scheme - describe "host" . it "works" $ do - let hostQQ = [QQ.host|markkarpov.com|] - host <- mkHost "markkarpov.com" - hostQQ `shouldBe` host - describe "username" . it "works" $ do - let usernameQQ = [QQ.username|mark|] - username <- mkUsername "mark" - usernameQQ `shouldBe` username - describe "password" . it "works" $ do - let passwordQQ = [QQ.password|secret123|] - password <- mkPassword "secret123" - passwordQQ `shouldBe` password - describe "pathPiece" . it "works" $ do - let pathPieceQQ = [QQ.pathPiece|foo|] - pathPiece <- mkPathPiece "foo" - pathPieceQQ `shouldBe` pathPiece - describe "queryKey" . it "works" $ do - let queryKeyQQ = [QQ.queryKey|foo|] - queryKey <- mkQueryKey "foo" - queryKeyQQ `shouldBe` queryKey - describe "queryValue" . it "works" $ do - let queryValueQQ = [QQ.queryValue|bar|] - queryValue <- mkQueryKey "bar" - queryValueQQ `shouldBe` queryValue - describe "fragment" . it "works" $ do - let fragmentQQ = [QQ.fragment|frag|] - fragment <- mkQueryKey "frag" - fragmentQQ `shouldBe` fragment + + describe "uri" $ do + it "works as an expression" $ do + let uriQQ = [QQ.uri|https://markkarpov.com|] + uri <- mkURI "https://markkarpov.com" + uriQQ `shouldBe` uri + it "works as a pattern" $ + mkURI "https://markkarpov.com" >>= \case + [QQ.uri|https://haskell.org|] -> shouldNotMatch + [QQ.uri|https://markkarpov.com|] -> return () + _ -> shouldHaveMatchedAlready + + describe "scheme" $ do + it "works as an expression" $ do + let schemeQQ = [QQ.scheme|https|] + scheme <- mkScheme "https" + schemeQQ `shouldBe` scheme + it "works as a pattern" $ + mkScheme "https" >>= \case + [QQ.scheme|ftp|] -> shouldNotMatch + [QQ.scheme|https|] -> return () + _ -> shouldHaveMatchedAlready + + describe "host" $ do + it "works as an expression" $ do + let hostQQ = [QQ.host|markkarpov.com|] + host <- mkHost "markkarpov.com" + hostQQ `shouldBe` host + it "works as a pattern" $ do + mkHost "markkarpov.com" >>= \case + [QQ.host|haskell.org|] -> shouldNotMatch + [QQ.host|markkarpov.com|] -> return () + _ -> shouldHaveMatchedAlready + + describe "username" $ do + it "works as an expression" $ do + let usernameQQ = [QQ.username|mark|] + username <- mkUsername "mark" + usernameQQ `shouldBe` username + it "works as a pattern" $ do + mkUsername "mark" >>= \case + [QQ.username|chris|] -> shouldNotMatch + [QQ.username|mark|] -> return () + _ -> shouldHaveMatchedAlready + + describe "password" $ do + it "works as an expression" $ do + let passwordQQ = [QQ.password|secret123|] + password <- mkPassword "secret123" + passwordQQ `shouldBe` password + it "works as a pattern" $ do + mkPassword "secret123" >>= \case + [QQ.password|secretXYZ|] -> shouldNotMatch + [QQ.password|secret123|] -> return () + _ -> shouldHaveMatchedAlready + + describe "pathPiece" $ do + it "works as an expression" $ do + let pathPieceQQ = [QQ.pathPiece|foo|] + pathPiece <- mkPathPiece "foo" + pathPieceQQ `shouldBe` pathPiece + it "works as a pattern" $ do + mkPathPiece "foo" >>= \case + [QQ.pathPiece|bar|] -> shouldNotMatch + [QQ.pathPiece|foo|] -> return () + _ -> shouldHaveMatchedAlready + + describe "queryKey" $ do + it "works as an expression" $ do + let queryKeyQQ = [QQ.queryKey|foo|] + queryKey <- mkQueryKey "foo" + queryKeyQQ `shouldBe` queryKey + it "works as a pattern" $ do + mkQueryKey "foo" >>= \case + [QQ.queryKey|xyz|] -> shouldNotMatch + [QQ.queryKey|foo|] -> return () + _ -> shouldHaveMatchedAlready + + describe "queryValue" $ do + it "works as an expression" $ do + let queryValueQQ = [QQ.queryValue|bar|] + queryValue <- mkQueryValue "bar" + queryValueQQ `shouldBe` queryValue + it "works as a pattern" $ do + mkQueryValue "bar" >>= \case + [QQ.queryValue|xyz|] -> shouldNotMatch + [QQ.queryValue|bar|] -> return () + _ -> shouldHaveMatchedAlready + + describe "fragment" $ do + it "works as an expression" $ do + let fragmentQQ = [QQ.fragment|frag|] + fragment <- mkFragment "frag" + fragmentQQ `shouldBe` fragment + it "works as a pattern" $ do + mkFragment "frag" >>= \case + [QQ.fragment|xyz|] -> shouldNotMatch + [QQ.fragment|frag|] -> return () + _ -> shouldHaveMatchedAlready + +shouldNotMatch :: Expectation +shouldNotMatch = expectationFailure + "First case should not have matched, but did" + +shouldHaveMatchedAlready :: Expectation +shouldHaveMatchedAlready = expectationFailure + "Second case should have matched, but didn't" diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -7,7 +8,6 @@ import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing, isJust) -import Data.Monoid ((<>)) import Data.String (IsString (..)) import Data.Text (Text) import Data.Void @@ -19,6 +19,10 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Text.URI as URI + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif instance Arbitrary Text where arbitrary = T.pack <$> arbitrary