{-# language AllowAmbiguousTypes   #-}
{-# language DataKinds             #-}
{-# language FlexibleContexts      #-}
{-# language FlexibleInstances     #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds             #-}
{-# language ScopedTypeVariables   #-}
{-# language TemplateHaskell       #-}
{-# language TypeApplications      #-}
{-# language TypeFamilies          #-}
{-# language TypeOperators         #-}
{-# language UndecidableInstances  #-}
{-|
Description : Client for gRPC services using plain Haskell records

For further information over initialization of the connection,
consult the <http://hackage.haskell.org/package/http2-client-grpc http2-client-grpc docs>.
-}
module Mu.GRpc.Client.Record (
  -- * Initialization of the gRPC client
  GrpcClient
, GrpcClientConfig
, grpcClientConfigSimple
, setupGrpcClient'
  -- * Fill and generate the Haskell record of functions
, buildService
, GRpcMessageProtocol(..)
, CompressMode(..)
, GRpcReply(..)
, generateRecordFromService
) where

import           Control.Applicative
import           Data.Char
import           Data.Conduit                 (ConduitT)
import           Data.Proxy
import           Data.Void
import           GHC.Generics                 hiding (NoSourceStrictness, NoSourceUnpackedness)
import           GHC.TypeLits
import           Language.Haskell.TH          hiding (ppr)
import           Language.Haskell.TH.Datatype

import           Network.GRPC.Client          (CompressMode (..))
import           Network.GRPC.Client.Helpers

import           Mu.GRpc.Bridge
import           Mu.GRpc.Client.Internal
import           Mu.Rpc

-- | Fills in a Haskell record of functions with the corresponding
--   calls to gRPC services from a Mu 'Service' declaration.
buildService :: forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol) t
                (nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]).
                (s ~ 'Service nm anns ms, Generic t, BuildService pro s p ms (Rep t))
             => GrpcClient -> t
buildService :: GrpcClient -> t
buildService client :: GrpcClient
client = Rep t Any -> t
forall a x. Generic a => Rep a x -> a
to (Proxy pro
-> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> Rep t Any
forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol)
       (ms :: [Method Symbol]) (f :: * -> *) a.
BuildService pro s p ms f =>
Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
buildService' (Proxy pro
forall k (t :: k). Proxy t
Proxy @pro) (Proxy s
forall k (t :: k). Proxy t
Proxy @s) (Proxy p
forall k (t :: k). Proxy t
Proxy @p) (Proxy ms
forall k (t :: k). Proxy t
Proxy @ms) GrpcClient
client)

class BuildService (pro :: GRpcMessageProtocol) (s :: Service')
                   (p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where
  buildService' :: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a

instance BuildService pro s p ms U1 where
  buildService' :: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> U1 a
buildService' _ _ _ _ _ = U1 a
forall k (p :: k). U1 p
U1
instance BuildService pro s p ms f => BuildService pro s p ms (D1 meta f) where
  buildService' :: Proxy pro
-> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> D1 meta f a
buildService' ppro :: Proxy pro
ppro ps :: Proxy s
ps ppr :: Proxy p
ppr pms :: Proxy ms
pms client :: GrpcClient
client
    = f a -> D1 meta f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol)
       (ms :: [Method Symbol]) (f :: * -> *) a.
BuildService pro s p ms f =>
Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
buildService' Proxy pro
ppro Proxy s
ps Proxy p
ppr Proxy ms
pms GrpcClient
client)
instance BuildService pro s p ms f => BuildService pro s p ms (C1 meta f) where
  buildService' :: Proxy pro
-> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> C1 meta f a
buildService' ppro :: Proxy pro
ppro ps :: Proxy s
ps ppr :: Proxy p
ppr pms :: Proxy ms
pms client :: GrpcClient
client
    = f a -> C1 meta f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol)
       (ms :: [Method Symbol]) (f :: * -> *) a.
BuildService pro s p ms f =>
Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
buildService' Proxy pro
ppro Proxy s
ps Proxy p
ppr Proxy ms
pms GrpcClient
client)
instance TypeError ('Text "building a service from sums is not supported")
         => BuildService pro s p ms (f :+: g) where
  buildService' :: Proxy pro
-> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> (:+:) f g a
buildService' = [Char]
-> Proxy pro
-> Proxy s
-> Proxy p
-> Proxy ms
-> GrpcClient
-> (:+:) f g a
forall a. HasCallStack => [Char] -> a
error "this should never happen"
instance (BuildService pro s p ms f, BuildService pro s p ms g)
         => BuildService pro s p ms (f :*: g) where
  buildService' :: Proxy pro
-> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> (:*:) f g a
buildService' ppro :: Proxy pro
ppro ps :: Proxy s
ps ppr :: Proxy p
ppr pms :: Proxy ms
pms client :: GrpcClient
client
    = Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol)
       (ms :: [Method Symbol]) (f :: * -> *) a.
BuildService pro s p ms f =>
Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
buildService' Proxy pro
ppro Proxy s
ps Proxy p
ppr Proxy ms
pms GrpcClient
client f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> g a
forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol)
       (ms :: [Method Symbol]) (f :: * -> *) a.
BuildService pro s p ms f =>
Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
buildService' Proxy pro
ppro Proxy s
ps Proxy p
ppr Proxy ms
pms GrpcClient
client
instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro s (s :-->: x) h)
         => BuildService pro s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
  buildService' :: Proxy pro
-> Proxy s
-> Proxy p
-> Proxy ms
-> GrpcClient
-> S1 ('MetaSel ('Just m) u ss ds) (K1 i h) a
buildService' ppro :: Proxy pro
ppro ps :: Proxy s
ps _ _ client :: GrpcClient
client
    = K1 i h a -> S1 ('MetaSel ('Just m) u ss ds) (K1 i h) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i h a -> S1 ('MetaSel ('Just m) u ss ds) (K1 i h) a)
