NamedArgs.hs

{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE PatternSynonyms       #-}

-- | This module provides combinators to represent named arguments
-- to endpoints. Note that only link generation instances are provided
-- here:
-- you will most likely want one or both of "Servant.Client.NamedArgs" and
-- "Servant.Server.NamedArgs"
module Servant.API.NamedArgs where

import GHC.TypeLits          (Symbol, KnownSymbol, symbolVal)
import Data.Functor.Identity (Identity)
import Data.Proxy            (Proxy(..))
import Data.Text             (Text)
import Named                 ((:!), (:?), arg, argF, Name(..), (!), NamedF(..), pattern Arg
                             , argDef)
import Servant.API           ((:>), (:<|>)(..), Capture', If, QueryFlag, QueryParam'
                             , QueryParams, SBoolI(..), SBool(..), HasLink(..)
                             , ToHttpApiData(..), CaptureAll(..), AddHeader(..), Headers(..)
                             , Header'(..))
import Servant.API.Modifiers (FoldRequired, Optional, Required, Strict, FoldLenient)
import Servant.API.Generic   (GenericMode(..), AsApi, ToServant)
import Servant.Links         (Param(..), Link(..), linkQueryParams)
import Type.Reflection       (Typeable)
import GHC.Generics

-- | Isomorphism of 'Servant.API.Capture'' 
data NamedCapture' (mods :: [*]) (sym :: Symbol) (a :: *)
    deriving Typeable

-- | Isomorphism of 'Servant.API.Capture'
type NamedCapture = NamedCapture' '[]

-- | Becomes a named required argument
instance (ToHttpApiData v, HasLink sub, KnownSymbol name)
    => HasLink (NamedCapture' mods name v :> sub) where
  type MkLink (NamedCapture' mods name v :> sub) a = (name :! v) -> MkLink sub a

  toLink toA _ l (arg (Name @name) -> capture)
      = (toLink toA (Proxy @(Capture' mods name v :> sub)) l) capture

-- | Isomorphism of 'Servant.API.CaptureAll'
data NamedCaptureAll (sym :: Symbol) (a :: *)
    deriving Typeable

-- | Becomes a named optional argument, taking a list and defaulting to an
-- empty list
instance (ToHttpApiData v, HasLink sub, KnownSymbol name)
    => HasLink (NamedCaptureAll name v :> sub) where
  type MkLink (NamedCaptureAll name v :> sub) a = (name :? [v]) -> MkLink sub a

  toLink toA _ l (argDef (Name @name) [] -> capture)
      = (toLink toA (Proxy @(CaptureAll name v :> sub)) l) capture

-- | Isomorphism of 'Servant.API.QueryParam''
data NamedParam (mods :: [*]) (sym :: Symbol) (a :: *)
    deriving Typeable

-- | Shorthand for a required param, isomorphic to
-- 'QueryParam'' \'['Required', 'Strict'] from Servant
type RequiredNamedParam = NamedParam '[Required, Strict]

-- | Shorthand for an optional param, isomorphic to
-- 'QueryParam'' \'['Optional', 'Strict'] from Servant
type OptionalNamedParam = NamedParam '[Optional, Strict]

-- | Becomes either a required or optional named argument depending on
-- whether it is set as 'Required' or 'Optional' (defaults to optional if
-- neither is specified)
instance (KnownSymbol name, HasLink sub, ToHttpApiData v, SBoolI (FoldRequired mods))
    => HasLink (NamedParam mods name v :> sub) where

    type MkLink (NamedParam mods name v :> sub) a
        = RequiredNamedArgument mods name v -> MkLink sub a

    toLink toA _ l = 
        foldRequiredAdapter @mods @name @v (toLink toA (Proxy @(QueryParam' mods name v :> sub)) l)

-- | Isomorphism of 'Servant.API.QueryParams'
data NamedParams (sym :: Symbol) (a :: *)
    deriving Typeable

-- | Becomes a required named argument, taking a list
instance (KnownSymbol name, HasLink sub, ToHttpApiData v)
    => HasLink (NamedParams name v :> sub) where

  type MkLink (NamedParams name v :> sub) a = (name :! [v]) -> MkLink sub a

  toLink toA _ l (arg (Name @name) -> vs)
      = (toLink toA (Proxy @(QueryParams name v :> sub)) l) vs

-- | Isomorphism of 'Servant.API.QueryFlag'
data NamedFlag (sym :: Symbol)
    deriving Typeable

-- | Becomes an optional named argument, defaulting to False
instance (KnownSymbol name, HasLink sub)
    => HasLink (NamedFlag name :> sub) where

  type MkLink (NamedFlag name :> sub) a =
    (name :? Bool) -> MkLink sub a

  toLink toA _ l (argDef (Name @name) False -> v) =
      (toLink toA (Proxy @(QueryFlag name :> sub)) l) v

-- | Isomorphism of 'Header''
data NamedHeader' (mods :: [*]) (sym :: Symbol) (a :: *)
    deriving Typeable

-- | Shorthand for a required Header; Isomorphism of 'Header'
type NamedHeader = NamedHeader' '[Optional, Strict]

-- | Has no effect on the resulting link
instance (HasLink sub) => HasLink (NamedHeader' mods name a :> sub) where
  type MkLink (NamedHeader' mods name a :> sub) r = MkLink sub r
  toLink toA _ = toLink toA (Proxy :: Proxy sub)

-- | Returns the type name :! a if given a list including 'Required'
-- and name :? a otherwise
type RequiredNamedArgument mods name a = If (FoldRequired mods) (name :! a) (name :? a)

-- | Returns either a `NamedF Identity` or `NamedF Maybe` depending on if
-- required/optional, wrapping an `Either Text a` or an `a` depending on if
-- lenient/strict
type RequestNamedArgument mods name a 
  = If (FoldRequired mods) 
       (name :! If (FoldLenient mods) (Either Text a) a)
       (name :? (If (FoldLenient mods) (Either Text a) a)) 

-- | Apply either the function 'f' which operates on 'a'
-- or 'g' which operates on 'Maybe' a depending on if the 
-- mods include `Required`
foldRequiredNamedArgument
  :: forall mods name a r. (SBoolI (FoldRequired mods), KnownSymbol name)
  => (a -> r)   -- ^ Function to apply if the mods includes 'Required'
  -> (Maybe a -> r) -- ^ Function to apply if the mods do not include 'Required'
  -> RequiredNamedArgument mods name a -- ^ Argument to either 'f' or 'g'
  -> r
foldRequiredNamedArgument f g mx =
    case (sbool :: SBool (FoldRequired mods), mx) of
      (STrue,  (arg (Name :: Name name) -> x)) -> f x
      (SFalse, (argF (Name :: Name name) -> x)) -> g x

-- | Adapt a function supposed to take a or 'Maybe' a to take name 
-- ':!'
-- a or name ':?' a instead
foldRequiredAdapter
  :: forall mods name a r. (SBoolI (FoldRequired mods), KnownSymbol name)
  => (If (FoldRequired mods) a (Maybe a) -> r) -- ^ Version of functions without named arguments
  -> RequiredNamedArgument mods name a -- ^ Argument to either 'f' or 'g'
  -> r
foldRequiredAdapter f mv = 
           case (sbool :: SBool (FoldRequired mods), mv) of
             (STrue,  (arg (Name :: Name name) -> x)) -> f x
             (SFalse, (argF (Name :: Name name) -> x)) -> f x

-- | Unfold a value into a 'RequestNamedArgument'.
unfoldRequestNamedArgument
    :: forall mods name m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))
    => m (RequestNamedArgument mods name a)            -- ^ error when argument is required
    -> (Text -> m (RequestNamedArgument mods name a))  -- ^ error when argument is strictly parsed
    -> Maybe (Either Text a)                 -- ^ value
    -> m (RequestNamedArgument mods name a)
unfoldRequestNamedArgument errReq errSt mex =
    case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of
        (STrue,  Nothing, _)      -> errReq
        (SFalse, Nothing, _)      -> pure $ ArgF Nothing
        (STrue,  Just ex, STrue)  -> pure $ Arg ex
        (STrue,  Just ex, SFalse) -> either errSt pure (Arg <$> ex)
        (SFalse, Just ex, STrue)  -> pure $ ArgF $ Just ex
        (SFalse, Just ex, SFalse) -> either errSt (pure . ArgF . Just) ex

-- | 'Transform' is used to transform back and forth between APIs 
-- using the "Named" combinators and APIs not using the "Named" combinators
-- by applying the listed transformations to the api
type family Transform (t :: [Transformation]) (api :: k) :: k where
  -- recurse on binary operators
  Transform t (a :<|> b) = Transform t a :<|> Transform t b
  Transform t (a :> b) = Transform t a :> Transform t b 
  -- naming rules
  Transform (NameParams:_) (QueryParam' mods sym a)
    = NamedParam mods sym a
  Transform (NameMultiParams:_) (QueryParams sym a)
    = NamedParams sym a
  Transform (NameFlags:_) (QueryFlag sym)
    = NamedFlag sym
  Transform (NameCaptures:_) (Capture' mods sym a)
    = NamedCapture' mods sym a
  Transform (NameCaptureAlls:_) (CaptureAll sym a)
    = NamedCaptureAll sym a
  Transform (NameHeaders:_) (Header' mods sym a)
    = NamedHeader' mods sym a
  -- unnaming rules
  Transform (UnnameParams:_) (NamedParam mods sym a)
    = QueryParam' mods sym a
  Transform (UnnameMultiParams:_) (NamedParams sym a)
    = QueryParams sym a
  Transform (UnnameFlags:_) (NamedFlag sym)
    = QueryFlag sym
  Transform (UnnameCaptures:_) (NamedCapture' mods sym a)
    = Capture' mods sym a
  Transform (UnnameCaptureAlls:_) (NamedCaptureAll sym a)
    = CaptureAll sym a
  Transform (UnnameHeaders:_) (NamedHeader' mods sym a)
    = Header' mods sym a
  -- if the current transformation doesn't match, try the next one
  Transform (_:ts) a = Transform ts a
  -- if none of them match, leave it unchanged
  Transform '[] a = a

-- | 'AsTransformed' can be used to transform back and forth while using
-- Servant's generic programming (see "Servant.API.Generic")
data AsTransformed (t :: [Transformation]) (m :: *)

instance (GenericMode mode) => GenericMode (AsTransformed t mode) where
    type AsTransformed t mode :- api = mode :- Transform t api

-- | Possible transformations 'Transform' can apply
data Transformation = NameParams -- ^ Replace 'QueryParam''s with 'NamedParam''s
                    | NameMultiParams -- ^ Replace 'QueryParams's with 'NamedParams's
                    | NameCaptures -- ^ Replace 'Capture''s with 'NamedCapture''s
                    | NameCaptureAlls -- ^ Replace 'CaptureAll's with 'NamedCaptureAll's
                    | NameFlags -- ^ Replace 'QueryFlag's with 'NamedFlag's
                    | NameHeaders -- ^ Replace 'Header''s with 'NamedHeader''s
                    | UnnameParams -- ^ Replace 'NamedParam's with 'QueryParam''s
                    | UnnameMultiParams -- ^ Replace 'NamedParams's with 'QueryParams's 
                    | UnnameCaptures -- ^ Replace 'NamedCapture''s with 'Capture's
                    | UnnameCaptureAlls -- ^ Replace 'NamedCaptureAll's with 'CaptureAll's 
                    | UnnameFlags -- ^ Replace 'NamedFlag's with 'QueryFlag's 
                    | UnnameHeaders -- ^ Replace 'NamedHeader''s with 'Header''s
                    deriving (Show, Read, Eq, Enum)