{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module DomainDriven.Server.TH where

import Control.Monad

import Control.Monad.State
import Data.Foldable
import Data.Function (on)
import Data.Generics.Product
import Data.List qualified as L
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import Data.Traversable
import DomainDriven.Server.Class
import DomainDriven.Server.Config
import DomainDriven.Server.Helpers
import DomainDriven.Server.Types
import Language.Haskell.TH
import Lens.Micro
import Servant
import UnliftIO (MonadUnliftIO (..))
import Prelude

-- import Debug.Trace
-- import GHC.Generics (Generic)
-- import Data.Bifunctor

-- | Generate a server with granular configuration
--
-- Expects a Map of ApiOptions generated by `DomainDriven.Config.getApiOptionsMap`
-- Due to GHC stage restrictions this cannot be generated in the same module.
--
-- Using this require you to enable template haskell
-- {\-# LANGUAGE TemplateHaskell #-\}

-- $(mkServer  config ''MyAction)

mkServer :: ServerConfig -> Name -> Q [Dec]
mkServer :: ServerConfig -> Name -> Q [Dec]
mkServer ServerConfig
cfg (Name -> GadtName
GadtName -> GadtName
gadtName) = do
    ApiSpec
spec <- ServerConfig -> GadtName -> Q ApiSpec
mkServerSpec ServerConfig
cfg GadtName
gadtName
    ApiOptions
opts <- ServerConfig -> GadtName -> Q ApiOptions
getApiOptions ServerConfig
cfg GadtName
gadtName
    let si :: ServerInfo
        si :: ServerInfo
si =
            ServerInfo
                { $sel:baseGadt:ServerInfo :: GadtName
baseGadt = ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed
                , $sel:currentGadt:ServerInfo :: GadtName
currentGadt = ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed
                , $sel:parentConstructors:ServerInfo :: [ConstructorName]
parentConstructors = []
                , $sel:prefixSegments:ServerInfo :: [UrlSegment]
prefixSegments = []
                , $sel:options:ServerInfo :: ApiOptions
options = ApiOptions
opts
                }
    forall a. ServerGenState -> ServerGenM a -> Q a
runServerGenM
        ServerGenState{$sel:info:ServerGenState :: ServerInfo
info = ServerInfo
si, $sel:usedParamNames:ServerGenState :: Set String
usedParamNames = forall a. Monoid a => a
mempty}
        (ApiSpec -> ServerGenM [Dec]
mkServerFromSpec ApiSpec
spec)

getApiOptions :: ServerConfig -> GadtName -> Q ApiOptions
getApiOptions :: ServerConfig -> GadtName -> Q ApiOptions
getApiOptions ServerConfig
cfg (GadtName Name
n) = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Show a => a -> String
show Name
n) (ServerConfig -> Map String ApiOptions
allApiOptions ServerConfig
cfg) of
    Just ApiOptions
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ApiOptions
o
    Maybe ApiOptions
Nothing ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            String
"Cannot find ApiOptions for "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Name
n
                forall a. Semigroup a => a -> a -> a
<> String
". "
                forall a. Semigroup a => a -> a -> a
<> String
"\nProbable reasons:"
                forall a. Semigroup a => a -> a -> a
<> String
"\n - It does not implement `HasApiOptions`."
                forall a. Semigroup a => a -> a -> a
<> String
"\n - The instance is not visible from where `mkServerConfig` is run."
                forall a. Semigroup a => a -> a -> a
<> String
"\n - The `ServerConfig` instance was manually defined and not complete."

getActionDec :: GadtName -> Q (Dec, VarBindings)
getActionDec :: GadtName -> Q (Dec, VarBindings)
getActionDec (GadtName Name
n) = do
    Info
cmdType <- Name -> Q Info
reify Name
n
    let errMsg :: Q (Dec, VarBindings)
errMsg = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Name
n forall a. Semigroup a => a -> a -> a
<> String
"to be a GADT"
    case Info
cmdType of
        TyConI dec :: Dec
dec@(DataD [Type]
_ctx Name
_name [TyVarBndr ()]
params Maybe Type
_ [Con]
_ [DerivClause]
_) ->
            case forall flag.
Show flag =>
[TyVarBndr flag] -> Either String VarBindings
mkVarBindings [TyVarBndr ()]
params of
                Right VarBindings
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
dec, VarBindings
b)
                Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"getActionDec: " forall a. Semigroup a => a -> a -> a
<> String
err
        TyConI{} -> Q (Dec, VarBindings)
errMsg
        ClassI{} -> Q (Dec, VarBindings)
errMsg
        ClassOpI{} -> Q (Dec, VarBindings)
errMsg
        FamilyI{} -> Q (Dec, VarBindings)
errMsg
        PrimTyConI{} -> Q (Dec, VarBindings)
errMsg
        DataConI{} -> Q (Dec, VarBindings)
errMsg
        PatSynI{} -> Q (Dec, VarBindings)
errMsg
        VarI{} -> Q (Dec, VarBindings)
errMsg
        TyVarI{} -> Q (Dec, VarBindings)
errMsg

getSubActionDec :: VarBindings -> SubActionMatch -> Q (Dec, VarBindings)
getSubActionDec :: VarBindings -> SubActionMatch -> Q (Dec, VarBindings)
getSubActionDec VarBindings
tyVars SubActionMatch
subAction = do
    -- We have to do a `reify` on the subaction to get the constructors. When we do this
    -- we get new [TyVarBndr ()]. These needs to be unified with what we have from the
    -- parent.

    Info
cmdType <- Name -> Q Info
reify forall a b. (a -> b) -> a -> b
$ SubActionMatch
subAction forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"subActionName"
    case Info
cmdType of
        TyConI (DataD [Type]
ctx Name
name [TyVarBndr ()]
params Maybe Type
mKind [Con]
constructors [DerivClause]
deriv) -> do
            let parentParams :: [TyVarBndr ()]
                parentParams :: [TyVarBndr ()]
parentParams =
                    forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars
                        (VarBindings -> [TyVarBndr ()]
toTyVarBndr VarBindings
tyVars)
                        (SubActionMatch
subAction forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"subActionType")

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                (forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
parentParams [TyVarBndr ()]
params)
                ( forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                    String
"getSubActionDec: Different number of parameters. Parent: "
                        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [TyVarBndr ()]
parentParams
                        forall a. Semigroup a => a -> a -> a
<> String
", child: "
                        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [TyVarBndr ()]
params
                )
            let tyVarMap :: M.Map Name Name
                tyVarMap :: Map Name Name
tyVarMap =
                    forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
                        forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a b. [a] -> [b] -> [(a, b)]
zip (forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name) [TyVarBndr ()]
params [TyVarBndr ()]
parentParams

            case forall flag.
Show flag =>
[TyVarBndr flag] -> Either String VarBindings
mkVarBindings [TyVarBndr ()]
parentParams of
                Right VarBindings
b -> do
                    let rename :: Type -> Type
                        rename :: Type -> Type
rename Type
ty = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Type
ty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Map Name Name -> Type -> Either String Type
replaceVarT Map Name Name
tyVarMap Type
ty

                        constructorDec :: Dec
                        constructorDec :: Dec
constructorDec =
                            [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD
                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
rename [Type]
ctx)
                                Name
name
                                [TyVarBndr ()]
parentParams
                                Maybe Type
mKind
                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> Type) -> Con -> Con
updateConstructorTypes Type -> Type
rename) [Con]
constructors)
                                [DerivClause]
deriv
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
constructorDec, VarBindings
b)
                Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"getSubActionDec: " forall a. Semigroup a => a -> a -> a
<> String
err forall a. Semigroup a => a -> a -> a
<> String
" --------- " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [TyVarBndr ()]
parentParams
        TyConI{} -> Q (Dec, VarBindings)
errorOut
        ClassI{} -> Q (Dec, VarBindings)
errorOut
        ClassOpI{} -> Q (Dec, VarBindings)
errorOut
        FamilyI{} -> Q (Dec, VarBindings)
errorOut
        PrimTyConI{} -> Q (Dec, VarBindings)
errorOut
        DataConI{} -> Q (Dec, VarBindings)
errorOut
        PatSynI{} -> Q (Dec, VarBindings)
errorOut
        VarI{} -> Q (Dec, VarBindings)
errorOut
        TyVarI{} -> Q (Dec, VarBindings)
errorOut
  where
    errorOut :: Q (Dec, VarBindings)
errorOut =
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            String
"Expected "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (SubActionMatch
subAction forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"subActionName")
                forall a. Semigroup a => a -> a -> a
<> String
"to be a GADT"

replaceVarT :: M.Map Name Name -> Type -> Either String Type
replaceVarT :: Map Name Name -> Type -> Either String Type
replaceVarT Map Name Name
m = \case
    AppT Type
