@@ -1,7 +1,9 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE DeriveDataTypeable #-}
45{-# LANGUAGE DeriveGeneric #-}
6+{-# LANGUAGE DeriveLift #-}
57{-# LANGUAGE FlexibleInstances #-}
68{-# LANGUAGE GeneralizedNewtypeDeriving #-}
79{-# LANGUAGE KindSignatures #-}
@@ -12,6 +14,7 @@
1214{-# LANGUAGE RankNTypes #-}
1315{-# LANGUAGE RecordWildCards #-}
1416{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE TemplateHaskellQuotes #-}
1518{-# LANGUAGE TypeFamilies #-}
1619{-# LANGUAGE UndecidableInstances #-}
1720
@@ -145,6 +148,7 @@ module Network.HTTP.Req
145148 useHttpURI,
146149 useHttpsURI,
147150 useURI,
151+ urlQ,
148152
149153 -- ** Body
150154 -- $body
@@ -251,10 +255,14 @@ import Data.Maybe (fromMaybe)
251255import Data.Proxy
252256import Data.Semigroup hiding (Option, option)
253257import Data.Text (Text)
258+import qualified Data.Text as T
254259import qualified Data.Text.Encoding as T
255−import Data.Typeable (Typeable)
260+import Data.Typeable (Typeable, cast)
256261import GHC.Generics
257262import GHC.TypeLits
263+import qualified Language.Haskell.TH as TH
264+import qualified Language.Haskell.TH.Quote as TH
265+import qualified Language.Haskell.TH.Syntax as TH
258266import qualified Network.Connection as NC
259267import qualified Network.HTTP.Client as L
260268import qualified Network.HTTP.Client.Internal as LI
@@ -862,6 +870,20 @@ data Url (scheme :: Scheme) = Url Scheme (NonEmpty Text)
862870 -- NOTE The second value is the path segments in reversed order.
863871 deriving (Eq, Ord, Show, Data, Typeable, Generic)
864872
873+-- With template-haskell >=2.15 and text >=1.2.4 Lift can be derived, however
874+-- the derived lift forgets the type of scheme.
875+instance Typeable scheme => TH.Lift (Url scheme) where
876+ lift url =
877+ TH.dataToExpQ (fmap liftText . cast) url `TH.sigE` case url of
878+ Url Http _ -> [t|Url 'Http|]
879+ Url Https _ -> [t|Url 'Https|]
880+ where
881+ liftText t = TH.AppE (TH.VarE 'T.pack) <$> TH.lift (T.unpack t)
882+
883+#if MIN_VERSION_template_haskell(2,16,0)
884+ liftTyped url = TH.TExp <$> TH.lift url
885+#endif
886+
865887-- | Given host name, produce a 'Url' which has “http” as its scheme and
866888-- empty path. This also sets port to @80@.
867889http :: Text -> Url 'Http
@@ -937,6 +959,27 @@ uriHost uri = case URI.uriAuthority uri of
937959 Right URI.Authority {..} ->
938960 Just (URI.unRText authHost)
939961
962+-- | A quasiquoter to build an 'Url' and 'Option' tuple. The type of the
963+-- generated expression is `('Url' <scheme1>, 'Option' scheme2)` with
964+-- `<scheme1>` being either `Http` or `Https` depending on the input.
965+urlQ :: TH.QuasiQuoter
966+urlQ =
967+ TH.QuasiQuoter
968+ { quoteExp = \str ->
969+ case URI.mkURI (T.pack str) of
970+ Left err -> fail (displayException err)
971+ Right uri -> case useURI uri of
972+ Nothing -> fail "Not a HTTP or HTTPS URL"
973+ Just eurl ->
974+ TH.tupE
975+ [ either (TH.lift . fst) (TH.lift . fst) eurl,
976+ [|uriOptions uri|]
977+ ],
978+ quotePat = error "This usage is not supported",
979+ quoteType = error "This usage is not supported",
980+ quoteDec = error "This usage is not supported"
981+ }
982+
940983-- | An internal helper function to extract 'Option's from a 'URI'.
941984uriOptions :: forall scheme. URI -> Option scheme
942985uriOptions uri =
@@ -1756,7 +1799,7 @@ data Scheme
17561799 Http
17571800 | -- | HTTPS
17581801 Https
1759− deriving (Eq, Ord, Show, Data, Typeable, Generic)
1802+ deriving (Eq, Ord, Show, Data, Typeable, Generic, TH.Lift)
17601803
17611804----------------------------------------------------------------------------
17621805-- Constants