{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Module      :  Servant.Checked.Exceptions.Internal.Servant.Docs

Copyright   :  Dennis Gosnell 2017
License     :  BSD3

Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)
Stability   :  experimental
Portability :  unknown

This module exports 'HasDocs' instances for 'Throws' and 'Throwing'.
-}

module Servant.Checked.Exceptions.Internal.Servant.Docs where

import Data.Proxy (Proxy(Proxy))
import Data.ByteString.Lazy (ByteString)
import Data.Function ((&))
import Data.Monoid ((<>))
import Data.Text (Text)
import Network.HTTP.Media (MediaType)
import Servant.API (Verb, (:>))
import Servant.API.ContentTypes (AllMimeRender(allMimeRender))
import Servant.Docs
       (Action, API, DocOptions, Endpoint, HasDocs(docsFor),
        ToSample(toSamples))
import Servant.Docs.Internal (apiEndpoints, respBody, response)

import Servant.Checked.Exceptions.Internal.Envelope
       (Envelope, toErrEnvelope, toSuccEnvelope)
import Servant.Checked.Exceptions.Internal.Prism ((<>~))
import Servant.Checked.Exceptions.Internal.Servant.API
       (NoThrow, Throws, Throwing)
import Servant.Checked.Exceptions.Internal.Util (Snoc)

-- TODO: Make sure to also account for when headers are being used.

-- | Change a 'Throws' into 'Throwing'.
instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where
  docsFor
    :: Proxy (Throws e :> api)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[e] :> api))

-- | When @'Throwing' es@ comes before a 'Verb', generate the documentation for
-- the same 'Verb', but returning an @'Envelope' es@.  Also add documentation
-- for the potential @es@.
instance
       ( CreateRespBodiesFor es ctypes
       , HasDocs (Verb method status ctypes (Envelope es a))
       )
    => HasDocs (Throwing es :> Verb method status ctypes a) where
  docsFor
    :: Proxy (Throwing es :> Verb method status ctypes a)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor Proxy (endpoint, action) docOpts =
    let api =
          docsFor
            (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
            (endpoint, action)
            docOpts
    in api & apiEndpoints . traverse . response . respBody <>~
        createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes)

-- | When 'NoThrow' comes before a 'Verb', generate the documentation for
-- the same 'Verb', but returning an @'Envelope' \'[]@.
instance (HasDocs (Verb method status ctypes (Envelope '[] a)))
    => HasDocs (NoThrow :> Verb method status ctypes a) where
  docsFor
    :: Proxy (NoThrow :> Verb method status ctypes a)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor Proxy (endpoint, action) docOpts =
    docsFor
      (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
      (endpoint, action)
      docOpts

-- | Create samples for a given @list@ of types, under given @ctypes@.
--
-- Additional instances of this class should not need to be created.
class CreateRespBodiesFor list ctypes where
  createRespBodiesFor
    :: Proxy list
    -> Proxy ctypes
    -> [(Text, MediaType, ByteString)]

-- | An empty list of types has no samples.
instance CreateRespBodiesFor '[] ctypes where
  createRespBodiesFor
    :: Proxy '[]
    -> Proxy ctypes
    -> [(Text, MediaType, ByteString)]
  createRespBodiesFor Proxy Proxy = []

-- | Create a response body for each of the error types.
instance
       ( AllMimeRender ctypes (Envelope '[e] ())
       , CreateRespBodiesFor es ctypes
       , ToSample e
       )
    => CreateRespBodiesFor (e ': es) ctypes where
  createRespBodiesFor
    :: Proxy (e ': es)
    -> Proxy ctypes
    -> [(Text, MediaType, ByteString)]
  createRespBodiesFor Proxy ctypes =
    createRespBodyFor (Proxy :: Proxy e) ctypes <>
    createRespBodiesFor (Proxy :: Proxy es) ctypes

-- | Create a sample for a given @e@ under given @ctypes@.
createRespBodyFor
  :: forall e ctypes.
     (AllMimeRender ctypes (Envelope '[e] ()), ToSample e)
  => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodyFor Proxy ctypes = concatMap enc samples
    where
      samples :: [(Text, Envelope '[e] ())]
      samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e)

      enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]
      enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s

-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
-- @e@ onto the @es@.
instance (HasDocs (Throwing (Snoc es e) :> api)) =>
    HasDocs (Throwing es :> Throws e :> api) where
  docsFor
    :: Proxy (Throwing es :> Throws e :> api)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor Proxy =
    docsFor (Proxy :: Proxy (Throwing (Snoc es e) :> api))

-- | We can generate a sample of an @'Envelope' es a@ as long as there is a way
-- to generate a sample of the @a@.
--
-- This doesn't need to worry about generating a sample of @es@, because that is
-- taken care of in the 'HasDocs' instance for @'Throwing' es@.
instance ToSample a => ToSample (Envelope es a) where
  toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]
  toSamples Proxy = fmap toSuccEnvelope <$> toSamples (Proxy :: Proxy a)