ty1 Type
ty2 -> Type -> Type -> Type
AppT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Name -> Type -> Either String Type
replaceVarT Map Name Name
m Type
ty1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Name -> Type -> Either String Type
replaceVarT Map Name Name
m Type
ty2
    VarT Name
oldName -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
oldName Map Name Name
m of
        Just Name
n -> forall a b. b -> Either a b
Right (Name -> Type
VarT Name
n)
        Maybe Name
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"replaceVarT: No match for variable \"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Name
oldName forall a. Semigroup a => a -> a -> a
<> String
"\""
    Type
ty -> forall a b. b -> Either a b
Right Type
ty -- Don't think I need to match on other constructors. *lazy*

guardMethodVar :: TyVarBndr flag -> Q ()
guardMethodVar :: forall flag. TyVarBndr flag -> Q ()
guardMethodVar = \case
    KindedTV Name
_ flag
_ Type
k -> Type -> Q ()
check Type
k
    PlainTV Name
_ flag
_ -> Type -> Q ()
check Type
StarT
  where
    check :: Type -> Q ()
    check :: Type -> Q ()
check Type
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getMutabilityOf :: Type -> Q Mutability
getMutabilityOf :: Type -> Q Mutability
getMutabilityOf = \case
    AppT (AppT (AppT Type
_ (PromotedT Name
verbName)) Type
_) Type
_ -> Name -> Q Mutability
checkVerb Name
verbName
    ConT Name
n ->
        Name -> Q Info
reify Name
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            TyConI (TySynD Name
_ [TyVarBndr ()]
_ (AppT (AppT (AppT Type
_ (PromotedT Name
verbName)) Type
_) Type
_)) ->
                Name -> Q Mutability
checkVerb Name
verbName
            Info
info ->
                forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                    String
"Expected method to be a Verb of a type synonym for a Verb. Got:\n"
                        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Info
info
    Type
ty -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected a Verb without return type applied, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty
  where
    checkVerb :: Name -> Q Mutability
    checkVerb :: Name -> Q Mutability
checkVerb Name
n = case forall a. Show a => a -> String
show Name
n of
        String
"Network.HTTP.Types.Method.GET" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutability
Immutable
        String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutability
Mutable

guardReturnVar :: Show flag => TyVarBndr flag -> Q ()
guardReturnVar :: forall flag. Show flag => TyVarBndr flag -> Q ()
guardReturnVar = \case
    KindedTV Name
_ flag
_ Type
StarT -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PlainTV Name
_ flag
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    TyVarBndr flag
ty -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Return type must be a concrete type. Got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TyVarBndr flag
ty

getConstructors :: Dec -> Q [Con]
getConstructors :: Dec -> Q [Con]
getConstructors = \case
    DataD [Type]
_ Name
_ (forall a. [a] -> Maybe (a, a, a)
last3 -> Just (TyVarBndr ()
_x, TyVarBndr ()
method, TyVarBndr ()
ret)) Maybe Type
_ [Con]
cs [DerivClause]
_ -> do
        forall flag. TyVarBndr flag -> Q ()
guardMethodVar TyVarBndr ()
method
        forall flag. Show flag => TyVarBndr flag -> Q ()
guardReturnVar TyVarBndr ()
ret
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cs
    d :: Dec
d@DataD{} -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unexpected Action data type: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Dec
d
    Dec
d -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected a GADT with two parameters but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Dec
d
  where
    last3 :: [a] -> Maybe (a, a, a)
    last3 :: forall a. [a] -> Maybe (a, a, a)
last3 = \case
        [a
a, a
b, a
c] -> forall a. a -> Maybe a
Just (a
a, a
b, a
c)
        [a
_, a
_] -> forall a. Maybe a
Nothing
        [a
_] -> forall a. Maybe a
Nothing
        [] -> forall a. Maybe a
Nothing
        [a]
l -> forall a. [a] -> Maybe (a, a, a)
last3 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [a]
l

toTyVarBndr :: VarBindings -> [TyVarBndr ()]
toTyVarBndr :: VarBindings -> [TyVarBndr ()]
toTyVarBndr VarBindings{Name
$sel:paramPart:VarBindings :: VarBindings -> Name
paramPart :: Name
paramPart, Name
$sel:method:VarBindings :: VarBindings -> Name
method :: Name
method, Name
$sel:return:VarBindings :: VarBindings -> Name
return :: Name
return, [TyVarBndr ()]
$sel:extra:VarBindings :: VarBindings -> [TyVarBndr ()]
extra :: [TyVarBndr ()]
extra} =
    [TyVarBndr ()]
extra forall a. Semigroup a => a -> a -> a
<> [forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
paramPart () (Name -> Type
ConT ''ParamPart), forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
method (), forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
return ()]

mkVarBindings :: Show flag => [TyVarBndr flag] -> Either String VarBindings
mkVarBindings :: forall flag.
Show flag =>
[TyVarBndr flag] -> Either String VarBindings
mkVarBindings [TyVarBndr flag]
varBinds = case [TyVarBndr flag]
varBinds of
    [KindedTV Name
x flag
_ Type
kind, TyVarBndr flag
method, TyVarBndr flag
ret]
        | Type
kind forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''ParamPart ->
            forall a b. b -> Either a b
Right
                VarBindings
                    { $sel:paramPart:VarBindings :: Name
paramPart = Name
x
                    , $sel:method:VarBindings :: Name
method = TyVarBndr flag
method forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to forall flag. TyVarBndr flag -> TyVarBndr ()
noFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name
                    , $sel:return:VarBindings :: Name
return = TyVarBndr flag
ret forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to forall flag. TyVarBndr flag -> TyVarBndr ()
noFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name
                    , $sel:extra:VarBindings :: [TyVarBndr ()]
extra = []
                    }
        | Bool
otherwise ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                String
"mkVarBindings: Expected parameter of kind ParamPart, got: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [TyVarBndr flag]
varBinds
    [TyVarBndr flag
_, TyVarBndr flag
_] -> forall a b. a -> Either a b
Left String
errMsg
    [TyVarBndr flag
_] -> forall a b. a -> Either a b
Left String
errMsg
    [] -> forall a b. a -> Either a b
Left String
errMsg
    TyVarBndr flag
p : [TyVarBndr flag]
l -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra") (forall flag. TyVarBndr flag -> TyVarBndr ()
noFlag TyVarBndr flag
p forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall flag.
Show flag =>
[TyVarBndr flag] -> Either String VarBindings
mkVarBindings [TyVarBndr flag]
l
  where
    noFlag :: TyVarBndr flag -> TyVarBndr ()
    noFlag :: forall flag. TyVarBndr flag -> TyVarBndr ()
noFlag = \case
        KindedTV Name
x flag
_ Type
kind -> forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
x () Type
kind
        PlainTV Name
x flag
_ -> forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
x ()

    errMsg :: String
errMsg =
        String
"mkVarBindings: Expected parameters `(x :: ParamPart) method return`, got: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [TyVarBndr flag]
varBinds

matchNormalConstructor :: Con -> Either String ConstructorMatch
matchNormalConstructor :: Con -> Either String ConstructorMatch
matchNormalConstructor Con
con = do
    (Name
x, Con
gadtCon) <- Con -> Either String (Name, Con)
unconsForall Con
con
    (Name
conName, [Pmatch]
params, Type
constructorType) <- Con -> Either String (Name, [Pmatch], Type)
unconsGadt Con
gadtCon
    FinalConstructorTypeMatch
finalType <- Type -> Either String FinalConstructorTypeMatch
matchFinalConstructorType Type
constructorType
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ConstructorMatch
            { $sel:xParam:ConstructorMatch :: Name
xParam = Name
x
            , $sel:constructorName:ConstructorMatch :: Name
constructorName = Name
conName
            , $sel:parameters:ConstructorMatch :: [Pmatch]
parameters = [Pmatch]
params
            , $sel:finalType:ConstructorMatch :: FinalConstructorTypeMatch
finalType = FinalConstructorTypeMatch
finalType
            }
  where
    getParamPartVar :: Show a => [TyVarBndr a] -> Either String Name
    getParamPartVar :: forall a. Show a => [TyVarBndr a] -> Either String Name
getParamPartVar = \case
        KindedTV Name
x a
_spec Type
kind : [TyVarBndr a]
_ | Type
kind forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''ParamPart -> forall a b. b -> Either a b
Right Name
x
        TyVarBndr a
a : [TyVarBndr a]
l -> case forall a. Show a => [TyVarBndr a] -> Either String Name
getParamPartVar [TyVarBndr a]
l of
            r :: Either String Name
r@Right{} -> Either String Name
r
            Left String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
e forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TyVarBndr a
a
        [] -> forall a b. a -> Either a b
