content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  -- |
  -- Module      :  Text.URI.Render
  -- Copyright   :  © 2017–present Mark Karpov
  -- License     :  BSD 3 clause
  --
  -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- URI renders, an internal module.
  module Text.URI.Render
    ( render,
      render',
      renderBs,
      renderBs',
      renderStr,
      renderStr',
    )
  where
  
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Builder as BB
  import qualified Data.ByteString.Lazy as BL
  import Data.Char (chr, intToDigit)
  import Data.Kind (Type)
  import Data.List (intersperse)
  import Data.List.NonEmpty (NonEmpty (..))
  import Data.Proxy
  import Data.Reflection
  import qualified Data.Semigroup as S
  import Data.String (IsString (..))
  import Data.Tagged
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as TE
  import qualified Data.Text.Lazy as TL
  import qualified Data.Text.Lazy.Builder as TLB
  import qualified Data.Text.Lazy.Builder.Int as TLB
  import Data.Word (Word8)
  import Numeric (showInt)
  import Text.URI.Types
  
  ----------------------------------------------------------------------------
  -- High-level wrappers
  
  -- | Render a given 'URI' value as strict 'Text'.
  render :: URI -> Text
  render = TL.toStrict . TLB.toLazyText . render'
  
  -- | Render a given 'URI' value as a 'TLB.Builder'.
  render' :: URI -> TLB.Builder
  render' x =
    equip
      TLB.decimal
      ( \mw r ->
          TLB.fromText
            ( percentEncode
                (uriScheme x)
                (mediateExtraEscaping x mw)
                r
            )
      )
      (genericRender x)
  
  -- | Render a given 'URI' value as a strict 'ByteString'.
  renderBs :: URI -> ByteString
  renderBs = BL.toStrict . BB.toLazyByteString . renderBs'
  
  -- | Render a given 'URI' value as a 'BB.Builder'.
  renderBs' :: URI -> BB.Builder
  renderBs' x =
    equip
      BB.wordDec
      ( \mw r ->
          BB.byteString
            ( TE.encodeUtf8
                ( percentEncode
                    (uriScheme x)
                    (mediateExtraEscaping x mw)
                    r
                )
            )
      )
      (genericRender x)
  
  -- | Render a given 'URI' value as a 'String'.
  --
  -- @since 0.0.2.0
  renderStr :: URI -> String
  renderStr = ($ []) . renderStr'
  
  -- | Render a given 'URI' value as 'ShowS'.
  --
  -- @since 0.0.2.0
  renderStr' :: URI -> ShowS
  renderStr' x =
    toShowS $
      equip
        (DString . showInt)
        ( \mw r ->
            fromString
              ( T.unpack
                  ( percentEncode
                      (uriScheme x)
                      (mediateExtraEscaping x mw)
                      r
                  )
              )
        )
        (genericRender x)
  
  -- | This is a (slightly hackish) way used to only escape ':' in the first
  -- path segment and only if there no scheme and no authority component.
  mediateExtraEscaping :: URI -> Maybe Word8 -> Maybe Word8
  mediateExtraEscaping uri mw =
    case (uriScheme uri, uriAuthority uri) of
      (Nothing, Left _) -> mw
      _ -> Nothing
  
  ----------------------------------------------------------------------------
  -- Reflection stuff
  
  data Renders b = Renders
    { rWord :: Word -> b,
      rText :: forall l. (RLabel l) => Maybe Word8 -> RText l -> b
    }
  
  equip ::
    forall b.
    (Word -> b) ->
    (forall l. (RLabel l) => Maybe Word8 -> RText l -> b) ->
    (forall (s :: Type). (Reifies s (Renders b)) => Tagged s b) ->
    b
  equip rWord rText f = reify Renders {..} $ \(Proxy :: Proxy s') ->
    unTagged (f :: Tagged s' b)
  
  renderWord ::
    forall s b.
    (Reifies s (Renders b)) =>
    Word ->
    Tagged s b
  renderWord = Tagged . rWord (reflect (Proxy :: Proxy s))
  
  renderText ::
    forall s b l.
    (Reifies s (Renders b), RLabel l) =>
    RText l ->
    Tagged s b
  renderText = Tagged . rText (reflect (Proxy :: Proxy s)) Nothing
  
  renderTextEscaping ::
    forall s b l.
    (Reifies s (Renders b), RLabel l) =>
    Word8 ->
    RText l ->
    Tagged s b
  renderTextEscaping w = Tagged . rText (reflect (Proxy :: Proxy s)) (Just w)
  
  ----------------------------------------------------------------------------
  -- Generic render
  
  type Render a b =
    forall (s :: Type).
    (Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
    a ->
    Tagged s b
  
  genericRender :: Render URI b
  genericRender URI {..} =
    mconcat
      [ rJust rScheme uriScheme,
        rJust rAuthority (either (const Nothing) Just uriAuthority),
        rAbsPathSlash uriAuthority uriPath,
        rPath uriPath,
        rQuery uriQuery,
        rJust rFragment uriFragment
      ]
  {-# INLINE genericRender #-}
  
  rJust :: (Monoid m) => (a -> m) -> Maybe a -> m
  rJust = maybe mempty
  
  rScheme :: Render (RText 'Scheme) b
  rScheme = (<> ":") . renderText
  {-# INLINE rScheme #-}
  
  rAuthority :: Render Authority b
  rAuthority Authority {..} =
    mconcat
      [ "//",
        rJust rUserInfo authUserInfo,
        renderText authHost,
        rJust ((":" <>) . renderWord) authPort
      ]
  {-# INLINE rAuthority #-}
  
  rUserInfo :: Render UserInfo b
  rUserInfo UserInfo {..} =
    mconcat
      [ renderText uiUsername,
        rJust ((":" <>) . renderText) uiPassword,
        "@"
      ]
  {-# INLINE rUserInfo #-}
  
  rAbsPathSlash ::
    Either Bool a ->
    Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
  rAbsPathSlash (Left isAbsolute) _ = if isAbsolute then "/" else mempty
  rAbsPathSlash (Right _) Nothing = mempty
  rAbsPathSlash (Right _) (Just _) = "/"
  {-# INLINE rAbsPathSlash #-}
  
  rPath :: Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
  rPath path =
    case path of
      Nothing -> mempty
      Just (trailingSlash, ps) ->
        ( mconcat . intersperse "/" $ case ps of
            (x :| xs) -> renderTextEscaping 58 x : fmap renderText xs
        )
          <> if trailingSlash then "/" else mempty
  {-# INLINE rPath #-}
  
  rQuery :: Render [QueryParam] b
  rQuery = \case
    [] -> mempty
    qs -> "?" <> mconcat (intersperse "&" (rQueryParam <$> qs))
  {-# INLINE rQuery #-}
  
  rQueryParam :: Render QueryParam b
  rQueryParam = \case
    QueryFlag flag -> renderText flag
    QueryParam k v -> renderText k <> "=" <> renderText v
  {-# INLINE rQueryParam #-}
  
  rFragment :: Render (RText 'Fragment) b
  rFragment = ("#" <>) . renderText
  {-# INLINE rFragment #-}
  
  ----------------------------------------------------------------------------
  -- DString
  
  newtype DString = DString {toShowS :: ShowS}
  
  instance S.Semigroup DString where
    DString a <> DString b = DString (a . b)
  
  instance Monoid DString where
    mempty = DString id
    mappend = (S.<>)
  
  instance IsString DString where
    fromString str = DString (str ++)
  
  ----------------------------------------------------------------------------
  -- Percent-encoding
  
  -- | Percent-encode a 'Text' value.
  percentEncode ::
    forall l.
    (RLabel l) =>
    -- | Scheme of the URI
    Maybe (RText 'Scheme) ->
    -- | A byte to additionally escape
    Maybe Word8 ->
    -- | Input text to encode
    RText l ->
    -- | Percent-encoded text
    Text
  percentEncode mscheme alsoEscape rtxt =
    if skipEscaping (Proxy :: Proxy l) txt
      then txt
      else T.unfoldr f (TE.encodeUtf8 txt, [])
    where
      f (bs', []) =
        case B.uncons bs' of
          Nothing -> Nothing
          Just (w, bs'') ->
            Just $
              if
                | sap && w == 32 -> ('+', (bs'', []))
                | nne w -> (chr (fromIntegral w), (bs'', []))
                | otherwise ->
                    let c :| cs = encodeByte w
                     in (c, (bs'', cs))
      f (bs', x : xs) = Just (x, (bs', xs))
      encodeByte x = '%' :| [intToDigit h, intToDigit l]
        where
          (h, l) = fromIntegral x `quotRem` 16
      nne w =
        let normalCase = needsNoEscaping (Proxy :: Proxy l) mscheme w
         in case alsoEscape of
              Nothing -> normalCase
              Just w' -> if w == w' then False else normalCase
      sap = spaceAsPlus (Proxy :: Proxy l)
      txt = unRText rtxt
  {-# INLINE percentEncode #-}
  
  -- | This type class attaches some predicates that control serialization to
  -- the type level label of kind 'RTextLabel'.
  class RLabel (l :: RTextLabel) where
    -- | The predicate selects bytes that are not to be percent-escaped in
    -- rendered URI.
    needsNoEscaping :: Proxy l -> Maybe (RText 'Scheme) -> Word8 -> Bool
  
    -- | Whether to serialize space as the plus sign.
    spaceAsPlus :: Proxy l -> Bool
    spaceAsPlus Proxy = False
  
    -- | Whether to skip percent-escaping altogether for this value.
    skipEscaping :: Proxy l -> Text -> Bool
    skipEscaping Proxy _ = False
  
  instance RLabel 'Scheme where
    needsNoEscaping Proxy _ x = isAlphaNum x || x == 43 || x == 45 || x == 46
  
  instance RLabel 'Host where
    needsNoEscaping Proxy _ x = isUnreserved x || isDelim x
    skipEscaping Proxy x = T.take 1 x == "["
  
  instance RLabel 'Username where
    needsNoEscaping Proxy _ x = isUnreserved x || isDelim x
  
  instance RLabel 'Password where
    needsNoEscaping Proxy _ x = isUnreserved x || isDelim x || x == 58
  
  instance RLabel 'PathPiece where
    needsNoEscaping Proxy mscheme x =
      case mscheme of
        Nothing -> commonCase
        Just scheme ->
          if unRText scheme == "mailto"
            then commonCase || x == 64
            else commonCase
      where
        commonCase = isUnreserved x || x == 58
  
  instance RLabel 'QueryKey where
    needsNoEscaping Proxy _ x =
      isPChar isDelim' x || x == 47 || x == 63
    spaceAsPlus Proxy = True
  
  instance RLabel 'QueryValue where
    needsNoEscaping Proxy _ x =
      isPChar isDelim' x || x == 47 || x == 63
    spaceAsPlus Proxy = True
  
  instance RLabel 'Fragment where
    needsNoEscaping Proxy _ x =
      isPChar isDelim x || x == 47 || x == 63
  
  isPChar :: (Word8 -> Bool) -> Word8 -> Bool
  isPChar f x = isUnreserved x || f x || x == 58 || x == 64
  
  isUnreserved :: Word8 -> Bool
  isUnreserved x = isAlphaNum x || other
    where
      other = case x of
        45 -> True
        46 -> True
        95 -> True
        126 -> True
        _ -> False
  
  isAlphaNum :: Word8 -> Bool
  isAlphaNum x
    | x >= 65 && x <= 90 = True -- 'A'..'Z'
    | x >= 97 && x <= 122 = True -- 'a'..'z'
    | x >= 48 && x <= 57 = True -- '0'..'9'
    | otherwise = False
  
  isDelim :: Word8 -> Bool
  isDelim x
    | x == 33 = True
    | x == 36 = True
    | x >= 38 && x <= 44 = True
    | x == 59 = True
    | x == 61 = True
    | otherwise = False
  
  isDelim' :: Word8 -> Bool
  isDelim' x
    | x == 33 = True
    | x == 36 = True
    | x >= 39 && x <= 42 = True
    | x == 44 = True
    | x == 59 = True
    | otherwise = False
  