{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module BtcLsp.Grpc.Combinator
  ( fromReqT,
    fromReqE,
    newGenFailure,
    newSpecFailure,
    newInternalFailure,
    throwSpec,
    mkFieldLocation,
    GrpcReq,
    GrpcRes,
  )
where

import BtcLsp.Data.Type
import BtcLsp.Import.External as Ext
import Data.Map as Map
import Data.ProtoLens.Field
import Data.ProtoLens.Message
import Data.Text as T
import Language.Haskell.TH.Syntax as TH
import qualified Proto.BtcLsp.Data.HighLevel as Proto
import qualified Proto.BtcLsp.Data.HighLevel_Fields as Proto
import qualified Universum
import qualified Witch

type GrpcReq req =
  ( HasField req "maybe'ctx" (Maybe Proto.Ctx)
  )

type GrpcRes res failure specific =
  ( HasField res "ctx" Proto.Ctx,
    HasField res "failure" failure,
    HasField failure "generic" [Proto.InputFailure],
    HasField failure "specific" [specific],
    HasField failure "internal" [Proto.InternalFailure],
    Message res,
    Message failure
  )

fromReqT ::
  forall a b res failure specific m.
  ( From a b,
    'False ~ (a == b),
    GrpcRes res failure specific,
    Monad m
  ) =>
  ReversedFieldLocation ->
  Maybe a ->
  ExceptT res m b
fromReqT :: forall a b res failure specific (m :: * -> *).
(From a b, 'False ~ (a == b), GrpcRes res failure specific,
 Monad m) =>
ReversedFieldLocation -> Maybe a -> ExceptT res m b
fromReqT ReversedFieldLocation
loc =
  Either res b -> ExceptT res m b
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
    (Either res b -> ExceptT res m b)
-> (Maybe a -> Either res b) -> Maybe a -> ExceptT res m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReversedFieldLocation -> Maybe a -> Either res b
forall a b res failure specific.
(From a b, 'False ~ (a == b), GrpcRes res failure specific) =>
ReversedFieldLocation -> Maybe a -> Either res b
fromReqE ReversedFieldLocation
loc

fromReqE ::
  forall a b res failure specific.
  ( From a b,
    'False ~ (a == b),
    GrpcRes res failure specific
  ) =>
  ReversedFieldLocation ->
  Maybe a ->
  Either res b
fromReqE :: forall a b res failure specific.
(From a b, 'False ~ (a == b), GrpcRes res failure specific) =>
ReversedFieldLocation -> Maybe a -> Either res b
fromReqE ReversedFieldLocation
loc =
  (a -> b
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from (a -> b) -> Either res a -> Either res b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    (Either res a -> Either res b)
-> (Maybe a -> Either res a) -> Maybe a -> Either res b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res -> Maybe a -> Either res a
forall l r. l -> Maybe r -> Either l r
maybeToRight res
msg
  where
    msg :: res
msg =
      res
forall msg. Message msg => msg
defMessage
        res -> (res -> res) -> res
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"failure"
          ((failure -> Identity failure) -> res -> Identity res)
-> failure -> res -> res
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( failure
forall msg. Message msg => msg
defMessage
                 failure -> (failure -> failure) -> failure
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"generic"
                   (([InputFailure] -> Identity [InputFailure])
 -> failure -> Identity failure)
-> [InputFailure] -> failure -> failure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ InputFailure
forall msg. Message msg => msg
defMessage
                          InputFailure -> (InputFailure -> InputFailure) -> InputFailure
forall a b. a -> (a -> b) -> b
& LensLike' Identity InputFailure [FieldIndex]
forall (f :: * -> *) s a.
(Functor f, HasField s "fieldLocation" a) =>
LensLike' f s a
Proto.fieldLocation LensLike' Identity InputFailure [FieldIndex]
-> [FieldIndex] -> InputFailure -> InputFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReversedFieldLocation -> [FieldIndex]
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from ReversedFieldLocation
loc
                          InputFailure -> (InputFailure -> InputFailure) -> InputFailure
forall a b. a -> (a -> b) -> b
& LensLike' Identity InputFailure InputFailureKind
forall (f :: * -> *) s a.
(Functor f, HasField s "kind" a) =>
LensLike' f s a
Proto.kind LensLike' Identity InputFailure InputFailureKind
-> InputFailureKind -> InputFailure -> InputFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InputFailureKind
Proto.REQUIRED
                      ]
             )

newGenFailure ::
  forall res failure specific.
  ( GrpcRes res failure specific
  ) =>
  Proto.InputFailureKind ->
  ReversedFieldLocation ->
  res
newGenFailure :: forall res failure specific.
GrpcRes res failure specific =>
InputFailureKind -> ReversedFieldLocation -> res
newGenFailure InputFailureKind
kind ReversedFieldLocation
loc =
  res
forall msg. Message msg => msg
defMessage
    res -> (res -> res) -> res
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"failure"
      ((failure -> Identity failure) -> res -> Identity res)
-> failure -> res -> res
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( failure
forall msg. Message msg => msg
defMessage
             failure -> (failure -> failure) -> failure
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"generic"
               (([InputFailure] -> Identity [InputFailure])
 -> failure -> Identity failure)
-> [InputFailure] -> failure -> failure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ InputFailure
forall msg. Message msg => msg
defMessage
                      InputFailure -> (InputFailure -> InputFailure) -> InputFailure
forall a b. a -> (a -> b) -> b
& LensLike' Identity InputFailure [FieldIndex]
forall (f :: * -> *) s a.
(Functor f, HasField s "fieldLocation" a) =>
LensLike' f s a
Proto.fieldLocation LensLike' Identity InputFailure [FieldIndex]
-> [FieldIndex] -> InputFailure -> InputFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReversedFieldLocation -> [FieldIndex]
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from ReversedFieldLocation
loc
                      InputFailure -> (InputFailure -> InputFailure) -> InputFailure
forall a b. a -> (a -> b) -> b
& LensLike' Identity InputFailure InputFailureKind
forall (f :: * -> *) s a.
(Functor f, HasField s "kind" a) =>
LensLike' f s a
Proto.kind LensLike' Identity InputFailure InputFailureKind
-> InputFailureKind -> InputFailure -> InputFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InputFailureKind
kind
                  ]
         )

newSpecFailure ::
  forall res failure specific.
  ( GrpcRes res failure specific
  ) =>
  specific ->
  res
newSpecFailure :: forall res failure specific.
GrpcRes res failure specific =>
specific -> res
newSpecFailure specific
spec =
  res
forall msg. Message msg => msg
defMessage
    res -> (res -> res) -> res
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"failure"
      ((failure -> Identity failure) -> res -> Identity res)
-> failure -> res -> res
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( failure
forall msg. Message msg => msg
defMessage
             failure -> (failure -> failure) -> failure
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"specific"
               (([specific] -> Identity [specific])
 -> failure -> Identity failure)
-> [specific] -> failure -> failure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ specific
spec
                  ]
         )

newInternalFailure ::
  forall res failure specific.
  ( GrpcRes res failure specific
  ) =>
  FailureInternal ->
  res
newInternalFailure :: forall res failure specific.
GrpcRes res failure specific =>
FailureInternal -> res
newInternalFailure FailureInternal
hFailure =
  res
forall msg. Message msg => msg
defMessage
    res -> (res -> res) -> res
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"failure"
      ((failure -> Identity failure) -> res -> Identity res)
-> failure -> res -> res
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( failure
forall msg. Message msg => msg
defMessage
             failure -> (failure -> failure) -> failure
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"internal"
               (([InternalFailure] -> Identity [InternalFailure])
 -> failure -> Identity failure)
-> [InternalFailure] -> failure -> failure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ InternalFailure
gFailure
                  ]
         )
  where
    gFailure :: InternalFailure