-> K1 i h a -> S1 ('MetaSel ('Just m) u ss ds) (K1 i h) a
forall a b. (a -> b) -> a -> b
$ h -> K1 i h a
forall k i c (p :: k). c -> K1 i c p
K1 (h -> K1 i h a) -> h -> K1 i h a
forall a b. (a -> b) -> a -> b
$ Proxy pro -> Proxy s -> Proxy (s :-->: x) -> GrpcClient -> h
forall snm mnm (p :: GRpcMessageProtocol) (s :: Service snm mnm)
       (m :: Method mnm) h.
GRpcServiceMethodCall p s m h =>
Proxy p -> Proxy s -> Proxy m -> GrpcClient -> h
gRpcServiceMethodCall Proxy pro
ppro Proxy s
ps (Proxy (s :-->: x)
forall k (t :: k). Proxy t
Proxy @(s :-->: x)) GrpcClient
client

-- TEMPLATE HASKELL
-- ================

-- | Generate the plain Haskell record corresponding to
--   a Mu 'Service' definition, and a concrete implementation
--   of 'buildService' for that record.
generateRecordFromService :: String -> String -> Namer -> Name -> Q [Dec]
generateRecordFromService :: [Char] -> [Char] -> Namer -> Name -> Q [Dec]
generateRecordFromService newRecordName :: [Char]
newRecordName fieldsPrefix :: [Char]
fieldsPrefix tNamer :: Namer
tNamer serviceTyName :: Name
serviceTyName
  = do let serviceTy :: Type
serviceTy = Name -> Type
ConT Name
serviceTyName
       Maybe (Service [Char] [Char])
srvDef <- Type -> Q (Maybe (Service [Char] [Char]))
typeToServiceDef Type
serviceTy
       case Maybe (Service [Char] [Char])
srvDef of
         Nothing -> [Char] -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "service definition cannot be parsed"
         Just sd :: Service [Char] [Char]
sd -> Name
-> [Char] -> [Char] -> Namer -> Service [Char] [Char] -> Q [Dec]
serviceDefToDecl Name
serviceTyName [Char]
newRecordName [Char]
fieldsPrefix Namer
tNamer Service [Char] [Char]
sd

type Namer = String -> String

