-- Copyright 2016 Google Inc. All Rights Reserved.
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

-- | Functions for converting protocol buffers to a human-readable text format.
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.ProtoLens.TextFormat(
    showMessage,
    showMessageWithRegistry,
    showMessageShort,
    pprintMessage,
    pprintMessageWithRegistry,
    readMessage,
    readMessageWithRegistry,
    readMessageOrDie,
    ) where

import Lens.Family2 ((&),(^.),(.~), set, over, view)
import Control.Arrow (left)
import Data.Bifunctor (first)
import qualified Data.ByteString
import Data.Char (isPrint, isAscii, chr)
import Data.Foldable (foldlM, foldl')
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy(Proxy))
import qualified Data.Set as Set
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text as Text (unpack)
import Numeric (showOct)
import Text.Parsec (parse)
import Text.PrettyPrint

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

import Data.ProtoLens.Encoding (decodeMessage, encodeMessage)
import Data.ProtoLens.Encoding.Bytes (runParser)
import Data.ProtoLens.Encoding.Wire
import Data.ProtoLens.Message hiding (buildMessage, parseMessage)
import qualified Data.ProtoLens.TextFormat.Parser as Parser

-- TODO: This code is newer and missing some edge cases,
-- including:
-- - Serialize directly to Text
-- - String/bytestring serialization
--   - Strings delimited by single quotes
--   - Concatenate multiple strings one after another
--   - control characters and non-UTF8 text
--   - characters in bytes fields should fit in Word8
-- - More output formats for floats like exponentials
-- - Print/parse enums by textual name in addition to integer value
-- - More compact printing/parsing for packed fields
-- - Decide what to do for values that don't fit in the field (e.g., overflow)
-- - Add more tests for:
--   - edge cases of deserialization ("deserializeFrom")


-- | Pretty-print the given message into a human-readable form.
pprintMessage :: Message msg => msg -> Doc
pprintMessage :: forall msg. Message msg => msg -> Doc
pprintMessage = Registry -> msg -> Doc
forall msg. Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry Registry
forall a. Monoid a => a
mempty

-- | Pretty-print the given message into human-readable form, using the given
-- 'Registry' to decode @google.protobuf.Any@ values.
pprintMessageWithRegistry :: Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry :: forall msg. Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry Registry
reg msg
msg
    -- Either put all fields together on a single line, or use a separate line
    -- for each field.  We use a single "sep" for all fields (and all elements
    -- of all the repeated fields) to avoid putting some repeated fields on one
    -- line and other fields on multiple lines, which is less readable.
    = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (FieldDescriptor msg -> [Doc]) -> [FieldDescriptor msg] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Registry -> msg -> FieldDescriptor msg -> [Doc]
