9335700 · typeable/req

git.iko.soy/typeable/req

on master help sign in

Add quasiquoters for url creation

9335700Lila6 years ago

Network/HTTP/Req.hs+45−2

compare with master

unifiedsplit

@@ -1,7 +1,9 @@

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DeriveGeneric #-}

5{-# LANGUAGE DeriveGeneric #-}

6+{-# LANGUAGE DeriveLift #-}

5{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE KindSignatures #-}

9{-# LANGUAGE KindSignatures #-}

@@ -12,6 +14,7 @@

12{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RecordWildCards #-}

15{-# LANGUAGE RecordWildCards #-}

14{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE TemplateHaskellQuotes #-}

15{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE UndecidableInstances #-}

19{-# LANGUAGE UndecidableInstances #-}

@@ -145,6 +148,7 @@ module Network.HTTP.Req

145 useHttpURI,

148 useHttpURI,

146 useHttpsURI,

149 useHttpsURI,

147 useURI,

150 useURI,

151+ urlQ,

148

152

149 -- ** Body

153 -- ** Body

150 -- $body

154 -- $body

@@ -251,10 +255,14 @@ import Data.Maybe (fromMaybe)

251import Data.Proxy

255import Data.Proxy

252import Data.Semigroup hiding (Option, option)

256import Data.Semigroup hiding (Option, option)

253import Data.Text (Text)

257import Data.Text (Text)

258+import qualified Data.Text as T

254import qualified Data.Text.Encoding as T

259import qualified Data.Text.Encoding as T

255−import Data.Typeable (Typeable)

260+import Data.Typeable (Typeable, cast)

256import GHC.Generics

261import GHC.Generics

257import GHC.TypeLits

262import 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

258import qualified Network.Connection as NC

266import qualified Network.Connection as NC

259import qualified Network.HTTP.Client as L

267import qualified Network.HTTP.Client as L

260import qualified Network.HTTP.Client.Internal as LI

268import qualified Network.HTTP.Client.Internal as LI

@@ -862,6 +870,20 @@ data Url (scheme :: Scheme) = Url Scheme (NonEmpty Text)

862 -- NOTE The second value is the path segments in reversed order.

870 -- NOTE The second value is the path segments in reversed order.

863 deriving (Eq, Ord, Show, Data, Typeable, Generic)

871 deriving (Eq, Ord, Show, Data, Typeable, Generic)

864

872

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+

865-- | Given host name, produce a 'Url' which has “http” as its scheme and

887-- | Given host name, produce a 'Url' which has “http” as its scheme and

866-- empty path. This also sets port to @80@.

888-- empty path. This also sets port to @80@.

867http :: Text -> Url 'Http

889http :: Text -> Url 'Http

@@ -937,6 +959,27 @@ uriHost uri = case URI.uriAuthority uri of

937 Right URI.Authority {..} ->

959 Right URI.Authority {..} ->

938 Just (URI.unRText authHost)

960 Just (URI.unRText authHost)

939

961

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+

940-- | An internal helper function to extract 'Option's from a 'URI'.

983-- | An internal helper function to extract 'Option's from a 'URI'.

941uriOptions :: forall scheme. URI -> Option scheme

984uriOptions :: forall scheme. URI -> Option scheme

942uriOptions uri =

985uriOptions uri =

@@ -1756,7 +1799,7 @@ data Scheme

1756 Http

1799 Http

1757 | -- | HTTPS

1800 | -- | HTTPS

1758 Https

1801 Https

1759− deriving (Eq, Ord, Show, Data, Typeable, Generic)

1802+ deriving (Eq, Ord, Show, Data, Typeable, Generic, TH.Lift)

1760

1803

1761----------------------------------------------------------------------------

1804----------------------------------------------------------------------------

1762-- Constants

1805-- Constants

req.cabal+1

@@ -52,6 +52,7 @@ library

52 monad-control >=1.0 && <1.1,

53 mtl >=2.0 && <3.0,

54 retry >=0.8 && <0.9,

55+ template-haskell >=2.14 && <2.17,

55 text >=0.2 && <1.3,

56 text >=0.2 && <1.3,

56 time >=1.2 && <1.10,

57 time >=1.2 && <1.10,

57 transformers >=0.4 && <0.6,

58 transformers >=0.4 && <0.6,