gFailure =
      InternalFailure
forall msg. Message msg => msg
defMessage
        InternalFailure
-> (InternalFailure -> InternalFailure) -> InternalFailure
forall a b. a -> (a -> b) -> b
& case FailureInternal
hFailure of
          FailureGrpcServer Text
x -> LensLike' Identity InternalFailure Text
forall (f :: * -> *) s a.
(Functor f, HasField s "grpcServer" a) =>
LensLike' f s a
Proto.grpcServer LensLike' Identity InternalFailure Text
-> Text -> InternalFailure -> InternalFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
x
          FailureGrpcClient {} -> LensLike' Identity InternalFailure Bool
forall (f :: * -> *) s a.
(Functor f, HasField s "redacted" a) =>
LensLike' f s a
Proto.redacted LensLike' Identity InternalFailure Bool
-> Bool -> InternalFailure -> InternalFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
          FailureMath Text
x -> LensLike' Identity InternalFailure Text
forall (f :: * -> *) s a.
(Functor f, HasField s "math" a) =>
LensLike' f s a
Proto.math LensLike' Identity InternalFailure Text
-> Text -> InternalFailure -> InternalFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
x
          FailurePrivate {} -> LensLike' Identity InternalFailure Bool
forall (f :: * -> *) s a.
(Functor f, HasField s "redacted" a) =>
LensLike' f s a
Proto.redacted LensLike' Identity InternalFailure Bool
-> Bool -> InternalFailure -> InternalFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
          FailureInternal