Left String
"Expected a constrctor parameterized by `(x :: ParamPart)`, got: "

    unconsForall :: Con -> Either String (Name, Con)
    unconsForall :: Con -> Either String (Name, Con)
unconsForall = \case
        ForallC [TyVarBndr Specificity]
bindings [Type]
_ctx Con
con' -> do
            Name
x <- forall a. Show a => [TyVarBndr a] -> Either String Name
getParamPartVar [TyVarBndr Specificity]
bindings
            forall a b. b -> Either a b
Right (Name
x, Con
con')
        Con
con' ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                String
"Expected a constrctor parameterized by `(x :: ParamPart)`, got: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con'

    unconsGadt :: Con -> Either String (Name, [Pmatch], Type)
    unconsGadt :: Con -> Either String (Name, [Pmatch], Type)
unconsGadt = \case
        GadtC [Name
conName] [BangType]
bangArgs Type
ty -> do
            [Pmatch]
params <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Type -> Either String Pmatch
matchP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [BangType]
bangArgs
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
conName, [Pmatch]
params, Type
ty)
        Con
con' -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected Gadt constrctor, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con'

matchSubActionConstructor :: Con -> Either String SubActionMatch
matchSubActionConstructor :: Con -> Either String SubActionMatch
matchSubActionConstructor Con
con = do
    Con
gadtCon <- Con -> Either String Con
unconsForall Con
con
    -- Left $ show gadtCon
    (Name
conName, [Pmatch]
normalParams, (Name
subActionName, Type
subActionType), Type
_constructorType) <-
        Con -> Either String (Name, [Pmatch], (Name, Type), Type)
unconsGadt Con
gadtCon
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        SubActionMatch
            { $sel:constructorName:SubActionMatch :: Name
constructorName = Name
conName
            , $sel:parameters:SubActionMatch :: [Pmatch]
parameters = [Pmatch]
normalParams
            , $sel:subActionName:SubActionMatch :: Name
subActionName = Name
subActionName
            , $sel:subActionType:SubActionMatch :: Type
subActionType = Type
subActionType
            }
  where
    unconsForall :: Con -> Either String Con
    unconsForall :: Con -> Either String Con
unconsForall = \case
        ForallC [TyVarBndr Specificity]
_params [Type]
_ctx Con
con' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con'
        Con
con' ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                String
"Expected a higher order constrctor parameterized by `(x :: ParamPart)`, got: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con'

    unconsGadt :: Con -> Either String (Name, [Pmatch], (Name, Type), Type)
    unconsGadt :: Con -> Either String (Name, [Pmatch], (Name, Type), Type)
unconsGadt = \case
        con' :: Con
con'@(GadtC [Name
actionName] [BangType]
bangArgs Type
ty) -> do
            ([Type]
normalArgs, Type
subActionType) <- do
                let ([Type]
normalArgs, [Type]
subActions) =
                        forall a. Int -> [a] -> ([a], [a])
L.splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
bangArgs forall a. Num a => a -> a -> a
- Int
1) (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
bangArgs)
                case [Type]
subActions of
                    [] -> forall a b. a -> Either a b
Left String
"No arguments"
                    Type
a : [Type]
_ -> forall a b. b -> Either a b
Right ([Type]
normalArgs, Type
a)
            [Pmatch]
normalParams <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Either String Pmatch
matchP [Type]
normalArgs
            let getActionName :: Type -> Either String Name
                getActionName :: Type -> Either String Name
getActionName = \case
                    ConT Name
subAction -> forall a b. b -> Either a b
Right Name
subAction
                    (AppT Type
a Type
_) -> Type -> Either String Name
getActionName Type
a
                    Type
ty' ->
                        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                            String
"getActionName: Expected `ConT [action name]` got: "
                                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty'
                                forall a. Semigroup a => a -> a -> a
<> String
" from constructor: "
                                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con'
            Name
subActionName <- Type -> Either String Name
getActionName Type
subActionType
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
actionName, [Pmatch]
normalParams, (Name
subActionName, Type
subActionType), Type
ty)
        Con
con' -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected Gadt constrctor, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con'

matchFinalConstructorType :: Type -> Either String FinalConstructorTypeMatch
matchFinalConstructorType :: Type -> Either String FinalConstructorTypeMatch
matchFinalConstructorType = \case
    AppT (AppT Type
_typeName Type
a) Type
retTy -> do
        RequestTypeMatch
reqTy <- Type -> Either String RequestTypeMatch
matchRequestType Type
a
        forall a b. b -> Either a b
Right FinalConstructorTypeMatch{$sel:requestType:FinalConstructorTypeMatch :: RequestTypeMatch
requestType = RequestTypeMatch
reqTy, $sel:returnType:FinalConstructorTypeMatch :: Type
returnType = Type
retTy}
    Type
ty -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected constructor like `GetCount x Query Int`, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty

matchRequestType :: Type -> Either String RequestTypeMatch
matchRequestType :: Type -> Either String RequestTypeMatch
matchRequestType = \case
    AppT (AppT (AppT (ConT Name
_reqTy) Type
accessType) Type
ct) Type
verb ->
        forall a b. b -> Either a b
Right RequestTypeMatch{$sel:accessType:RequestTypeMatch :: Type
accessType = Type
accessType, $sel:contentTypes:RequestTypeMatch :: Type
contentTypes = Type
ct, $sel:verb:RequestTypeMatch :: Type
verb = Type
verb}
    Type
ty -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected `RequestType`, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty

-- | Tries to match a Type to a more easily readable Pmatch.
-- Successful match means the type is representing the type family `P`
matchP :: Type -> Either String Pmatch
matchP :: Type -> Either String Pmatch
matchP = \case
    AppT (AppT (AppT (ConT Name
p) (VarT Name
x)) (LitT (StrTyLit String
pName))) Type
ty -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall a. Show a => a -> String
show Name
p ''P)
            (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ''P forall a. Semigroup a => a -> a -> a
<> String
", got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Name
p)
        forall a b. b -> Either a b
Right Pmatch{$sel:paramPart:Pmatch :: Name
paramPart = Name
x, $sel:paramName:Pmatch :: String
paramName = String
pName, $sel:paramType:Pmatch :: Type
paramType = Type
ty}
    Type
ty -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected type family `P`, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty

mkApiPiece :: ServerConfig -> VarBindings -> Con -> Q ApiPiece
mkApiPiece :: ServerConfig -> VarBindings -> Con -> Q ApiPiece
mkApiPiece ServerConfig
cfg VarBindings
varBindings Con
con = do
    case (Con -> Either String ConstructorMatch
matchNormalConstructor Con
con, Con -> Either String SubActionMatch
matchSubActionConstructor Con
con) of
        (Right ConstructorMatch
c, Either String SubActionMatch
_) -> do
            Mutability
actionType <-
                Type -> Q Mutability
getMutabilityOf forall a b. (a -> b) -> a -> b
$
                    ConstructorMatch
c
                        forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"finalType"
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"requestType"
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"verb"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                ConstructorName
-> ConstructorArgs
-> VarBindings
-> HandlerSettings
-> Mutability
-> EpReturnType
-> ApiPiece
Endpoint
                    (Name -> ConstructorName
ConstructorName forall a b. (a -> b) -> a -> b
$ ConstructorMatch
c forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"constructorName")
                    ( [(String, Type)] -> ConstructorArgs
ConstructorArgs forall a b. (a -> b) -> a -> b
$
                        ConstructorMatch
c
                            forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"parameters"
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to
                                    (\Pmatch
p -> (Pmatch
p forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"paramName", Pmatch
p forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"paramType"))
                    )
                    VarBindings
varBindings
                    HandlerSettings
                        { $sel:contentTypes:HandlerSettings :: Type
contentTypes =
                            ConstructorMatch
c
                                forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"finalType"
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"requestType"
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"contentTypes"
                        , $sel:verb:HandlerSettings :: Type
verb =
                            ConstructorMatch
c
                                forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"finalType"
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"requestType"
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"verb"
                        }
                    Mutability
actionType
                    (Type -> EpReturnType
EpReturnType forall a b. (a -> b) -> a -> b
$ ConstructorMatch
c forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"finalType" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"returnType")
        (Either String ConstructorMatch
_, Right SubActionMatch
c) -> do
            ApiSpec
subServerSpec <- ServerConfig -> VarBindings -> SubActionMatch -> Q ApiSpec
mkSubServerSpec ServerConfig
cfg VarBindings
varBindings SubActionMatch
c
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                ConstructorName -> ConstructorArgs -> ApiSpec -> ApiPiece
SubApi
                    (SubActionMatch
c forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"constructorName" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Name -> ConstructorName
ConstructorName)
                    ( [(String, Type)] -> ConstructorArgs
ConstructorArgs forall a b. (a -> b) -> a -> b
$
                        SubActionMatch
c
                            forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"parameters"
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to
                                    (\Pmatch
p -> (Pmatch
p forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"paramName", Pmatch
p forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"paramType"))
                    )
                    ApiSpec
