{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Normal form of @google.protobuf.FieldMask@ paths, ported from
-- @addFieldPath@ and @toFieldMask@ of protobuf Java's @FieldMaskTree@.
--
-- Paths start at the response message. A path may continue through repeated
-- message fields and then applies to each element. Paths that do not resolve
-- are dropped whole. An absent or empty mask, or a @*@ path, selects everything.
-- A mask whose paths all drop selects nothing.
module Cardano.Rpc.Server.Internal.FieldMask
  ( FieldPath
  , FieldMaskTree (..)
  , PathTree (..)
  , applyFieldMask
  , FieldFill
  , runFill
  , runFillPure
  , fill
  , fillSub
  , fillFrom
  , isSelected
  , lensLabel
  , normalise
  , resolve
  , subMask
  , toPaths
  )
where

import RIO hiding (toList)

import Data.Char (isUpper)
import Data.List (find)
import Data.Map qualified as Map
import Data.Monoid (Ap (..), Endo (..))
import Data.ProtoLens.Field (HasField)
import Data.ProtoLens.Field qualified as Field (field)
import Data.ProtoLens.Message
  ( FieldAccessor (..)
  , FieldDefault (..)
  , FieldDescriptor (..)
  , FieldTypeDescriptor (..)
  , Message (..)
  , WireDefault (..)
  )
import Data.Text qualified as T
import GHC.Exts (IsList (toList))
import GHC.TypeLits (KnownSymbol, symbolVal)

-- | A dot-separated field mask path, as in @google.protobuf.FieldMask.paths@ (e.g. @values.cardano@).
type FieldPath = Text

-- | Normalised field mask paths. An empty map at a non-root node selects that
-- whole field.
newtype PathTree = PathTree (Map Text PathTree)
  deriving (PathTree -> PathTree -> Bool
(PathTree -> PathTree -> Bool)
-> (PathTree -> PathTree -> Bool) -> Eq PathTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathTree -> PathTree -> Bool
== :: PathTree -> PathTree -> Bool
$c/= :: PathTree -> PathTree -> Bool
/= :: PathTree -> PathTree -> Bool
Eq, Int -> PathTree -> ShowS
[PathTree] -> ShowS
PathTree -> String
(Int -> PathTree -> ShowS)
-> (PathTree -> String) -> ([PathTree] -> ShowS) -> Show PathTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PathTree -> ShowS
showsPrec :: Int -> PathTree -> ShowS
$cshow :: PathTree -> String
show :: PathTree -> String
$cshowList :: [PathTree] -> ShowS
showList :: [PathTree] -> ShowS
Show)

-- | Build a tree from dotted paths; a path below another is dropped, in any order.
-- Paths with an empty segment are dropped too (Java keeps some).
normalise
  :: [FieldPath]
  -- ^ Dotted field mask paths
  -> PathTree
normalise :: [Text] -> PathTree
normalise = (PathTree -> Text -> PathTree) -> PathTree -> [Text] -> PathTree
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PathTree -> Text -> PathTree
addPath (Map Text PathTree -> PathTree
PathTree Map Text PathTree
forall a. Monoid a => a
mempty)
 where
  addPath :: PathTree -> Text -> PathTree
addPath PathTree
tree Text
path
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
T.null [Text]
segments = PathTree
tree
    | Bool
otherwise = [Text] -> PathTree -> PathTree
addSegments [Text]
segments PathTree
tree
   where
    segments :: [Text]
segments = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
path

-- | The leaves of the tree as dotted paths, sorted ascending. A tree without
-- children has no paths.
toPaths
  :: PathTree
  -- ^ Normalised paths
  -> [FieldPath]
toPaths :: PathTree -> [Text]
toPaths (PathTree Map Text PathTree
children) = ((Text, PathTree) -> [Text]) -> [(Text, PathTree)] -> [Text]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Text
name, PathTree
child) -> [Text] -> PathTree -> [Text]
go [Text
name] PathTree
child) ([(Text, PathTree)] -> [Text]) -> [(Text, PathTree)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text PathTree -> [Item (Map Text PathTree)]
forall l. IsList l => l -> [Item l]
toList Map Text PathTree
children
 where
  go :: [Text] -> PathTree -> [Text]
go [Text]
reversedSegments (PathTree Map Text PathTree
subtree)
    | Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
subtree = [Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
reversedSegments]
    | Bool
otherwise = ((Text, PathTree) -> [Text]) -> [(Text, PathTree)] -> [Text]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Text
name, PathTree
child) -> [Text] -> PathTree -> [Text]
go (Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
reversedSegments) PathTree
child) ([(Text, PathTree)] -> [Text]) -> [(Text, PathTree)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text PathTree -> [Item (Map Text PathTree)]
forall l. IsList l => l -> [Item l]
toList Map Text PathTree
subtree

-- | Add a path below a node that is the root or has children.
addSegments
  :: [Text]
  -- ^ Segments of the path below the node
  -> PathTree
  -- ^ The node
  -> PathTree
addSegments :: [Text] -> PathTree -> PathTree
addSegments [] PathTree
_ = Map Text PathTree -> PathTree
PathTree Map Text PathTree
forall a. Monoid a => a
mempty
addSegments (Text
segment : [Text]
rest) (PathTree Map Text PathTree
children) =
  Map Text PathTree -> PathTree
PathTree (Map Text PathTree -> PathTree) -> Map Text PathTree -> PathTree
forall a b. (a -> b) -> a -> b
$ (Maybe PathTree -> Maybe PathTree)
-> Text -> Map Text PathTree -> Map Text PathTree
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (PathTree -> Maybe PathTree
forall a. a -> Maybe a
Just (PathTree -> Maybe PathTree)
-> (Maybe PathTree -> PathTree) -> Maybe PathTree -> Maybe PathTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTree -> (PathTree -> PathTree) -> Maybe PathTree -> PathTree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> PathTree -> PathTree
addSegments [Text]
rest (PathTree -> PathTree) -> PathTree -> PathTree
forall a b. (a -> b) -> a -> b
$ Map Text PathTree -> PathTree
PathTree Map Text PathTree
forall a. Monoid a => a
mempty) PathTree -> PathTree
extend) Text
segment Map Text PathTree
children
 where
  -- A leaf already selects every path below it.
  extend :: PathTree -> PathTree