FailureRedacted -> LensLike' Identity InternalFailure Bool
forall (f :: * -> *) s a.
(Functor f, HasField s "redacted" a) =>
LensLike' f s a
Proto.redacted LensLike' Identity InternalFailure Bool
-> Bool -> InternalFailure -> InternalFailure
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True

throwSpec ::
  forall a res failure specific m.
  ( GrpcRes res failure specific,
    Monad m
  ) =>
  specific ->
  ExceptT res m a
throwSpec :: forall a res failure specific (m :: * -> *).
(GrpcRes res failure specific, Monad m) =>
specific -> ExceptT res m a
throwSpec =
  res -> ExceptT res m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (res -> ExceptT res m a)
-> (specific -> res) -> specific -> ExceptT res m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. specific -> res
forall res failure specific.
GrpcRes res failure specific =>
specific -> res
newSpecFailure

--
-- TH FieldIndex combinators
--

newtype FieldIndex
  = FieldIndex Word32
  deriving newtype
    ( FieldIndex -> FieldIndex -> Bool
(FieldIndex -> FieldIndex -> Bool)
-> (FieldIndex -> FieldIndex -> Bool) -> Eq FieldIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldIndex -> FieldIndex -> Bool
$c/= :: FieldIndex -> FieldIndex -> Bool
== :: FieldIndex -> FieldIndex -> Bool
$c== :: FieldIndex -> FieldIndex -> Bool
Eq,
      Eq FieldIndex
Eq FieldIndex
-> (FieldIndex -> FieldIndex -> Ordering)
-> (FieldIndex -> FieldIndex -> Bool)
-> (FieldIndex -> FieldIndex -> Bool)
-> (FieldIndex -> FieldIndex -> Bool)
-> (FieldIndex -> FieldIndex -> Bool)
-> (FieldIndex -> FieldIndex -> FieldIndex)
-> (FieldIndex -> FieldIndex -> FieldIndex)
-> Ord FieldIndex
FieldIndex -> FieldIndex -> Bool
FieldIndex -> FieldIndex -> Ordering
FieldIndex -> FieldIndex -> FieldIndex
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FieldIndex -> FieldIndex -> FieldIndex
$cmin :: FieldIndex -> FieldIndex -> FieldIndex
max :: FieldIndex -> FieldIndex -> FieldIndex
$cmax :: FieldIndex -> FieldIndex -> FieldIndex
>= :: FieldIndex -> FieldIndex -> Bool
$c>= :: FieldIndex -> FieldIndex -> Bool
> :: FieldIndex -> FieldIndex -> Bool
$c> :: FieldIndex -> FieldIndex -> Bool
<= :: FieldIndex -> FieldIndex -> Bool
$c<= :: FieldIndex -> FieldIndex -> Bool
< :: FieldIndex -> FieldIndex -> Bool
$c< :: FieldIndex -> FieldIndex -> Bool
compare :: FieldIndex -> FieldIndex -> Ordering
$ccompare :: FieldIndex -> FieldIndex -> Ordering
Ord,
      Int -> FieldIndex -> ShowS
[FieldIndex] -> ShowS
FieldIndex -> String
(Int -> FieldIndex -> ShowS)
-> (FieldIndex -> String)
-> ([FieldIndex] -> ShowS)
-> Show FieldIndex
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldIndex] -> ShowS
$cshowList :: [FieldIndex] -> ShowS
show :: FieldIndex -> String
$cshow :: FieldIndex -> String
showsPrec :: Int -> FieldIndex -> ShowS
$cshowsPrec :: Int -> FieldIndex -> ShowS
Show
    )
  deriving stock
    ( (forall (m :: * -> *). Quote m => FieldIndex -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    FieldIndex -> Code m FieldIndex)
-> Lift FieldIndex
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => FieldIndex -> m Exp
forall (m :: * -> *). Quote m => FieldIndex -> Code m FieldIndex
liftTyped :: forall (m :: * -> *). Quote m => FieldIndex -> Code m FieldIndex
$cliftTyped :: forall (m :: * -> *). Quote m => FieldIndex -> Code m FieldIndex
lift :: forall (m :: * -> *). Quote m => FieldIndex -> m Exp
$clift :: forall (m :: * -> *). Quote m => FieldIndex -> m Exp
TH.Lift
    )

