Flatten.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.API.Flatten where

import Data.Proxy
import GHC.TypeLits
import Servant.API

-- | Flatten (a 'Proxy' to) an API type.
--
--   This performs a number of transformations on the API type so
--   as to end up with all combinators distributed over endpoints.
--   For example, the following API type:
--
--   @
--   type API = 'Capture' "foo" 'Int' ':>'
--     ( 'Capture' "bar" 'String' ':>'
--         ( 'Get' '['JSON'] 'String' ':<|>'
--           'ReqBody' '['JSON'] 'Int' ':>' 'Post' '['JSON'] 'Int'
--         ) ':<|>'
--       'Get' '['JSON'] 'Int'
--     ) ':<|>'
--     'Get' '['JSON'] ['String']
--   @
--
--   gets transformed into:
--
--   @
--   'Capture' "foo" 'Int' ':>' 'Capture' "bar" 'String' ':>' 'Get' '['JSON'] 'String' ':<|>'
--   'Capture' "foo" 'Int' ':>' 'Capture' "bar" 'String' ':>' 'ReqBody' '[JSON] 'Int' ':>' 'Post' '['JSON'] 'Int' ':<|>'
--   'Capture' "foo" 'Int' ':>' 'Get' '['JSON'] 'Int' ':<|>'
--   'Get' '['JSON'] ['String']
--   @
--
--   The main point of doing this is to avoid \"nested types\" for server-side handlers
--   and client functions. See <https://haskell-servant.readthedocs.io/en/stable/cookbook/structuring-apis/StructuringApis.html#structuring-apis this cookbook recipe>
--   (particularly the notes on @FactoringAPI@) for more about \"nested types\".
--
--   To derive \"flat\" client functions for the API type above, @API@, you can do:
--
--   @
--   getfoobar ':<|>' postfoobar ':<|>' getfoo ':<|>' getstrings
--     = 'client' $ 'flatten' ('Proxy' :: 'Proxy' API)
--   @
--
--   To serve an implementation for that API with \"flat\" handler types, you can do:
--
--   @
--   -- we define all our handlers assuming all the arguments are distributed,
--   -- and declare that this is an implementation for @Flat API@, not @API@.
--   server :: Server ('Flat' API)
--   server = (\foo bar -> return $ show (foo + bar))
--       ':<|>' (\foo bar body -> return $ show (foo + bar - body^2))
--       ':<|>' (\foo -> return (foo * 2))
--       ':<|>' (return ["hello", "world"])
--
--   api :: 'Proxy' API
--   api = 'Proxy'
--
--   main :: 'IO' ()
--   main = Network.Wai.Handler.Warp.run 8080 $
--     serve ('flatten' api) server
--   @
flatten :: Proxy api -> Proxy (Flat api)
flatten Proxy = Proxy

-- | Flatten and transform the API type a little bit.
type Flat api = Reassoc (Flatten (Reassoc (Flatten api)))
-- looks like Flatten/Reassoc are missing some opportunities the first time,
-- so we apply them twice for now...

-- | Completely flattens an API type by applying a few simple transformations.
--   The goal is to end up with an API type where things like @a ':>' (b ':<|>' c)@
--   are rewritten to @a ':>' b ':<|>' a ':>' c@, so as to have client with very simple
--   types, instead of "nested clients".
type family Flatten (api :: k) :: k where
  Flatten ((a :: k) :> (b :<|> c)) = Flatten (a :> b) :<|> Flatten (a :> c)
  Flatten ((a :: k) :> b)          = Redex b (Flatten b) a
  Flatten (a :<|> b)               = Flatten a :<|> Flatten b
  Flatten (a :: k)                 = a

type family Redex a b (c :: k) :: * where
  Redex a a first = Flatten first :> a
  Redex a b first = Flatten (first :> b)

-- | Reassociates '(:<|>)' to the right.
type family Reassoc api where
  Reassoc ((a :<|> b) :<|> c) = Reassoc a :<|> Reassoc (b :<|> c)
  Reassoc (a :<|> b) = a :<|> Reassoc b
  Reassoc a = a

-- * Utilities that we can define on a flat representation

-- | Get the endpoints with given indices in the all-flat
--   representation of the API type, glueing them together
--   with ':<|>'.
type family Nths (idxs :: [Nat]) api where
  Nths  '[i]      api = Nth i api
  Nths  (i ': is) api = Nth i api :<|> Nths is api

-- | Get the endpoint with given index in the all-flat representation
--   of the API type.
type family Nth (i :: Nat) api where
  Nth 0 (a :<|> b) = a
  Nth 0 a          = a
  Nth n (a :<|> b) = Nth (n - 1) b