subServerSpec
        (Left String
err1, Left String
err2) ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                String
"mkApiPiece - "
                    forall a. Semigroup a => a -> a -> a
<> String
"\n---------------------mkApiPiece: Expected ------------------------"
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
err1
                    forall a. Semigroup a => a -> a -> a
<> String
"\n---------------------or-------------------------------------------"
                    forall a. Semigroup a => a -> a -> a
<> String
"\n"
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
err2
                    forall a. Semigroup a => a -> a -> a
<> String
"\n------------------------------------------------------------------"

-- | Create a ApiSpec from a GADT
-- The GADT must have one parameter representing the return type
mkServerSpec :: ServerConfig -> GadtName -> Q ApiSpec
mkServerSpec :: ServerConfig -> GadtName -> Q ApiSpec
mkServerSpec ServerConfig
cfg GadtName
n = do
    (Dec
dec, VarBindings
varBindings) <- GadtName -> Q (Dec, VarBindings)
getActionDec GadtName
n --- AHA, THis is the fucker fucking with me!
    [ApiPiece]
eps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ServerConfig -> VarBindings -> Con -> Q ApiPiece
mkApiPiece ServerConfig
cfg VarBindings
varBindings) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Dec -> Q [Con]
getConstructors Dec
dec
    ApiOptions
opts <- ServerConfig -> GadtName -> Q ApiOptions
getApiOptions ServerConfig
cfg GadtName
n
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ApiSpec
            { $sel:gadtName:ApiSpec :: GadtName
gadtName = GadtName
n
            , $sel:gadtType:ApiSpec :: GadtType
gadtType =
                Type -> GadtType
GadtType forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl'
                        Type -> Type -> Type
AppT
                        (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ GadtName
n forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @Name)
                        ( VarBindings
varBindings
                            forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra"
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Name -> Type
VarT
                        )
            , $sel:allVarBindings:ApiSpec :: VarBindings
allVarBindings = VarBindings
varBindings
            , $sel:endpoints:ApiSpec :: [ApiPiece]
endpoints = [ApiPiece]
eps
            , $sel:options:ApiSpec :: ApiOptions
options = ApiOptions
opts
            }

gadtToAction :: GadtType -> Either String Type
gadtToAction :: GadtType -> Either String Type
gadtToAction (GadtType Type
ty) = case Type
ty of
    AppT (AppT (AppT Type
ty' (VarT Name
_x)) (VarT Name
_method)) (VarT Name
_return) -> forall a b. b -> Either a b
Right Type
ty'
    Type
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected `GADT` with final kind `Action`, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty

mkSubServerSpec :: ServerConfig -> VarBindings -> SubActionMatch -> Q ApiSpec
mkSubServerSpec :: ServerConfig -> VarBindings -> SubActionMatch -> Q ApiSpec
mkSubServerSpec ServerConfig
cfg VarBindings
varBindings SubActionMatch
subAction = do
    (Dec
dec, VarBindings
bindings) <- VarBindings -> SubActionMatch -> Q (Dec, VarBindings)
getSubActionDec VarBindings
varBindings SubActionMatch
subAction -- We must not use the bindings or we'd end up with different names
    [ApiPiece]
eps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ServerConfig -> VarBindings -> Con -> Q ApiPiece
mkApiPiece ServerConfig
cfg VarBindings
bindings) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Dec -> Q [Con]
getConstructors Dec
dec
    ApiOptions
opts <- ServerConfig -> GadtName -> Q ApiOptions
getApiOptions ServerConfig
cfg GadtName
name

    Type
actionTy <-
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            SubActionMatch
subAction
                forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"subActionType"
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Type -> GadtType
GadtType
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to GadtType -> Either String Type
gadtToAction
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ApiSpec
            { $sel:gadtName:ApiSpec :: GadtName
gadtName = GadtName
name
            , $sel:gadtType:ApiSpec :: GadtType
gadtType = Type -> GadtType
GadtType Type
actionTy
            , $sel:allVarBindings:ApiSpec :: VarBindings
allVarBindings = VarBindings
varBindings
            , $sel:endpoints:ApiSpec :: [ApiPiece]
endpoints = [ApiPiece]
eps
            , $sel:options:ApiSpec :: ApiOptions
options = ApiOptions
opts
            }
  where
    name :: GadtName
    name :: GadtName
name = SubActionMatch
subAction forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"subActionName" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Name -> GadtName
GadtName

-- | Name and type variables used by API
askApiNameAndParams :: ApiSpec -> ServerGenM (Name, [TyVarBndr ()])
askApiNameAndParams :: ApiSpec -> ServerGenM (Name, [TyVarBndr ()])
askApiNameAndParams ApiSpec
spec = do
    Name
apiTypeName <- ServerGenM Name
askApiTypeName
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
apiTypeName, ApiSpec -> [TyVarBndr ()]
apiSpecTyVars ApiSpec
spec)

apiPieceTyVars :: ApiPiece -> [TyVarBndr ()]
apiPieceTyVars :: ApiPiece -> [TyVarBndr ()]
apiPieceTyVars = \case
    Endpoint ConstructorName
_ ConstructorArgs
args VarBindings
bindings HandlerSettings
_ Mutability
_ EpReturnType
ret ->
        forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                (forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars forall a b. (a -> b) -> a -> b
$ VarBindings
bindings forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra")
                (EpReturnType
ret forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @Type forall a. a -> [a] -> [a]
: ConstructorArgs
args forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Type)
    SubApi ConstructorName
_ ConstructorArgs
_ ApiSpec
spec -> ApiSpec -> [TyVarBndr ()]
apiSpecTyVars ApiSpec
spec

apiSpecTyVars :: ApiSpec -> [TyVarBndr ()]
apiSpecTyVars :: ApiSpec -> [TyVarBndr ()]
apiSpecTyVars ApiSpec
spec =
    forall a. (a -> Bool) -> [a] -> [a]
filter
        (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyVarBndr ()]
usedTyVars)
        (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"allVarBindings" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra")
  where
    usedTyVars :: [TyVarBndr ()]
usedTyVars = forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ApiPiece -> [TyVarBndr ()]
apiPieceTyVars forall a b. (a -> b) -> a -> b
$ ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"endpoints"

mkApiTypeDecs :: ApiSpec -> ServerGenM [Dec]
mkApiTypeDecs :: ApiSpec -> ServerGenM [Dec]
mkApiTypeDecs ApiSpec
spec = do
    (Name
apiTypeName, [TyVarBndr ()]
tyVars) <- ApiSpec -> ServerGenM (Name, [TyVarBndr ()])
askApiNameAndParams ApiSpec
spec
    [(Type, [TyVarBndr ()])]
epTypes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ApiPiece -> ServerGenM (Type, [TyVarBndr ()])
mkEndpointApiType (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[ApiPiece])
    Dec
topLevelDec <- case forall a. [a] -> [a]
reverse [(Type, [TyVarBndr ()])]
epTypes of -- :<|> is right associative
        [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Server contains no endpoints"
        (Type
ty, [TyVarBndr ()]
_tyVars) : [(Type, [TyVarBndr ()])]
ts -> do
            let fish :: Type -> Type -> Q Type
                fish :: Type -> Type -> Q Type
fish Type
b Type
a = [t|$(pure a) :<|> $(pure b)|]
            Type
apiType <- forall a. Q a -> ServerGenM a
liftQ (forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Type -> Type -> Q Type
fish Type
ty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Type, [TyVarBndr ()])]
ts))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndr ()] -> Type -> Dec
TySynD Name
apiTypeName [TyVarBndr ()]
tyVars Type
apiType
    [Dec]
handlerDecs <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ApiPiece -> ServerGenM [Dec]
mkHandlerTypeDec (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[ApiPiece])
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
topLevelDec forall a. a -> [a] -> [a]
: [Dec]
handlerDecs

applyTyVars :: Type -> [TyVarBndr ()] -> Type
applyTyVars :: Type -> [TyVarBndr ()] -> Type
applyTyVars Type
ty [TyVarBndr ()]
tyVars = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
ty ([TyVarBndr ()]
tyVars forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Name -> Type
VarT)

-- | Create endpoint types to be referenced in the API
-- * For Endpoint this is just a reference to the handler type
-- * For SubApi we apply the path parameters before referencing the SubApi
mkEndpointApiType :: ApiPiece -> ServerGenM (Type, [TyVarBndr ()])
mkEndpointApiType :: ApiPiece -> ServerGenM (Type, [TyVarBndr ()])
mkEndpointApiType ApiPiece
p = forall a. ApiPiece -> ServerGenM a -> ServerGenM a
enterApiPiece ApiPiece
p forall a b. (a -> b) -> a -> b
$ case ApiPiece
p of
    Endpoint ConstructorName
