QQ.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- 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/).
module Text.URI.QQ
  ( uri,
    scheme,
    host,
    username,
    password,
    pathPiece,
    queryKey,
    queryValue,
    fragment,
  )
where

import Control.Exception (Exception (..), SomeException)
import Data.Text (Text)
import qualified Data.Text as T
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

-- | Construct a 'URI' value at compile time.
uri :: QuasiQuoter
uri = liftToQQ mkURI

-- | Construct a @'RText' 'Scheme'@ value at compile time.
scheme :: QuasiQuoter
scheme = liftToQQ mkScheme

-- | Construct a @'RText' 'Host'@ value at compile time.
host :: QuasiQuoter
host = liftToQQ mkHost

-- | Construct a @'RText' 'Username'@ value at compile time.
username :: QuasiQuoter
username = liftToQQ mkUsername

-- | Construct a @'RText' 'Password'@ value at compile time.
password :: QuasiQuoter
password = liftToQQ mkPassword

-- | Construct a @'RText' 'PathPiece'@ value at compile time.
pathPiece :: QuasiQuoter
pathPiece = liftToQQ mkPathPiece

-- | Construct a @'RText' 'QueryKey'@ value at compile time.
queryKey :: QuasiQuoter
queryKey = liftToQQ mkQueryKey

-- | Construct a @'RText 'QueryValue'@ value at compile time.
queryValue :: QuasiQuoter
queryValue = liftToQQ mkQueryValue

-- | Construct a @'RText' 'Fragment'@ value at compile time.
fragment :: QuasiQuoter
fragment = liftToQQ 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 f =
  QuasiQuoter
    { quoteExp = \str ->
        case f (T.pack str) of
          Left err -> fail (displayException err)
          Right x -> lift x,
      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"
    }