-- | Description: ways to build a reified api from a servant description.
--
--   arguably this could be more general and be abstracted away from even relying on servant
--   but that's future work.

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Roboservant.Types.ReifiedApi where

import Data.Dynamic (Dynamic)
import Control.Exception(Exception)
import Data.List.NonEmpty (NonEmpty)
import Data.Typeable (Typeable)
import GHC.Generics ((:*:)(..))
import Roboservant.Types.Internal
import Roboservant.Types.Breakdown
import Roboservant.Types.BuildFrom
import Data.Kind(Type)
import Servant
import Servant.API.Modifiers(FoldRequired,FoldLenient)
import GHC.TypeLits (Symbol)
import qualified Data.Text as T
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
import qualified Type.Reflection as R

newtype ApiOffset = ApiOffset Int
  deriving (ApiOffset -> ApiOffset -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiOffset -> ApiOffset -> Bool
$c/= :: ApiOffset -> ApiOffset -> Bool
== :: ApiOffset -> ApiOffset -> Bool
$c== :: ApiOffset -> ApiOffset -> Bool
Eq, Int -> ApiOffset -> ShowS
[ApiOffset] -> ShowS
ApiOffset -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiOffset] -> ShowS
$cshowList :: [ApiOffset] -> ShowS
show :: ApiOffset -> String
$cshow :: ApiOffset -> String
showsPrec :: Int -> ApiOffset -> ShowS
$cshowsPrec :: Int -> ApiOffset -> ShowS
Show, Eq ApiOffset
ApiOffset -> ApiOffset -> Bool
ApiOffset -> ApiOffset -> Ordering
ApiOffset -> ApiOffset -> ApiOffset
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ApiOffset -> ApiOffset -> ApiOffset
$cmin :: ApiOffset -> ApiOffset -> ApiOffset
max :: ApiOffset -> ApiOffset -> ApiOffset
$cmax :: ApiOffset -> ApiOffset -> ApiOffset
>= :: ApiOffset -> ApiOffset -> Bool
$c>= :: ApiOffset -> ApiOffset -> Bool
> :: ApiOffset -> ApiOffset -> Bool
$c> :: ApiOffset -> ApiOffset -> Bool
<= :: ApiOffset -> ApiOffset -> Bool
$c<= :: ApiOffset -> ApiOffset -> Bool
< :: ApiOffset -> ApiOffset -> Bool
$c< :: ApiOffset -> ApiOffset -> Bool
compare :: ApiOffset -> ApiOffset -> Ordering
$ccompare :: ApiOffset -> ApiOffset -> Ordering
Ord)
  deriving newtype (Int -> ApiOffset
ApiOffset -> Int
ApiOffset -> [ApiOffset]
ApiOffset -> ApiOffset
ApiOffset -> ApiOffset -> [ApiOffset]
ApiOffset -> ApiOffset -> ApiOffset -> [ApiOffset]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ApiOffset -> ApiOffset -> ApiOffset -> [ApiOffset]
$cenumFromThenTo :: ApiOffset -> ApiOffset -> ApiOffset -> [ApiOffset]
enumFromTo :: ApiOffset -> ApiOffset -> [ApiOffset]
$cenumFromTo :: ApiOffset -> ApiOffset -> [ApiOffset]
enumFromThen :: ApiOffset -> ApiOffset -> [ApiOffset]
$cenumFromThen :: ApiOffset -> ApiOffset -> [ApiOffset]
enumFrom :: ApiOffset -> [ApiOffset]
$cenumFrom :: ApiOffset -> [ApiOffset]
fromEnum :: ApiOffset -> Int
$cfromEnum :: ApiOffset -> Int
toEnum :: Int -> ApiOffset
$ctoEnum :: Int -> ApiOffset
pred :: ApiOffset -> ApiOffset
$cpred :: ApiOffset -> ApiOffset
succ :: ApiOffset -> ApiOffset
$csucc :: ApiOffset -> ApiOffset
Enum, Integer -> ApiOffset
ApiOffset -> ApiOffset
ApiOffset -> ApiOffset -> ApiOffset
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> ApiOffset
$cfromInteger :: Integer -> ApiOffset
signum :: ApiOffset -> ApiOffset
$csignum :: ApiOffset -> ApiOffset
abs :: ApiOffset -> ApiOffset
$cabs :: ApiOffset -> ApiOffset
negate :: ApiOffset -> ApiOffset
$cnegate :: ApiOffset -> ApiOffset
* :: ApiOffset -> ApiOffset -> ApiOffset
$c* :: ApiOffset -> ApiOffset -> ApiOffset
- :: ApiOffset -> ApiOffset -> ApiOffset
$c- :: ApiOffset -> ApiOffset -> ApiOffset
+ :: ApiOffset -> ApiOffset -> ApiOffset
$c+ :: ApiOffset -> ApiOffset -> ApiOffset
Num)

type TypedF = (:*:) R.TypeRep

newtype Argument a = Argument
    { forall a. Argument a -> Stash -> Maybe (StashValue a)
getArgument :: Stash -> Maybe (StashValue a)
    }

data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
    { ()
reArguments    :: V.Rec (TypedF Argument) as
    , ()
reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
    }

instance Show ReifiedEndpoint where
  show :: ReifiedEndpoint -> String
show ReifiedEndpoint
_ = String
"lol"

class ( V.RecordToList (EndpointArgs endpoint)
      , V.RMap (EndpointArgs endpoint)
      ) => ToReifiedEndpoint (endpoint :: Type) where
  type EndpointArgs endpoint :: [Type]
  type EndpointRes endpoint :: Type

  reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)