forall msg. Registry -> msg -> FieldDescriptor msg -> [Doc]
pprintField Registry
reg msg
msg) [FieldDescriptor msg]
forall msg. Message msg => [FieldDescriptor msg]
allFields
              [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (TaggedValue -> Doc) -> [TaggedValue] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TaggedValue -> Doc
pprintTaggedValue (msg
msg msg
-> FoldLike [TaggedValue] msg msg [TaggedValue] [TaggedValue]
-> [TaggedValue]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [TaggedValue] msg msg [TaggedValue] [TaggedValue]
forall msg. Message msg => Lens' msg [TaggedValue]
Lens' msg [TaggedValue]
unknownFields)

-- | Convert the given message into a human-readable 'String'.
showMessage :: Message msg => msg -> String
showMessage :: forall msg. Message msg => msg -> String
showMessage = Doc -> String
render (Doc -> String) -> (msg -> Doc) -> msg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. msg -> Doc
forall msg. Message msg => msg -> Doc
pprintMessage

-- | Convert the given message into a human-readable 'String', using the
-- 'Registry' to encode @google.protobuf.Any@ values.
showMessageWithRegistry :: Message msg => Registry -> msg -> String
showMessageWithRegistry :: forall msg. Message msg => Registry -> msg -> String
showMessageWithRegistry Registry
reg = Doc -> String
render (Doc -> String) -> (msg -> Doc) -> msg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Registry -> msg -> Doc
forall msg. Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry Registry
reg

-- | Serializes a proto as a string on a single line.  Useful for debugging
-- and error messages like @.DebugString()@ in other languages.
showMessageShort :: Message msg => msg -> String
showMessageShort :: forall msg. Message msg => msg -> String
showMessageShort = Style -> Doc -> String
renderStyle (Mode -> Int -> Float -> Style
Style Mode
OneLineMode Int
forall a. Bounded a => a
maxBound Float
1.5) (Doc -> String) -> (msg -> Doc) -> msg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. msg -> Doc
forall msg. Message msg => msg -> Doc
pprintMessage

pprintField :: Registry -> msg -> FieldDescriptor msg -> [Doc]
pprintField :: forall msg. Registry -> msg -> FieldDescriptor msg -> [Doc]
pprintField Registry
reg msg
msg (FieldDescriptor String
name FieldTypeDescriptor value
typeDescr FieldAccessor msg value
accessor)
    = (value -> Doc) -> [value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Registry -> String -> FieldTypeDescriptor value -> value -> Doc
forall value.
Registry -> String -> FieldTypeDescriptor value -> value -> Doc
pprintFieldValue Registry
reg String
name FieldTypeDescriptor value
typeDescr) ([value] -> [Doc]) -> [value] -> [Doc]
forall a b. (a -> b) -> a -> b
$ case FieldAccessor msg value
accessor of
        PlainField WireDefault value
d Lens' msg value
f
            | WireDefault value
Optional <- WireDefault value
d, value
val value -> value -> Bool
forall a. Eq a => a -> a -> Bool
== value
forall value. FieldDefault value => value
fieldDefault -> []
            | Bool
otherwise -> [value
val]
          where val :: value
val = msg
msg msg -> FoldLike value msg msg value value -> value
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike value msg msg value value
Lens' msg value
f
        OptionalField Lens' msg (Maybe value)
f -> [Maybe value] -> [value]
forall a. [Maybe a] -> [a]
catMaybes [msg
msg msg
-> FoldLike (Maybe value) msg msg (Maybe value) (Maybe value)
-> Maybe value
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike (Maybe value) msg msg (Maybe value) (Maybe value)
Lens' msg (Maybe value)
f]
        -- TODO: better printing for packed fields
        RepeatedField Packing
_ Lens' msg [value]
f -> msg
msg msg -> FoldLike [value] msg msg [value] [value] -> [value]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [value] msg msg [value] [value]
Lens' msg [value]
f
        MapField Lens' value key
k Lens' value value1
v Lens' msg (Map key value1)
f -> (key, value1) -> value
pairToMsg ((key, value1) -> value) -> [(key, value1)] -> [value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map key value1 -> [(key, value1)]
forall k a. Map k a -> [(k, a)]
Map.assocs (msg
msg msg
-> FoldLike
     (Map key value1) msg msg (Map key value1) (Map key value1)
-> Map key value1
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike (Map key value1) msg msg (Map key value1) (Map key value1)
Lens' msg (Map key value1)
f)
          where pairToMsg :: (key, value1) -> value
pairToMsg (key
x,value1
y) = value
forall msg. Message msg => msg
defMessage
                                    value -> (value -> value) -> value
forall s t. s -> (s -> t) -> t
& LensLike' f value key
Lens' value key
forall {f :: * -> *}. Identical f => LensLike' f value key
k (forall {f :: * -> *}. Identical f => LensLike' f value key)
-> key -> value -> value
forall s t a b. Setter s t a b -> b -> s -> t
.~ key
x
                                    value -> (value -> value) -> value
forall s t. s -> (s -> t) -> t
& LensLike' f value value1
Lens' value value1
forall {f :: * -> *}. Identical f => LensLike' f value value1
v (forall {f :: * -> *}. Identical f => LensLike' f value value1)
-> value1 -> value -> value
forall s t a b. Setter s t a b -> b -> s -> t
.~ value1
y

pprintFieldValue :: Registry -> String -> FieldTypeDescriptor value -> value -> Doc
pprintFieldValue :: forall value.
Registry -> String -> FieldTypeDescriptor value -> value -> Doc
pprintFieldValue Registry
reg String
name field :: FieldTypeDescriptor value
field@(MessageField MessageOrGroup
MessageType) value
m
  | Just AnyMessageDescriptor { Lens' value Text
anyTypeUrlLens :: Lens' value Text
anyTypeUrlLens :: forall msg. AnyMessageDescriptor msg -> Lens' msg Text
anyTypeUrlLens, Lens' value ByteString
anyValueLens :: Lens' value ByteString
anyValueLens :: forall msg. AnyMessageDescriptor msg -> Lens' msg ByteString
anyValueLens } <- FieldTypeDescriptor value -> Maybe (AnyMessageDescriptor value)
forall value.
FieldTypeDescriptor value -> Maybe (AnyMessageDescriptor value)
matchAnyMessage FieldTypeDescriptor value
field,
    Text
typeUri <- FoldLike Text value value Text Text -> value -> Text
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike Text value value Text Text
Lens' value Text
anyTypeUrlLens value
m,
    ByteString
fieldData <- FoldLike ByteString value value ByteString ByteString
-> value -> ByteString
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike ByteString value value ByteString ByteString
Lens' value ByteString
anyValueLens value
m,
    Just (SomeMessageType (Proxy msg
Proxy :: Proxy value')) <- Text -> Registry -> Maybe SomeMessageType
lookupRegistered Text
typeUri Registry
reg,
    Right (msg
anyValue :: value') <- ByteString -> Either String msg
forall msg. Message msg => ByteString -> Either String msg
decodeMessage ByteString
fieldData =
      String -> Doc -> Doc
pprintSubmessage String
name
          (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
            [ Doc
lbrack Doc -> Doc -> Doc
<> String -> Doc
text (Text -> String
Text.unpack Text
typeUri) Doc -> Doc -> Doc
<> Doc
rbrack Doc -> Doc -> Doc
<+> Doc
lbrace
            , Int -> Doc -> Doc
nest Int
2 (Registry -> msg -> Doc
forall msg. Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry Registry
reg msg
anyValue)
            , Doc
rbrace ]
  | Bool
otherwise =
      String -> Doc -> Doc
pprintSubmessage String
name (Registry -> value -> Doc
forall msg. Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry Registry
reg value
m)
pprintFieldValue Registry
reg String
name (MessageField MessageOrGroup
GroupType) value
m
    = String -> Doc -> Doc
pprintSubmessage String
name (Registry -> value -> Doc
forall msg. Message msg => Registry -> msg -> Doc
pprintMessageWithRegistry Registry
reg value
m)
pprintFieldValue Registry
_ String
name (ScalarField ScalarField value
f) value
x = String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ScalarField value -> value -> Doc
forall value. ScalarField value -> value -> Doc
pprintScalarValue ScalarField value
f value
x

named :: String -> Doc -> Doc
named :: String -> Doc -> Doc
named String
n Doc
x = String -> Doc
text String
n Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<+> Doc
x


pprintScalarValue :: ScalarField value -> value -> Doc
pprintScalarValue :: forall value. ScalarField value -> value -> Doc
pprintScalarValue ScalarField value
EnumField value
x = String -> Doc
text (value -> String
forall a. MessageEnum a => a -> String
showEnum value
x)
pprintScalarValue ScalarField value
Int32Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
Int64Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
UInt32Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
UInt64Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
SInt32Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
SInt64Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
Fixed32Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
Fixed64Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
SFixed32Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
SFixed64Field value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
FloatField value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
DoubleField value
x = value -> Doc
forall value. Show value => value -> Doc
primField value
x
pprintScalarValue ScalarField value
BoolField value
x = Bool -> Doc
boolValue value
Bool
x
pprintScalarValue ScalarField value
StringField value
x = ByteString -> Doc
pprintByteString (Text -> ByteString
Text.encodeUtf8 value
Text
x)
pprintScalarValue ScalarField value
BytesField value
x = ByteString -> Doc
pprintByteString value
ByteString
x

pprintSubmessage :: String -> Doc -> Doc
pprintSubmessage :: String -> Doc -> Doc
pprintSubmessage String
name Doc
contents =
    [Doc] -> Doc
sep [String -> Doc
text String
name Doc -> Doc -> Doc
<+> Doc
lbrace, Int -> Doc -> Doc
nest Int
2 Doc
contents, Doc
rbrace]

-- | Formats a string in a way that mostly matches the C-compatible escaping
-- used by the Protocol Buffer distribution.  We depart a bit by escaping all
-- non-ASCII characters, which depending on the locale, the distribution might
-- not do.
--
-- This uses three-digit octal escapes, e.g. "\011" plus \n, \r,, \t, \', \",
-- and \\ only.  Note that Haskell string-literal syntax calls for "\011" to be
-- interpreted as decimal 11, rather than the decimal 9 it actually represent,
-- so you can't use Prelude.read to parse the strings created here.
pprintByteString :: Data.ByteString.ByteString -> Doc
pprintByteString :: ByteString -> Doc
pprintByteString ByteString
x = Char -> Doc
char Char
'\"'
    Doc -> Doc -> Doc
<> String -> Doc
text ((Word8 -> String) -> [Word8] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word8 -> String
forall {a}. Integral a => a -> String
escape ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
Data.ByteString.unpack ByteString
x) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'\"'
  where escape :: a -> String
escape a
w8 | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'               = String
"\\n"
                  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'               = String
"\\r"
                  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'               = String
"\\t"
                  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"'               = String
"\\\""
                  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''               = String
"\\\'"
                  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'               = String
"\\\\"
                  | Char -> Bool
isPrint Char
ch Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
ch = Char
ch Char -> String -> String
forall a. a -> [a] -> [a]
: String
""
                  | Bool
otherwise                = String
"\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
pad (a -> String -> String
forall a. Integral a => a -> String -> String
showOct a
w8 String
"")
          where
            ch :: Char
ch = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w8
            pad :: String -> String
pad String
str = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str

primField :: Show value => value -> Doc
primField :: forall value. Show value => value -> Doc
primField value
x = String -> Doc
text (value -> String
forall a. Show a => a -> String
show value
x)

boolValue :: Bool -> Doc
boolValue :: Bool -> Doc
boolValue Bool
True = String -> Doc
text String
"true"
boolValue Bool
False = String -> Doc
text String
"false"

pprintTaggedValue :: TaggedValue -> Doc
pprintTaggedValue :: TaggedValue -> Doc
pprintTaggedValue (TaggedValue Tag
t WireValue
wv) = case WireValue
wv of
    VarInt Word64
x -> String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Word64 -> Doc
forall value. Show value => value -> Doc
primField Word64
x
    Fixed64 Word64
x -> String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Word64 -> Doc
forall value. Show value => value -> Doc
primField Word64
x
    Fixed32 Word32
x -> String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Word32 -> Doc
forall value. Show value => value -> Doc
primField Word32
x
    Lengthy ByteString
x -> case Parser [TaggedValue] -> ByteString -> Either String [TaggedValue]
forall a. Parser a -> ByteString -> Either String a
runParser Parser [TaggedValue]
parseFieldSet ByteString
x of
                  Left String
_ -> String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> Doc
pprintByteString ByteString
x
                  Right [TaggedValue]
ts -> String -> Doc -> Doc
pprintSubmessage String
name
                                (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (TaggedValue -> Doc) -> [TaggedValue] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TaggedValue -> Doc
pprintTaggedValue [TaggedValue]
ts
    -- TODO: implement better printing for unknown groups
    WireValue
StartGroup -> String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"start_group"
    WireValue
EndGroup -> String -> Doc -> Doc
named String
name (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"end_group"
  where
    name :: String
name = Int -> String
forall a. Show a => a -> String
show (Tag -> Int
unTag Tag
t)


--------------------------------------------------------------------------------
-- Parsing

-- | Parse a 'Message' from the human-readable protocol buffer text format.
readMessage :: Message msg => Lazy.Text -> Either String msg
readMessage :: forall msg. Message msg => Text -> Either String msg
readMessage = Registry -> Text -> Either String msg
forall msg. Message msg => Registry -> Text -> Either String msg
readMessageWithRegistry Registry
forall a. Monoid a => a
mempty

-- | Parse a 'Message' from the human-readable protocol buffer text format.
-- Throws an error if the parse was not successful.
readMessageOrDie :: Message msg => Lazy.Text -> msg
readMessageOrDie :: forall msg. Message msg => Text -> msg
readMessageOrDie Text
str = case Text -> Either String msg
forall msg. Message msg => Text -> Either String msg
readMessage Text
str of
    Left String
e -> String -> msg
forall a. HasCallStack => String -> a
error (String -> msg) -> String -> msg
forall a b. (a -> b) -> a -> b
$ String
"readMessageOrDie: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
    Right msg
x -> msg
x

-- | Parse a 'Message' from a human-readable protocol buffer text format, using
-- the given 'Registry' to decode 'Any' fields
readMessageWithRegistry :: Message msg => Registry -> Lazy.Text -> Either String msg
readMessageWithRegistry :: forall msg. Message msg => Registry -> Text -> Either String msg
readMessageWithRegistry Registry
reg Text
str = (ParseError -> String)
-> Either ParseError [Field] -> Either String [Field]
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ParseError -> String
forall a. Show a => a -> String
show (Parsec Text () [Field]
-> String -> Text -> Either ParseError [Field]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec Text () [Field]
Parser.parser String
"" Text
str) Either String [Field]
-> ([Field] -> Either String msg) -> Either String msg
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Registry -> [Field] -> Either String msg
forall msg. Message msg => Registry -> [Field] -> Either String msg
buildMessage Registry
reg

buildMessage :: forall msg . Message msg => Registry -> Parser.Message -> Either String msg
buildMessage :: forall msg. Message msg => Registry -> [Field] -> Either String msg
buildMessage Registry
reg [Field]
fields
    | [String]
missing <- Proxy msg -> [Field] -> [String]
forall msg. Message msg => Proxy msg -> [Field] -> [String]
missingFields (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @msg) [Field]
fields, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missing
        = String -> Either String msg
forall a b. a -> Either a b
Left (String -> Either String msg) -> String -> Either String msg
forall a b. (a -> b) -> a -> b
$ String
"Missing fields " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
missing
    | Bool
otherwise = Map Tag (FieldDescriptor msg) -> msg -> msg
forall k msg. Map k (FieldDescriptor msg) -> msg -> msg
reverseRepeatedFields Map Tag (FieldDescriptor msg)
forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag
                      (msg -> msg) -> Either String msg -> Either String msg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Registry -> msg -> [Field] -> Either String msg
forall msg.
Message msg =>
Registry -> msg -> [Field] -> Either String msg
buildMessageFromDescriptor Registry
reg msg
forall msg. Message msg => msg
defMessage [Field]
fields

missingFields :: forall msg . Message msg => Proxy msg -> Parser.Message -> [String]
missingFields :: forall msg. Message msg => Proxy msg -> [Field] -> [String]
missingFields Proxy msg
_ = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String])
-> ([Field] -> Set String) -> [Field] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set String -> Field -> Set String)
-> Set String -> [Field] -> Set String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set String -> Field -> Set String
deleteField Set String
requiredFieldNames
  where
    requiredFieldNames :: Set.Set String
    requiredFieldNames :: Set String
requiredFieldNames = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ Map String (FieldDescriptor msg) -> [String]
forall k a. Map k a -> [k]
Map.keys
                            (Map String (FieldDescriptor msg) -> [String])
-> Map String (FieldDescriptor msg) -> [String]
forall a b. (a -> b) -> a -> b
$ (FieldDescriptor msg -> Bool)
-> Map String (FieldDescriptor msg)
-> Map String (FieldDescriptor msg)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter FieldDescriptor msg -> Bool
forall msg. FieldDescriptor msg -> Bool
isRequired
                            (Map String (FieldDescriptor msg)
 -> Map String (FieldDescriptor msg))
-> Map String (FieldDescriptor msg)
-> Map String (FieldDescriptor msg)
forall a b. (a -> b) -> a -> b
$ forall msg. Message msg => Map String (FieldDescriptor msg)
fieldsByTextFormatName @msg
    deleteField :: Set.Set String -> Parser.Field -> Set.Set String
    deleteField :: Set String -> Field -> Set String
deleteField Set String
fs (Parser.Field (Parser.Key String
name) Value
_) = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
name Set String
fs
    deleteField Set String
fs (Parser.Field (Parser.UnknownKey Integer
n) Value
_)
        | Just FieldDescriptor msg
d <- Tag -> Map Tag (FieldDescriptor msg) -> Maybe (FieldDescriptor msg)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int -> Tag
Tag (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)) (forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag @msg)
        = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete (FieldDescriptor msg -> String
forall msg. FieldDescriptor msg -> String
fieldDescriptorName FieldDescriptor msg
d) Set String
fs
    deleteField Set String
fs Field
_ = Set String
fs


buildMessageFromDescriptor
    :: Message msg => Registry -> msg -> Parser.Message -> Either String msg
buildMessageFromDescriptor :: forall msg.
Message msg =>
Registry -> msg -> [Field] -> Either String msg
buildMessageFromDescriptor Registry
reg = (msg -> Field -> Either String msg)
-> msg -> [Field] -> Either String msg
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Registry -> msg -> Field -> Either String msg
forall msg.
Message msg =>
Registry -> msg -> Field -> Either String msg
addField Registry
reg)

addField :: forall msg . Message msg => Registry -> msg -> Parser.Field -> Either String msg
addField :: forall msg.
Message msg =>
Registry -> msg -> Field -> Either String msg
addField Registry
reg msg
msg (Parser.Field Key
key Value
rawValue) = do
    FieldDescriptor String
name FieldTypeDescriptor value
typeDescriptor FieldAccessor msg value
accessor <- Either String (FieldDescriptor msg)
getFieldDescriptor
    value
value <- String
-> Registry
-> FieldTypeDescriptor value
-> Value
-> Either String value
forall value.
String
-> Registry
-> FieldTypeDescriptor value
-> Value
-> Either String value
makeValue String
name Registry
reg FieldTypeDescriptor value
typeDescriptor Value
rawValue
    msg -> Either String msg
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (msg -> Either String msg) -> msg -> Either String msg
forall a b. (a -> b) -> a -> b
$ FieldAccessor msg value -> value -> msg -> msg
forall msg value. FieldAccessor msg value -> value -> msg -> msg
modifyField FieldAccessor msg value
accessor value
value msg
msg
  where
    getFieldDescriptor :: Either String (FieldDescriptor msg)
getFieldDescriptor
        | Parser.Key String
name <- Key
key, Just FieldDescriptor msg
f <- String
-> Map String (FieldDescriptor msg) -> Maybe (FieldDescriptor msg)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name
                                                Map String (FieldDescriptor msg)
forall msg. Message msg => Map String (FieldDescriptor msg)
fieldsByTextFormatName
            = FieldDescriptor msg -> Either String (FieldDescriptor msg)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return FieldDescriptor msg
f
        | Parser.UnknownKey Integer
tag <- Key
key, Just FieldDescriptor msg
f <- Tag -> Map Tag (FieldDescriptor msg) -> Maybe (FieldDescriptor msg)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Integer -> Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
tag)
                                                      Map Tag (FieldDescriptor msg)
forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag
            = FieldDescriptor msg -> Either String (FieldDescriptor msg)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return FieldDescriptor msg
f
        | Bool
otherwise = String -> Either String (FieldDescriptor msg)
forall a b. a -> Either a b
Left (String -> Either String (FieldDescriptor msg))
-> String -> Either String (FieldDescriptor msg)
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
key

modifyField :: FieldAccessor msg value -> value -> msg -> msg
modifyField :: forall msg value. FieldAccessor msg value -> value -> msg -> msg
modifyField (PlainField WireDefault value
_ Lens' msg value
f) value
value = Setter msg msg value value -> value -> msg -> msg
forall s t a b. Setter s t a b -> b -> s -> t
set LensLike' f msg value
Lens' msg value
Setter msg msg value value
f value
value
modifyField (OptionalField Lens' msg (Maybe value)
f) value
value = Setter msg msg (Maybe value) (Maybe value)
-> Maybe value -> msg -> msg
forall s t a b. Setter s t a b -> b -> s -> t
set LensLike' f msg (Maybe value)
Lens' msg (Maybe value)
Setter msg msg (Maybe value) (Maybe value)
f (value -> Maybe value
forall a. a -> Maybe a
Just value
value)
modifyField (RepeatedField Packing
_ Lens' msg [value]
f) value
value = Setter msg msg [value] [value]
-> ([value] -> [value]) -> msg -> msg
forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over LensLike' f msg [value]
Lens' msg [value]
Setter msg msg [value] [value]
f (value
value value -> [value] -> [value]
forall a. a -> [a] -> [a]
:)
modifyField (MapField Lens' value key
key Lens' value value1
value Lens' msg (Map key value1)
f) value
mapElem
    = Setter msg msg (Map key value1) (Map key value1)
-> (Map key value1 -> Map key value1) -> msg -> msg
forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over LensLike' f msg (Map key value1)
Lens' msg (Map key value1)
Setter msg msg (Map key value1) (Map key value1)
f (key -> value1 -> Map key value1 -> Map key value1
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (value
mapElem value -> FoldLike key value value key key -> key
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike key value value key key
Lens' value key
key) (value
mapElem value -> FoldLike value1 value value value1 value1 -> value1
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike value1 value value value1 value1
Lens' value value1
value))

makeValue
    :: forall value
     . String -- ^ name of field
    -> Registry
    -> FieldTypeDescriptor value
    -> Parser.Value
    -> Either String value
makeValue :: forall value.
String
-> Registry
-> FieldTypeDescriptor value
-> Value
-> Either String value
makeValue String
name Registry
_ (ScalarField ScalarField value
f) Value
v =
    (String -> String) -> Either String value -> Either String value
forall b c d. (b -> c) -> Either b d -> Either c d
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((String
"Error parsing field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Either String value -> Either String value)
-> Either String value -> Either String value
forall a b. (a -> b) -> a -> b
$ ScalarField value -> Value -> Either String value
forall value. ScalarField value -> Value -> Either String value
makeScalarValue ScalarField value
f Value
v
makeValue String
name Registry
reg field :: FieldTypeDescriptor value
field@(MessageField MessageOrGroup
MessageType) (Parser.MessageValue (Just Text
typeUri) [Field]
x)
    | Just AnyMessageDescriptor { Lens' value Text
anyTypeUrlLens :: forall msg. AnyMessageDescriptor msg -> Lens' msg Text
anyTypeUrlLens :: Lens' value Text
anyTypeUrlLens, Lens' value ByteString
anyValueLens :: forall msg. AnyMessageDescriptor msg -> Lens' msg ByteString
anyValueLens :: Lens' value ByteString
anyValueLens } <- FieldTypeDescriptor value -> Maybe (AnyMessageDescriptor value)
forall value.
FieldTypeDescriptor value -> Maybe (AnyMessageDescriptor value)
matchAnyMessage FieldTypeDescriptor value
field =
        case Text -> Registry -> Maybe SomeMessageType
lookupRegistered Text
typeUri Registry
reg of
          Maybe SomeMessageType
Nothing -> String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Could not decode google.protobuf.Any for field "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": unregistered type URI "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
typeUri
          Just (SomeMessageType (Proxy msg
Proxy :: Proxy value')) ->
            case Registry -> [Field] -> Either String msg
forall msg. Message msg => Registry -> [Field] -> Either String msg
buildMessage Registry
reg [Field]
x :: Either String value' of
              Left String
err -> String -> Either String value
forall a b. a -> Either a b
Left String
err
              Right msg
value' -> value -> Either String value
forall a b. b -> Either a b
Right (value
forall msg. Message msg => msg
defMessage
                                        value -> (value -> value) -> value
forall s t. s -> (s -> t) -> t
& LensLike' f value Text
Lens' value Text
forall {f :: * -> *}. Identical f => LensLike' f value Text
anyTypeUrlLens (forall {f :: * -> *}. Identical f => LensLike' f value Text)
-> Text -> value -> value
forall s t a b. Setter s t a b -> b -> s -> t
.~ Text
typeUri
                                        value -> (value -> value) -> value
forall s t. s -> (s -> t) -> t
& LensLike' f value ByteString
Lens' value ByteString
forall {f :: * -> *}. Identical f => LensLike' f value ByteString
anyValueLens (forall {f :: * -> *}. Identical f => LensLike' f value ByteString)
-> ByteString -> value -> value
forall s t a b. Setter s t a b -> b -> s -> t
.~ msg -> ByteString
forall msg. Message msg => msg -> ByteString
encodeMessage msg
value')
    | Bool
otherwise = String -> Either String value
forall a b. a -> Either a b
Left (String
"Type mismatch parsing explicitly typed message. Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        Text -> String
forall a. Show a => a -> String
show (Proxy value -> Text
forall msg. Message msg => Proxy msg -> Text
messageName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @value))  String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
typeUri)
makeValue String
_ Registry
reg (MessageField MessageOrGroup
_) (Parser.MessageValue Maybe Text
_ [Field]
x) = Registry -> [Field] -> Either String value
forall msg. Message msg => Registry -> [Field] -> Either String msg
buildMessage Registry
reg [Field]
x
makeValue String
name Registry
_ (MessageField MessageOrGroup
_) Value
val =
    String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Type mismatch for field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
": expected message, found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
val

makeScalarValue :: ScalarField value -> Parser.Value -> Either String value
makeScalarValue :: forall value. ScalarField value -> Value -> Either String value
makeScalarValue ScalarField value
Int32Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
Int64Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
UInt32Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
UInt64Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
SInt32Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
SInt64Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
Fixed32Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
Fixed64Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
SFixed32Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
SFixed64Field (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
FloatField (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
DoubleField (Parser.IntValue Integer
x) = value -> Either String value
forall a b. b -> Either a b
Right (Integer -> value
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
BoolField (Parser.IntValue Integer
x)
    | Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = value -> Either String value
forall a b. b -> Either a b
Right value
Bool
False
    | Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = value -> Either String value
forall a b. b -> Either a b
Right value
Bool
True
    | Bool
otherwise = String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized bool value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
x
makeScalarValue ScalarField value
DoubleField (Parser.DoubleValue Double
x) = value -> Either String value
forall a b. b -> Either a b
Right value
Double
x
makeScalarValue ScalarField value
FloatField (Parser.DoubleValue Double
x) = value -> Either String value
forall a b. b -> Either a b
Right (Double -> value
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
x)
makeScalarValue ScalarField value
BoolField (Parser.EnumValue String
x)
    | String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"true", String
"True", String
"t"] = value -> Either String value
forall a b. b -> Either a b
Right value
Bool
True
    | String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"false", String
"False", String
"f"] = value -> Either String value
forall a b. b -> Either a b
Right value
Bool
False
    | Bool
otherwise = String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized bool value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x
makeScalarValue ScalarField value
StringField (Parser.ByteStringValue ByteString
x) = value -> Either String value
forall a b. b -> Either a b
Right (ByteString -> Text
Text.decodeUtf8 ByteString
x)
makeScalarValue ScalarField value
BytesField (Parser.ByteStringValue ByteString
x) = value -> Either String value
forall a b. b -> Either a b
Right value
ByteString
x
makeScalarValue ScalarField value
EnumField (Parser.IntValue Integer
x) =
    Either String value
-> (value -> Either String value)
-> Maybe value
-> Either String value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized enum value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
x) value -> Either String value
forall a b. b -> Either a b
Right
        (Int -> Maybe value
forall a. MessageEnum a => Int -> Maybe a
maybeToEnum (Int -> Maybe value) -> Int -> Maybe value
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
x)
makeScalarValue ScalarField value
EnumField (Parser.EnumValue String
x) =
    Either String value
-> (value -> Either String value)
-> Maybe value
-> Either String value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized enum value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x) value -> Either String value
forall a b. b -> Either a b
Right
        (String -> Maybe value
forall a. MessageEnum a => String -> Maybe a
readEnum String
x)
makeScalarValue ScalarField value
f Value
val = String -> Either String value
forall a b. a -> Either a b
Left (String -> Either String value) -> String -> Either String value
forall a b. (a -> b) -> a -> b
$ String
"Type mismatch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ScalarField value, Value) -> String
forall a. Show a => a -> String
show (ScalarField value
f, Value
val)