Created
June 18, 2020 09:23
-
-
Save gdeest/27d41541839bae947997bec52c519b51 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #!/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) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment