diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Modern URI 0.3.1.0 + +* Dropped support for GHC 8.0 and 7.10. + +* Added Template Haskell `Lift` instance for the `URI` type and its + sub-components. + ## Modern URI 0.3.0.1 * Allow superfluous `&` right after question sign in query parameters. diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2017–2018 Mark Karpov +Copyright © 2017–present Mark Karpov All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -215,6 +215,6 @@ ## License -Copyright © 2017–2018 Mark Karpov +Copyright © 2017–present Mark Karpov Distributed under BSD 3 clause license. diff --git a/Text/URI.hs b/Text/URI.hs --- a/Text/URI.hs +++ b/Text/URI.hs @@ -1,6 +1,6 @@ -- | -- Module : Text.URI --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov diff --git a/Text/URI/Lens.hs b/Text/URI/Lens.hs --- a/Text/URI/Lens.hs +++ b/Text/URI/Lens.hs @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.Lens --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov 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 @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.Parser.ByteString --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -9,7 +9,6 @@ -- -- URI parser for string 'ByteString', an internal module. -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -39,10 +38,6 @@ import qualified Data.Set as E import qualified Data.Text.Encoding as TE import qualified Text.Megaparsec.Byte.Lexer as L - -#if !MIN_VERSION_megaparsec(6,4,0) -import Control.Applicative (empty) -#endif -- | This parser can be used to parse 'URI' from strict 'ByteString'. -- Remember to use a concrete non-polymorphic parser type for efficiency. 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 @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.Parser.Text --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -9,7 +9,6 @@ -- -- URI parser for strict 'Text', an internal module. -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -36,10 +35,6 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text.Encoding as TE import qualified Text.Megaparsec.Char.Lexer as L - -#if !MIN_VERSION_megaparsec(6,4,0) -import Control.Applicative (empty) -#endif -- | Construct a 'URI' from 'Text'. The input you pass to 'mkURI' must be a -- valid URI as per RFC 3986, that is, its components should be 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 @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.Parser.Text.Utils --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov diff --git a/Text/URI/QQ.hs b/Text/URI/QQ.hs --- a/Text/URI/QQ.hs +++ b/Text/URI/QQ.hs @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.QQ --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -10,7 +10,6 @@ -- Quasi-quoters for compile-time construction of URIs and refined text -- values. -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,23 +26,13 @@ where import Control.Exception (SomeException, Exception (..)) -import Data.Data (Data) import Data.Text (Text) -import Data.Typeable (cast) -import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter (..)) -import Language.Haskell.TH.Syntax (lift) +import Language.Haskell.TH.Syntax (Lift (..)) import Text.URI.Parser.Text import Text.URI.Types import qualified Data.Text as T -#if MIN_VERSION_template_haskell(2,11,0) -import Language.Haskell.TH.Syntax (dataToExpQ) -#else -dataToExpQ :: Data a => (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp -dataToExpQ _ _ = fail "The feature requires at least GHC 8 to work" -#endif - -- | Construct a 'URI' value at compile time. uri :: QuasiQuoter @@ -94,17 +83,12 @@ -- | Lift a smart constructor for refined text into a 'QuasiQuoter'. -liftToQQ :: Data a => (Text -> Either SomeException a) -> QuasiQuoter +liftToQQ :: 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 -> dataToExpQ (fmap liftText . cast) x + Right x -> lift x , quotePat = error "This usage is not supported" , quoteType = error "This usage is not supported" , quoteDec = error "This usage is not supported" } - --- | Lift strict 'T.Text' to @'Q' 'Exp'@. - -liftText :: Text -> Q Exp -liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) diff --git a/Text/URI/Render.hs b/Text/URI/Render.hs --- a/Text/URI/Render.hs +++ b/Text/URI/Render.hs @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.Render --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov diff --git a/Text/URI/Types.hs b/Text/URI/Types.hs --- a/Text/URI/Types.hs +++ b/Text/URI/Types.hs @@ -1,6 +1,6 @@ -- | -- Module : Text.URI.Types --- Copyright : © 2017–2018 Mark Karpov +-- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -18,6 +18,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Text.URI.Types @@ -56,7 +57,7 @@ import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Proxy import Data.Text (Text) -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, cast) import Data.Void import Data.Word (Word8, Word16) import GHC.Generics @@ -66,6 +67,7 @@ import Text.URI.Parser.Text.Utils (pHost) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Language.Haskell.TH.Syntax as TH ---------------------------------------------------------------------------- -- Data types @@ -111,6 +113,11 @@ instance NFData URI +-- | @since 0.3.1.0 + +instance TH.Lift URI where + lift = liftData + -- | Make a given 'URI' reference absolute using the supplied @'RText' -- 'Scheme'@ if necessary. @@ -145,6 +152,11 @@ instance NFData Authority +-- | @since 0.3.1.0 + +instance TH.Lift Authority where + lift = liftData + -- | User info as a combination of username and password. data UserInfo = UserInfo @@ -162,6 +174,11 @@ instance NFData UserInfo +-- | @since 0.3.1.0 + +instance TH.Lift UserInfo where + lift = liftData + -- | 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. @@ -179,6 +196,11 @@ instance NFData QueryParam +-- | @since 0.3.1.0 + +instance TH.Lift QueryParam where + lift = liftData + -- | Parse exception thrown by 'mkURI' when a given 'Text' value cannot be -- parsed as a 'URI'. @@ -204,6 +226,11 @@ instance NFData (RText l) where +-- | @since 0.3.1.0 + +instance Typeable l => TH.Lift (RText l) where + lift = liftData + -- | Refined text labels. data RTextLabel @@ -476,3 +503,12 @@ arbText' :: (Text -> Maybe (RText l)) -> Gen (RText l) arbText' f = fromJust . f . T.pack <$> listOf1 arbitrary + +---------------------------------------------------------------------------- +-- TH lifting helpers + +liftData :: Data a => a -> TH.Q TH.Exp +liftData = TH.dataToExpQ (fmap liftText . cast) + +liftText :: Text -> TH.Q 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,7 +1,7 @@ name: modern-uri -version: 0.3.0.1 +version: 0.3.1.0 cabal-version: 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1 +tested-with: GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 license: BSD3 license-file: LICENSE.md author: Mark Karpov @@ -26,9 +26,9 @@ library build-depends: QuickCheck >= 2.4 && < 3.0 - , base >= 4.7 && < 5.0 + , base >= 4.10 && < 5.0 , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 && < 0.7 , contravariant >= 1.3 && < 2.0 , deepseq >= 1.3 && < 1.5 , exceptions >= 0.6 && < 0.11 @@ -39,8 +39,6 @@ , tagged >= 0.8 && < 0.9 , template-haskell >= 2.10 && < 2.15 , text >= 0.2 && < 1.3 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* exposed-modules: Text.URI , Text.URI.Lens , Text.URI.QQ @@ -53,7 +51,7 @@ ghc-options: -Wall -Werror else ghc-options: -O2 -Wall - if flag(dev) && impl(ghc >= 8.0) + if flag(dev) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns @@ -66,7 +64,7 @@ hs-source-dirs: tests type: exitcode-stdio-1.0 build-depends: QuickCheck >= 2.4 && < 3.0 - , base >= 4.7 && < 5.0 + , base >= 4.10 && < 5.0 , bytestring >= 0.2 && < 0.11 , hspec >= 2.0 && < 3.0 , hspec-megaparsec >= 2.0 && < 3.0 @@ -74,9 +72,8 @@ , modern-uri , text >= 0.2 && < 1.3 build-tools: hspec-discover >= 2.0 && < 3.0 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - other-modules: Text.URISpec + other-modules: Text.QQSpec + , Text.URISpec if flag(dev) ghc-options: -Wall -Werror else @@ -87,7 +84,7 @@ main-is: Main.hs hs-source-dirs: bench/speed type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 + build-depends: base >= 4.10 && < 5.0 , bytestring >= 0.2 && < 0.11 , criterion >= 0.6.2.1 && < 1.6 , megaparsec >= 7.0 && < 8.0 @@ -103,7 +100,7 @@ main-is: Main.hs hs-source-dirs: bench/memory type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0 + build-depends: base >= 4.10 && < 5.0 , bytestring >= 0.2 && < 0.11 , deepseq >= 1.3 && < 1.5 , megaparsec >= 7.0 && < 8.0 diff --git a/tests/Text/QQSpec.hs b/tests/Text/QQSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/QQSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Text.QQSpec (spec) where + +import Test.Hspec +import Text.URI +import qualified Text.URI.QQ as QQ + +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 diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -220,18 +220,25 @@ uri <- mkTestURI let s = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri+%3a@?&foo:@=bar+:@#fragment:@" parse urip "" s `shouldParse` uri - describe "render" $ do it "sort of works" $ fmap URI.render mkTestURI `shouldReturn` testURI - context "when URI has absolute path" $ - it "escapes colon properly in first path piece" $ - (URI.render <$> URI.mkURI "/docu:ment.html") - `shouldReturn` "/docu%3ament.html" - context "when URI has relative path" $ - it "escapes colon properly in first path piece" $ - (URI.render <$> URI.mkURI "docu%3ament.html") - `shouldReturn` "docu%3ament.html" + context "when URI has scheme" $ + it "escapes colon in path components" $ + (URI.render <$> URI.mkURI "https:/fir:st/se:cond") + `shouldReturn` "https:/fir%3ast/se%3acond" + context "when URI is a network-path reference" $ + it "does not escape colon in path components" $ + (URI.render <$> URI.mkURI "//host/fir:st/se:cond") + `shouldReturn` "//host/fir%3ast/se%3acond" + context "when URI is a relative-path reference" $ + it "escapes colon but only in the first path segment" $ do + firstSeg <- URI.mkPathPiece "fir:st" + secondSeg <- URI.mkPathPiece "se:cond" + let uri = URI.emptyURI + { uriPath = Just (False, firstSeg :| [secondSeg]) + } + URI.render uri `shouldBe` "fir%3ast/se%3acond" describe "renderBs" $ it "sort of works" $ fmap URI.renderBs mkTestURI `shouldReturn` testURI