HasServer instances for records of routes using TemplateHaskell instead of Generic

named-routes-th.hs

data NamedRoutesTH api

class ToServantApiTH routes where
  type ServantApiTH routes :: Type

  toServantTH :: routes (AsServerT m) -> ServerT (ServantApiTH routes) m
  fromServantTH :: ServerT (ServantApiTH routes) m -> routes (AsServerT m)

instance
  ( ToServantApiTH api
  , HasServer (ServantApiTH api) context
  ) => HasServer (NamedRoutesTH api) context where

  type ServerT (NamedRoutesTH api) m = api (AsServerT m)

  route
    :: Proxy (NamedRoutesTH api)
    -> Context context
    -> Delayed env (api (AsServerT Handler))
    -> Router env
  route _p ctx delayed =
    route (Proxy @(ServantApiTH api)) ctx (toServantTH <$> delayed)

  hoistServerWithContext _ pctx nat server =
    fromServantTH $
      hoistServerWithContext (Proxy @(ServantApiTH api)) pctx nat $
        toServantTH server

-- mkNamedRoutesTH :: Name -> DecsQ
-- mkNamedRoutesTH = undefined -- exercise for reader

data RoutesRecord mode = RoutesRecord
  { routeA :: mode :- "a" :> Get '[JSON] [Int]
  , routeB :: mode :- "b" :> Get '[JSON] String
  }

-- mkNamedRoutesTH ''RoutesRecord

-- this is the instance that `mkNamedRoutesTH` should generate
instance ToServantApiTH RoutesRecord where
  type ServantApiTH RoutesRecord =
    "a" :> Get '[JSON] [Int] :<|>
    "b" :> Get '[JSON] String

  toServantTH (RoutesRecord a b) = a :<|> b
  fromServantTH (a :<|> b) = RoutesRecord a b
  

type API = NamedRoutesTH RoutesRecord