serviceDefToDecl :: Name -> String -> String -> Namer -> Service String String -> Q [Dec]
serviceDefToDecl :: Name
-> [Char] -> [Char] -> Namer -> Service [Char] [Char] -> Q [Dec]
serviceDefToDecl serviceTyName :: Name
serviceTyName complete :: [Char]
complete fieldsPrefix :: [Char]
fieldsPrefix tNamer :: Namer
tNamer (Service _ _ methods :: [Method [Char]]
methods)
  = do Dec
d <- CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                  ([Char] -> Name
mkName [Char]
complete)
                  []
                  Maybe Type
forall a. Maybe a
Nothing
                  [Name -> [VarBangType] -> Con
RecC ([Char] -> Name
mkName [Char]
complete) ([VarBangType] -> Con) -> Q [VarBangType] -> ConQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Method [Char] -> Q VarBangType)
-> [Method [Char]] -> Q [VarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> Namer -> Method [Char] -> Q VarBangType
methodToDecl [Char]
fieldsPrefix Namer
tNamer) [Method [Char]]
methods]
                  [DerivClause -> DerivClauseQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Generic])]
       let buildName :: Name
buildName = [Char] -> Name
mkName ("build" [Char] -> Namer
forall a. [a] -> [a] -> [a]
++ [Char]
complete)
       Dec
s <- Name -> Type -> Dec
SigD Name
buildName (Type -> Dec) -> Q Type -> DecQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|GrpcClient -> $(return (ConT (mkName complete)))|]
       Clause
c <- [Pat] -> Body -> [Dec] -> Clause
Clause ([Pat] -> Body -> [Dec] -> Clause)
-> Q [Pat] -> Q (Body -> [Dec] -> Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pat] -> Q [Pat]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                   Q (Body -> [Dec] -> Clause) -> Q Body -> Q ([Dec] -> Clause)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> Body
NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|buildService @($(return $ ConT serviceTyName))
                                                    @($(return $ LitT (StrTyLit fieldsPrefix)))|])
                   Q ([Dec] -> Clause) -> Q [Dec] -> Q Clause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
       [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
d, Dec
s, Name -> [Clause] -> Dec
FunD Name
buildName [Clause
c]]

methodToDecl :: String -> Namer -> Method String -> Q (Name, Bang, Type)
methodToDecl :: [Char] -> Namer -> Method [Char] -> Q VarBangType
methodToDecl fieldsPrefix :: [Char]
fieldsPrefix tNamer :: Namer
tNamer (Method mName :: [Char]
mName _ args :: [Argument]
args ret :: Return
ret)
  = do let nm :: [Char]
nm = Namer
firstLower ([Char]
fieldsPrefix [Char] -> Namer
forall a. [a] -> [a] -> [a]
++ [Char]
mName)
       Type
ty <- Namer -> [Argument] -> Return -> Q Type
computeMethodType Namer
tNamer [Argument]
args Return
ret
       VarBangType -> Q VarBangType
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Char] -> Name
mkName [Char]
nm, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
ty )

computeMethodType :: Namer -> [Argument] -> Return -> Q Type
computeMethodType :: Namer -> [Argument] -> Return -> Q Type
computeMethodType _ [] RetNothing
  = [t|IO (GRpcReply ())|]
computeMethodType n :: Namer
n [] (RetSingle r :: TypeRef
r)
  = [t|IO (GRpcReply $(typeRefToType n r))|]
computeMethodType n :: Namer
n [ArgSingle v :: TypeRef
v] RetNothing
  = [t|$(typeRefToType n v) -> IO (GRpcReply ())|]
computeMethodType n :: Namer
n [ArgSingle v :: TypeRef
v] (RetSingle r :: TypeRef
r)
  = [t|$(typeRefToType n v) -> IO (GRpcReply $(typeRefToType n r))|]
computeMethodType n :: Namer
n [ArgStream v :: TypeRef
v] (RetSingle r :: TypeRef
r)
  = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) Void IO (GRpcReply $(typeRefToType n r)))|]
computeMethodType n :: Namer
n [ArgSingle v :: TypeRef
v] (RetStream r :: TypeRef
r)
  = [t|$(typeRefToType n v) -> IO (ConduitT () (GRpcReply $(typeRefToType n r)) IO ())|]
