-- |
-- Module      :  Text.URI.QQ
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- 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 #-}

module Text.URI.QQ
  ( uri
  , scheme
  , host
  , username
  , password
  , pathPiece
  , queryKey
  , queryValue
  , fragment )
where

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
import Text.URI.Types
import qualified Data.Text as T

-- | Construct a 'URI' value at compile time.

uri :: QuasiQuoter
uri :: QuasiQuoter
uri = (Text -> Either SomeException URI) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
mkURI

-- | Construct a @'RText' 'Scheme'@ value at compile time.

scheme :: QuasiQuoter
scheme :: QuasiQuoter
scheme = (Text -> Either SomeException (RText 'Scheme)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
mkScheme

-- | Construct a @'RText' 'Host'@ value at compile time.

host :: QuasiQuoter
host :: QuasiQuoter
host = (Text -> Either SomeException (RText 'Host)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'Host)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Host)
mkHost

-- | Construct a @'RText' 'Username'@ value at compile time.

username :: QuasiQuoter
username :: QuasiQuoter
username = (Text -> Either SomeException (RText 'Username)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'Username)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
mkUsername

-- | Construct a @'RText' 'Password'@ value at compile time.

password :: QuasiQuoter
password :: QuasiQuoter
password = (Text -> Either SomeException (RText 'Password)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'Password)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Password)
mkPassword

-- | Construct a @'RText' 'PathPiece'@ value at compile time.

pathPiece :: QuasiQuoter
pathPiece :: QuasiQuoter
pathPiece = (Text -> Either SomeException (RText 'PathPiece)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
mkPathPiece

-- | Construct a @'RText' 'QueryKey'@ value at compile time.

queryKey :: QuasiQuoter
queryKey :: QuasiQuoter
queryKey = (Text -> Either SomeException (RText 'QueryKey)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'QueryKey)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey

-- | Construct a @'RText 'QueryValue'@ value at compile time.

queryValue :: QuasiQuoter
queryValue :: QuasiQuoter
queryValue = (Text -> Either SomeException (RText 'QueryValue)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'QueryValue)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryValue)
mkQueryValue

-- | Construct a @'RText' 'Fragment'@ value at compile time.

fragment :: QuasiQuoter
fragment :: QuasiQuoter
fragment = (Text -> Either SomeException (RText 'Fragment)) -> QuasiQuoter
forall a.
(Eq a, Lift a) =>
(Text -> Either SomeException a) -> QuasiQuoter
liftToQQ Text -> Either SomeException (RText 'Fragment)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Fragment)
mkFragment

----------------------------------------------------------------------------
-- 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 :: (Eq a, Lift a) => (Text -> Either SomeException a) -> QuasiQuoter
liftToQQ :: (Text -> Either SomeException a) -> QuasiQuoter
liftToQQ f :: Text -> Either SomeException a
f = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = \str :: String
str ->
      case Text -> Either SomeException a
f (String -> Text
T.pack String
str) of
        Left err :: SomeException
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)
        Right x :: a
x  -> a -> Q Exp
forall t. Lift t => t -> Q Exp
lift a
x
  , quotePat :: String -> Q Pat
quotePat  = \str :: String
str ->
      case Text -> Either SomeException a
f (String -> Text
T.pack String
str) of
        Left err :: SomeException
err -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)
        Right x :: a
x  -> Q Exp -> Q Exp -> Q Exp
appE [|(==)|] (a -> Q Exp
forall t. Lift t => t -> Q Exp
lift a
x) Q Exp -> Q Pat -> Q Pat
`viewP` [p|True|]
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error "This usage is not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error "This usage is not supported" }