GenericServant.hs

#!/usr/bin/env stack
-- stack --resolver lts-16.0 --no-nix --system-ghc script

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module GenericServant where

import Data.Constraint (Dict(..))
import GHC.Generics
import Servant

import Servant.API.Generic
import Servant.Client
import Servant.Client.Core
import Servant.Client.Generic
import Servant.Server.Generic

-- | Servant combinator indicating that part of an API is defined by a generic product.
data GenericApi (routes :: * -> *)

---------------------
-- Generic servers --
---------------------

-- | Constraint synonyms
type GServerConstraints routes context m =
  ( ToServant routes (AsServerT m) ~ ServerT (ToServant routes AsApi) m
  , HasServer (ToServantApi routes) context
  , Generic (routes (AsServerT m))
  , GServantProduct (Rep (routes (AsServerT m))))

class GServer (routes :: * -> *) where
  dict :: forall context m. Dict (GServerConstraints routes context m)

  default dict
    :: GServerConstraints routes context m
    => Dict (GServerConstraints routes context m)
  dict = Dict

instance ( GServer routes ) => HasServer (GenericApi routes) context where
  type ServerT (GenericApi routes) m = routes (AsServerT m)

  route Proxy ctx delayed =
    case dict @routes @context @Handler of
      Dict -> route (Proxy @(ToServantApi routes)) ctx (toServant <$> delayed)


  hoistServerWithContext
    :: forall  m n.
       Proxy (GenericApi routes)
    -> Proxy context
    -> (forall x. m x -> n x)
    -> ServerT (GenericApi routes) m
    -> ServerT (GenericApi routes) n
  hoistServerWithContext _ pctx nat server =
    case (dict @routes @context @m, dict @routes @context @n) of
      (Dict, Dict) ->
        let
          servantSrvM :: ServerT (ToServantApi routes) m =
            toServant server
          servantSrvN :: ServerT (ToServantApi routes) n =
              hoistServerWithContext (Proxy @(ToServantApi routes)) pctx nat servantSrvM
        in
          fromServant servantSrvN

---------------------
-- Generic clients --
---------------------

type GClientConstraints routes m =
  ( GenericServant routes (AsClientT m)
  , Client m (ToServantApi routes) ~ ToServant routes (AsClientT m)
  , HasClient m (ToServantApi routes)
  -- , Client mb (ToServantApi routes) ~
  )

class  GClient (routes :: * -> *) where

  clientDict :: forall m.  RunClient m => Dict (GClientConstraints routes m)
  default clientDict :: (GClientConstraints routes m, RunClient m) => Dict (GClientConstraints routes m)
  clientDict = Dict

instance (GClient routes, RunClient m) => HasClient m (GenericApi routes) where
  type Client m (GenericApi routes) = routes (AsClientT m)

  clientWithRoute :: Proxy m -> Proxy (GenericApi routes) -> Request -> Client m (GenericApi routes)
  clientWithRoute pm _ request =
    case clientDict @routes @m of
      Dict -> fromServant $ clientWithRoute  pm (Proxy @(ToServantApi routes)) request

  hoistClientMonad :: forall ma mb. Proxy m
    -> Proxy (GenericApi routes)
    -> (forall x. ma x -> mb x)
    -> Client ma (GenericApi routes)
    -> Client mb (GenericApi routes)
  hoistClientMonad pm _ nat clientA = undefined
    -- This doesn't work because we don't ''have RunClient ma/mb'.
    -- case (clientDict @routes @ma, clientDict @routes @mb, clientDict @routes @m) of
    --   -- Hack alert.
    --   (Dict, Dict, Dict) ->
    --     fromServant @routes @(AsClientT mb) $
    --     hoistClientMonad pm (Proxy @(ToServantApi routes)) nat $
    --     toServant @routes @(AsClientT ma) clientA

type Api = GenericApi Api'

data Api' routes = Api'
  { get :: routes :- Get '[JSON] ()
  , subApi :: routes :- GenericApi SubApi
  }
  deriving (Generic, GServer, GClient)

data SubApi routes = SubApi { otherEndPoint :: routes :- Get '[JSON] () }
  deriving (Generic, GServer, GClient)