computeMethodType n :: Namer
n [ArgStream v :: TypeRef
v] (RetStream r :: TypeRef
r)
  = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|]
computeMethodType _ _ _ = [Char] -> Q Type
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "method signature not supported"

typeRefToType :: Namer -> TypeRef -> Q Type
typeRefToType :: Namer -> TypeRef -> Q Type
typeRefToType tNamer :: Namer
tNamer (ViaTH (LitT (StrTyLit s :: [Char]
s)))
  = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ([Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Namer -> Namer
completeName Namer
tNamer [Char]
s)
typeRefToType _tNamer :: Namer
_tNamer (ViaTH ty :: Type
ty)
  = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
typeRefToType _ _ = [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error "this should never happen"

completeName :: Namer -> String -> String
completeName :: Namer -> Namer
completeName namer :: Namer
namer name :: [Char]
name = Namer
firstUpper (Namer
namer (Namer
firstUpper [Char]
name))

firstUpper :: String -> String
firstUpper :: Namer
firstUpper []       = Namer
forall a. HasCallStack => [Char] -> a
error "Empty names are not allowed"
firstUpper (x :: Char
x:rest :: [Char]
rest) = Char -> Char
toUpper Char
x Char -> Namer
forall a. a -> [a] -> [a]
: [Char]
rest

firstLower :: String -> String
firstLower :: Namer
firstLower []       = Namer
forall a. HasCallStack => [Char] -> a
error "Empty names are not allowed"
firstLower (x :: Char
x:rest :: [Char]
rest) = Char -> Char
toLower Char
x Char -> Namer
forall a. a -> [a] -> [a]
: [Char]
rest

-- Parsing
-- =======

typeToServiceDef :: Type -> Q (Maybe (Service String String))
typeToServiceDef :: Type -> Q (Maybe (Service [Char] [Char]))
typeToServiceDef toplevelty :: Type
toplevelty
  = Type -> Maybe (Service [Char] [Char])
typeToServiceDef' (Type -> Maybe (Service [Char] [Char]))
-> Q Type -> Q (Maybe (Service [Char] [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
toplevelty
  where
    typeToServiceDef' :: Type -> Maybe (Service String String)
    typeToServiceDef' :: Type -> Maybe (Service [Char] [Char])
typeToServiceDef' expanded :: Type
expanded
      = do (sn :: Type
sn, _, methods :: Type
methods) <- Name -> Type -> Maybe (Type, Type, Type)
tyD3 'Service Type
expanded
           [Type]
methods' <- Type -> Maybe [Type]
tyList Type
methods
           [Char] -> [*] -> [Method [Char]] -> Service [Char] [Char]
forall serviceName methodName.
serviceName
-> [*] -> [Method methodName] -> Service serviceName methodName
Service ([Char] -> [*] -> [Method [Char]] -> Service [Char] [Char])
-> Maybe [Char]
-> Maybe ([*] -> [Method [Char]] -> Service [Char] [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Char]
tyString Type
sn
                   Maybe ([*] -> [Method [Char]] -> Service [Char] [Char])
-> Maybe [*] -> Maybe ([Method [Char]] -> Service [Char] [Char])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [*] -> Maybe [*]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                   Maybe ([Method [Char]] -> Service [Char] [Char])
-> Maybe [Method [Char]] -> Maybe (Service [Char] [Char])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Maybe (Method [Char])) -> [Type] -> Maybe [Method [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Maybe (Method [Char])
typeToMethodDef [Type]
methods'

    typeToMethodDef :: Type -> Maybe (Method String)
    typeToMethodDef :: Type -> Maybe (Method [Char])
typeToMethodDef ty :: Type
ty
      = do (mn :: Type
mn, _, args :: Type
args, ret :: Type
ret) <- Name -> Type -> Maybe (Type, Type, Type, Type)
tyD4 'Method Type
ty
           [Type]
args' <- Type -> Maybe [Type]
tyList Type
args
           [Char] -> [*] -> [Argument] -> Return -> Method [Char]
forall methodName.
methodName -> [*] -> [Argument] -> Return -> Method methodName
Method ([Char] -> [*] -> [Argument] -> Return -> Method [Char])
-> Maybe [Char]
-> Maybe ([*] -> [Argument] -> Return -> Method [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Char]
tyString Type
mn
                  Maybe ([*] -> [Argument] -> Return -> Method [Char])
-> Maybe [*] -> Maybe ([Argument] -> Return -> Method [Char])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [*] -> Maybe [*]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                  Maybe ([Argument] -> Return -> Method [Char])
-> Maybe [Argument] -> Maybe (Return -> Method [Char])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Maybe Argument) -> [Type] -> Maybe [Argument]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Maybe Argument
typeToArgDef [Type]
args'
                  Maybe (Return -> Method [Char])
-> Maybe Return -> Maybe (Method [Char])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Return
typeToRetDef Type
ret

    typeToArgDef :: Type -> Maybe Argument
    typeToArgDef :: Type -> Maybe Argument
typeToArgDef ty :: Type
ty
      =   TypeRef -> Argument
ArgSingle (TypeRef -> Argument) -> Maybe TypeRef -> Maybe Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Type -> Maybe Type
tyD1 'ArgSingle Type
ty Maybe Type -> (Type -> Maybe TypeRef) -> Maybe TypeRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe TypeRef
typeToTypeRef)
      Maybe Argument -> Maybe Argument -> Maybe Argument
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TypeRef -> Argument
ArgStream (TypeRef -> Argument) -> Maybe TypeRef -> Maybe Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Type -> Maybe Type
tyD1 'ArgStream Type
ty Maybe Type -> (Type -> Maybe TypeRef) -> Maybe TypeRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe TypeRef
typeToTypeRef)

    typeToRetDef :: Type -> Maybe Return
    typeToRetDef :: Type -> Maybe Return
typeToRetDef ty :: Type
ty
      =   Return
RetNothing Return -> Maybe () -> Maybe Return
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Type -> Maybe ()
tyD0 'RetNothing Type
ty
      Maybe Return -> Maybe Return -> Maybe Return
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TypeRef -> Return
RetSingle (TypeRef -> Return) -> Maybe TypeRef -> Maybe Return
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Type -> Maybe Type
tyD1 'RetSingle Type
ty Maybe Type -> (Type -> Maybe TypeRef) -> Maybe TypeRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe TypeRef
typeToTypeRef)
      Maybe Return -> Maybe Return -> Maybe Return
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do (e :: Type
e, v :: Type
v) <- Name -> Type -> Maybe (Type, Type)
tyD2 'RetThrows Type
ty
              TypeRef -> TypeRef -> Return
RetThrows (TypeRef -> TypeRef -> Return)
-> Maybe TypeRef -> Maybe (TypeRef -> Return)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe TypeRef
typeToTypeRef Type
e Maybe (TypeRef -> Return) -> Maybe TypeRef -> Maybe Return
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe TypeRef
typeToTypeRef Type
v)
      Maybe Return -> Maybe Return -> Maybe Return
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TypeRef -> Return
RetStream (TypeRef -> Return) -> Maybe TypeRef -> Maybe Return
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Type -> Maybe Type
tyD1 'RetStream Type
ty Maybe Type -> (Type -> Maybe TypeRef) -> Maybe TypeRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe TypeRef
typeToTypeRef)

    typeToTypeRef :: Type -> Maybe TypeRef
    typeToTypeRef :: Type -> Maybe TypeRef
typeToTypeRef ty :: Type
ty
      =   (do (_,innerTy :: Type
innerTy) <- Name -> Type -> Maybe (Type, Type)
tyD2 'ViaSchema Type
ty
              TypeRef -> Maybe TypeRef
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeRef
ViaTH Type
innerTy))
      Maybe TypeRef -> Maybe TypeRef -> Maybe TypeRef
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do (_,innerTy :: Type
innerTy,_) <- Name -> Type -> Maybe (Type, Type, Type)
tyD3 'ViaRegistry Type
ty
              TypeRef -> Maybe TypeRef
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeRef
ViaTH Type
innerTy))