_n ConstructorArgs
args VarBindings
bindings HandlerSettings
_ Mutability
_ EpReturnType
ret -> do
        Name
epName <- ServerGenM Name
askEndpointTypeName
        let usedTyVars :: [TyVarBndr ()]
            usedTyVars :: [TyVarBndr ()]
usedTyVars =
                forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                        (forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars forall a b. (a -> b) -> a -> b
$ VarBindings
bindings forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra")
                        (EpReturnType
ret forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @Type forall a. a -> [a] -> [a]
: ConstructorArgs
args forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Type)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Type -> [TyVarBndr ()] -> Type
applyTyVars (Name -> Type
ConT Name
epName) [TyVarBndr ()]
usedTyVars
            , forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyVarBndr ()]
usedTyVars) (VarBindings
bindings forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra") -- Make sure we get type vars in the right order
            )
    SubApi ConstructorName
cName ConstructorArgs
cArgs ApiSpec
spec -> do
        UrlSegment
urlSegment <- ConstructorName -> ServerGenM UrlSegment
mkUrlSegment ConstructorName
cName
        (Name
n, [TyVarBndr ()]
tyVars) <- ApiSpec -> ServerGenM (Name, [TyVarBndr ()])
askApiNameAndParams ApiSpec
spec
        Type
finalType <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ UrlSegment -> Type -> Q Type
prependServerEndpointName UrlSegment
urlSegment (Type -> [TyVarBndr ()] -> Type
applyTyVars (Name -> Type
ConT Name
n) [TyVarBndr ()]
tyVars)

        [Type]
params <- ConstructorArgs -> ServerGenM [Type]
mkQueryParams ConstructorArgs
cArgs
        Type
bird <- forall a. Q a -> ServerGenM a
liftQ [t|(:>)|]
        let ep :: Type
ep = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
a Type
b -> Type
bird Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` Type
b) Type
finalType [Type]
params
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
ep, [TyVarBndr ()]
tyVars)

-- | Defines the servant types for the endpoints
-- For SubApi it will trigger the full creating of the sub server with types and all
--
-- Result will be something like:
-- ```
-- type Customer_CreateEndpoint
--     = "Create"
--     :> ReqBody '[JSON] (NamedField1 "Customer_Create" Name Email)
--     :> Post '[JSON] CustomerKey
mkHandlerTypeDec :: ApiPiece -> ServerGenM [Dec]
mkHandlerTypeDec :: ApiPiece -> ServerGenM [Dec]
mkHandlerTypeDec ApiPiece
p = forall a. ApiPiece -> ServerGenM a -> ServerGenM a
enterApiPiece ApiPiece
p forall a b. (a -> b) -> a -> b
$ do
    case ApiPiece
p of
        Endpoint ConstructorName
name ConstructorArgs
args VarBindings
varBindings HandlerSettings
hs Mutability
Immutable EpReturnType
retType -> do
            -- Get endpoint will use query parameters
            Type
ty <- do
                [Type]
queryParams <- ConstructorArgs -> ServerGenM [Type]
mkQueryParams ConstructorArgs
args
                let reqReturn :: Type
reqReturn = HandlerSettings -> Type -> Type
mkVerb HandlerSettings
hs forall a b. (a -> b) -> a -> b
$ EpReturnType -> Type
mkReturnType EpReturnType
retType
                Type
bird <- forall a. Q a -> ServerGenM a
liftQ [t|(:>)|]
                let stuff :: Type
stuff = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
joinUrlParts forall a b. (a -> b) -> a -> b
$ [Type]
queryParams forall a. Semigroup a => a -> a -> a
<> [Type
reqReturn]
                    joinUrlParts :: Type -> Type -> Type
                    joinUrlParts :: Type -> Type -> Type
joinUrlParts Type
a Type
b = Type
bird Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` Type
b
                UrlSegment
urlSegment <- ConstructorName -> ServerGenM UrlSegment
mkUrlSegment ConstructorName
name
                forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ UrlSegment -> Type -> Q Type
prependServerEndpointName UrlSegment
urlSegment Type
stuff
            Name
epTypeName <- ServerGenM Name
askEndpointTypeName
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name -> [TyVarBndr ()] -> Type -> Dec
TySynD Name
epTypeName (forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars (VarBindings -> [TyVarBndr ()]
toTyVarBndr VarBindings
varBindings) Type
ty) Type
ty]
        Endpoint ConstructorName
name ConstructorArgs
args VarBindings
varBindings HandlerSettings
hs Mutability
Mutable EpReturnType
retType -> do
            -- Non-get endpoints use a request body
            Type
ty <- do
                Maybe Type
reqBody <- HandlerSettings
-> ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkReqBody HandlerSettings
hs ConstructorName
name ConstructorArgs
args
                let reqReturn :: Type
reqReturn = EpReturnType -> Type
mkReturnType EpReturnType
retType
                Type
middle <- case Maybe Type
reqBody of
                    Maybe Type
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HandlerSettings -> Type -> Type
mkVerb HandlerSettings
hs Type
reqReturn
                    Just Type
b -> forall a. Q a -> ServerGenM a
liftQ [t|$(pure b) :> $(pure $ mkVerb hs reqReturn)|]
                UrlSegment
urlSegment <- ConstructorName -> ServerGenM UrlSegment
mkUrlSegment ConstructorName
name
                forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ UrlSegment -> Type -> Q Type
prependServerEndpointName UrlSegment
urlSegment Type
middle
            Name
epTypeName <- ServerGenM Name
askEndpointTypeName
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name -> [TyVarBndr ()] -> Type -> Dec
TySynD Name
epTypeName (forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars (VarBindings -> [TyVarBndr ()]
toTyVarBndr VarBindings
varBindings) Type
ty) Type
ty]
        SubApi ConstructorName
_name ConstructorArgs
args ApiSpec
spec' -> forall a. ApiSpec -> ServerGenM a -> ServerGenM a
enterApi ApiSpec
spec' forall a b. (a -> b) -> a -> b
$ do
            [Type]
_ <- ConstructorArgs -> ServerGenM [Type]
mkQueryParams ConstructorArgs
args
            -- Make sure we take into account what parameters have already been used.
            -- Skip this and we could end up generating APIs with multiple
            -- QueryParams with the same name, which servant will accept and use one
            -- one the values for both parameters.
            ApiSpec -> ServerGenM [Dec]
mkServerFromSpec ApiSpec
spec'

guardUniqueParamName :: String -> ServerGenM ()
guardUniqueParamName :: String -> ServerGenM ()
guardUniqueParamName String
paramName = do
    Set String
existingNames <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"usedParamNames")
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
paramName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set String
existingNames) forall a b. (a -> b) -> a -> b
$ do
        ServerInfo
info <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"info")
        let problematicConstructor :: String
problematicConstructor = ServerInfo
info forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"currentGadt" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to forall a. Show a => a -> String
show
            problematicParentConstructors :: String
problematicParentConstructors =
                forall a. [a] -> [[a]] -> [a]
L.intercalate String
"->" forall a b. (a -> b) -> a -> b
$
                    ServerInfo
info
                        forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"parentConstructors"
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed @Name
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to forall a. Show a => a -> String
show
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            String
"Duplicate query parameters with name "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
paramName
                forall a. Semigroup a => a -> a -> a
<> String
" in Action "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
problematicConstructor
                forall a. Semigroup a => a -> a -> a
<> String
" with constructor hierarcy "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
problematicParentConstructors
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"usedParamNames") (forall a. Ord a => a -> Set a -> Set a
S.insert String
paramName)

mkQueryParams :: ConstructorArgs -> ServerGenM [QueryParamType]
mkQueryParams :: ConstructorArgs -> ServerGenM [Type]
mkQueryParams (ConstructorArgs [(String, Type)]
args) = do
    Type
may <- forall a. Q a -> ServerGenM a
liftQ [t|Maybe|] -- Maybe parameters are optional, others required
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(String, Type)]
args forall a b. (a -> b) -> a -> b
$ \case
        (String
name, AppT Type
may' Type
ty)
            | Type
may' forall a. Eq a => a -> a -> Bool
== Type
may -> do
                String -> ServerGenM ()
guardUniqueParamName String
name
                forall a. Q a -> ServerGenM a
liftQ
                    [t|
                        QueryParam'
                            '[Optional, Servant.Strict]
                            $(pure . LitT . StrTyLit $ name)
                            $(pure ty)
                        |]
        (String
name, Type
ty) -> do
            String -> ServerGenM ()
guardUniqueParamName String
name
            forall a. Q a -> ServerGenM a
liftQ
                [t|
                    QueryParam'
                        '[Required, Servant.Strict]
                        $(pure . LitT . StrTyLit $ name)
                        $(pure ty)
                    |]

type QueryParamType = Type

updateConstructorTypes :: (Type -> Type) -> Con -> Con
updateConstructorTypes :: (Type -> Type) -> Con -> Con
updateConstructorTypes Type -> Type
f = \case
    NormalC Name
n [BangType]
bts -> Name -> [BangType] -> Con
NormalC Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
f) [BangType]
bts)
    RecC Name
n [VarBangType]
vbt -> Name -> [VarBangType] -> Con
RecC Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
f) [VarBangType]
vbt)
    InfixC BangType
bt1 Name
n BangType
bt2 -> BangType -> Name -> BangType -> Con
InfixC BangType
bt1 Name
n BangType
bt2
    ForallC [TyVarBndr Specificity]
b [Type]
cxt' Con
c -> [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC [TyVarBndr Specificity]
b [Type]
cxt' ((Type -> Type) -> Con -> Con
updateConstructorTypes Type -> Type
f Con
c)
    GadtC [Name]
n [BangType]
bts Type
ty -> [Name] -> [BangType] -> Type -> Con
GadtC [Name]
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
f) [BangType]
bts) (Type -> Type
f Type
ty)
    RecGadtC [Name]
n [VarBangType]
vbt Type
ty -> [Name] -> [VarBangType] -> Type -> Con
RecGadtC [Name]
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
f) [VarBangType]
vbt) (Type -> Type
f Type
ty)

mkVerb :: HandlerSettings -> Type -> Type
mkVerb :: HandlerSettings -> Type -> Type
mkVerb (HandlerSettings Type
_ Type
verb) Type
ret = Type
verb Type -> Type -> Type
`AppT` Type
ret

-- | Declare then handlers for the API
mkServerDec :: ApiSpec -> ServerGenM [Dec]
mkServerDec :: ApiSpec -> ServerGenM [Dec]
mkServerDec ApiSpec
spec = do
    (Name
apiTypeName, [TyVarBndr ()]
apiParams) <- ApiSpec -> ServerGenM (Name, [TyVarBndr ()])
askApiNameAndParams ApiSpec
spec
    Name
serverName <- ServerGenM Name
askServerName

    let runnerName :: Name
        runnerName :: Name
runnerName = String -> Name
mkName String
"runner"

        actionRunner' :: Type
        actionRunner' :: Type
actionRunner' =
            Name -> Type
ConT ''ActionRunner
                Type -> Type -> Type
`AppT` Name -> Type
VarT Name
runnerMonadName
                Type -> Type -> Type
`AppT` ( ApiSpec
spec
                            forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"gadtType"
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed
                       )

        server :: Type
        server :: Type
server =
            Name -> Type
ConT ''ServerT
                Type -> Type -> Type
`AppT` Type -> [TyVarBndr ()] -> Type
applyTyVars (Name -> Type
ConT Name
apiTypeName) [TyVarBndr ()]
apiParams
                Type -> Type -> Type
`AppT` Name -> Type
VarT Name
runnerMonadName

        serverType :: Type
        serverType :: Type
serverType =
            [TyVarBndr ()] -> Type -> Type
withForall
                (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @"allVarBindings" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra")
                (Type
ArrowT Type -> Type -> Type
`AppT` Type
actionRunner' Type -> Type -> Type
`AppT` Type
server)

    let serverSigDec :: Dec
        serverSigDec :: Dec
serverSigDec = Name -> Type -> Dec
SigD Name
serverName Type
serverType

        mkHandlerExp :: ApiPiece -> ServerGenM Exp
        mkHandlerExp :: ApiPiece -> ServerGenM Exp
mkHandlerExp ApiPiece
p = forall a. ApiPiece -> ServerGenM a -> ServerGenM a
enterApiPiece ApiPiece
p forall a b. (a -> b) -> a -> b
$ do
            Name
n <- ServerGenM Name
askHandlerName
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
runnerName
    [Exp]
handlers <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ApiPiece -> ServerGenM Exp
mkHandlerExp (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[ApiPiece])
    Exp
body <- case forall a. [a] -> [a]
reverse [Exp]
handlers of -- :<|> is right associative
        [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Server contains no endpoints"
        Exp
e : [Exp]
es -> forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
b Exp
a -> [|$(pure a) :<|> $(pure b)|]) Exp
e [Exp]
es
    let serverFunDec :: Dec
        serverFunDec :: Dec
serverFunDec = Name -> [Clause] -> Dec
FunD Name
serverName [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
runnerName] (Exp -> Body
NormalB Exp
body) []]
    [Dec]
serverHandlerDecs <-
        forall a. Monoid a => [a] -> a
mconcat
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (GadtType -> ApiPiece -> ServerGenM [Dec]
mkApiPieceHandler (ApiSpec -> GadtType
gadtType ApiSpec
spec)) (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[ApiPiece])

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
serverSigDec forall a. a -> [a] -> [a]
: Dec
serverFunDec forall a. a -> [a] -> [a]
: [Dec]
serverHandlerDecs

-- | Get the subset of type varaibes used ty a type, in the roder they're applied
-- Used to avoid rendundant type variables in the forall statement of sub-servers
getUsedTyVars :: forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars :: forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars [TyVarBndr flag]
bindings Type
ty = Type -> [Name]
getUsedTyVarNames Type
ty forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name (TyVarBndr flag)
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just
  where
    m :: M.Map Name (TyVarBndr flag)
    m :: Map Name (TyVarBndr flag)
m = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr flag -> Name
getName [TyVarBndr flag]
bindings) [TyVarBndr flag]
bindings

    getName :: TyVarBndr flag -> Name
    getName :: TyVarBndr flag -> Name
getName = \case
        PlainTV Name
n flag
_ -> Name
n
        KindedTV Name
n flag
_ Type
_ -> Name
n

-- | Get the type variables (VarT) used in a type, returned in the order they're
-- referenced
getUsedTyVarNames :: Type -> [Name]
getUsedTyVarNames :: Type -> [Name]
getUsedTyVarNames Type
ty' = forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ case Type
ty' of
    (AppT Type
a Type
b) -> forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Semigroup a => a -> a -> a
(<>) Type -> [Name]
getUsedTyVarNames Type
a Type
b
    (ConT Name
_) -> []
    (VarT Name
n) -> [Name
n]
    ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
ty -> Type -> [Name]
getUsedTyVarNames Type
ty
    ForallVisT [TyVarBndr ()]
_ Type
ty -> Type -> [Name]
getUsedTyVarNames Type
ty
    AppKindT Type
ty Type
_ -> Type -> [Name]
getUsedTyVarNames Type
ty
    SigT Type
ty Type
_ -> Type -> [Name]
getUsedTyVarNames Type
ty
    PromotedT Name
_ -> []
    InfixT Type
ty1 Name
_ Type
ty2 -> Type -> [Name]
getUsedTyVarNames Type
ty1 forall a. Semigroup a => a -> a -> a
<> Type -> [Name]
getUsedTyVarNames Type
ty2
    UInfixT Type
ty1 Name
_ Type
ty2 -> Type -> [Name]
getUsedTyVarNames Type
ty1 forall a. Semigroup a => a -> a -> a
<> Type -> [Name]
getUsedTyVarNames Type
ty2
    ParensT Type
ty -> Type -> [Name]
getUsedTyVarNames Type
ty
    TupleT Int
_ -> []
    UnboxedTupleT Int
_ -> []
    UnboxedSumT Int
_ -> []
    Type
ArrowT -> []
    Type
MulArrowT -> []
    Type
EqualityT -> []
    Type
ListT -> []
    PromotedTupleT Int
_ -> []
    Type
PromotedNilT -> []
    Type
PromotedConsT -> []
    Type
StarT -> []
    Type
ConstraintT -> []
    LitT TyLit
_ -> []
    Type
WildCardT -> []
    ImplicitParamT String
_ Type
ty -> Type -> [Name]
getUsedTyVarNames Type
ty

withForall :: [TyVarBndr ()] -> Type -> Type
withForall :: [TyVarBndr ()] -> Type -> Type
withForall [TyVarBndr ()]
extra Type
ty =
    [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT
        [TyVarBndr Specificity]
bindings
        [Type]
varConstraints
        Type
ty
  where
    bindings :: [TyVarBndr Specificity]
    bindings :: [TyVarBndr Specificity]
bindings =
        forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
runnerMonadName Specificity
SpecifiedSpec (Type
ArrowT Type -> Type -> Type
`AppT` Type
StarT Type -> Type -> Type
`AppT` Type
StarT)
            forall a. a -> [a] -> [a]
: ( forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]
getUsedTyVars [TyVarBndr ()]
extra Type
ty
                    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b.
Traversable f =>
Traversal (f a) (f b) a b
traversed forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \case
                        PlainTV Name
n ()
_ -> forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
SpecifiedSpec
                        KindedTV Name
n ()
_ Type
k -> forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n Specificity
SpecifiedSpec Type
k
              )

    varConstraints :: [Type]
    varConstraints :: [Type]
varConstraints = [Name -> Type
ConT ''MonadUnliftIO Type -> Type -> Type
`AppT` Name -> Type
VarT Name
runnerMonadName]

actionRunner :: Type -> Type
actionRunner :: Type -> Type
actionRunner Type
runnerGADT =
    Name -> Type
ConT ''ActionRunner
        Type -> Type -> Type
`AppT` Name -> Type
VarT Name
runnerMonadName
        Type -> Type -> Type
`AppT` Type
runnerGADT

runnerMonadName :: Name
runnerMonadName :: Name
runnerMonadName = String -> Name
mkName String
"m"

mkNamedFieldsType :: ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkNamedFieldsType :: ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkNamedFieldsType ConstructorName
cName = \case
    ConstructorArgs [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    ConstructorArgs [(String, Type)]
args -> do
        TyLit
bodyTag <- ConstructorName -> ServerGenM TyLit
askBodyTag ConstructorName
cName

        let nfType :: Type
            nfType :: Type
nfType = Type -> Type -> Type
AppT (Name -> Type
ConT Name
nfName) (TyLit -> Type
LitT TyLit
bodyTag)

            nfName :: Name
            nfName :: Name
nfName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"NF" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Type)]
args)

            addNFxParam :: Type -> (String, Type) -> Type
            addNFxParam :: Type -> (String, Type) -> Type
addNFxParam Type
nfx (String
name, Type
ty) = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
nfx (TyLit -> Type
LitT forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit String
name)) Type
ty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> (String, Type) -> Type
addNFxParam Type
nfType [(String, Type)]
args

mkQueryHandlerSignature :: GadtType -> ConstructorArgs -> EpReturnType -> Type
mkQueryHandlerSignature :: GadtType -> ConstructorArgs -> EpReturnType -> Type
mkQueryHandlerSignature
    gadt :: GadtType
gadt@(GadtType Type
actionType)
    (ConstructorArgs [(String, Type)]
args)
    (EpReturnType Type
retType) =
        [TyVarBndr ()] -> Type -> Type
withForall (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ GadtType -> Either String [TyVarBndr ()]
gadtTypeParams GadtType
gadt) forall a b. (a -> b) -> a -> b
$
            [Type] -> Type
mkFunction forall a b. (a -> b) -> a -> b
$
                Type -> Type
actionRunner Type
actionType forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(String, Type)]
args forall a. Semigroup a => a -> a -> a
<> [Type
ret]
      where
        ret :: Type
        ret :: Type
ret = Type -> Type -> Type
AppT (Name -> Type
VarT Name
runnerMonadName) Type
retType

-- | Makes command handler, e.g.
--  counterCmd_AddToCounterHandler ::
--    ActionRunner m CounterCmd -> NamedFields1 "CounterCmd_AddToCounter" Int -> m Int
mkCmdHandlerSignature
    :: GadtType -> ConstructorName -> ConstructorArgs -> EpReturnType -> ServerGenM Type
mkCmdHandlerSignature :: GadtType
-> ConstructorName
-> ConstructorArgs
-> EpReturnType
-> ServerGenM Type
mkCmdHandlerSignature GadtType
gadt ConstructorName
cName ConstructorArgs
cArgs (EpReturnType Type
retType) = do
    Maybe Type
nfArgs <- ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkNamedFieldsType ConstructorName
cName ConstructorArgs
cArgs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        [TyVarBndr ()] -> Type -> Type
withForall (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ GadtType -> Either String [TyVarBndr ()]
gadtTypeParams GadtType
gadt) forall a b. (a -> b) -> a -> b
$
            [Type] -> Type
mkFunction forall a b. (a -> b) -> a -> b
$
                [Type -> Type
actionRunner (GadtType
gadt forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed)]
                    forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Type
nfArgs
                    forall a. Semigroup a => a -> a -> a
<> [Type
ret]
  where
    ret :: Type
    ret :: Type
ret = Type -> Type -> Type
AppT (Name -> Type
VarT Name
runnerMonadName) forall a b. (a -> b) -> a -> b
$ case Type
retType of
        TupleT Int
0 -> Name -> Type
ConT ''NoContent
        Type
ty -> Type
ty

mkFunction :: [Type] -> Type
mkFunction :: [Type] -> Type
mkFunction = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Type
a Type
b -> Type
ArrowT Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` Type
b)

sortAndExcludeBindings :: [TyVarBndr Specificity] -> Type -> Either String [TyVarBndr Specificity]
sortAndExcludeBindings :: [TyVarBndr Specificity]
-> Type -> Either String [TyVarBndr Specificity]
sortAndExcludeBindings [TyVarBndr Specificity]
bindings Type
ty = do
    [Name]
varOrder <- Type -> Either String [Name]
varNameOrder Type
ty
    let m :: M.Map Name Int
        m :: Map Name Int
m = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
varOrder [Int
1 ..]

    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity]
bindings forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to (\TyVarBndr Specificity
a -> (TyVarBndr Specificity
a,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (TyVarBndr Specificity
a forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed) Map Name Int
m)

varNameOrder :: Type -> Either String [Name]
varNameOrder :: Type -> Either String [Name]
varNameOrder = \case
    ConT Name
_ -> forall a b. b -> Either a b
Right []
    VarT Name
n -> forall a b. b -> Either a b
Right [Name
n]
    (AppT Type
a Type
b) -> forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Either String [Name]
varNameOrder Type
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either String [Name]
varNameOrder Type
b
    Type
crap -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"sortAndExcludeBindings: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
crap

gadtTypeParams :: GadtType -> Either String [TyVarBndr ()]
gadtTypeParams :: GadtType -> Either String [TyVarBndr ()]
gadtTypeParams = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ())) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Either String [Name]
varNameOrder forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed)

-- | Define the servant handler for an enpoint or referens the subapi with path
-- parameters applied
mkApiPieceHandler :: GadtType -> ApiPiece -> ServerGenM [Dec]
mkApiPieceHandler :: GadtType -> ApiPiece -> ServerGenM [Dec]
mkApiPieceHandler GadtType
gadt ApiPiece
apiPiece =
    forall a. ApiPiece -> ServerGenM a -> ServerGenM a
enterApiPiece ApiPiece
apiPiece forall a b. (a -> b) -> a -> b
$ do
        case ApiPiece
apiPiece of
            Endpoint ConstructorName
_cName ConstructorArgs
cArgs VarBindings
_ HandlerSettings
_hs Mutability
Immutable EpReturnType
ty -> do
                let nrArgs :: Int
                    nrArgs :: Int
nrArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ ConstructorArgs
cArgs forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)]
                [Name]
varNames <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nrArgs (forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg")
                Name
handlerName <- ServerGenM Name
askHandlerName
                Name
runnerName <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"runner"

                let funSig :: Dec
                    funSig :: Dec
funSig = Name -> Type -> Dec
SigD Name
handlerName forall a b. (a -> b) -> a -> b
$ GadtType -> ConstructorArgs -> EpReturnType -> Type
mkQueryHandlerSignature GadtType
gadt ConstructorArgs
cArgs EpReturnType
ty

                    funBodyBase :: Exp
funBodyBase =
                        Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
runnerName) forall a b. (a -> b) -> a -> b
$
                            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                                Exp -> Exp -> Exp
AppE
                                (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ ApiPiece
apiPiece forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @ConstructorName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed)
                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames)

                    funBody :: Q Exp
funBody = case EpReturnType
ty forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed of
                        TupleT Int
0 -> [|fmap (const NoContent) $(pure funBodyBase)|]
                        Type
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp
funBodyBase
                Clause
funClause <-
                    forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pat
VarP) (Name
runnerName forall a. a -> [a] -> [a]
: [Name]
varNames))
                            (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|$(funBody)|])
                            []
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
funSig, Name -> [Clause] -> Dec
FunD Name
handlerName [Clause
funClause]]
            Endpoint ConstructorName
cName ConstructorArgs
cArgs VarBindings
_ HandlerSettings
hs Mutability
Mutable EpReturnType
ty | HandlerSettings -> Bool
hasJsonContentType HandlerSettings
hs -> do
                let nrArgs :: Int
                    nrArgs :: Int
nrArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ ConstructorArgs
cArgs forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)]
                [Name]