newtype ReversedFieldLocation
  = ReversedFieldLocation [FieldIndex]
  deriving newtype
    ( ReversedFieldLocation -> ReversedFieldLocation -> Bool
(ReversedFieldLocation -> ReversedFieldLocation -> Bool)
-> (ReversedFieldLocation -> ReversedFieldLocation -> Bool)
-> Eq ReversedFieldLocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
$c/= :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
== :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
$c== :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
Eq,
      Eq ReversedFieldLocation
Eq ReversedFieldLocation
-> (ReversedFieldLocation -> ReversedFieldLocation -> Ordering)
-> (ReversedFieldLocation -> ReversedFieldLocation -> Bool)
-> (ReversedFieldLocation -> ReversedFieldLocation -> Bool)
-> (ReversedFieldLocation -> ReversedFieldLocation -> Bool)
-> (ReversedFieldLocation -> ReversedFieldLocation -> Bool)
-> (ReversedFieldLocation
    -> ReversedFieldLocation -> ReversedFieldLocation)
-> (ReversedFieldLocation
    -> ReversedFieldLocation -> ReversedFieldLocation)
-> Ord ReversedFieldLocation
ReversedFieldLocation -> ReversedFieldLocation -> Bool
ReversedFieldLocation -> ReversedFieldLocation -> Ordering
ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
$cmin :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
max :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
$cmax :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
>= :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
$c>= :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
> :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
$c> :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
<= :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
$c<= :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
< :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
$c< :: ReversedFieldLocation -> ReversedFieldLocation -> Bool
compare :: ReversedFieldLocation -> ReversedFieldLocation -> Ordering
$ccompare :: ReversedFieldLocation -> ReversedFieldLocation -> Ordering
Ord,
      Int -> ReversedFieldLocation -> ShowS
[ReversedFieldLocation] -> ShowS
ReversedFieldLocation -> String
(Int -> ReversedFieldLocation -> ShowS)
-> (ReversedFieldLocation -> String)
-> ([ReversedFieldLocation] -> ShowS)
-> Show ReversedFieldLocation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReversedFieldLocation] -> ShowS
$cshowList :: [ReversedFieldLocation] -> ShowS
show :: ReversedFieldLocation -> String
$cshow :: ReversedFieldLocation -> String
showsPrec :: Int -> ReversedFieldLocation -> ShowS
$cshowsPrec :: Int -> ReversedFieldLocation -> ShowS
Show,
      NonEmpty ReversedFieldLocation -> ReversedFieldLocation
ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
(ReversedFieldLocation
 -> ReversedFieldLocation -> ReversedFieldLocation)
-> (NonEmpty ReversedFieldLocation -> ReversedFieldLocation)
-> (forall b.
    Integral b =>
    b -> ReversedFieldLocation -> ReversedFieldLocation)
-> Semigroup ReversedFieldLocation
forall b.
Integral b =>
b -> ReversedFieldLocation -> ReversedFieldLocation
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b.
Integral b =>
b -> ReversedFieldLocation -> ReversedFieldLocation
$cstimes :: forall b.
Integral b =>
b -> ReversedFieldLocation -> ReversedFieldLocation
sconcat :: NonEmpty ReversedFieldLocation -> ReversedFieldLocation
$csconcat :: NonEmpty ReversedFieldLocation -> ReversedFieldLocation
<> :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
$c<> :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
Semigroup,
      Semigroup ReversedFieldLocation
ReversedFieldLocation
Semigroup ReversedFieldLocation
-> ReversedFieldLocation
-> (ReversedFieldLocation
    -> ReversedFieldLocation -> ReversedFieldLocation)
