How to get a record of record of links from a record of records of Servant routes

ServantGenericLinks.hs

-- Based on https://gist.github.com/jship/d2237fad40cfb34166d82597735fbacf
--
-- The above example demonstrates how to flatten all the routes in a record of
-- records of routes, in order to bind a long list of top-level 'Link'
-- functions.
--
-- Below, I demonstrate how to instead go from a record of records of routes to
-- a record of records of 'Link's, and how to easily navigate the resulting
-- nested record.
{-# LANGUAGE DataKinds, DeriveGeneric, DerivingStrategies, FlexibleContexts, GADTs, TypeApplications, TypeOperators #-}
module Main where

import Data.Function ((&))
import Data.Proxy (Proxy(..))
import Servant.API ((:>), Capture, DeleteNoContent, Get, JSON, ReqBody, PutNoContent)
import Servant.API.Generic (Generic, GenericMode((:-)), GenericServant, ToServant, ToServantApi, fromServant, genericApi)
import Servant.Links (AsLink, Link, {-allFieldLinks,-} allLinks)


-- I will use the exact same record of records of routes as Jason.

type FooAPI = ToServantApi FooRoutes

theFooAPI :: Proxy FooAPI
theFooAPI = genericApi $ Proxy @FooRoutes

data FooRoutes route = FooRoutes
  { bar :: route :- "bar" :> FooBarAPI
  , baz :: route :- "baz" :> FooBazAPI
  } deriving stock (Generic)

type FooBarAPI = ToServantApi FooBarRoutes

theFooBarAPI :: Proxy FooBarAPI
theFooBarAPI = genericApi $ Proxy @FooBarRoutes

data FooBarRoutes route = FooBarRoutes
  { getBar :: route :- Capture "barId" String :> Get '[JSON] Int
  , updateBar :: route :- Capture "barId" String :> ReqBody '[JSON] Int :> PutNoContent
  , deleteBar :: route :- Capture "barId" String :> DeleteNoContent
  } deriving stock (Generic)

type FooBazAPI = ToServantApi FooBazRoutes

theFooBazAPI :: Proxy FooBazAPI
theFooBazAPI = genericApi $ Proxy @FooBazRoutes

data FooBazRoutes route = FooBazRoutes
  { getBaz :: route :- Capture "bazId" String :> Get '[JSON] Int
  , deleteBaz :: route :- Capture "bazId" String :> DeleteNoContent
  } deriving stock (Generic)


-- Next, Jason writes:
--
-- @
--     barLinks :: (String -> Link) :<|> (String -> Link) :<|> (String -> Link)
--     bazLinks :: (String -> Link) :<|> (String -> Link)
--     barLinks :<|> bazLinks = allLinks theFooAPI
-- @
--
-- indicating that @allLinks theFooAPI@ has the following really long type:
--
-- @
--   fooLinks :: ( (String -> Link) :<|> (String -> Link) :<|> (String -> Link) )
--          :<|> ( (String -> Link) :<|> (String -> Link) )
--   fooLinks = allLinks theFooAPI
-- @
--
-- Fortunately, Servant has a type family named 'ToServant' which computes this
-- long-form type for us, so we don't need to type it all up:

longFooLinks :: ToServant FooRoutes (AsLink Link)
longFooLinks = allLinks theFooAPI

-- This poorly-named 'ToServant' type family is the key to manipulating servant
-- records effectively, so let's take a moment to look at it in detail.
--
-- First, the name. The servant package used to only support these long-form
-- @... :<|> ... :<|> ...@ types, while a separate package named
-- servant-generic added support for records of records of routes. Thus,
-- "ToServant" means to convert from the record format to the long-form format.
--
-- It is important to realize that 'ToServant' is a type-level function, not a
-- value-level function. It is not a function which converts a value-level
-- record to the value-level long-form representation. In fact, 'ToServant' is
-- used to describe _both_ the value-level function which does that _and_ the
-- value-level function which goes in the opposite direction. There is no
-- 'FromServant'.
--
-- @
--     toServant
--       :: GenericServant record mode
--       => record mode -> ToServant record mode
--
--     fromServant
--       :: GenericServant record mode
--       => ToServant record mode -> record mode
-- @

-- We now know enough to figure out how to obtain a record of records of
-- 'Link's, as promised in the intro:
fooLinksRecord :: FooRoutes (AsLink Link)
fooLinksRecord = fromServant longFooLinks  -- aka 'allFieldLinks'

-- Next, let's look at this 'mode' type parameter. It's typically named 'route'
-- in the record of routes, it goes before the '(:-)' type family:
--
-- @
--     data FooBazRoutes route = FooBazRoutes
--       { getBaz :: route :- Capture "bazId" String :> Get '[JSON] Int
--       , deleteBaz :: route :- Capture "bazId" String :> DeleteNoContent
--       } deriving stock (Generic)
-- @
--
-- @mode :- routeType@ is basically the same thing as
-- @ToServant record mode@, but for an individual field instead of a whole
-- record:
-- 
-- >>> :kind! ToServant FooBazRoutes (AsLink Link)
-- ([Char] -> Link) :<|> ([Char] -> Link)
-- >>> :kind! AsLink Link :- Capture "bazId" String :> Get '[JSON] Int
-- [Char] -> Link
-- >>> :kind! AsLink Link :- Capture "bazId" String :> DeleteNoContent
-- [Char] -> Link
-- 
-- Note that every field in a record of records of routes begins with
-- @route :- ...@, and '(:-)' converts its right-hand-side to the long-form
-- format. This has one big consequence for our record of records of routes:
-- there's no such thing! It only _looks_ like a record of records, but in fact
-- it is a record of long-form routes.

-- Thus, when we look at the 'bar' field of our 'fooLinksRecord', we don't get
-- a @FooBarRoutes (AsLink Link)@, we instead get the long-form equivalent.
-- Which we again write succinctly thanks to 'ToServant'.
longBarLinks :: ToServant FooBarRoutes (AsLink Link)
longBarLinks = bar fooLinksRecord

-- ...but it is easy to get a record of 'Link's from that.
barLinksRecord :: FooBarRoutes (AsLink Link)
barLinksRecord = fromServant longBarLinks

-- It is tempting to take what we just did to get a record of links out of a
-- record of records of links, and to generalize it to get a record of things
-- out of a record of record of things:

(//-) :: GenericServant innerRecord mode
      => outerRecord mode
      -> (outerRecord mode -> ToServant innerRecord mode)
      -> innerRecord mode
outerRecord //- fieldAccessor = fromServant (fieldAccessor outerRecord)

barLinksRecord2 :: FooBarRoutes (AsLink Link)
barLinksRecord2 = fooLinksRecord //- bar

-- However, this API is a bit sub-optimal in that it only works for
-- nested-records; once we reach a route leaf, we need to switch to a different
-- infix operator, '(&)':

getBarLink2 :: String -> Link
getBarLink2 = fooLinksRecord //- bar & getBar

-- For this reason, I prefer this alternative API which embraces the long-form
-- format, in the sense that instead of extracting a record of links from a
-- record of records of links, it extracts the long-form version of a record of
-- links from the long-form version of a record of records of links. Note how
-- the 'a' could either be @ToServant innerRecord mode@ or @AsLink :- Capture ...@,
-- so we can use '(//)' to extract either.
-- 
-- This API is inspired from the following blog post:
-- https://blog.clement.delafargue.name/posts/2019-09-10-a-new-tale-of-servant-clients.html

(//) :: ( mode ~ AsLink Link  -- otherwise 'mode' is ambiguous
        , GenericServant outerRecord mode
        )
     => ToServant outerRecord mode
     -> (outerRecord mode -> a)
     -> a
longOuterRecord // fieldAccessor = fieldAccessor (fromServant longOuterRecord)

-- Finally, here is how to use this alternate API to extract all the links.
-- I include these here mainly to demonstrate how to use the API: in practice,
-- I would not define all of those top-level functions, I would only define
-- 'fooLinks'. Then I would write @fooLinks // bar // getBar $ "my-bar"@ at the
-- use site instead of @getBarLink "my-bar"@. This is one of the benefits of
-- the records of records format over the long-form format: we don't need to
-- bind one top-level identifier for each route, it suffices to define a single
-- top-level definition representing all the routes, and then to dive into it
-- in order to reference a particular route.

fooLinks :: ToServant FooRoutes (AsLink Link)
fooLinks = allLinks theFooAPI

barLinks :: ToServant FooBarRoutes (AsLink Link)
barLinks = fooLinks // bar

getBarLink :: String -> Link
getBarLink = fooLinks // bar // getBar

updateBarLink :: String -> Link
updateBarLink = fooLinks // bar // updateBar

deleteBarLink :: String -> Link
deleteBarLink = fooLinks // bar // deleteBar

bazLinks :: ToServant FooBazRoutes (AsLink Link)
bazLinks = fooLinks // baz

getBazLink :: String -> Link
getBazLink = fooLinks // baz // getBaz

deleteBazLink :: String -> Link
deleteBazLink = fooLinks // baz // deleteBaz


main :: IO ()
main = do
  putStrLn "typechecks."