extend child :: PathTree
child@(PathTree Map Text PathTree
grandchildren)
    | Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
grandchildren = PathTree
child
    | Bool
otherwise = [Text] -> PathTree -> PathTree
addSegments [Text]
rest PathTree
child

-- | A field mask resolved against the descriptors of @msg@.
data FieldMaskTree msg
  = -- | An absent or empty mask, or a @*@ path.
    SelectAll
  | -- | The paths that resolved. May be empty, which selects nothing.
    Select PathTree
  deriving (FieldMaskTree msg -> FieldMaskTree msg -> Bool
(FieldMaskTree msg -> FieldMaskTree msg -> Bool)
-> (FieldMaskTree msg -> FieldMaskTree msg -> Bool)
-> Eq (FieldMaskTree msg)
forall msg. FieldMaskTree msg -> FieldMaskTree msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall msg. FieldMaskTree msg -> FieldMaskTree msg -> Bool
== :: FieldMaskTree msg -> FieldMaskTree msg -> Bool
$c/= :: forall msg. FieldMaskTree msg -> FieldMaskTree msg -> Bool
/= :: FieldMaskTree msg -> FieldMaskTree msg -> Bool
Eq, Int -> FieldMaskTree msg -> ShowS
[FieldMaskTree msg] -> ShowS
FieldMaskTree msg -> String
(Int -> FieldMaskTree msg -> ShowS)
-> (FieldMaskTree msg -> String)
-> ([FieldMaskTree msg] -> ShowS)
-> Show (FieldMaskTree msg)
forall msg. Int -> FieldMaskTree msg -> ShowS
forall msg. [FieldMaskTree msg] -> ShowS
forall msg. FieldMaskTree msg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall msg. Int -> FieldMaskTree msg -> ShowS
showsPrec :: Int -> FieldMaskTree msg -> ShowS
$cshow :: forall msg. FieldMaskTree msg -> String
show :: FieldMaskTree msg -> String
$cshowList :: forall msg. [FieldMaskTree msg] -> ShowS
showList :: [FieldMaskTree msg] -> ShowS
Show)

type role FieldMaskTree nominal

-- | Resolve field mask paths, rooted at @msg@, against its proto descriptors.
-- A path that does not name a field is dropped whole.
resolve
  :: forall msg
   . Message msg
  => [FieldPath]
  -- ^ Field mask paths, rooted at @msg@
  -> FieldMaskTree msg
resolve :: forall msg. Message msg => [Text] -> FieldMaskTree msg
resolve [Text]
paths
  | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
paths Bool -> Bool -> Bool
|| Text
"*" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
paths = FieldMaskTree msg
forall msg. FieldMaskTree msg
SelectAll
  | Bool
otherwise = PathTree -> FieldMaskTree msg
forall msg. PathTree -> FieldMaskTree msg
Select (PathTree -> FieldMaskTree msg)
-> (PathTree -> PathTree) -> PathTree -> FieldMaskTree msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall msg. Message msg => PathTree -> PathTree
prune @msg (PathTree -> FieldMaskTree msg) -> PathTree -> FieldMaskTree msg
forall a b. (a -> b) -> a -> b
$ [Text] -> PathTree
normalise [Text]
paths

-- | Keep the paths that resolve against the fields of @msg@. A branch whose
-- sub-paths all drop is dropped too.
prune
  :: forall msg
   . Message msg
  => PathTree
  -- ^ Normalised paths, rooted at @msg@
  -> PathTree
prune :: forall msg. Message msg => PathTree -> PathTree
prune (PathTree Map Text PathTree
children) = Map Text PathTree -> PathTree
PathTree (Map Text PathTree -> PathTree) -> Map Text PathTree -> PathTree
forall a b. (a -> b) -> a -> b
$ (Text -> PathTree -> Maybe PathTree)
-> Map Text PathTree -> Map Text PathTree
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey Text -> PathTree -> Maybe PathTree
keepField Map Text PathTree
children
 where
  keepField :: Text -> PathTree -> Maybe PathTree
  keepField :: Text -> PathTree -> Maybe PathTree
keepField Text
name PathTree
child =
    PathTree -> FieldDescriptor msg -> Maybe PathTree
keepResolved PathTree
child (FieldDescriptor msg -> Maybe PathTree)
-> Maybe (FieldDescriptor msg) -> Maybe PathTree
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> Map String (FieldDescriptor msg) -> Maybe (FieldDescriptor msg)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> String
T.unpack Text
name) (forall msg. Message msg => Map String (FieldDescriptor msg)
fieldsByTextFormatName @msg)

  keepResolved :: PathTree -> FieldDescriptor msg -> Maybe PathTree
  keepResolved :: PathTree -> FieldDescriptor msg -> Maybe PathTree
keepResolved child :: PathTree
child@(PathTree Map Text PathTree
grandchildren) (FieldDescriptor String
_ FieldTypeDescriptor value
fieldType FieldAccessor msg value
accessor)
    | Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
grandchildren = PathTree -> Maybe PathTree
forall a. a -> Maybe a
Just PathTree
child
    | MessageField MessageOrGroup
_ <- FieldTypeDescriptor value
fieldType
    , FieldAccessor msg value -> Bool
forall {msg} {value}. FieldAccessor msg value -> Bool
hasSubfields FieldAccessor msg value
accessor =
        PathTree -> Maybe PathTree
nonEmptyTree (PathTree -> Maybe PathTree) -> PathTree -> Maybe PathTree
forall a b. (a -> b) -> a -> b
$ FieldTypeDescriptor value -> PathTree -> PathTree
forall value.
Message value =>
FieldTypeDescriptor value -> PathTree -> PathTree
pruneBelow FieldTypeDescriptor value
fieldType PathTree
child
    | Bool
otherwise = Maybe PathTree
forall a. Maybe a
Nothing

  nonEmptyTree :: PathTree -> Maybe PathTree
nonEmptyTree tree :: PathTree
tree@(PathTree Map Text PathTree
remaining) = if Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
remaining then Maybe PathTree
forall a. Maybe a
Nothing else PathTree -> Maybe PathTree
forall a. a -> Maybe a
Just PathTree
tree

  hasSubfields :: FieldAccessor msg value -> Bool
hasSubfields = \case
    MapField{} -> Bool
False
    FieldAccessor msg value
_ -> Bool
True

  pruneBelow :: forall value. Message value => FieldTypeDescriptor value -> PathTree -> PathTree
  -- The descriptor argument only pins @value@.
  pruneBelow :: forall value.
Message value =>
FieldTypeDescriptor value -> PathTree -> PathTree
pruneBelow FieldTypeDescriptor value
_ = forall msg. Message msg => PathTree -> PathTree
prune @value

-- | Keep only the selected fields and reset the rest to defaults. Required and
-- unknown fields stay.
applyFieldMask
  :: forall msg
   . Message msg
  => FieldMaskTree msg
  -- ^ Selects the fields to keep
  -> msg
  -- ^ The message to trim
  -> msg
applyFieldMask :: forall msg. Message msg => FieldMaskTree msg -> msg -> msg
applyFieldMask FieldMaskTree msg
SelectAll = msg -> msg
forall a. a -> a
id
applyFieldMask (Select PathTree
tree) = PathTree -> msg -> msg
forall msg. Message msg => PathTree -> msg -> msg
applyTree PathTree
tree

applyTree :: forall msg. Message msg => PathTree -> msg -> msg
applyTree :: forall msg. Message msg => PathTree -> msg -> msg
applyTree (PathTree Map Text PathTree
selected) msg
message =
  (msg -> (String, FieldDescriptor msg) -> msg)
-> msg -> [(String, FieldDescriptor msg)] -> msg
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' msg -> (String, FieldDescriptor msg) -> msg
step msg
message ([(String, FieldDescriptor msg)] -> msg)
-> (Map String (FieldDescriptor msg)
    -> [(String, FieldDescriptor msg)])
-> Map String (FieldDescriptor msg)
-> msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (FieldDescriptor msg) -> [(String, FieldDescriptor msg)]
Map String (FieldDescriptor msg)
-> [Item (Map String (FieldDescriptor msg))]
forall l. IsList l => l -> [Item l]
toList (Map String (FieldDescriptor msg) -> msg)
-> Map String (FieldDescriptor msg) -> msg
forall a b. (a -> b) -> a -> b
$ forall msg. Message msg => Map String (FieldDescriptor msg)
fieldsByTextFormatName @msg
 where
  step :: msg -> (String, FieldDescriptor msg) -> msg
  step :: msg -> (String, FieldDescriptor msg) -> msg
step msg
current (String
name, FieldDescriptor String
_ FieldTypeDescriptor value
fieldType FieldAccessor msg value
accessor) =
    msg -> (PathTree -> msg) -> Maybe PathTree -> msg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FieldAccessor msg value -> msg -> msg
forall msg value. FieldAccessor msg value -> msg -> msg
resetField FieldAccessor msg value
accessor msg
current) (FieldTypeDescriptor value
-> FieldAccessor msg value -> msg -> PathTree -> msg
forall value.
FieldTypeDescriptor value
-> FieldAccessor msg value -> msg -> PathTree -> msg
keepSelected FieldTypeDescriptor value
fieldType FieldAccessor msg value
accessor msg
current) (Maybe PathTree -> msg) -> Maybe PathTree -> msg
forall a b. (a -> b) -> a -> b
$
      Text -> Map Text PathTree -> Maybe PathTree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> Text
T.pack String
name) Map Text PathTree
selected

  keepSelected :: FieldTypeDescriptor value -> FieldAccessor msg value -> msg -> PathTree -> msg
  keepSelected :: forall value.
FieldTypeDescriptor value
-> FieldAccessor msg value -> msg -> PathTree -> msg
keepSelected FieldTypeDescriptor value
fieldType FieldAccessor msg value
accessor msg
current subtree :: PathTree
subtree@(PathTree Map Text PathTree
children)
    | Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
children = msg
current
    | MessageField MessageOrGroup
_ <- FieldTypeDescriptor value
fieldType = PathTree -> FieldAccessor msg value -> msg -> msg
forall value msg.
Message value =>
PathTree -> FieldAccessor msg value -> msg -> msg
trimField PathTree
subtree FieldAccessor msg value
accessor msg
current
    | Bool
otherwise = msg
current

-- | Reset a field to its default. Required fields stay.
resetField
  :: FieldAccessor msg value
  -- ^ Accesses the field
  -> msg
  -- ^ The message holding the field
  -> msg
resetField :: forall msg value. FieldAccessor msg value -> msg -> msg
resetField FieldAccessor msg value
accessor msg
message = case FieldAccessor msg value
accessor of
  PlainField WireDefault value
Optional Lens' msg value
field -> msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg value
Lens' msg value
field LensLike' Identity msg value -> value -> msg -> msg
forall s t a b. ASetter s t a b -> b -> s -> t
.~ value
forall value. FieldDefault value => value
fieldDefault
  PlainField WireDefault value
Required Lens' msg value
_ -> msg
message
  RepeatedField Packing
_ Lens' msg [value]
field -> msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg [value]
Lens' msg [value]
field LensLike' Identity msg [value] -> [value] -> msg -> msg
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
  MapField Lens' value key
_ Lens' value value1
_ Lens' msg (Map key value1)
field -> msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg (Map key value1)
Lens' msg (Map key value1)
field LensLike' Identity msg (Map key value1)
-> Map key value1 -> msg -> msg
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map key value1
forall a. Monoid a => a
mempty
  OptionalField Lens' msg (Maybe value)
field -> Maybe value -> msg -> msg -> msg
forall value msg. Maybe value -> msg -> msg -> msg
whenActive (msg
message msg -> Getting (Maybe value) msg (Maybe value) -> Maybe value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe value) msg (Maybe value)
Lens' msg (Maybe value)
field) msg
message (msg -> msg) -> msg -> msg
forall a b. (a -> b) -> a -> b
$ msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg (Maybe value)
Lens' msg (Maybe value)
field LensLike' Identity msg (Maybe value) -> Maybe value -> msg -> msg
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe value
forall a. Maybe a
Nothing

-- | Apply the subtree to the message or messages held by a field.
trimField
  :: Message value
  => PathTree
  -- ^ The paths below the field
  -> FieldAccessor msg value
  -- ^ Accesses the field
  -> msg
  -- ^ The message holding the field
  -> msg
trimField :: forall value msg.
Message value =>
PathTree -> FieldAccessor msg value -> msg -> msg
trimField PathTree
subtree FieldAccessor msg value
accessor msg
message = case FieldAccessor msg value
accessor of
  OptionalField Lens' msg (Maybe value)
field -> Maybe value -> msg -> msg -> msg
forall value msg. Maybe value -> msg -> msg -> msg
whenActive (msg
message msg -> Getting (Maybe value) msg (Maybe value) -> Maybe value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe value) msg (Maybe value)
Lens' msg (Maybe value)
field) msg
message (msg -> msg) -> msg -> msg
forall a b. (a -> b) -> a -> b
$ msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg (Maybe value)
Lens' msg (Maybe value)
field LensLike' Identity msg (Maybe value)
-> (Maybe value -> Maybe value) -> msg -> msg
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (value -> value) -> Maybe value -> Maybe value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PathTree -> value -> value
forall msg. Message msg => PathTree -> msg -> msg
applyTree PathTree
subtree)
  PlainField WireDefault value
_ Lens' msg value
field -> msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg value
Lens' msg value
field LensLike' Identity msg value -> (value -> value) -> msg -> msg
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PathTree -> value -> value
forall msg. Message msg => PathTree -> msg -> msg
applyTree PathTree
subtree
  RepeatedField Packing
_ Lens' msg [value]
field -> msg
message msg -> (msg -> msg) -> msg
forall a b. a -> (a -> b) -> b
& LensLike' Identity msg [value]
Lens' msg [value]
field LensLike' Identity msg [value]
-> ([value] -> [value]) -> msg -> msg
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (value -> value) -> [value] -> [value]
forall a b. (a -> b) -> [a] -> [b]
map (PathTree -> value -> value
forall msg. Message msg => PathTree -> msg -> msg
applyTree PathTree
subtree)
  MapField{} -> msg
message

-- | Update only when the oneof member is active: proto-lens oneof setters
-- replace the whole oneof, so touching an inactive member wipes the active one.
whenActive
  :: Maybe value
  -- ^ The oneof member, 'Nothing' when inactive
  -> msg
  -- ^ The message before the update
  -> msg
  -- ^ The message after the update
  -> msg
whenActive :: forall value msg. Maybe value -> msg -> msg -> msg
whenActive Maybe value
member msg
message msg
update = msg -> (value -> msg) -> Maybe value -> msg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe msg
message (msg -> value -> msg
forall a b. a -> b -> a
const msg
update) Maybe value
member

-- | Effects that fill the fields a mask selects; 'Nothing' when it selects none
-- of them. Effects run left to right.
--
-- The type, from the outside in:
--
-- * @FieldMaskTree msg ->@: each fill sees the part of the mask that applies to @msg@.
-- * @Maybe@: 'Nothing' when the mask selects none of the fill's fields, so 'runFill' never
--   calls its runner (no node session) for an empty selection.
-- * @Ap m@: the effect that obtains the selected values. 'Ap' gives @m (Endo msg)@ the
--   'Semigroup' that the 'Monoid' of 'Maybe' needs, and runs combined effects left to right.
-- * @Endo msg@: the setters for the selected fields; '(<>)' composes them and 'runFill'
--   applies them to @defMessage@.
newtype FieldFill m msg = FieldFill (FieldMaskTree msg -> Maybe (Ap m (Endo msg)))
  deriving (NonEmpty (FieldFill m msg) -> FieldFill m msg
FieldFill m msg -> FieldFill m msg -> FieldFill m msg
(FieldFill m msg -> FieldFill m msg -> FieldFill m msg)
-> (NonEmpty (FieldFill m msg) -> FieldFill m msg)
-> (forall b.
    Integral b =>
    b -> FieldFill m msg -> FieldFill m msg)
-> Semigroup (FieldFill m msg)
forall b. Integral b => b -> FieldFill m msg -> FieldFill m msg
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (m :: * -> *) msg.
Applicative m =>
NonEmpty (FieldFill m msg) -> FieldFill m msg
forall (m :: * -> *) msg.
Applicative m =>
FieldFill m msg -> FieldFill m msg -> FieldFill m msg
forall (m :: * -> *) msg b.
(Applicative m, Integral b) =>
b -> FieldFill m msg -> FieldFill m msg
$c<> :: forall (m :: * -> *) msg.
Applicative m =>
FieldFill m msg -> FieldFill m msg -> FieldFill m msg
<> :: FieldFill m msg -> FieldFill m msg -> FieldFill m msg
$csconcat :: forall (m :: * -> *) msg.
Applicative m =>
NonEmpty (FieldFill m msg) -> FieldFill m msg
sconcat :: NonEmpty (FieldFill m msg) -> FieldFill m msg
$cstimes :: forall (m :: * -> *) msg b.
(Applicative m, Integral b) =>
b -> FieldFill m msg -> FieldFill m msg
stimes :: forall b. Integral b => b -> FieldFill m msg -> FieldFill m msg
Semigroup, Semigroup (FieldFill m msg)
FieldFill m msg
Semigroup (FieldFill m msg) =>
FieldFill m msg
-> (FieldFill m msg -> FieldFill m msg -> FieldFill m msg)
-> ([FieldFill m msg] -> FieldFill m msg)
-> Monoid (FieldFill m msg)
[FieldFill m msg] -> FieldFill m msg
FieldFill m msg -> FieldFill m msg -> FieldFill m msg
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (m :: * -> *) msg.
Applicative m =>
Semigroup (FieldFill m msg)
forall (m :: * -> *) msg. Applicative m => FieldFill m msg
forall (m :: * -> *) msg.
Applicative m =>
[FieldFill m msg] -> FieldFill m msg
forall (m :: * -> *) msg.
Applicative m =>
FieldFill m msg -> FieldFill m msg -> FieldFill m msg
$cmempty :: forall (m :: * -> *) msg. Applicative m => FieldFill m msg
mempty :: FieldFill m msg
$cmappend :: forall (m :: * -> *) msg.
Applicative m =>
FieldFill m msg -> FieldFill m msg -> FieldFill m msg
mappend :: FieldFill m msg -> FieldFill m msg -> FieldFill m msg
$cmconcat :: forall (m :: * -> *) msg.
Applicative m =>
[FieldFill m msg] -> FieldFill m msg
mconcat :: [FieldFill m msg] -> FieldFill m msg
Monoid) via (FieldMaskTree msg -> Maybe (Ap m (Endo msg)))

-- | Run the effects of the fields the mask selects, then trim the message to the
-- mask. When the mask selects no field, the runner is never called.
runFill
  :: (Applicative n, Message msg)
  => (forall x. m x -> n x)
  -- ^ Runs the effects, for example in one node session
  -> FieldMaskTree msg
  -- ^ Selects the fields to fill
  -> FieldFill m msg
  -- ^ Fills the fields
  -> n msg
runFill :: forall (n :: * -> *) msg (m :: * -> *).
(Applicative n, Message msg) =>
(forall x. m x -> n x)
-> FieldMaskTree msg -> FieldFill m msg -> n msg
runFill forall x. m x -> n x
runEffects FieldMaskTree msg
fieldMask = (msg -> msg) -> n msg -> n msg
forall a b. (a -> b) -> n a -> n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldMaskTree msg -> msg -> msg
forall msg. Message msg => FieldMaskTree msg -> msg -> msg
applyFieldMask FieldMaskTree msg
fieldMask) (n msg -> n msg)
-> (FieldFill m msg -> n msg) -> FieldFill m msg -> n msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. m x -> n x)
-> FieldMaskTree msg -> FieldFill m msg -> n msg
forall (n :: * -> *) msg (m :: * -> *).
(Applicative n, Message msg) =>
(forall x. m x -> n x)
-> FieldMaskTree msg -> FieldFill m msg -> n msg
fillMessage m x -> n x
forall x. m x -> n x
runEffects FieldMaskTree msg
fieldMask

-- | 'runFill' for fills without effects.
runFillPure
  :: Message msg
  => FieldMaskTree msg
  -- ^ Selects the fields to fill
  -> FieldFill Identity msg
  -- ^ Fills the fields
  -> msg
runFillPure :: forall msg.
Message msg =>
FieldMaskTree msg -> FieldFill Identity msg -> msg
runFillPure FieldMaskTree msg
fieldMask = Identity msg -> msg
forall a. Identity a -> a
runIdentity (Identity msg -> msg)
-> (FieldFill Identity msg -> Identity msg)
-> FieldFill Identity msg
-> msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Identity x -> Identity x)
-> FieldMaskTree msg -> FieldFill Identity msg -> Identity msg
forall (n :: * -> *) msg (m :: * -> *).
(Applicative n, Message msg) =>
(forall x. m x -> n x)
-> FieldMaskTree msg -> FieldFill m msg -> n msg
runFill Identity x -> Identity x
forall a. a -> a
forall x. Identity x -> Identity x
id FieldMaskTree msg
fieldMask