-> ([ReversedFieldLocation] -> ReversedFieldLocation)
-> Monoid ReversedFieldLocation
[ReversedFieldLocation] -> ReversedFieldLocation
ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ReversedFieldLocation] -> ReversedFieldLocation
$cmconcat :: [ReversedFieldLocation] -> ReversedFieldLocation
mappend :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
$cmappend :: ReversedFieldLocation
-> ReversedFieldLocation -> ReversedFieldLocation
mempty :: ReversedFieldLocation
$cmempty :: ReversedFieldLocation
Monoid
    )
  deriving stock
    ( (forall (m :: * -> *). Quote m => ReversedFieldLocation -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    ReversedFieldLocation -> Code m ReversedFieldLocation)
-> Lift ReversedFieldLocation
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => ReversedFieldLocation -> m Exp
forall (m :: * -> *).
Quote m =>
ReversedFieldLocation -> Code m ReversedFieldLocation
liftTyped :: forall (m :: * -> *).
Quote m =>
ReversedFieldLocation -> Code m ReversedFieldLocation
$cliftTyped :: forall (m :: * -> *).
Quote m =>
ReversedFieldLocation -> Code m ReversedFieldLocation
lift :: forall (m :: * -> *). Quote m => ReversedFieldLocation -> m Exp
$clift :: forall (m :: * -> *). Quote m => ReversedFieldLocation -> m Exp
TH.Lift
    )

instance From ReversedFieldLocation [Proto.FieldIndex] where
  from :: ReversedFieldLocation -> [FieldIndex]
from (ReversedFieldLocation [FieldIndex]
xs) =
    ( \FieldIndex
x ->
        FieldIndex
forall msg. Message msg => msg
defMessage
          FieldIndex -> (FieldIndex -> FieldIndex) -> FieldIndex
forall a b. a -> (a -> b) -> b
& LensLike' Identity FieldIndex Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "val" a) =>
LensLike' f s a
Proto.val LensLike' Identity FieldIndex Word32
-> Word32 -> FieldIndex -> FieldIndex
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldIndex -> Word32
coerce FieldIndex
x
    )
      (FieldIndex -> FieldIndex) -> [FieldIndex] -> [FieldIndex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldIndex] -> [FieldIndex]
forall a. [a] -> [a]
Ext.reverse [FieldIndex]
xs

mkFieldLocation ::
  forall a.
  ( Message a
  ) =>
  [String] ->
  Q Exp
mkFieldLocation :: forall a. Message a => [String] -> Q Exp
mkFieldLocation [String]
ns =
  [|
    $(mkPushFieldIndexes @a ns) $
      ReversedFieldLocation []
    |]

mkPushFieldIndexes ::
  forall a.
  ( Message a
  ) =>
  [String] ->
  Q Exp
mkPushFieldIndexes :: forall a. Message a => [String] -> Q Exp
mkPushFieldIndexes [String]
ns = do
  ReversedFieldLocation
addLoc <- forall a (m :: * -> *).
(Message a, MonadFail m) =>
[String] -> m ReversedFieldLocation
getFieldLocation @a [String]
ns
  [|(<>) $(TH.lift addLoc)|]

getFieldLocation ::
  forall a m.
  ( Message a,
    MonadFail m
  ) =>
  [String] ->
  m ReversedFieldLocation
getFieldLocation :: forall a (m :: * -> *).
(Message a, MonadFail m) =>
[String] -> m ReversedFieldLocation
getFieldLocation =
  ([FieldIndex] -> ReversedFieldLocation
ReversedFieldLocation ([FieldIndex] -> ReversedFieldLocation)
-> m [FieldIndex] -> m ReversedFieldLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    (m [FieldIndex] -> m ReversedFieldLocation)
-> ([String] -> m [FieldIndex])
-> [String]
-> m ReversedFieldLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(Message a, MonadFail m) =>
[FieldIndex] -> [String] -> m [FieldIndex]
getFieldLocation0 @a []

getFieldLocation0 ::
  forall a m.
  ( Message a,
    MonadFail m
  ) =>
  [FieldIndex] ->
  [String] ->
  m [FieldIndex]
getFieldLocation0 :: forall a (m :: * -> *).
(Message a, MonadFail m) =>
[FieldIndex] -> [String] -> m [FieldIndex]
getFieldLocation0 [FieldIndex]
acc0 [] = [FieldIndex] -> m [FieldIndex]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FieldIndex]
acc0
getFieldLocation0 [FieldIndex]
acc0 (String
n : [String]
ns) =
  case (Element [(Tag, FieldDescriptor a)] -> Bool)
-> [(Tag, FieldDescriptor a)]
-> Maybe (Element [(Tag, FieldDescriptor a)])
forall t.
Container t =>
(Element t -> Bool) -> t -> Maybe (Element t)
Ext.find ((\(FieldDescriptor String
x FieldTypeDescriptor value
_ FieldAccessor a value
_) -> String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n) (FieldDescriptor a -> Bool)
-> ((Tag, FieldDescriptor a) -> FieldDescriptor a)
-> (Tag, FieldDescriptor a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag, FieldDescriptor a) -> FieldDescriptor a
forall a b. (a, b) -> b
snd) ([(Tag, FieldDescriptor a)]
 -> Maybe (Element [(Tag, FieldDescriptor a)]))
-> [(Tag, FieldDescriptor a)]
-> Maybe (Element [(Tag, FieldDescriptor a)])
forall a b. (a -> b) -> a -> b
$
    Map Tag (FieldDescriptor a) -> [(Tag, FieldDescriptor a)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Tag (FieldDescriptor a)
forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag :: Map Tag (FieldDescriptor a)) of
    Just (Tag
_, FieldDescriptor String
_ FieldTypeDescriptor value
_ MapField {}) ->
      String -> m [FieldIndex]
fieldFail
        String
"is MapField (not supported by current TH combinators)"
    Just (Tag
_, FieldDescriptor String
_ FieldTypeDescriptor value
_ RepeatedField {})
      | Bool -> Bool
not ([String] -> Bool
forall t. Container t => t -> Bool
Ext.null [String]
ns) ->
        String -> m [FieldIndex]
fieldFail
          String
"is RepeatedField and not last field in TH splice"
    Just (Tag
it, FieldDescriptor String
_ FieldTypeDescriptor value
ftd FieldAccessor a value
_) -> do
      [FieldIndex]
acc <- case Int -> Either (TryFromException Int Word32) Word32
forall source target.
(TryFrom source target, 'False ~ (source == target)) =>
source -> Either (TryFromException source target) target
tryFrom (Int -> Either (TryFromException Int Word32) Word32)
-> Int -> Either (TryFromException Int Word32) Word32
forall a b. (a -> b) -> a -> b
$ Tag -> Int
unTag Tag
it of
        Right Word32
x -> [FieldIndex] -> m [FieldIndex]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FieldIndex] -> m [FieldIndex]) -> [FieldIndex] -> m [FieldIndex]
forall a b. (a -> b) -> a -> b
$ Word32 -> FieldIndex
FieldIndex Word32
x FieldIndex -> [FieldIndex] -> [FieldIndex]
forall a. a -> [a] -> [a]
: [FieldIndex]
acc0
        Left TryFromException Int Word32
e ->
          String -> m [FieldIndex]
fieldFail (String -> m [FieldIndex]) -> String -> m [FieldIndex]
forall a b. (a -> b) -> a -> b
$
            String
"tag overflow "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TryFromException Int Word32 -> String
forall b a. (Show a, IsString b) => a -> b
Universum.show TryFromException Int Word32
e
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Tag -> String
forall b a. (Show a, IsString b) => a -> b
Universum.show Tag
it
      case FieldTypeDescriptor value
ftd of
        (MessageField {} :: FieldTypeDescriptor nextA) ->
          forall a (m :: * -> *).
(Message a, MonadFail m) =>
[FieldIndex] -> [String] -> m [FieldIndex]
getFieldLocation0 @nextA [FieldIndex]
acc [String]
ns
        ScalarField {} ->
          if [String] -> Bool
forall t. Container t => t -> Bool
Ext.null [String]
ns
            then [FieldIndex] -> m [FieldIndex]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FieldIndex]
acc
            else
              String -> m [FieldIndex]
fieldFail (String -> m [FieldIndex]) -> String -> m [FieldIndex]
forall a b. (a -> b) -> a -> b
$
                String
"scalar got extra tags "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Out a => a -> String
inspectStr [String]
ns
    Maybe (Element [(Tag, FieldDescriptor a)])
Nothing ->
      String -> m [FieldIndex]
fieldFail String
"not found"
  where
    msgName :: String
msgName =
      Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
        Proxy a -> Text
forall msg. Message msg => Proxy msg -> Text
messageName (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    fieldFail :: String -> m [FieldIndex]
fieldFail String
x =
      String -> m [FieldIndex]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [FieldIndex]) -> String -> m [FieldIndex]
forall a b. (a -> b) -> a -> b
$
        String
"Field " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msgName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x