tyString :: Type -> Maybe String
tyString :: Type -> Maybe [Char]
tyString (SigT t :: Type
t _)
  = Type -> Maybe [Char]
tyString Type
t
tyString (LitT (StrTyLit s :: [Char]
s))
  = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s
tyString _
  = Maybe [Char]
forall a. Maybe a
Nothing

tyList :: Type -> Maybe [Type]
tyList :: Type -> Maybe [Type]
tyList (SigT t :: Type
t _)
  = Type -> Maybe [Type]
tyList Type
t
tyList PromotedNilT
  = [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []
tyList (AppT (AppT PromotedConsT ty :: Type
ty) rest :: Type
rest)
  = (Type
ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([Type] -> [Type]) -> Maybe [Type] -> Maybe [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Type]
tyList Type
rest
tyList _ = Maybe [Type]
forall a. Maybe a
Nothing

tyD0 :: Name -> Type -> Maybe ()
tyD0 :: Name -> Type -> Maybe ()
tyD0 name :: Name
name (SigT t :: Type
t _) = Name -> Type -> Maybe ()
tyD0 Name
name Type
t
tyD0 name :: Name
name (PromotedT c :: Name
c)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = () -> Maybe ()
forall a. a -> Maybe a
Just ()
  | Bool
otherwise = Maybe ()
forall a. Maybe a
Nothing
tyD0 _ _ = Maybe ()
forall a. Maybe a
Nothing

tyD1 :: Name -> Type -> Maybe Type
tyD1 :: Name -> Type -> Maybe Type
tyD1 name :: Name
name (SigT t :: Type
t _) = Name -> Type -> Maybe Type
tyD1 Name
name Type
t
tyD1 name :: Name
name (AppT (PromotedT c :: Name
c) x :: Type
x)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
x
  | Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
tyD1 _ _ = Maybe Type
forall a. Maybe a
Nothing

tyD2 :: Name -> Type -> Maybe (Type, Type)
tyD2 :: Name -> Type -> Maybe (Type, Type)
tyD2 name :: Name
name (SigT t :: Type
t _) = Name -> Type -> Maybe (Type, Type)
tyD2 Name
name Type
t
tyD2 name :: Name
name (AppT (AppT (PromotedT c :: Name
c) x :: Type
x) y :: Type
y)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
x, Type
y)
  | Bool
otherwise = Maybe (Type, Type)
forall a. Maybe a
Nothing
tyD2 _ _ = Maybe (Type, Type)
forall a. Maybe a
Nothing

tyD3 :: Name -> Type -> Maybe (Type, Type, Type)
tyD3 :: Name -> Type -> Maybe (Type, Type, Type)
tyD3 name :: Name
name (SigT t :: Type
t _) = Name -> Type -> Maybe (Type, Type, Type)
tyD3 Name
name Type
t
tyD3 name :: Name
name (AppT (AppT (AppT (PromotedT c :: Name
c) x :: Type
x) y :: Type
y) z :: Type
z)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = (Type, Type, Type) -> Maybe (Type, Type, Type)
forall a. a -> Maybe a
Just (Type
x, Type
y, Type
z)
  | Bool
otherwise = Maybe (Type, Type, Type)
forall a. Maybe a
Nothing
tyD3 _ _ = Maybe (Type, Type, Type)
forall a. Maybe a
Nothing

tyD4 :: Name -> Type -> Maybe (Type, Type, Type, Type)
tyD4 :: Name -> Type -> Maybe (Type, Type, Type, Type)
tyD4 name :: Name
name (SigT t :: Type
t _) = Name -> Type -> Maybe (Type, Type, Type, Type)
tyD4 Name
name Type
t
tyD4 name :: Name
name (AppT (AppT (AppT (AppT (PromotedT c :: Name
c) x :: Type
x) y :: Type
y) z :: Type
z) u :: Type
u)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = (Type, Type, Type, Type) -> Maybe (Type, Type, Type, Type)
forall a. a -> Maybe a
Just (Type
x, Type
y, Type
z, Type
u)
  | Bool
otherwise = Maybe (Type, Type, Type, Type)
forall a. Maybe a
Nothing
tyD4 _ _ = Maybe (Type, Type, Type, Type)
forall a. Maybe a
Nothing