-- | Fill the field that the lens label names with the result of the action.
-- When the mask does not select the field, the action never runs and its value is never evaluated.
fill
  :: forall label msg a m
   . (HasField msg label a, KnownSymbol label, Message msg, Functor m)
  => m a
  -- ^ Obtains the value of the field
  -> FieldFill m msg
fill :: forall (label :: Symbol) msg a (m :: * -> *).
(HasField msg label a, KnownSymbol label, Message msg,
 Functor m) =>
m a -> FieldFill m msg
fill m a
doValue = (FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg
forall (m :: * -> *) msg.
(FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg
FieldFill ((FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg)
-> (FieldMaskTree msg -> Maybe (Ap m (Endo msg)))
-> FieldFill m msg
forall a b. (a -> b) -> a -> b
$ \FieldMaskTree msg
fieldMask -> do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ forall (label :: Symbol) msg a.
(HasField msg label a, KnownSymbol label, Message msg) =>
FieldMaskTree msg -> Bool
isSelected @label FieldMaskTree msg
fieldMask
  Ap m (Endo msg) -> Maybe (Ap m (Endo msg))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ap m (Endo msg) -> Maybe (Ap m (Endo msg)))
-> (m (Endo msg) -> Ap m (Endo msg))
-> m (Endo msg)
-> Maybe (Ap m (Endo msg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Endo msg) -> Ap m (Endo msg)
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (m (Endo msg) -> Maybe (Ap m (Endo msg)))
-> m (Endo msg) -> Maybe (Ap m (Endo msg))
forall a b. (a -> b) -> a -> b
$ (msg -> msg) -> Endo msg
forall a. (a -> a) -> Endo a
Endo ((msg -> msg) -> Endo msg) -> (a -> msg -> msg) -> a -> Endo msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
Field.field @label ((a -> Identity a) -> msg -> Identity msg) -> a -> msg -> msg
forall s t a b. ASetter s t a b -> b -> s -> t
.~) (a -> Endo msg) -> m a -> m (Endo msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
doValue

-- | Fill the singular message field that the lens label names from fills of its
-- own fields, against the part of the mask below it.
fillSub
  :: forall label msg sub m
   . (HasField msg label sub, KnownSymbol label, Message msg, Message sub, Applicative m)
  => FieldFill m sub
  -- ^ Fills the fields of the sub-message
  -> FieldFill m msg
fillSub :: forall (label :: Symbol) msg sub (m :: * -> *).
(HasField msg label sub, KnownSymbol label, Message msg,
 Message sub, Applicative m) =>
FieldFill m sub -> FieldFill m msg
fillSub FieldFill m sub
subFill = (FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg
forall (m :: * -> *) msg.
(FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg
FieldFill ((FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg)
-> (FieldMaskTree msg -> Maybe (Ap m (Endo msg)))
-> FieldFill m msg
forall a b. (a -> b) -> a -> b
$ \FieldMaskTree msg
fieldMask -> do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ forall (label :: Symbol) msg a.
(HasField msg label a, KnownSymbol label, Message msg) =>
FieldMaskTree msg -> Bool
isSelected @label FieldMaskTree msg
fieldMask
  Ap m (Endo msg) -> Maybe (Ap m (Endo msg))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ap m (Endo msg) -> Maybe (Ap m (Endo msg)))
-> (m (Endo msg) -> Ap m (Endo msg))
-> m (Endo msg)
-> Maybe (Ap m (Endo msg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Endo msg) -> Ap m (Endo msg)
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (m (Endo msg) -> Maybe (Ap m (Endo msg)))
-> m (Endo msg) -> Maybe (Ap m (Endo msg))
forall a b. (a -> b) -> a -> b
$ (msg -> msg) -> Endo msg
forall a. (a -> a) -> Endo a
Endo ((msg -> msg) -> Endo msg)
-> (sub -> msg -> msg) -> sub -> Endo msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
Field.field @label ((sub -> Identity sub) -> msg -> Identity msg) -> sub -> msg -> msg
forall s t a b. ASetter s t a b -> b -> s -> t
.~) (sub -> Endo msg) -> m sub -> m (Endo msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. m x -> m x)
-> FieldMaskTree sub -> FieldFill m sub -> m sub
forall (n :: * -> *) msg (m :: * -> *).
(Applicative n, Message msg) =>
(forall x. m x -> n x)
-> FieldMaskTree msg -> FieldFill m msg -> n msg
fillMessage m x -> m x
forall a. a -> a
forall x. m x -> m x
id (forall (label :: Symbol) msg sub.
(HasField msg label sub, KnownSymbol label, Message msg) =>
FieldMaskTree msg -> FieldMaskTree sub
subMask @label FieldMaskTree msg
fieldMask) FieldFill m sub
subFill

-- | Fill several fields from one value that is already at hand, reading each
-- field with a function of it. A field the mask does not select never reads it.
fillFrom
  :: Applicative m
  => shared
  -- ^ The value the fields are read from
  -> FieldFill ((->) shared) msg
  -- ^ Reads each field from the value
  -> FieldFill m msg
fillFrom :: forall (m :: * -> *) shared msg.
Applicative m =>
shared -> FieldFill ((->) shared) msg -> FieldFill m msg
fillFrom shared
shared (FieldFill FieldMaskTree msg -> Maybe (Ap ((->) shared) (Endo msg))
readFrom) = (FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg
forall (m :: * -> *) msg.
(FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg
FieldFill ((FieldMaskTree msg -> Maybe (Ap m (Endo msg))) -> FieldFill m msg)
-> (FieldMaskTree msg -> Maybe (Ap m (Endo msg)))
-> FieldFill m msg
forall a b. (a -> b) -> a -> b
$ \FieldMaskTree msg
fieldMask ->
  m (Endo msg) -> Ap m (Endo msg)
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (m (Endo msg) -> Ap m (Endo msg))
-> (Ap ((->) shared) (Endo msg) -> m (Endo msg))
-> Ap ((->) shared) (Endo msg)
-> Ap m (Endo msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo msg -> m (Endo msg)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Endo msg -> m (Endo msg))
-> (Ap ((->) shared) (Endo msg) -> Endo msg)
-> Ap ((->) shared) (Endo msg)
-> m (Endo msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ap ((->) shared) (Endo msg) -> shared -> Endo msg)
-> shared -> Ap ((->) shared) (Endo msg) -> Endo msg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ap ((->) shared) (Endo msg) -> shared -> Endo msg
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp shared
shared (Ap ((->) shared) (Endo msg) -> Ap m (Endo msg))
-> Maybe (Ap ((->) shared) (Endo msg)) -> Maybe (Ap m (Endo msg))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldMaskTree msg -> Maybe (Ap ((->) shared) (Endo msg))
readFrom FieldMaskTree msg
fieldMask

-- | Run the effects of the fields the mask selects and set them on 'defMessage',
-- untrimmed. When the mask selects no field, the runner is never called.
fillMessage
  :: (Applicative n, Message msg)
  => (forall x. m x -> n x)
  -- ^ Runs the effects
  -> FieldMaskTree msg
  -- ^ Selects the fields to fill
  -> FieldFill m msg
  -- ^ Fills the fields
  -> n msg
fillMessage :: forall (n :: * -> *) msg (m :: * -> *).
(Applicative n, Message msg) =>
(forall x. m x -> n x)
-> FieldMaskTree msg -> FieldFill m msg -> n msg
fillMessage forall x. m x -> n x
runEffects FieldMaskTree msg
fieldMask (FieldFill FieldMaskTree msg -> Maybe (Ap m (Endo msg))
fieldFill) =
  (Endo msg -> msg -> msg
forall a. Endo a -> a -> a
`appEndo` msg
forall msg. Message msg => msg
defMessage) (Endo msg -> msg)
-> (Maybe (Endo msg) -> Endo msg) -> Maybe (Endo msg) -> msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Endo msg) -> Endo msg
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe (Endo msg) -> msg) -> n (Maybe (Endo msg)) -> n msg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ap m (Endo msg) -> n (Endo msg))
-> Maybe (Ap m (Endo msg)) -> n (Maybe (Endo msg))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (m (Endo msg) -> n (Endo msg)
forall x. m x -> n x
runEffects (m (Endo msg) -> n (Endo msg))
-> (Ap m (Endo msg) -> m (Endo msg))
-> Ap m (Endo msg)
-> n (Endo msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m (Endo msg) -> m (Endo msg)
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp) (FieldMaskTree msg -> Maybe (Ap m (Endo msg))
fieldFill FieldMaskTree msg
fieldMask)

-- | Whether the mask needs the field that the lens label names: the field or a
-- field below it is selected. A label that names no field is selected only under 'SelectAll'.
isSelected
  :: forall label msg a
   . (HasField msg label a, KnownSymbol label, Message msg)
  => FieldMaskTree msg
  -- ^ The mask, rooted at @msg@
  -> Bool
isSelected :: forall (label :: Symbol) msg a.
(HasField msg label a, KnownSymbol label, Message msg) =>
FieldMaskTree msg -> Bool
isSelected FieldMaskTree msg
fieldMask = case forall (label :: Symbol) msg sub.
(HasField msg label sub, KnownSymbol label, Message msg) =>
FieldMaskTree msg -> FieldMaskTree sub
subMask @label FieldMaskTree msg
fieldMask of
  FieldMaskTree a
SelectAll -> Bool
True
  Select (PathTree Map Text PathTree
children) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
children

-- | The part of a mask below the singular message field that the lens label
-- names, for building that field on its own.
subMask
  :: forall label msg sub
   . (HasField msg label sub, KnownSymbol label, Message msg)
  => FieldMaskTree msg
  -- ^ The mask, rooted at @msg@
  -> FieldMaskTree sub
subMask :: forall (label :: Symbol) msg sub.
(HasField msg label sub, KnownSymbol label, Message msg) =>
FieldMaskTree msg -> FieldMaskTree sub
subMask = Maybe Text -> FieldMaskTree msg -> FieldMaskTree sub
forall msg sub.
Maybe Text -> FieldMaskTree msg -> FieldMaskTree sub
fieldSubMask (Maybe Text -> FieldMaskTree msg -> FieldMaskTree sub)
-> Maybe Text -> FieldMaskTree msg -> FieldMaskTree sub
forall a b. (a -> b) -> a -> b
$ forall (label :: Symbol) msg a.
(HasField msg label a, KnownSymbol label, Message msg) =>
Maybe Text
labelledFieldName @label @msg

-- | The part of a mask below a top-level field; 'Nothing' names no field.
fieldSubMask
  :: Maybe Text
  -- ^ The proto name of the field
  -> FieldMaskTree msg
  -- ^ The mask, rooted at the message holding the field
  -> FieldMaskTree sub
fieldSubMask :: forall msg sub.
Maybe Text -> FieldMaskTree msg -> FieldMaskTree sub
fieldSubMask Maybe Text
_ FieldMaskTree msg
SelectAll = FieldMaskTree sub
forall msg. FieldMaskTree msg
SelectAll
fieldSubMask Maybe Text
name (Select (PathTree Map Text PathTree
roots)) =
  FieldMaskTree sub
-> (PathTree -> FieldMaskTree sub)
-> Maybe PathTree
-> FieldMaskTree sub
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PathTree -> FieldMaskTree sub
forall msg. PathTree -> FieldMaskTree msg
Select (PathTree -> FieldMaskTree sub) -> PathTree -> FieldMaskTree sub
forall a b. (a -> b) -> a -> b
$ Map Text PathTree -> PathTree
PathTree Map Text PathTree
forall a. Monoid a => a
mempty) PathTree -> FieldMaskTree sub
forall msg. PathTree -> FieldMaskTree msg
wholeOrPart (Maybe PathTree -> FieldMaskTree sub)
-> Maybe PathTree -> FieldMaskTree sub
forall a b. (a -> b) -> a -> b
$ (Text -> Map Text PathTree -> Maybe PathTree
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Text PathTree
roots) (Text -> Maybe PathTree) -> Maybe Text -> Maybe PathTree
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
name
 where
  -- A field selected without sub-paths is selected whole.
  wholeOrPart :: PathTree -> FieldMaskTree msg
wholeOrPart (PathTree Map Text PathTree
children)
    | Map Text PathTree -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text PathTree
children = FieldMaskTree msg
forall msg. FieldMaskTree msg
SelectAll
    | Bool
otherwise = PathTree -> FieldMaskTree msg
forall msg. PathTree -> FieldMaskTree msg
Select (PathTree -> FieldMaskTree msg) -> PathTree -> FieldMaskTree msg
forall a b. (a -> b) -> a -> b
$ Map Text PathTree -> PathTree
PathTree Map Text PathTree
children

-- | The proto name of the field whose 'lensLabel' is the label. A @maybe'@ label
-- names the same field as the plain one.
labelledFieldName
  :: forall label msg a
   . (HasField msg label a, KnownSymbol label, Message msg)
  => Maybe Text
labelledFieldName :: forall (label :: Symbol) msg a.
(HasField msg label a, KnownSymbol label, Message msg) =>
Maybe Text
labelledFieldName =
  (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
label) (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
lensLabel) ([Text] -> Maybe Text)
-> (Map String (FieldDescriptor msg) -> [Text])
-> Map String (FieldDescriptor msg)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> [Text])
-> (Map String (FieldDescriptor msg) -> [String])
-> Map String (FieldDescriptor msg)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (FieldDescriptor msg) -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String (FieldDescriptor msg) -> Maybe Text)
-> Map String (FieldDescriptor msg) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ forall msg. Message msg => Map String (FieldDescriptor msg)
fieldsByTextFormatName @msg
 where
  symbol :: Text
symbol = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy label -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @label)
  label :: Text
label = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
symbol (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"maybe'" Text
symbol
  -- Uses the 'HasField' constraint, which rejects labels that name no lens of @msg@.
  _lens :: (a -> Identity a) -> msg -> Identity msg
_lens = forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
Field.field @label @msg @a @Identity

-- | The label proto-lens gives the lenses of a proto field, for example
-- @ledger_tip@ to @ledgerTip@ or @plutus_v1@ to @plutusV1@.
lensLabel
  :: Text
  -- ^ The proto name of the field
  -> Text
lensLabel :: Text -> Text
lensLabel Text
name
  | Text
camelCased Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
reservedKeywords = Text
camelCased Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
  | Bool
otherwise = Text
camelCased
 where
  (Text
underscores, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') Text
name
  camelCased :: Text
camelCased =
    Text
underscores Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (((Text -> Text) -> Text -> Text)
-> [Text -> Text] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
($) (Text -> Text
lowerInitials (Text -> Text) -> [Text -> Text] -> [Text -> Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text -> Text]
forall a. a -> [a]
repeat Text -> Text
capitalise) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"_" Text
rest)
  lowerInitials :: Text -> Text
lowerInitials Text
word = Text -> Text
T.toLower ((Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isUpper Text
word) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isUpper Text
word
  capitalise :: Text -> Text
capitalise Text
word = Text -> Text
T.toUpper (Int -> Text -> Text
T.take Int
1 Text
word) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
1 Text
word

-- | Haskell keywords, which proto-lens suffixes with @'@ in lens labels.
-- Mirrors @reservedKeywords@ in proto-lens-protoc's @app/Data/ProtoLens/Compiler/Definitions.hs@.
reservedKeywords :: [Text]
reservedKeywords :: [Text]
reservedKeywords =
  [ Text
"case"
  , Text
"class"
  , Text
"data"
  , Text
"default"
  , Text
"deriving"
  , Text
"do"
  , Text
"else"
  , Text
"forall"
  , Text
"foreign"
  , Text
"if"
  , Text
"import"
  , Text
"in"
  , Text
"infix"
  , Text
"infixl"
  , Text
"infixr"
  , Text
"instance"
  , Text
"let"
  , Text
"module"
  , Text
"newtype"
  , Text
"of"
  , Text
"then"
  , Text
"type"
  , Text
"where"
  , Text
"mdo"
  , Text
"rec"
  , Text
"pattern"
  , Text
"proc"
  ]