tagType :: Typeable a => f a -> TypedF f a
tagType :: forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType = (forall {k} (a :: k). Typeable a => TypeRep a
R.typeRep forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:)

data InteractionError = InteractionError
  { InteractionError -> Text
errorMessage :: T.Text
  , InteractionError -> Bool
fatalError :: Bool
  }
  deriving Int -> InteractionError -> ShowS
[InteractionError] -> ShowS
InteractionError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InteractionError] -> ShowS
$cshowList :: [InteractionError] -> ShowS
show :: InteractionError -> String
$cshow :: InteractionError -> String
showsPrec :: Int -> InteractionError -> ShowS
$cshowsPrec :: Int -> InteractionError -> ShowS
Show
instance Exception InteractionError



instance
  (Typeable responseType, Breakdown responseType) =>
  ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
  where
  type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
  type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
  reifiedEndpointArguments :: Rec
  (TypedF Argument)
  (EndpointArgs (Verb method statusCode contentTypes responseType))
reifiedEndpointArguments = forall {u} (a :: u -> *). Rec a '[]
V.RNil

instance ToReifiedEndpoint (NoContentVerb method)
  where
  type EndpointArgs (NoContentVerb method) = '[]
  type EndpointRes (NoContentVerb method) = NoContent
  reifiedEndpointArguments :: Rec (TypedF Argument) (EndpointArgs (NoContentVerb method))
reifiedEndpointArguments = forall {u} (a :: u -> *). Rec a '[]
V.RNil

instance
  (ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint ((x :: Symbol) :> endpoint)
  where
  type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
  type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec (TypedF Argument) (EndpointArgs (x :> endpoint))
reifiedEndpointArguments = forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint

instance
  (ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (RemoteHost :> endpoint)
  where
  type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint
  type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec (TypedF Argument) (EndpointArgs (RemoteHost :> endpoint))
reifiedEndpointArguments = forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint



instance
  (ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (Description s :> endpoint)
  where
  type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
  type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec (TypedF Argument) (EndpointArgs (Description s :> endpoint))
reifiedEndpointArguments = forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint

instance
  (ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (Summary s :> endpoint)
  where
  type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
  type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec (TypedF Argument) (EndpointArgs (Summary s :> endpoint))
reifiedEndpointArguments = forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint

instance
  (Typeable requestType
  ,BuildFrom requestType
  ,ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (QueryFlag name :> endpoint)
  where
  type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
  type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec (TypedF Argument) (EndpointArgs (QueryFlag name :> endpoint))
reifiedEndpointArguments = forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType (forall a. (Stash -> Maybe (StashValue a)) -> Argument a
Argument (forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom @Bool)) forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint

type IfLenient s mods t  = If (FoldLenient mods) (Either s t) t
type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)

instance
  ( BuildFrom (IfRequiredLenient T.Text mods paramType)
  , ToReifiedEndpoint endpoint
  ) =>
  ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
  where
  type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
  type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec
  (TypedF Argument)
  (EndpointArgs (QueryParam' mods name paramType :> endpoint))
reifiedEndpointArguments =
   forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType (forall a. (Stash -> Maybe (StashValue a)) -> Argument a
Argument (forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom @(IfRequiredLenient T.Text mods paramType)))
      forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint


instance
  ( BuildFrom paramType
  , ToReifiedEndpoint endpoint
  , Show paramType
  , Eq paramType
  ) =>
  ToReifiedEndpoint (QueryParams name paramType :> endpoint)
  where
  type EndpointArgs (QueryParams name paramType :> endpoint) =  [paramType] ': EndpointArgs endpoint
  type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec
  (TypedF Argument)
  (EndpointArgs (QueryParams name paramType :> endpoint))
reifiedEndpointArguments =
    forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType (forall a. (Stash -> Maybe (StashValue a)) -> Argument a
Argument (forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom @[paramType]))
      forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint




instance
  ( BuildFrom (IfRequiredLenient T.Text mods headerType)
  , ToReifiedEndpoint endpoint
  ) =>
  ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
  where
  type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
  type EndpointRes  (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec
  (TypedF Argument)
  (EndpointArgs (Header' mods headerName headerType :> endpoint))
reifiedEndpointArguments =
   forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType (forall a. (Stash -> Maybe (StashValue a)) -> Argument a
Argument (forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom @(IfRequiredLenient T.Text mods headerType)))
      forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint

#if MIN_VERSION_servant(0,17,0)
instance
  ( BuildFrom (IfLenient String mods captureType)
  , ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
  where
  type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
  type EndpointRes  (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec
  (TypedF Argument)
  (EndpointArgs (Capture' mods name captureType :> endpoint))
reifiedEndpointArguments =
   forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType (forall a. (Stash -> Maybe (StashValue a)) -> Argument a
Argument (forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom @(IfLenient String mods captureType)))
      forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint
#else
instance
  ( BuildFrom captureType
  , ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
  where
  type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
  type EndpointRes  (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments =
   tagType (Argument (buildFrom @(captureType)))
      V.:& reifiedEndpointArguments @endpoint

#endif

instance
  ( BuildFrom (IfLenient String mods requestType)
  , ToReifiedEndpoint endpoint) =>
  ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
  where
  type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
  type EndpointRes  (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
  reifiedEndpointArguments :: Rec
  (TypedF Argument)
  (EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint))
reifiedEndpointArguments =
   forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypedF f a
tagType (forall a. (Stash -> Maybe (StashValue a)) -> Argument a
Argument (forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom @(IfLenient String mods requestType)))
      forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint