{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE DataKinds             #-}

-- | Provides instances to be able to use combinators from
-- "Servant.API.NamedArgs" with "Servant.Client", returning functions
-- using named parameters from "Named"
module Servant.Client.NamedArgs where

import Named ((:!), (:?), arg, argF, argDef, Name(..))
import Data.Text (pack, Text)
import Data.Functor.Identity (Identity)
import Data.List (foldl')
import Servant.API ((:>), SBoolI, ToHttpApiData, toQueryParam, toUrlPiece, MimeRender(mimeRender), contentType)
import Servant.API.Modifiers (FoldRequired)
import Servant.API.NamedArgs ( foldRequiredNamedArgument, NamedCapture', NamedFlag
                             , NamedParam, NamedParams, RequiredNamedArgument
                             , NamedCaptureAll, NamedHeader', NamedBody')
import Servant.Client.Core (HasClient(..), appendToPath, appendToQueryString, Request, addHeader, setRequestBodyLBS)
import Data.String (fromString)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Data.Proxy (Proxy(..))

-- | 'NamedCapture''s become required named arguments
instance (KnownSymbol name, ToHttpApiData a, HasClient m api)
    => HasClient m (NamedCapture' mods name a :> api) where

  type Client m (NamedCapture' mods name a :> api) =
    (name :! a) -> Client m api

  clientWithRoute pm _ req (arg (Name @name) -> capture) =
      clientWithRoute pm (Proxy @api) (appendToPath (toUrlPiece capture) req)
      
  hoistClientMonad pm _ f cl = \a ->
      hoistClientMonad pm (Proxy @api) f (cl a)

-- | 'NamedCaptureAll's become optional named arguments taking a list and
-- defaulting to an empty list
instance (KnownSymbol name, ToHttpApiData a, HasClient m api)
    => HasClient m (NamedCaptureAll name a :> api) where

  type Client m (NamedCaptureAll name a :> api) =
    (name :? [a]) -> Client m api

  clientWithRoute pm _ req (argDef (Name @name) [] -> captures) =
      clientWithRoute pm (Proxy @api) (foldl' (flip appendToPath) req ps)
    where
      ps = map toUrlPiece captures
      
  hoistClientMonad pm _ f cl = \as ->
      hoistClientMonad pm (Proxy @api) f (cl as)

-- | 'NamedFlag's become optional named arguments, defaulting to 'False'
instance (KnownSymbol name, HasClient m api)
    => HasClient m (NamedFlag name :> api) where

  type Client m (NamedFlag name :> api) =
    (name :? Bool) -> Client m api

  clientWithRoute pm _ req (argDef (Name @name) False -> mflag) =
      clientWithRoute pm (Proxy @api) $
      if mflag
        then appendToQueryString pname Nothing req
        else req
    where
      pname :: Text
      pname = pack $ symbolVal (Proxy @name)

  hoistClientMonad pm _ f cl = \b ->
      hoistClientMonad pm (Proxy @api) f (cl b)

-- | 'NamedHeader''s become either required or optional named arguments
-- depending on if 'Servant.API.Modifiers.Required' or
-- 'Servant.API.Modifiers.Optional' are in the modifiers
instance (KnownSymbol name, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
    => HasClient m (NamedHeader' mods name a :> api) where

  type Client m (NamedHeader' mods name a :> api) =
     RequiredNamedArgument mods name a -> Client m api

  clientWithRoute pm _ req mval =
      clientWithRoute pm (Proxy @api) $
        foldRequiredNamedArgument @mods @name
          add
          (maybe req add)
          mval

    where
      add :: a -> Request
      add value = addHeader hname value req

      hname  = fromString $ symbolVal (Proxy @name)

  hoistClientMonad pm _ f cl = \a ->
      hoistClientMonad pm (Proxy @api) f (cl a)

-- | 'NamedParam's become either required or optional named arguments
-- depending on if 'Servant.API.Modifiers.Required' or
-- 'Servant.API.Modifiers.Optional' are in the modifiers
instance (KnownSymbol name, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
    => HasClient m (NamedParam mods name a :> api) where

  type Client m (NamedParam mods name a :> api) =
     RequiredNamedArgument mods name a -> Client m api

  clientWithRoute pm _ req mparam =
      clientWithRoute pm (Proxy @api) $
        foldRequiredNamedArgument @mods @name
          add
          (maybe req add)
          mparam

    where
      add :: a -> Request
      add param = appendToQueryString pname (Just $ toQueryParam param) req

      pname :: Text
      pname  = pack $ symbolVal (Proxy @name)

  hoistClientMonad pm _ f cl = \a ->
      hoistClientMonad pm (Proxy @api) f (cl a)

-- | 'NamedParams's become optional named arguments taking a list and
-- defaulting to an empty list
instance (KnownSymbol name, ToHttpApiData a, HasClient m api)
    => HasClient m (NamedParams name a :> api) where

  type Client m (NamedParams name a :> api) =
    (name :? [a]) -> Client m api

  clientWithRoute pm _ req (argDef (Name @name) [] -> mparams) =
      clientWithRoute pm (Proxy @api) $
        case mparams of
          [] -> req
          ls -> foldl'
                  (\req' param -> appendToQueryString pname (Just $ toQueryParam param) req')
                  req
                  ls
    where
      pname :: Text
      pname = pack $ symbolVal (Proxy :: Proxy name)

  hoistClientMonad pm _ f cl = \as ->
      hoistClientMonad pm (Proxy @api) f (cl as)

-- | 'NamedBody''s become required named arguments 
instance (KnownSymbol name, MimeRender ct a, HasClient m api)
    => HasClient m (NamedBody' mods name (ct ': cts) a :> api) where

  type Client m (NamedBody' mods name (ct ': cts) a :> api) =
    (name :! a) -> Client m api

  clientWithRoute pm _ req (arg (Name @name) -> body) =
      clientWithRoute pm (Proxy @api) $
        setRequestBodyLBS (mimeRender ctProxy body)
                          (contentType ctProxy)
                          req
     where
       ctProxy = Proxy @ct

  hoistClientMonad pm _ f cl = \a ->
    hoistClientMonad pm (Proxy @api) f (cl a)