varNames <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nrArgs (forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg")
                Name
handlerName <- ServerGenM Name
askHandlerName
                Name
runnerName <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"runner"
                let varPat :: Pat
                    varPat :: Pat
varPat = Name -> [Type] -> [Pat] -> Pat
ConP Name
nfName [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames)

                    nfName :: Name
                    nfName :: Name
nfName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"NF" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
nrArgs

                Dec
funSig <- Name -> Type -> Dec
SigD Name
handlerName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GadtType
-> ConstructorName
-> ConstructorArgs
-> EpReturnType
-> ServerGenM Type
mkCmdHandlerSignature GadtType
gadt ConstructorName
cName ConstructorArgs
cArgs EpReturnType
ty

                let funBodyBase :: Exp
funBodyBase =
                        Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
runnerName) forall a b. (a -> b) -> a -> b
$
                            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                                Exp -> Exp -> Exp
AppE
                                (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ ApiPiece
apiPiece forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @ConstructorName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed)
                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames)

                    funBody :: Q Exp
funBody = case EpReturnType
ty forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed of
                        TupleT Int
0 -> [|fmap (const NoContent) $(pure funBodyBase)|]
                        Type
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp
funBodyBase
                Clause
funClause <-
                    forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                            (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Pat
VarP Name
runnerName) forall a. a -> [a] -> [a]
: [forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
varPat | Int
nrArgs forall a. Ord a => a -> a -> Bool
> Int
0])
                            (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|$(funBody)|])
                            []
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
funSig, Name -> [Clause] -> Dec
FunD Name
handlerName [Clause
funClause]]
            Endpoint ConstructorName
_cName ConstructorArgs
cArgs VarBindings
_ HandlerSettings
_hs Mutability
Mutable EpReturnType
ty -> do
                let nrArgs :: Int
                    nrArgs :: Int
nrArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ ConstructorArgs
cArgs forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)]
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
nrArgs forall a. Ord a => a -> a -> Bool
< Int
2) forall a b. (a -> b) -> a -> b
$
                    forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only one argument is supported for non-JSON request bodies"
                Name
varName <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
                Name
handlerName <- ServerGenM Name
askHandlerName
                Name
runnerName <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"runner"
                let varPat :: Pat
                    varPat :: Pat
varPat = Name -> Pat
VarP Name
varName

                let funSig :: Dec
                    funSig :: Dec
funSig = Name -> Type -> Dec
SigD Name
handlerName forall a b. (a -> b) -> a -> b
$ GadtType -> ConstructorArgs -> EpReturnType -> Type
mkQueryHandlerSignature GadtType
gadt ConstructorArgs
cArgs EpReturnType
ty

                    funBodyBase :: Exp
funBodyBase =
                        Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
runnerName) forall a b. (a -> b) -> a -> b
$
                            Exp -> Exp -> Exp
AppE
                                (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ ApiPiece
apiPiece forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @ConstructorName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasType a s => Lens s s a a
typed)
                                (Name -> Exp
VarE Name
varName)

                    funBody :: Q Exp
funBody = case EpReturnType
ty forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed of
                        TupleT Int
0 -> [|fmap (const NoContent) $(pure funBodyBase)|]
                        Type
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp
funBodyBase
                Clause
funClause <-
                    forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                            (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Pat
VarP Name
runnerName) forall a. a -> [a] -> [a]
: [forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
varPat | Int
nrArgs forall a. Ord a => a -> a -> Bool
> Int
0])
                            (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|$(funBody)|])
                            []
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
funSig, Name -> [Clause] -> Dec
FunD Name
handlerName [Clause
funClause]]
            SubApi ConstructorName
cName ConstructorArgs
cArgs ApiSpec
spec -> do
                -- Apply the arguments to the constructor before referencing the subserver
                [Name]
varNames <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorArgs
cArgs forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)])) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg")
                Name
handlerName <- ServerGenM Name
askHandlerName
                (Name
targetApiTypeName, [TyVarBndr ()]
targetApiParams) <- forall a. ApiSpec -> ServerGenM a -> ServerGenM a
enterApi ApiSpec
spec (ApiSpec -> ServerGenM (Name, [TyVarBndr ()])
askApiNameAndParams ApiSpec
spec)
                Name
targetServer <- forall a. ApiSpec -> ServerGenM a -> ServerGenM a
enterApi ApiSpec
spec ServerGenM Name
askServerName
                Name
runnerName <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"runner"

                Dec
funSig <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ do
                    let params :: Type
params =
                            [TyVarBndr ()] -> Type -> Type
withForall (ApiSpec
spec forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"allVarBindings" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"extra") forall a b. (a -> b) -> a -> b
$
                                [Type] -> Type
mkFunction forall a b. (a -> b) -> a -> b
$
                                    [Type -> Type
actionRunner (GadtType
gadt forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed)]
                                        forall a. Semigroup a => a -> a -> a
<> ConstructorArgs
cArgs forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a s. HasType a s => Lens s s a a
typed @[(String, Type)] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2
                                        forall a. Semigroup a => a -> a -> a
<> [ Name -> Type
ConT ''ServerT
                                                Type -> Type -> Type
`AppT` Type -> [TyVarBndr ()] -> Type
applyTyVars (Name -> Type
ConT Name
targetApiTypeName) [TyVarBndr ()]
targetApiParams
                                                Type -> Type -> Type
`AppT` Name -> Type
VarT Name
runnerMonadName
                                           ]
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type -> Dec
SigD Name
handlerName Type
params)

                Clause
funClause <- forall a. Q a -> ServerGenM a
liftQ forall a b. (a -> b) -> a -> b
$ do
                    let cmd :: Exp
cmd =
                            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                                Exp -> Exp -> Exp
AppE
                                (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ ConstructorName
cName forall s a. s -> Getting a s a -> a
^. forall a s. HasType a s => Lens s s a a
typed)
                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames)
                     in forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                            (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
runnerName forall a. a -> [a] -> [a]
: [Name]
varNames)
                            ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                                Exp -> Body
NormalB
                                [e|
                                    $(varE targetServer)
                                        ($(varE runnerName) . $(pure cmd))
                                    |]
                            )
                            []
                let funDef :: Dec
funDef = Name -> [Clause] -> Dec
FunD Name
handlerName [Clause
funClause]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
funSig, Dec
funDef]

---- | This is the only layer of the ReaderT stack where we do not use `local` to update the
---- url segments.
mkServerFromSpec :: ApiSpec -> ServerGenM [Dec]
mkServerFromSpec :: ApiSpec -> ServerGenM [Dec]
mkServerFromSpec ApiSpec
spec = forall a. ApiSpec -> ServerGenM a -> ServerGenM a
enterApi ApiSpec
spec forall a b. (a -> b) -> a -> b
$ do
    [Dec]
apiTypeDecs <- ApiSpec -> ServerGenM [Dec]
mkApiTypeDecs ApiSpec
spec
    [Dec]
serverDecs <- ApiSpec -> ServerGenM [Dec]
mkServerDec ApiSpec
spec
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Dec]
apiTypeDecs forall a. Semigroup a => a -> a -> a
<> [Dec]
serverDecs

-- | Handles the special case of `()` being transformed into `NoContent`
mkReturnType :: EpReturnType -> Type
mkReturnType :: EpReturnType -> Type
mkReturnType (EpReturnType Type
ty) = case Type
ty of
    TupleT Int
0 -> Name -> Type
ConT ''NoContent
    Type
_ -> Type
ty

prependServerEndpointName :: UrlSegment -> Type -> Q Type
prependServerEndpointName :: UrlSegment -> Type -> Q Type
prependServerEndpointName UrlSegment
prefix Type
rest =
    [t|$(pure $ LitT . StrTyLit $ prefix ^. typed) :> $(pure $ rest)|]

mkReqBody
    :: HandlerSettings -> ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkReqBody :: HandlerSettings
-> ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkReqBody HandlerSettings
hs ConstructorName
name ConstructorArgs
args =
    if HandlerSettings -> Bool
hasJsonContentType HandlerSettings
hs
        then do
            Maybe Type
body <- ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)
mkNamedFieldsType ConstructorName
name ConstructorArgs
args
            case Maybe Type
body of
                Maybe Type
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                Just Type
b -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Q a -> ServerGenM a
liftQ [t|ReqBody '[JSON] $(pure b)|]
        else do
            let body :: Maybe Type
body = case ConstructorArgs
args of
                    ConstructorArgs [] -> forall a. Maybe a
Nothing
                    ConstructorArgs [(String
_, Type
t)] -> forall a. a -> Maybe a
Just Type
t
                    ConstructorArgs [(String, Type)]
_ ->
                        forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Multiple arguments are only supported for JSON content"
            case Maybe Type
body of
                Maybe Type
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                Just Type
b ->
                    forall a. a -> Maybe a
Just
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Q a -> ServerGenM a
liftQ
                            [t|ReqBody $(pure $ hs ^. field @"contentTypes") $(pure b)|]