proto-lens-protoc 0.4.0.2 → 0.5.0.0

raw patch · 8 files changed

+1360/−262 lines, 8 filesdep ~proto-lensPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: proto-lens

API changes (from Hackage documentation)

Files

• Changelog.md +14/−2
• app/protoc-gen-haskell.hs +5/−2
• proto-lens-protoc.cabal +9/−6
• src/Data/ProtoLens/Compiler/Combinators.hs +63/−4
• src/Data/ProtoLens/Compiler/Definitions.hs +212/−31
• src/Data/ProtoLens/Compiler/Generate.hs +159/−217
• src/Data/ProtoLens/Compiler/Generate/Encoding.hs +638/−0
• src/Data/ProtoLens/Compiler/Generate/Field.hs +260/−0

@@ -1,7 +1,19 @@ # Changelog for `proto-lens-protoc` -## v0.4.0.2-- Support `haskell-src-exts-1.22.*`, and remove support for `haskell-src-exts-1.17.*`.+## v0.5.0.0++### Breaking Changes+- Capitalize enum values, and capitalize names of enum sub-messages (#270).+- Fix the parser to fail on end-group markers with the wrong tag number (#282).++### Backwards-Compatible Changes+- Allow enum names that start with underscores. (#238)+- Track changes to `proto-lens`: use generated Haskell code and a custom+  parsing monad to encode/decode proto messages faster.+- Store repeated fields internally as `Vector`s, and expose the internal+  representation via new `vec'*` lenses. (#302)+- Use `Vector`s for more efficient encoding/decoding.+- Add more combinators to support the generated code.  ## v0.4.0.1 - Bump the dependency on `base` and `containers` to support `ghc-8.6.1`.

@@ -14,7 +14,11 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text, pack)-import Data.ProtoLens (decodeMessage, defMessage, encodeMessage)+import Data.ProtoLens (defMessage, decodeMessage, encodeMessage)+-- Force the use of the Reflected API when decoding DescriptorProto+-- so that we can run the test suite against the Generated API.+-- TODO: switch back to Data.ProtoLens.Encoding once the Generated encoding is+-- good enough. import Lens.Family2 import Proto.Google.Protobuf.Compiler.Plugin     ( CodeGeneratorRequest@@ -84,7 +88,6 @@                   , exportName <- exports (filesByName ! dep)                   ]       in generateModule (haskellModule f) imports-             (fileSyntaxType (descriptor f))              modifyImports              (definitions f)              (collectEnvFromDeps deps filesByName)

@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack ----- hash: 71538a306f042a685e226ca1da1db154ba2609f0f69544fbe19c4d061b05325c+-- hash: e145fd43ae4afd8f47db892dc65ea8f96de237631a8d9299638fbe34a9c43a5a  name:           proto-lens-protoc-version:        0.4.0.2+version:        0.5.0.0 synopsis:       Protocol buffer compiler for the proto-lens library. description:    Turn protocol buffer files (.proto) into Haskell files (.hs) which can be used with the proto-lens package.                 The library component of this package contains compiler code (namely Data.ProtoLens.Compiler.*) is not guaranteed to have stable APIs.'@@ -18,7 +20,6 @@ license:        BSD3 license-file:   LICENSE build-type:     Simple-cabal-version:  >= 1.10 extra-source-files:     Changelog.md @@ -34,6 +35,8 @@       Data.ProtoLens.Compiler.Generate       Data.ProtoLens.Compiler.Plugin   other-modules:+      Data.ProtoLens.Compiler.Generate.Encoding+      Data.ProtoLens.Compiler.Generate.Field       Paths_proto_lens_protoc   hs-source-dirs:       src@@ -44,7 +47,7 @@     , haskell-src-exts >=1.18 && <1.22     , lens-family ==1.2.*     , pretty ==1.1.*-    , proto-lens ==0.4.*+    , proto-lens ==0.5.*     , text ==1.2.*   default-language: Haskell2010 @@ -59,7 +62,7 @@     , bytestring ==0.10.*     , containers >=0.5 && <0.7     , lens-family ==1.2.*-    , proto-lens ==0.4.*+    , proto-lens ==0.5.*     , proto-lens-protoc     , text ==1.2.*   default-language: Haskell2010

@@ -105,6 +105,9 @@ funBind :: [Match] -> Decl funBind = Syntax.FunBind () +patBind :: Pat -> Exp -> Decl+patBind p e = Syntax.PatBind () p (Syntax.UnGuardedRhs () e) Nothing+ instType :: Type -> Type -> Syntax.InstDecl () instType = Syntax.InsType () @@ -139,8 +142,9 @@ case' :: Exp -> [Alt] -> Exp case' = Syntax.Case () -alt :: Pat -> Exp -> Alt-alt p e = Syntax.Alt () p (Syntax.UnGuardedRhs () e) Nothing+(-->) :: Pat -> Exp -> Alt+p --> e = Syntax.Alt () p (Syntax.UnGuardedRhs () e) Nothing+infixl 1 -->  stringExp :: String -> Exp stringExp = Syntax.Lit () . string@@ -152,7 +156,7 @@ tuple = Syntax.Tuple () Syntax.Boxed  lambda :: [Pat] -> Exp -> Exp-lambda = Syntax.Lambda ()+lambda ps e = Syntax.Paren () $ Syntax.Lambda () ps e  (@::@) :: Exp -> Type -> Exp (@::@) = Syntax.ExpTypeSig ()@@ -171,7 +175,39 @@ list :: [Exp] -> Exp list = Syntax.List () +if' :: Exp -> Exp -> Exp -> Exp+if' = Syntax.If () +-- | The ":" constructor.+cons :: Exp+cons = var $ Syntax.Special () $ Syntax.Cons ()++-- | The "[]" constructor.+emptyList :: Exp+emptyList = var $ Syntax.Special () $ Syntax.ListCon ()++-- | The "()" constructor.+unit :: Exp+unit = var $ Syntax.Special () $ Syntax.UnitCon ()++typeApp :: Type -> Exp+typeApp = Syntax.TypeApp ()++type Stmt = Syntax.Stmt ()++do' :: [Stmt] -> Exp+do' = Syntax.Do ()++(<--) :: Pat -> Exp -> Stmt+(<--) = Syntax.Generator ()+infixl 1 <--++stmt :: Exp -> Stmt+stmt = Syntax.Qualifier ()++letStmt :: [Decl] -> Stmt+letStmt = Syntax.LetStmt () . Syntax.BDecls ()+ type FieldUpdate = Syntax.FieldUpdate ()  fieldUpdate :: QName -> Exp -> FieldUpdate@@ -185,6 +221,9 @@ tyParen :: Type -> Type tyParen = Syntax.TyParen () +tyFun :: Type -> Type -> Type+tyFun = Syntax.TyFun ()+ type Match = Syntax.Match ()  -- | A simple clause of a function binding.@@ -272,7 +311,12 @@ stringPat :: String -> Pat stringPat = Syntax.PLit () (Syntax.Signless ()) . string +bangPat :: Pat -> Pat+bangPat = Syntax.PBangPat () +patTypeSig :: Pat -> Type -> Pat+patTypeSig = Syntax.PatTypeSig ()+ type QName = Syntax.QName ()  qual :: ModuleName -> Name -> QName@@ -313,6 +357,9 @@ tyBang :: Type -> Type tyBang = Syntax.TyBang () (Syntax.BangedTy ()) (Syntax.NoUnpackPragma ()) +tyWildCard :: Type+tyWildCard = Syntax.TyWildCard () Nothing+ -- | Application of a Haskell type or expression to an argument. -- For example, to represent @f x y@, you can write --@@ -325,7 +372,16 @@     (@@) = Syntax.TyApp ()  instance App Exp where-    (@@) = Syntax.App ()+    Syntax.App () (Syntax.Con () v) x @@ y+        -- For readability, print fully-applied operators infix, i.e., "x OP y"+        -- rather than "(OP) x y".+        | isSymbol v+        = Syntax.InfixApp () (Syntax.Paren () x) (Syntax.QVarOp () v) y+      where+        isSymbol (Syntax.Qual () _ (Syntax.Symbol () _)) = True+        isSymbol (Syntax.UnQual () (Syntax.Symbol () _)) = True+        isSymbol _ = False+    x @@ y = Syntax.App () x y  instance IsString Name where     fromString s@@ -359,6 +415,9 @@  instance IsString Exp where     fromString fs@(f:_)+        -- TODO: this logic isn't correct for qualified names (since the module is+        -- capitalized).  However, it doesn't matter in practice if we're just+        -- generating code.         | isUpper f = Syntax.Con () $ fromString fs     fromString fs = Syntax.Var () $ fromString fs 

@@ -17,7 +17,11 @@     , MessageInfo(..)     , ServiceInfo(..)     , MethodInfo(..)+    , PlainFieldInfo(..)     , FieldInfo(..)+    , FieldKind(..)+    , FieldPacking(..)+    , MapEntryInfo(..)     , OneofInfo(..)     , OneofCase(..)     , FieldName(..)@@ -26,6 +30,7 @@     , promoteSymbol     , EnumInfo(..)     , EnumValueInfo(..)+    , EnumUnrecognizedInfo(..)     , qualifyEnv     , unqualifyEnv     , collectDefinitions@@ -33,8 +38,10 @@     , definedFieldType     , definedType     , camelCase+    , overloadedFieldName     ) where +import Control.Applicative (liftA2) import Data.Char (isUpper, toUpper) import Data.Int (Int32) import Data.List (mapAccumL)@@ -48,12 +55,19 @@ import Data.String (IsString(..)) import Data.Text (Text, cons, splitOn, toLower, uncons, unpack) import qualified Data.Text as T+import Data.Tree+    ( Tree(..)+    , Forest+    , flatten+    ) import Lens.Family2 ((^.), (^..), toListOf) import Proto.Google.Protobuf.Descriptor     ( DescriptorProto     , EnumDescriptorProto     , EnumValueDescriptorProto     , FieldDescriptorProto+    , FieldDescriptorProto'Label(..)+    , FieldDescriptorProto'Type(..)     , FileDescriptorProto     , MethodDescriptorProto     , ServiceDescriptorProto@@ -63,17 +77,23 @@     , enumType     , field     , inputType+    , label+    , mapEntry     , maybe'oneofIndex+    , maybe'packed     , messageType     , method     , name     , nestedType     , number     , oneofDecl+    , options     , outputType     , package     , serverStreaming     , service+    , syntax+    , type'     , typeName     , value     )@@ -98,6 +118,16 @@ -- either from this or another file). type Env n = Map.Map Text (Definition n) +data SyntaxType = Proto2 | Proto3+    deriving (Show, Eq)++fileSyntaxType :: FileDescriptorProto -> SyntaxType+fileSyntaxType f = case f ^. syntax of+    "proto2" -> Proto2+    "proto3" -> Proto3+    "" -> Proto2  -- The proto compiler doesn't set syntax for proto2 files.+    s -> error $ "Unknown syntax type " ++ show s+ data Definition n = Message (MessageInfo n) | Enum (EnumInfo n)     deriving Functor @@ -105,13 +135,15 @@ data MessageInfo n = MessageInfo     { messageName :: n  -- ^ Haskell type name     , messageDescriptor :: DescriptorProto-    , messageFields :: [FieldInfo] -- ^ Fields not belonging to a oneof.+    , messageFields :: [PlainFieldInfo] -- ^ Fields not belonging to a oneof.     , messageOneofFields :: [OneofInfo]       -- ^ The oneofs in this message, associated with the fields that       --   belong to them.     , messageUnknownFields :: Name       -- ^ The name of the Haskell field in this message that holds the       -- unknown fields.+    , groupFieldNumber :: Maybe Int32+      -- ^ The number of the field that holds this message, if it is a group.     } deriving Functor  data ServiceInfo = ServiceInfo@@ -129,12 +161,49 @@     , methodServerStreaming :: Bool     } +-- | Information about a single field of a proto message,+-- associated with how it is stored.+data PlainFieldInfo = PlainFieldInfo+    { plainFieldKind :: FieldKind+    , plainFieldInfo :: FieldInfo+    }+ -- | Information about a single field of a proto message. data FieldInfo = FieldInfo     { fieldDescriptor  :: FieldDescriptorProto-    , plainFieldName :: FieldName+    , fieldName :: FieldName     } +-- | How a field is stored inside of the proto message.+data FieldKind+    = RequiredField+        -- ^ A proto2 required field.  Stored internally as a value.+    | OptionalValueField+        -- ^ A proto3 optional scalar field.  Stored internally as a+        -- value, and defaults to corresponding instance of fieldDefault.+    | OptionalMaybeField+        -- ^ An optional field where the "unset" and "defaulT" values+        -- are distinguishable.  Stored internally as a Maybe.+        -- In particular: proto2 optional fields, proto3 messages,+        -- and "oneof" fields.+    | RepeatedField FieldPacking+        -- ^ A field containing a sequence of values.+        -- Stored internally as either a list or a map, depending on+        -- whether the field's FieldDescriptorProto of the field has+        -- options.map_entry set.+    | MapField MapEntryInfo+       -- ^ A field containing a map of keys to values.+       -- Serialized as a repeated field of an autogenerated "entry"+       -- proto type, each instance of which contains a key-value pair.++data FieldPacking+    = NotPackable  -- ^ Cannot be packed (e.g., strings or messages).+    | Packable     -- ^ Can be decoded as packed, but should not be not be+                   --   encoded as packed by default.+    | Packed       -- ^ Can be decoded as packed, and should be encoded+                   --   as packed by default.+  deriving Eq+ data OneofInfo = OneofInfo     { oneofFieldName :: FieldName     , oneofTypeName :: Name@@ -152,6 +221,18 @@         -- ^ The name for building 'Prism' definition.     } +-- | The "entry" type for a map field is a proto message, autogenerated by+-- protoc, that has two fields: a key and a value. The map field should be+-- serialized like a repeated field of the entry messages.+data MapEntryInfo = MapEntryInfo+    { mapEntryTypeName :: Name+        -- ^ The Haskell name for this type.+    , keyField :: FieldInfo+        -- ^ The field of the entry type corresponding to the map key.+    , valueField :: FieldInfo+        -- ^ The field of the entry type corresponding to the map value.+    }+ data FieldName = FieldName     { overloadedName :: Symbol       -- ^ The overloaded name of lenses that access this field.@@ -190,12 +271,17 @@ -- | All the information needed to define or use a proto enum type. data EnumInfo n = EnumInfo     { enumName :: n-    , enumUnrecognizedName :: n-    , enumUnrecognizedValueName :: n+    , enumUnrecognized :: Maybe EnumUnrecognizedInfo     , enumDescriptor :: EnumDescriptorProto     , enumValues :: [EnumValueInfo n]     } deriving Functor +-- | Information about the "unrecognized" case of an enum.+data EnumUnrecognizedInfo = EnumUnrecognizedInfo+    { unrecognizedName :: Name+    , unrecognizedValueName :: Name+    }+ -- | Information about a single value case of a proto enum. data EnumValueInfo n = EnumValueInfo     { enumValueName :: n@@ -240,8 +326,10 @@         "" -> "."         p -> "." <> p <> "."     hsPrefix = ""-    in Map.fromList $ messageAndEnumDefs protoPrefix hsPrefix-                          (fd ^. messageType) (fd ^. enumType)+    in Map.fromList $ concatMap flatten $+            messageAndEnumDefs (fileSyntaxType fd)+                protoPrefix hsPrefix Map.empty+                (fd ^. messageType) (fd ^. enumType)  collectServices :: FileDescriptorProto -> [ServiceInfo] collectServices fd = fmap (toServiceInfo $ fd ^. package) $ fd ^. service@@ -265,22 +353,27 @@             , methodServerStreaming = md ^. serverStreaming             } -messageAndEnumDefs :: Text -> String -> [DescriptorProto]-                   -> [EnumDescriptorProto] -> [(Text, Definition Name)]-messageAndEnumDefs protoPrefix hsPrefix messages enums-    = concatMap (messageDefs protoPrefix hsPrefix) messages-        ++ map (enumDef protoPrefix hsPrefix) enums+messageAndEnumDefs ::+    SyntaxType -> Text -> String+    -> GroupMap+        -- ^ Group fields of the parent message (if any).+    -> [DescriptorProto]+    -> [EnumDescriptorProto]+    -> Forest (Text, Definition Name)+        -- ^ Organized as a list of trees, to make it possible for callers+        -- to get the immediate child nested types.+messageAndEnumDefs syntaxType protoPrefix hsPrefix groups messages enums+    = map (messageDefs syntaxType protoPrefix hsPrefix groups) messages+        ++ map+            (flip Node [] -- Enums have no sub-definitions+                . enumDef syntaxType protoPrefix hsPrefix)+            enums  -- | Generate the definitions for a message and its nested types (if any).-messageDefs :: Text -> String -> DescriptorProto-            -> [(Text, Definition Name)]-messageDefs protoPrefix hsPrefix d-    = (protoName, thisDef)-          : messageAndEnumDefs-                (protoName <> ".")-                hsPrefix'-                (d ^. nestedType)-                (d ^. enumType)+messageDefs :: SyntaxType -> Text -> String -> GroupMap -> DescriptorProto+            -> Tree (Text, Definition Name)+messageDefs syntaxType protoPrefix hsPrefix groups d+    = Node (protoName, thisDef) subDefs   where     protoName = protoPrefix <> d ^. name     hsPrefix' = hsPrefix ++ hsName (d ^. name) ++ "'"@@ -290,16 +383,92 @@             { messageName = fromString $ hsPrefix ++ hsName (d ^. name)             , messageDescriptor = d             , messageFields =-                  map (fieldInfo hsPrefix')+                  map (liftA2 PlainFieldInfo+                              (fieldKind syntaxType mapEntries) (fieldInfo hsPrefix'))                       $ Map.findWithDefault [] Nothing allFields             , messageOneofFields = collectOneofFields hsPrefix' d allFields             , messageUnknownFields =                   fromString $ "_" ++ hsPrefix' ++ "_unknownFields"+            , groupFieldNumber = Map.lookup protoName groups             }+    subDefs = messageAndEnumDefs+                    syntaxType+                    (protoName <> ".")+                    hsPrefix'+                    (collectGroupFields $ d ^. field)+                    (d ^. nestedType)+                    (d ^. enumType)+    -- For efficiency, only look for map entries within the immediate+    -- nested types, rather than recursively searching through all of them.+    mapEntries = collectMapEntries $ map rootLabel subDefs +-- | If this type is a map entry, retrieves the relevant information+-- along with the proto name of this type.+mapEntryInfo :: Definition Name -> Maybe MapEntryInfo+mapEntryInfo (Message m)+    | messageDescriptor m ^. options . mapEntry+    , [keyFd, valueFd] <- messageFields m+    = Just MapEntryInfo+                { mapEntryTypeName = messageName m+                , keyField = plainFieldInfo keyFd+                , valueField = plainFieldInfo valueFd+                }+mapEntryInfo _ = Nothing++-- | Returns a map whose keys are the proto type name of the entry message.+collectMapEntries :: [(Text, Definition Name)] -> Map.Map Text MapEntryInfo+collectMapEntries defs =+    Map.fromList+        [(protoName, e) | (protoName, d) <- defs, Just e <- [mapEntryInfo d]]++-- | A map whose keys are the proto type names of the groups in a message,+-- and values are the field numbers for those groups.+-- (Every group corresponds to exactly one message field.)+type GroupMap = Map.Map Text Int32++collectGroupFields :: [FieldDescriptorProto] -> GroupMap+collectGroupFields fs = Map.fromList+    [ (f ^. typeName, f ^. number)+    | f <- fs+    , f ^. type' == FieldDescriptorProto'TYPE_GROUP+      ]+ fieldInfo :: String -> FieldDescriptorProto -> FieldInfo-fieldInfo hsPrefix f = FieldInfo f $ mkFieldName hsPrefix $ f ^. name+fieldInfo hsPrefix f = FieldInfo+                            { fieldDescriptor = f+                            , fieldName = mkFieldName hsPrefix $ f ^. name+                            } +fieldKind ::+    SyntaxType -> Map.Map Text MapEntryInfo -> FieldDescriptorProto+    -> FieldKind+fieldKind syntaxType mapEntries f = case f ^. label of+            FieldDescriptorProto'LABEL_OPTIONAL+                | syntaxType == Proto3+                    && f ^. type' /= FieldDescriptorProto'TYPE_MESSAGE+                    -> OptionalValueField+                | otherwise -> OptionalMaybeField+            FieldDescriptorProto'LABEL_REQUIRED -> RequiredField+            FieldDescriptorProto'LABEL_REPEATED+                | Just entryInfo <- Map.lookup (f ^. typeName) mapEntries+                    -> MapField entryInfo+                | otherwise -> RepeatedField packed+  where+    packed+        | f ^. type' `elem` unpackableTypes = NotPackable+        | packedByDefault = Packed+        | otherwise = Packable+    -- If the "packed" attribute isn't set, then default to packed if proto3.+    -- Unfortunately, protoc doesn't implement this logic for us automatically.+    packedByDefault = fromMaybe (syntaxType == Proto3)+                        $ f ^. options . maybe'packed+    unpackableTypes =+        [ FieldDescriptorProto'TYPE_MESSAGE+        , FieldDescriptorProto'TYPE_GROUP+        , FieldDescriptorProto'TYPE_STRING+        , FieldDescriptorProto'TYPE_BYTES+        ]+ collectOneofFields     :: String -> DescriptorProto -> Map.Map (Maybe Int32) [FieldDescriptorProto]     -> [OneofInfo]@@ -359,12 +528,13 @@                     , haskellRecordFieldName = fromString $ "_" ++ hsPrefix ++ n'                     }       where-        n' = fieldName n+        n' = fieldBaseName n  -- | Get the name in Haskell of a proto field, taking care of camel casing and--- clashes with language keywords.-fieldName :: Text -> String-fieldName = unpack . disambiguate . camelCase+-- clashes with language keywords.  Doesn't handle the name prefix of the+-- containing type.+fieldBaseName :: Text -> String+fieldBaseName = unpack . disambiguate . camelCase   where     disambiguate s         | s `Set.member` reservedKeywords = s <> "'"@@ -426,16 +596,24 @@     ]  -- | Generate the definition for an enum type.-enumDef :: Text -> String -> EnumDescriptorProto+enumDef :: SyntaxType -> Text -> String -> EnumDescriptorProto           -> (Text, Definition Name)-enumDef protoPrefix hsPrefix d = let+enumDef syntaxType protoPrefix hsPrefix d = let     mkText n = protoPrefix <> n-    mkHsName n = fromString $ hsPrefix ++ unpack n+    mkHsName n = fromString $ hsPrefix ++ case hsName n of+      ('_':xs) -> 'X':xs+      xs       -> xs     in (mkText (d ^. name)        , Enum EnumInfo             { enumName = mkHsName (d ^. name)-            , enumUnrecognizedName = mkHsName (d ^. name <> "'Unrecognized")-            , enumUnrecognizedValueName = mkHsName (d ^. name <> "'UnrecognizedValue")+            , enumUnrecognized = if syntaxType == Proto2+                    then Nothing+                    else Just EnumUnrecognizedInfo+                            { unrecognizedName+                                = mkHsName (d ^. name <> "'Unrecognized")+                            , unrecognizedValueName+                                = mkHsName (d ^. name <> "'UnrecognizedValue")+                            }             , enumDescriptor = d             , enumValues = collectEnumValues mkHsName $ d ^. value             })@@ -467,3 +645,6 @@ capitalize s     | Just (c, s') <- uncons s = cons (toUpper c) s'     | otherwise = s++overloadedFieldName :: FieldInfo -> Symbol+overloadedFieldName = overloadedName . fieldName

@@ -10,7 +10,6 @@ {-# LANGUAGE OverloadedStrings #-} module Data.ProtoLens.Compiler.Generate(     generateModule,-    fileSyntaxType,     ModifyImports,     reexported,     ) where@@ -20,7 +19,7 @@ import qualified Data.Foldable as F import qualified Data.List as List import qualified Data.Map as Map-import Data.Maybe (isNothing, isJust)+import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Ord (comparing) import qualified Data.Set as Set@@ -34,36 +33,23 @@ import Proto.Google.Protobuf.Descriptor     ( EnumValueDescriptorProto     , FieldDescriptorProto-    , FieldDescriptorProto'Label(..)     , FieldDescriptorProto'Type(..)-    , FileDescriptorProto     ) import Proto.Google.Protobuf.Descriptor_Fields     ( defaultValue-    , label-    , mapEntry-    , maybe'oneofIndex-    , maybe'packed     , name     , number-    , options-    , syntax     , type'     , typeName     )  import Data.ProtoLens.Compiler.Combinators import Data.ProtoLens.Compiler.Definitions--data SyntaxType = Proto2 | Proto3-    deriving (Show, Eq)--fileSyntaxType :: FileDescriptorProto -> SyntaxType-fileSyntaxType f = case f ^. syntax of-    "proto2" -> Proto2-    "proto3" -> Proto3-    "" -> Proto2  -- The proto compiler doesn't set syntax for proto2 files.-    s -> error $ "Unknown syntax type " ++ show s+import Data.ProtoLens.Compiler.Generate.Encoding+import Data.ProtoLens.Compiler.Generate.Field+    ( hsFieldType+    , hsFieldVectorType+    )  -- Whether to import the "Runtime" modules or the originals; -- e.g., Data.ProtoLens.Runtime.Data.Map vs Data.Map.@@ -74,13 +60,12 @@ -- input contains all defined names, incl. those in this module generateModule :: ModuleName                -> [ModuleName]  -- ^ The imported modules-               -> SyntaxType                -> ModifyImports                -> Env Name      -- ^ Definitions in this file                -> Env QName     -- ^ Definitions in the imported modules                -> [ServiceInfo]                -> [Module]-generateModule modName imports syntaxType modifyImport definitions importedEnv services+generateModule modName imports modifyImport definitions importedEnv services     = [ Module modName                 (Just $ (serviceExports ++) $ concatMap generateExports $ Map.elems definitions)                 pragmas@@ -102,7 +87,7 @@                "UndecidableInstances", "GeneralizedNewtypeDeriving",                "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances",                "PatternSynonyms", "MagicHash", "NoImplicitPrelude",-               "DataKinds"]+               "DataKinds", "BangPatterns", "TypeApplications"]               -- Allow unused imports in case we don't import anything from               -- Data.Text, Data.Int, etc.           , optionsGhcPragma "-fno-warn-unused-imports"@@ -111,28 +96,39 @@           , optionsGhcPragma "-fno-warn-duplicate-exports"           ]     mainImports = map (modifyImport . importSimple)-                    [ "Control.DeepSeq", "Lens.Labels.Prism" ]+                    [ "Control.DeepSeq", "Data.ProtoLens.Prism" ]     sharedImports = map (modifyImport . importSimple)-              [ "Prelude", "Data.Int", "Data.Word"-              , "Data.ProtoLens", "Data.ProtoLens.Message.Enum", "Data.ProtoLens.Service.Types"+              [ "Prelude", "Data.Int", "Data.Monoid", "Data.Word"+              , "Data.ProtoLens"+              , "Data.ProtoLens.Encoding.Bytes"+              , "Data.ProtoLens.Encoding.Growing"+              , "Data.ProtoLens.Encoding.Parser.Unsafe"+              , "Data.ProtoLens.Encoding.Wire"+              , "Data.ProtoLens.Field"+              , "Data.ProtoLens.Message.Enum"+              , "Data.ProtoLens.Service.Types"               , "Lens.Family2", "Lens.Family2.Unchecked"               , "Data.Text",  "Data.Map", "Data.ByteString", "Data.ByteString.Char8"-              , "Lens.Labels", "Text.Read"+              , "Data.Text.Encoding"+              , "Data.Vector"+              , "Data.Vector.Generic"+              , "Data.Vector.Unboxed"+              , "Text.Read"               ]             ++ map importSimple imports     env = Map.union (unqualifyEnv definitions) importedEnv     generateDecls (protoName, Message m)-        = generateMessageDecls fieldModName syntaxType env (stripDotPrefix protoName) m+        = generateMessageDecls fieldModName env (stripDotPrefix protoName) m        ++ map uncommented (concatMap (generatePrisms env) (messageOneofFields m))-    generateDecls (_, Enum e) = map uncommented $ generateEnumDecls syntaxType e+    generateDecls (_, Enum e) = map uncommented $ generateEnumDecls e     generateExports (Message m) = generateMessageExports m                                ++ concatMap generatePrismExports (messageOneofFields m)-    generateExports (Enum e) = generateEnumExports syntaxType e+    generateExports (Enum e) = generateEnumExports e     serviceExports = fmap generateServiceExports services     allLensNames = F.toList $ Set.fromList         [ lensSymbol inst         | Message m <- Map.elems definitions-        , info <- allMessageFields syntaxType env m+        , info <- allMessageFields env m         , inst <- recordFieldLenses info         ]     -- The Env uses the convention that Message names are prefixed with '.'@@ -142,9 +138,9 @@         | Just ('.', s') <- T.uncons s = s'         | otherwise = s -allMessageFields :: SyntaxType -> Env QName -> MessageInfo Name -> [RecordField]-allMessageFields syntaxType env info =-    map (plainRecordField syntaxType env) (messageFields info)+allMessageFields :: Env QName -> MessageInfo Name -> [RecordField]+allMessageFields env info =+    map (plainRecordField env) (messageFields info)         ++ map (oneofRecordField env) (messageOneofFields info)  importSimple :: ModuleName -> ImportDecl ()@@ -243,8 +239,8 @@                        Enum _ -> error "Service must have a message type"  -generateMessageDecls :: ModuleName -> SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [CommentedDecl]-generateMessageDecls fieldModName syntaxType env protoName info =+generateMessageDecls :: ModuleName -> Env QName -> T.Text -> MessageInfo Name -> [CommentedDecl]+generateMessageDecls fieldModName env protoName info =     -- data Bar = Bar {     --    foo :: Baz     -- }@@ -276,7 +272,7 @@     -- haskell: data Foo'Bar = Foo'Bar'c !Prelude.Float     --                       | Foo'Bar's !Sub     [ uncommented $ dataDecl (oneofTypeName oneofInfo)-      [ conDecl consName [hsFieldType env $ fieldDescriptor f]+      [ conDecl consName [hsFieldType env f]       | c <- oneofCases oneofInfo       , let f = caseField c       , let consName = caseConstructorName c@@ -284,14 +280,14 @@       $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]     | oneofInfo <- messageOneofFields info     ] ++-    -- instance HasLens' Foo "foo" Bar-    --   lensOf _ = ...+    -- instance HasField Foo "foo" Bar+    --   fieldOf _ = ...     -- Note: for optional fields, this generates an instance both for "foo" and     -- for "maybe'foo" (see plainRecordField below).     [ uncommented $ instDecl []-        ("Lens.Labels.HasLens'" `ihApp`+        ("Data.ProtoLens.Field.HasField" `ihApp`             [dataType, sym, tyParen t])-            [[match "lensOf'" [pWildCard] $+            [[match "fieldOf" [pWildCard] $                 "Prelude.."                     @@ rawFieldAccessor (unQual $ recordFieldName li)                     @@ lensExp i]]@@ -303,7 +299,7 @@     ++     -- instance Message.Message Bar where     [ uncommented $ instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType])-        $ messageInstance syntaxType env protoName info+        $ messageInstance env protoName info     -- instance NFData Bar where     , uncommented $ instDecl [] ("Control.DeepSeq.NFData" `ihApp` [dataType])         [[match "rnf" [] $ messageRnfExpr info]]@@ -318,7 +314,7 @@   where     dataType = tyCon $ unQual dataName     dataName = messageName info-    allFields = allMessageFields syntaxType env info+    allFields = allMessageFields env info  -- oneof Prism declarations -- proto: message Foo {@@ -331,9 +327,9 @@ --          _Foo'S :: Prism' Bar'S Sub -- --  example of the function definition for _Foo'C:--- _Foo'C :: Lens.Prism.Prism' Bar'C Float+-- _Foo'C :: Prism' Bar'C Float -- _Foo'C---   = Lens.Prism.prism' Bar'C+--   = prism' Bar'C --       (\ p__ -> --          case p__ of --              Bar'C p__val -> Prelude.Just p__val@@ -345,28 +341,28 @@        else concatMap (generatePrism mempty) cases     where         cases = oneofCases oneofInfo-        altOtherwise = [ alt "_otherwise" "Prelude.Nothing" ]+        altOtherwise = [ "_otherwise" --> "Prelude.Nothing" ]          -- Generate type signature         -- e.g. Prism' Bar'C Float         generateTypeSig f funName =-            typeSig [funName] $ "Lens.Labels.Prism.Prism'"+            typeSig [funName] $ "Data.ProtoLens.Prism.Prism'"                                 -- The oneof sum type name                              @@ (tyCon . unQual $ oneofTypeName oneofInfo)                                 -- The field contained in the sum-                             @@ (hsFieldType env $ fieldDescriptor f)+                             @@ (hsFieldType env f)         -- Generate function definition         -- Prism' is constructed with Constructor for building value         -- and Deconstructor and wrapping in Just for getting value         generateFunDef otherwiseCase consName =-               "Lens.Labels.Prism.prism'"+               "Data.ProtoLens.Prism.prism'"                -- Sum type constructor             @@ con (unQual consName)                -- Case deconstruction             @@ (lambda ["p__"] $                     case' "p__" $-                        [ alt (pApp (unQual consName) ["p__val"])-                              ("Prelude.Just" @@ "p__val")+                        [ pApp (unQual consName) ["p__val"]+                              --> "Prelude.Just" @@ "p__val"                         ]                        -- We want to generate the otherwise case                        -- depending on the amount of sum type cases there are@@ -383,28 +379,28 @@ generatePrismExports :: OneofInfo -> [ExportSpec] generatePrismExports = map (exportVar . unQual . casePrismName) . oneofCases -generateEnumExports :: SyntaxType -> EnumInfo Name -> [ExportSpec]-generateEnumExports syntaxType e = [exportAll n, exportWith n aliases] ++ proto3NewType+generateEnumExports :: EnumInfo Name -> [ExportSpec]+generateEnumExports e = [exportAll n, exportWith n aliases] ++ proto3NewType   where     n = unQual $ enumName e     aliases = [enumValueName v | v <- enumValues e, needsManualExport v]     needsManualExport v = isJust (enumAliasOf v)-    proto3NewType = if syntaxType == Proto3-      then [exportVar . unQual $ enumUnrecognizedValueName e]-      else []+    proto3NewType = case enumUnrecognized e of+        Just u -> [exportVar . unQual $ unrecognizedValueName u]+        Nothing -> []  generateServiceExports :: ServiceInfo -> ExportSpec generateServiceExports si = exportAll $ unQual $ fromString $ T.unpack $ serviceName si -generateEnumDecls :: SyntaxType -> EnumInfo Name -> [Decl]-generateEnumDecls syntaxType info =+generateEnumDecls :: EnumInfo Name -> [Decl]+generateEnumDecls info =     -- Proto3-only:     -- newtype FooEnum'UnrecognizedValue = FooEnum'UnrecognizedValue Data.Int.Int32     --   deriving (Prelude.Eq, Prelude.Ord, Prelude.Show, Prelude.Read)-    [ newtypeDecl unrecognizedValueName+    [ newtypeDecl (unrecognizedValueName u)        "Data.Int.Int32"         $ deriving' ["Prelude.Eq", "Prelude.Ord", "Prelude.Show"]-    | syntaxType == Proto3+    | Just u <- [unrecognized]     ]     ++ @@ -415,8 +411,8 @@     --   deriving (Prelude.Show, Prelude.Eq, Prelude.Ord, Prelude.Read)     [ dataDecl dataName         (  (flip conDecl [] <$> constructorNames)-        ++ [ conDecl unrecognizedName [tyCon $ unQual unrecognizedValueName]-           | syntaxType == Proto3+        ++ [ conDecl (unrecognizedName u) [tyCon $ unQual (unrecognizedValueName u)]+           | Just u <- [unrecognized]            ]         )         $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]@@ -447,12 +443,12 @@           | (c, k) <- constructorNumbers           ]           ++-          [ case syntaxType of-              Proto2 -> match "maybeToEnum" [pWildCard] "Prelude.Nothing"-              Proto3 -> match "maybeToEnum" ["k"]+          [ case enumUnrecognized info of+              Nothing -> match "maybeToEnum" [pWildCard] "Prelude.Nothing"+              Just u -> match "maybeToEnum" ["k"]                           $ "Prelude.Just" @@-                            (con (unQual unrecognizedName)-                              @@ (con (unQual unrecognizedValueName)+                            (con (unQual $ unrecognizedName u)+                              @@ (con (unQual $ unrecognizedValueName u)                                   @@ ("Prelude.fromIntegral" @@ "k")                                  )                             )@@ -463,11 +459,11 @@           , let n = enumValueName v           , let pn = T.unpack $ enumValueDescriptor v ^. name           ] ++-          [ match "showEnum" [pApp (unQual unrecognizedName)-                              [pApp (unQual unrecognizedValueName) [pVar "k"]]+          [ match "showEnum" [pApp (unQual $ unrecognizedName u)+                              [pApp (unQual $ unrecognizedValueName u) [pVar "k"]]                             ]                   $ "Prelude.show" @@ "k"-          | syntaxType == Proto3+          | Just u <- [unrecognized]           ]         , [ guardedMatch "readEnum" [pVar "k"]               [ ("Prelude.==" @@ "k" @@ stringExp pn, "Prelude.Just" @@ con (unQual n))@@ -515,11 +511,11 @@           | (c, k) <- constructorNumbers           ]           ++-          [ match "fromEnum" [pApp (unQual unrecognizedName)-                              [pApp (unQual unrecognizedValueName) [pVar "k"]]+          [ match "fromEnum" [pApp (unQual $ unrecognizedName u)+                              [pApp (unQual $ unrecognizedValueName u) [pVar "k"]]                             ]                   $ "Prelude.fromIntegral" @@ "k"-          | syntaxType == Proto3+          | Just u <- [unrecognized]           ]         , succDecl "succ" maxBoundName succPairs         , succDecl "pred" minBoundName $ map swap succPairs@@ -556,8 +552,7 @@    where     EnumInfo { enumName = dataName-             , enumUnrecognizedName = unrecognizedName-             , enumUnrecognizedValueName = unrecognizedValueName+             , enumUnrecognized = unrecognized              , enumDescriptor = ed              } = info     errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name)@@ -599,24 +594,24 @@         | (from, to) <- thePairs         ]         ++-        [ match funName [pApp (unQual unrecognizedName) [pWildCard]]+        [ match funName [pApp (unQual $ unrecognizedName u) [pWildCard]]             ("Prelude.error" @@ stringExp (concat                 [ prettyPrint dataName, ".", prettyPrint funName, ": bad argument: unrecognized value"                 ]))-        | syntaxType == Proto3+        | Just u <- [unrecognized]         ]  generateFieldDecls :: Symbol -> [Decl] generateFieldDecls xStr =     -- foo :: forall f s a     --        . (Functor f, HasLens s x a) => LensLike' f s a-    -- foo = lensOf (Proxy# :: Proxy# x)+    -- foo = fieldOf @s     [ typeSig [x]           $ tyForAll ["f", "s", "a"]                   [classA "Prelude.Functor" ["f"],-                   classA "Lens.Labels.HasLens'" ["s", xSym, "a"]]+                   classA "Data.ProtoLens.Field.HasField" ["s", xSym, "a"]]                     $ "Lens.Family2.LensLike'" @@ "f" @@ "s" @@ "a"-    , funBind [match x [] $ lensOfExp xStr]+    , funBind [match x [] $ fieldOfExp xStr]     ]   where     x = nameFromSymbol xStr@@ -649,19 +644,18 @@ -- for this particular field. -- -- Used for "plain" record fields that are not part of a oneof.-plainRecordField :: SyntaxType -> Env QName -> FieldInfo -> RecordField-plainRecordField syntaxType env f = case fd ^. label of+plainRecordField :: Env QName -> PlainFieldInfo -> RecordField+plainRecordField env (PlainFieldInfo kind f) = case kind of     -- data Foo = Foo { _Foo_bar :: Bar }     -- type instance Field "bar" Foo = Bar-    FieldDescriptorProto'LABEL_REQUIRED+    RequiredField         -> recordField baseType                   [LensInstance                       { lensSymbol = baseName                       , lensFieldType = baseType                       , lensExp = rawAccessor                       }]-    FieldDescriptorProto'LABEL_OPTIONAL-        | isDefaultingOptional syntaxType fd+    OptionalValueField               -> recordField baseType                     [LensInstance                       { lensSymbol = baseName@@ -671,7 +665,7 @@     -- data Foo = Foo { _Foo_bar :: Maybe Bar }     -- type instance Field "bar" Foo = Bar     -- type instance Field "maybe'bar" Foo = Maybe Bar-        | otherwise ->+    OptionalMaybeField ->               recordField maybeType                   [LensInstance                       { lensSymbol = baseName@@ -684,12 +678,12 @@                       , lensExp = rawAccessor                       }                   ]-    FieldDescriptorProto'LABEL_REPEATED         -- data Foo = Foo { _Foo_bar :: Map Bar Baz }         -- type instance Field "foo" Foo = Map Bar Baz-        | Just (k,v) <- getMapFields env fd -> let-            mapType = "Data.Map.Map" @@ hsFieldType env (fieldDescriptor k)-                                     @@ hsFieldType env (fieldDescriptor v)+    MapField entry ->+            let mapType = "Data.Map.Map"+                            @@ hsFieldType env (keyField entry)+                            @@ hsFieldType env (valueField entry)             in recordField mapType                   [LensInstance                        { lensSymbol = baseName@@ -698,23 +692,37 @@                        }]         -- data Foo = Foo { _Foo_bar :: [Bar] }         -- type instance Field "bar" Foo = [Bar]-        | otherwise -> recordField listType-                  [LensInstance+    RepeatedField {} ->+            recordField vectorType+                  [ LensInstance                       { lensSymbol = baseName                       , lensFieldType = listType+                      , lensExp = vectorAccessor+                      }+                  , LensInstance+                      { lensSymbol = "vec'" <> baseName+                      , lensFieldType = vectorType                       , lensExp = rawAccessor-                      }]+                      }+                  ]   where-    recordField = RecordField (haskellRecordFieldName $ plainFieldName f)-    baseName = overloadedName $ plainFieldName f+    recordField = RecordField (haskellRecordFieldName $ fieldName f)+    baseName = overloadedName $ fieldName f     fd = fieldDescriptor f-    baseType = hsFieldType env fd+    baseType = hsFieldType env f     maybeType = "Prelude.Maybe" @@ baseType     listType = tyList baseType+    vectorType = hsFieldVectorType f @@ baseType     rawAccessor = "Prelude.id"     maybeAccessor = "Data.ProtoLens.maybeLens"                           @@ hsFieldValueDefault env fd +vectorAccessor :: Exp+vectorAccessor = "Lens.Family2.Unchecked.lens" @@ getter @@ setter+  where+    getter = "Data.Vector.Generic.toList"+    setter = lambda ["_", "y__"]+                $ "Data.Vector.Generic.fromList" @@ "y__"  oneofRecordField :: Env QName -> OneofInfo -> RecordField oneofRecordField env oneofInfo@@ -760,62 +768,20 @@               ]             | c <- oneofCases oneofInfo             , let f = caseField c-            , let baseName = overloadedName $ plainFieldName f-            , let baseType = hsFieldType env $ fieldDescriptor f+            , let baseName = overloadedName $ fieldName f+            , let baseType = hsFieldType env f             , let maybeName = "maybe'" <> baseName             ] --- Get the key/value types of this type, if it is really a map.-getMapFields :: Env QName -> FieldDescriptorProto-             -> Maybe (FieldInfo, FieldInfo)-getMapFields env f-    | f ^. type' == FieldDescriptorProto'TYPE_MESSAGE-    , Message m@MessageInfo { messageDescriptor = d } <- definedFieldType f env-    , d ^. options.mapEntry-    , [f1, f2] <- messageFields m = Just (f1, f2)-    | otherwise = Nothing--hsFieldType :: Env QName -> FieldDescriptorProto -> Type-hsFieldType env fd = case fd ^. type' of-    FieldDescriptorProto'TYPE_DOUBLE -> "Prelude.Double"-    FieldDescriptorProto'TYPE_FLOAT -> "Prelude.Float"-    FieldDescriptorProto'TYPE_INT64 -> "Data.Int.Int64"-    FieldDescriptorProto'TYPE_UINT64 -> "Data.Word.Word64"-    FieldDescriptorProto'TYPE_INT32 -> "Data.Int.Int32"-    FieldDescriptorProto'TYPE_FIXED64 -> "Data.Word.Word64"-    FieldDescriptorProto'TYPE_FIXED32 -> "Data.Word.Word32"-    FieldDescriptorProto'TYPE_BOOL -> "Prelude.Bool"-    FieldDescriptorProto'TYPE_STRING -> "Data.Text.Text"-    FieldDescriptorProto'TYPE_GROUP-        | Message m <- definedFieldType fd env -> tyCon $ messageName m-        | otherwise -> error $ "expected TYPE_GROUP for type name"-                              ++ unpack (fd ^. typeName)-    FieldDescriptorProto'TYPE_MESSAGE-        | Message m <- definedFieldType fd env -> tyCon $ messageName m-        | otherwise -> error $ "expected TYPE_MESSAGE for type name"-                              ++ unpack (fd ^. typeName)-    FieldDescriptorProto'TYPE_BYTES -> "Data.ByteString.ByteString"-    FieldDescriptorProto'TYPE_UINT32 -> "Data.Word.Word32"-    FieldDescriptorProto'TYPE_ENUM-        | Enum e <- definedFieldType fd env -> tyCon $ enumName e-        | otherwise -> error $ "expected TYPE_ENUM for type name"-                              ++ unpack (fd ^. typeName)-    FieldDescriptorProto'TYPE_SFIXED32 -> "Data.Int.Int32"-    FieldDescriptorProto'TYPE_SFIXED64 -> "Data.Int.Int64"-    FieldDescriptorProto'TYPE_SINT32 -> "Data.Int.Int32"-    FieldDescriptorProto'TYPE_SINT64 -> "Data.Int.Int64"--hsFieldDefault :: SyntaxType -> Env QName -> FieldDescriptorProto -> Exp-hsFieldDefault syntaxType env fd-    = case fd ^. label of-          FieldDescriptorProto'LABEL_OPTIONAL-              | isDefaultingOptional syntaxType fd -> hsFieldValueDefault env fd-              | otherwise -> "Prelude.Nothing"-          FieldDescriptorProto'LABEL_REPEATED-              | Just _ <- getMapFields env fd -> "Data.Map.empty"-              | otherwise -> list []-          -- TODO: More sensible initialization of required fields.-          FieldDescriptorProto'LABEL_REQUIRED -> hsFieldValueDefault env fd+hsFieldDefault :: Env QName -> PlainFieldInfo -> Exp+hsFieldDefault env f = case plainFieldKind f of+    RequiredField -> hsFieldValueDefault env fd+    OptionalValueField -> hsFieldValueDefault env fd+    OptionalMaybeField -> "Prelude.Nothing"+    MapField {} -> "Data.Map.empty"+    RepeatedField {} -> "Data.Vector.Generic.empty"+  where+    fd = fieldDescriptor (plainFieldInfo f)  hsFieldValueDefault :: Env QName -> FieldDescriptorProto -> Exp hsFieldValueDefault env fd = case fd ^. type' of@@ -899,18 +865,15 @@     consName = caseConstructorName o     getter = lambda ["x__"] $         case' "x__"-            [ alt-                (pApp "Prelude.Just" [pApp (unQual consName) ["x__val"]])-                ("Prelude.Just" @@ "x__val")-            , alt-                "_otherwise"-                "Prelude.Nothing"+            [ pApp "Prelude.Just" [pApp (unQual consName) ["x__val"]]+                --> "Prelude.Just" @@ "x__val"+            , "_otherwise" --> "Prelude.Nothing"             ]     setter = lambda ["_", "y__"]                 $ "Prelude.fmap" @@ con (unQual consName) @@ "y__" -messageInstance :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [[Match]]-messageInstance syntaxType env protoName m =+messageInstance :: Env QName -> T.Text -> MessageInfo Name -> [[Match]]+messageInstance env protoName m =     [ [ match "messageName" [pWildCard] $           "Data.Text.pack" @@ stringExp (T.unpack protoName)]     , [ match "fieldsByTag" [] $@@ -919,8 +882,9 @@     , [ match "unknownFields" [] $ rawFieldAccessor (unQual $ messageUnknownFields m) ]     , [ match "defMessage" []            $ recConstr (unQual $ messageName m) $-                  [ fieldUpdate (unQual $ haskellRecordFieldName $ plainFieldName f)-                        (hsFieldDefault syntaxType env (fieldDescriptor f))+                  [ fieldUpdate (unQual $ haskellRecordFieldName+                                    $ fieldName $ plainFieldInfo f)+                        (hsFieldDefault env f)                   | f <- messageFields m                   ] ++                   [ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o)@@ -930,6 +894,8 @@                   [ fieldUpdate (unQual $ messageUnknownFields m)                         "[]"]       ]+    , [ match "parseMessage" [] $ generatedParser env m ]+    , [ match "buildMessage" [] $ generatedBuilder m ]     ]   where     fieldsByTag =@@ -938,18 +904,21 @@               | f <- fields               , let t = "Data.ProtoLens.Tag"                           @@ litInt (fromIntegral-                                      $ fieldDescriptor f ^. number)+                                      $ fieldDescriptor (plainFieldInfo f) ^. number)               ]     fieldDescriptorVar = var . unQual . fieldDescriptorName     fieldDescriptorName f-        = nameFromSymbol $ overloadedName (plainFieldName f) <> "__field_descriptor"+        = nameFromSymbol $ overloadedName (fieldName . plainFieldInfo $ f)+                                <> "__field_descriptor"     fieldDescriptorVarBind n f         = funBind               [match (fieldDescriptorName f) []-                  $ fieldDescriptorExpr syntaxType env n f+                  $ fieldDescriptorExpr env n f               ]     fields = messageFields m-                ++ (messageOneofFields m >>= fmap caseField . oneofCases)+                ++ (messageOneofFields m >>= fmap casePlainField . oneofCases)+    -- The cases of an optional are always treated like proto2 "maybe" fields.+    casePlainField = PlainFieldInfo OptionalMaybeField . caseField  -- | Get the name of the field when used in a text format proto. Groups are -- special because their text format field name is the name of their type,@@ -963,9 +932,9 @@                            ++ T.unpack (descr ^. typeName)     _ -> descr ^. name -fieldDescriptorExpr :: SyntaxType -> Env QName -> Name -> FieldInfo+fieldDescriptorExpr :: Env QName -> Name -> PlainFieldInfo                     -> Exp-fieldDescriptorExpr syntaxType env n f =+fieldDescriptorExpr env n f =     ("Data.ProtoLens.FieldDescriptor"         -- Record the original .proto name for text format         @@ stringExp (T.unpack $ textFormatFieldName env fd)@@ -974,72 +943,45 @@         @@ (fieldTypeDescriptorExpr (fd ^. type')                 @::@                     ("Data.ProtoLens.FieldTypeDescriptor"-                        @@ hsFieldType env fd))-        @@ fieldAccessorExpr syntaxType env f)+                        @@ hsFieldType env (plainFieldInfo f)))+        @@ fieldAccessorExpr f)     -- TODO: why is this type sig needed?     @::@     ("Data.ProtoLens.FieldDescriptor" @@ tyCon (unQual n))   where-    fd = fieldDescriptor f+    fd = fieldDescriptor $ plainFieldInfo f -fieldAccessorExpr :: SyntaxType -> Env QName -> FieldInfo -> Exp+fieldAccessorExpr :: PlainFieldInfo -> Exp -- (PlainField Required foo), (OptionalField foo), etc...-fieldAccessorExpr syntaxType env f = accessorCon @@ lensOfExp hsFieldName+fieldAccessorExpr (PlainFieldInfo kind f) = accessorCon @@ fieldOfExp hsFieldName    where-    fd = fieldDescriptor f-    accessorCon = case fd ^. label of-          FieldDescriptorProto'LABEL_REQUIRED-              -> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Required"-          FieldDescriptorProto'LABEL_OPTIONAL-              | isDefaultingOptional syntaxType fd-                  -> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Optional"-              | otherwise -> "Data.ProtoLens.OptionalField"-          FieldDescriptorProto'LABEL_REPEATED-              | Just (k, v) <- getMapFields env fd+    accessorCon = case kind of+          RequiredField+                -> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Required"+          OptionalValueField+                -> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Optional"+          OptionalMaybeField+                -> "Data.ProtoLens.OptionalField"+          MapField entry                   -> "Data.ProtoLens.MapField"-                         @@ lensOfExp (overloadedField k)-                         @@ lensOfExp (overloadedField v)-              | otherwise -> "Data.ProtoLens.RepeatedField"-                  @@ if isPackedField syntaxType fd+                         @@ fieldOfExp (overloadedField $ keyField entry)+                         @@ fieldOfExp (overloadedField $ valueField entry)+          RepeatedField packed -> +                "Data.ProtoLens.RepeatedField"+                  @@ if packed == Packed                         then "Data.ProtoLens.Packed"                         else "Data.ProtoLens.Unpacked"     hsFieldName-        = case fd ^. label of-              FieldDescriptorProto'LABEL_OPTIONAL-                  | not (isDefaultingOptional syntaxType fd)-                      -> "maybe'" <> overloadedField f-              _ -> overloadedField f+        = case kind of+            OptionalMaybeField -> "maybe'" <> overloadedField f+            _ -> overloadedField f -lensOfExp :: Symbol -> Exp-lensOfExp sym = ("Lens.Labels.lensOf'"-                  @@ ("Lens.Labels.proxy#" @::@-                      ("Lens.Labels.Proxy#" @@ promoteSymbol sym)))+fieldOfExp :: Symbol -> Exp+fieldOfExp sym = "Data.ProtoLens.Field.field" @@ typeApp (promoteSymbol sym)  overloadedField :: FieldInfo -> Symbol-overloadedField = overloadedName . plainFieldName--isDefaultingOptional :: SyntaxType -> FieldDescriptorProto -> Bool-isDefaultingOptional syntaxType f-    = f ^. label == FieldDescriptorProto'LABEL_OPTIONAL-          && syntaxType == Proto3-          && f ^. type' /= FieldDescriptorProto'TYPE_MESSAGE-          -- oneof fields have the same API as proto2 optional fields,-          -- but setting one field will automatically clear the others.-          && isNothing (f ^. maybe'oneofIndex)--isPackedField :: SyntaxType -> FieldDescriptorProto -> Bool-isPackedField s f = case f ^. options . maybe'packed of-    Just t -> t-    -- proto3 fields are packed by default.  Annoyingly, we need to-    -- implement this logic manually rather than relying on protoc.-    Nothing -> s == Proto3-                && f ^. type' `notElem`-                      [ FieldDescriptorProto'TYPE_MESSAGE-                      , FieldDescriptorProto'TYPE_GROUP-                      , FieldDescriptorProto'TYPE_STRING-                      , FieldDescriptorProto'TYPE_BYTES-                      ]+overloadedField = overloadedName . fieldName  fieldTypeDescriptorExpr :: FieldDescriptorProto'Type -> Exp fieldTypeDescriptorExpr = \case@@ -1073,7 +1015,7 @@ messageRnfExpr msg = lambda ["x__"] $ foldr (@@) "()" (map seqField fieldNames)   where     fieldNames = messageUnknownFields msg-                : map (haskellRecordFieldName . plainFieldName)+                : map (haskellRecordFieldName . fieldName . plainFieldInfo)                        (messageFields msg)                 ++ map (haskellRecordFieldName . oneofFieldName)                        (messageOneofFields msg)

@@ -0,0 +1,638 @@+-- | This module generates code for decoding and encoding protocol buffer messages.+--+-- Upstream docs: <https://developers.google.com/protocol-buffers/docs/encoding>+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.ProtoLens.Compiler.Generate.Encoding+    ( generatedParser+    , generatedBuilder+    ) where++import Data.Int (Int32)+import qualified Data.Map as Map+import Data.Semigroup ((<>))+import qualified Data.Text as Text+import Lens.Family2 (view, (^.))++import Data.ProtoLens.Compiler.Combinators+import Data.ProtoLens.Compiler.Definitions+import Data.ProtoLens.Compiler.Generate.Field+import Data.ProtoLens.Encoding.Wire (joinTypeAndTag)++import Proto.Google.Protobuf.Descriptor_Fields+    ( name+    , number+    , type'+    )++generatedParser :: Env QName -> MessageInfo Name -> Exp+generatedParser env m =+    {- let loop :: T -> Bool -> Bool -> ...+                   -> MVector RealWorld Int32 -> MVector RealWorld Float -> ...+                   -> Parser T+           loop x required'a required'b ... mutable'a mutable'b ... = ...+       in "package.T" <?> do+            mutable'a <- unsafeLiftIO new+            mutable'b <- unsafeLiftIO new+            ...+            loop defMessage True True ... mutable'a mutable'b ...+    -}+    let' [typeSig [loop] loopSig+         , funBind [match loop (fmap pVar $ loopArgs names) loopExpr]+         ]+        $ "Data.ProtoLens.Encoding.Bytes.<?>"+           @@ do' (startStmts ++ [stmt $ continue startExp])+           @@ stringExp msgName+  where+    ty = tyCon (unQual $ messageName m)+    msgName = Text.unpack (messageDescriptor m ^. name)+    loopSig = foldr tyFun+        ("Data.ProtoLens.Encoding.Bytes.Parser" @@ ty)+        (loopArgs $ parseStateTypes env m)++    names = parseStateNames m+    exprs = fmap (var . unQual) names+    tag = "tag"+    end = "end"+    loop = "loop"++    (startStmts, startExp) = startParse names++    continue :: ParseState Exp -> Exp+    continue s = foldl (@@) loop (loopArgs s)++    loopExpr+        {- Group:+            do+              tag <- getVarInt+              case tag of+                {groupEndTag} -> {finish}+                ... -- Regular message fields++          TODO(#282): fail the parse if we find a group-end tag+          with an incorrect field number.+        -}+        | Just g <- groupFieldNumber m = do'+            [ tag <-- getVarInt'+            , stmt $ case' tag $+                (pLitInt (groupEndTag g) --> finish m exprs)+                    : parseTagCases continue exprs m+            ]+        {- Regular message type:+              do+                end <- atEnd+                if end+                    then {finish}+                    else do+                        tag <- getVarInt+                        case tag of ...+        -}+        | otherwise = do'+            [ end <-- "Data.ProtoLens.Encoding.Bytes.atEnd"+            , stmt $+                if' end (finish m exprs)+                    $ do'+                        [ tag <-- getVarInt'+                        , stmt $ case' tag $ parseTagCases continue exprs m+                        ]+            ]++-- | A Parser expression that finalizes the message.+finish :: MessageInfo Name -> ParseState Exp -> Exp+finish m s = do' $+    {- do+        frozen'a <- unsafeLiftIO $ unsafeFreeze mutable'a+        frozen'b <- unsafeLiftIO $ unsafeFreeze mutable'b+        ...+        {checkMissingFields}+        over unknownFields reverse+            $ set field @"vec'a" frozen'a+            $ set field @"vec'b" frozen'b+            ...+            $ {partialMessage}+    -}+    [ pVar frozen <-- unsafeLiftIO' @@+                    ("Data.ProtoLens.Encoding.Growing.unsafeFreeze"+                        @@ mutable)+    | (frozen, mutable) <- Map.elems $ Map.intersectionWith (,)+                                frozenNames (repeatedFieldMVectors s)+    ]+    +++    [ stmt $ checkMissingFields s+    , stmt $ "Prelude.return" @@+        (over' unknownFields' "Prelude.reverse"+            @@(foldr (@@)+                (partialMessage s)+                (Map.intersectionWith+                    (\finfo frozen ->+                        "Lens.Family2.set"+                            @@ fieldOfVector finfo+                            @@ var (unQual frozen))+                repeatedInfos frozenNames)))+            ]++  where+    repeatedInfos = repeatedFields m+    frozenNames = (\f -> nameFromSymbol $ "frozen'" <> overloadedFieldName f)+                    <$> repeatedInfos++-- | The state of the parsing loop.  Each instance of @v@ corresponds+-- to an argument of the loop function.+data ParseState v = ParseState+    { partialMessage :: v+        -- ^ The message that we're parsing.+    , requiredFieldsUnset :: Map.Map FieldId v+        -- ^ The required fields of the message, each corresponding to+        -- a @Bool@ argument of the loop.+    , repeatedFieldMVectors :: Map.Map FieldId v+        -- ^ The repeated fields of the message, each corresponding to+        -- an @MVector@ argument of the loop.+    } deriving Functor++-- | Returns a sequence of all arguments of the loop function.+loopArgs :: ParseState v -> [v]+loopArgs s = partialMessage s : Map.elems (requiredFieldsUnset s)+                                ++ Map.elems (repeatedFieldMVectors s)++-- | The proto name of the field.+newtype FieldId = FieldId Text.Text+    deriving (Eq, Ord)++fieldId :: PlainFieldInfo -> FieldId+fieldId f = FieldId $ fieldDescriptor (plainFieldInfo f) ^. name++-- | The names of the loop arguments.+parseStateNames :: MessageInfo Name -> ParseState Name+parseStateNames m = ParseState+    { partialMessage = "x"+    , requiredFieldsUnset = Map.fromList+        [ (fieldId f, nameFromSymbol $ "required'" <> n)+        | f <- messageFields m+        , let info = plainFieldInfo f+        , let n = overloadedFieldName info+        , RequiredField <- [plainFieldKind f]+        ]+    , repeatedFieldMVectors =+        (\f -> nameFromSymbol $ "mutable'" <> overloadedFieldName f)+            <$> repeatedFields m+    }++repeatedFields :: MessageInfo Name -> Map.Map FieldId FieldInfo+repeatedFields m = Map.fromList+    [ (fieldId f, plainFieldInfo f)+    | f <- messageFields m+    , RepeatedField{} <- [plainFieldKind f]+    ]++-- | Intialize the values of the loop arguments.+startParse :: ParseState Name -> ([Stmt], ParseState Exp)+startParse names =+    ([ pVar n <-- unsafeLiftIO' @@ "Data.ProtoLens.Encoding.Growing.new"+     | n <- Map.elems mvectorNames+     ]+    , ParseState+        { partialMessage = "Data.ProtoLens.defMessage"+        , requiredFieldsUnset = const "Prelude.True"+                                    <$> requiredFieldsUnset names+        , repeatedFieldMVectors = var . unQual <$> mvectorNames+        }+    )+  where+    mvectorNames = repeatedFieldMVectors names++-- | The types of the loop arguments.+parseStateTypes :: Env QName -> MessageInfo Name -> ParseState Type+parseStateTypes env m = ParseState+    { partialMessage = tyCon (unQual $ messageName m)+    , requiredFieldsUnset = fmap (const "Prelude.Bool")+                            $ requiredFieldsUnset+                            $ parseStateNames m+    , repeatedFieldMVectors = growingType env <$> repeatedFields m+    }++-- | Transform the loop arguments by applying a given function+-- to the intermediate message value.+updateParseState ::+       Exp -- ^ An expression of type @msg -> msg@+    -> ParseState Exp+    -> ParseState Exp+updateParseState f s = s { partialMessage = f @@ (partialMessage s) }++-- | Transform the loop arguments by marking a required field+-- as having been set.+markRequiredField :: FieldId -> ParseState Exp -> ParseState Exp+markRequiredField f s =+    s { requiredFieldsUnset = Map.insert f "Prelude.False"+                                $ requiredFieldsUnset s }++-- | Append to the given repeated field.+appendToRepeated :: FieldId -> Exp -> ParseState Exp -> (Stmt, ParseState Exp)+appendToRepeated f x s =+    ( v <-- unsafeLiftIO'+                @@ ("Data.ProtoLens.Encoding.Growing.append"+                        @@ (repeatedFieldMVectors s Map.! f)+                        @@ x)+    , s { repeatedFieldMVectors =+                            Map.insert f (var $ unQual v)+                                $ repeatedFieldMVectors s+                        }+    )+  where+    v = "v"++-- | Returns an Exp of type @Parser ()@+-- which fails if any of the missing fields aren't set.+checkMissingFields :: ParseState Exp -> Exp+checkMissingFields s =+    {- let missing = (if required'a then ("a":) else id)+                        ((if required'b then ("b":) else id)+                        ... [])+       in if null missing then return ()+          else fail ("Missing required fields: " ++ show missing)+    -}+    let' [patBind missing allMissingFields]+    $ if' ("Prelude.null" @@ missing) ("Prelude.return" @@ unit)+    $ "Prelude.fail"+        @@ ("Prelude.++"+                @@ stringExp "Missing required fields: "+                @@ ("Prelude.show" @@ (missing @::@ "[Prelude.String]")))+  where+    missing = "missing"+    allMissingFields = Map.foldrWithKey consIfMissing emptyList (requiredFieldsUnset s)+    consIfMissing (FieldId f) e rest =+        (if' e (cons @@ stringExp (Text.unpack f)) "Prelude.id") @@ rest++-- | A list case alternatives for the fields of a message.+--+-- The exact structure of each case differs based on the field type.  However, it+-- generally looks like:+--+-- @+--   {N} -> do+--           {VALUE} <- {PARSE}+--           loop (set {FIELD} {VALUE} x) required'a False required'c ...+-- @+--+-- where:+--  - {N} is an integer representing the wire type + field number,+--  - {VALUE} is an expression of type "V", which is the type of the field,+--  - {PARSE} is an expression of the form "Parser V",+--  - and "loop" and "x" are as in @generatedParser@.+parseTagCases ::+       (ParseState Exp -> Exp)+            -- ^ loop continuation, equivalent to "msg -> Bool -> ... -> Bool -> Parser msg".+            -- It continues the loop with the given new value of the message, keeping track+            -- of whether the required fields are still needed.+    -> ParseState Exp -- ^ Previous value of the message and required field states+    -> MessageInfo Name+    -> [Alt]+parseTagCases loop x info =+    concatMap (parseFieldCase loop x) allFields+    -- TODO: currently we ignore unknown fields.+    ++ [unknownFieldCase info loop x]+  where+    allFields = messageFields info+                -- Cases of a oneof are decoded like optional oneof fields.+                ++ [ PlainFieldInfo OptionalMaybeField (caseField c)+                   | o <- messageOneofFields info+                   , c <- oneofCases o+                   ]++-- | A particular parsing case.  See @parseTagCases@ for details.+parseFieldCase ::+    (ParseState Exp -> Exp) -> ParseState Exp -> PlainFieldInfo -> [Alt]+parseFieldCase loop x f = case plainFieldKind f of+    MapField entryInfo -> [mapCase entryInfo]+    RepeatedField p+        | p == NotPackable -> [unpackedCase]+        | otherwise -> [unpackedCase, packedCase]+    RequiredField -> [requiredCase]+    _ -> [valueCase]+  where+    y = "y"+    entry = "entry"+    info = plainFieldInfo f+    valueCase = pLitInt (fieldTag info) --> do'+        [ y <-- parseField info+        , stmt . loop . updateParseState (setField info @@ y)+            $ x+        ]+    requiredCase = pLitInt (fieldTag info) --> do'+        [ y <-- parseField info+        , stmt . loop+               . updateParseState (setField info @@ y)+               . markRequiredField (fieldId f)+               $ x+        ]+    unpackedCase = pLitInt (fieldTag info) -->+        let (appendStmt, x') = appendToRepeated (fieldId f) y x+        in do'+            [ bangPat y <-- parseField info+            , appendStmt+            , stmt . loop $ x'+            ]+    packedCase = pLitInt (packedFieldTag info) --> do'+        [ y <-- isolatedLengthy (parsePackedField info+                                    @@ repeatedFieldMVectors x Map.! fieldId f)+        , stmt $ loop x { repeatedFieldMVectors =+                                Map.insert (fieldId f) (var $ unQual y)+                                    $ repeatedFieldMVectors x }+        ]+    mapCase entryInfo = pLitInt (fieldTag info) --> do'+        [ bangPat (entry `patTypeSig` tyCon (unQual $ mapEntryTypeName entryInfo))+                <-- parseField info+        , stmt . let' [ patBind "key"+                            $ view' @@ fieldOf (keyField entryInfo)+                                    @@ entry+                      , patBind "value"+                            $ view' @@ fieldOf (valueField entryInfo)+                                    @@ entry+                      ]+               . loop+               . updateParseState+                    (overField info+                                ("Data.Map.insert" @@ "key" @@ "value"))+               $ x+        ]++unknownFieldCase ::+    MessageInfo Name -> (ParseState Exp -> Exp) -> ParseState Exp -> Alt+{-+  wire -> do+        !y <- parseTaggedValueFromWire wire+        -- Omitted if not a group:+        case y of+            TaggedValue utag EndGroup+                -> fail ("Mismatched group-end tag number " ++ show utag)+            _ -> return ()+        loop (over unknownFields (\!t -> y:t) x) ...+-}+unknownFieldCase info loop x = wire --> (do' $+    [ bangPat y <-- "Data.ProtoLens.Encoding.Wire.parseTaggedValueFromWire" @@ wire+    ]+    +++    [ stmt $ case' y+        [ pApp "Data.ProtoLens.Encoding.Wire.TaggedValue"+            [utag, "Data.ProtoLens.Encoding.Wire.EndGroup"]+            --> "Prelude.fail" @@+                    ("Prelude.++"+                        @@ stringExp "Mismatched group-end tag number "+                        @@ ("Prelude.show" @@ utag))+        , pWildCard --> "Prelude.return" @@ unit+        ]+    | Just _ <- [groupFieldNumber info]+    ]+    +++    [ stmt . loop . updateParseState (over' unknownFields' (cons @@ y))+        $ x+    ])+  where+    wire = "wire"+    y = "y"+    utag = "utag"++-- | An expression of type "b -> a -> a", corresponding to a Lens a b+-- for this field.+setField :: FieldInfo -> Exp+setField f = "Lens.Family2.set" @@ fieldOf f++-- | An expression of type "(b -> b) -> a -> a", corresponding to a+-- Lens a b for this field.+overField :: FieldInfo -> Exp -> Exp+overField f = over' (fieldOf f)++-- | An expression of type "(b -> b) -> a -> a".+--+-- Specifically, this renders to:+--   over f (\!z -> g z) x+-- The extra strictness prevents a space leak due to lists being lazy.+over' :: Exp -> Exp -> Exp+over' f g = "Lens.Family2.over"+                @@ f+                @@ lambda [bangPat t] (g @@ t)+  where+    t = "t"++-- | A "Growing v RealWorld a -> Parser (Growing v RealWorld a)"+-- for a field that can be packed.+parsePackedField :: FieldInfo -> Exp+{- let ploop qs = do+                    packedEnd <- atEnd+                    if packedEnd+                        then return qs+                        else do+                            !q <- {PARSE FIELD}+                            qs' <- append qs q+                            ploop qs'+   in ploop+-}+parsePackedField info = let' [funBind [match ploop [qs] ploopExp]]+                            ploop+  where+    ploop = "ploop"+    q = "q"+    qs = "qs"+    qs' = "qs'"+    packedEnd = "packedEnd"+    ploopExp = do'+        [ packedEnd <-- "Data.ProtoLens.Encoding.Bytes.atEnd"+        , stmt $+            if' packedEnd+                ("Prelude.return" @@ qs)+                $ do'+                    [ bangPat q <-- parseField info+                    , qs' <-- unsafeLiftIO' @@+                                ("Data.ProtoLens.Encoding.Growing.append"+                                    @@ qs @@ q)+                    , stmt $ ploop @@ qs'+                    ]+        ]++generatedBuilder :: MessageInfo Name -> Exp+generatedBuilder m =+    lambda [x] $ foldMapExp $ map (buildPlainField x) (messageFields m)+                                ++ map (buildOneofField x) (messageOneofFields m)+                            ++ [buildUnknown x]+                            ++ buildGroupEnd+  where+    x = "_x" -- TODO: rename to "x" once it's always used+    -- If this is a group, finish by emitting the end-group tag.+    buildGroupEnd = [ putVarInt' @@ litInt (groupEndTag g)+               | Just g <- [groupFieldNumber m]+               ]++buildUnknown :: Exp -> Exp+buildUnknown x+    = "Data.ProtoLens.Encoding.Wire.buildFieldSet"+                @@ (view' @@ unknownFields' @@ x)++-- | Concatenate a list of Monoids into a single value.+-- For example, foldMapExp [a,b,c] will be transformed into+-- the (unrolled) expression a <> b <> c.+foldMapExp :: [Exp] -> Exp+foldMapExp [] = mempty'+foldMapExp [x] = x+foldMapExp (x:xs) = "Data.Monoid.<>" @@ x @@ foldMapExp xs++-- | An expression of type @Builder@ which encodes the field value+-- @x@ based on the kind and type of the field @f@.+buildPlainField :: Exp -> PlainFieldInfo -> Exp+buildPlainField x f = case plainFieldKind f of+    RequiredField -> buildTaggedField info fieldValue+    OptionalMaybeField -> case' maybeFieldValue+                            ["Prelude.Nothing" --> mempty'+                            , "Prelude.Just" `pApp` [v]+                                --> buildTaggedField info v+                            ]+    OptionalValueField -> let' [patBind v fieldValue]+                          $ if' ("Prelude.==" @@ v @@ "Data.ProtoLens.fieldDefault")+                                mempty'+                                (buildTaggedField info v)+    MapField entryInfo+        -> "Data.Monoid.mconcat"+            @@ ("Prelude.map"+                    @@ lambda [v] (buildEntry entryInfo v)+                    @@ ("Data.Map.toList" @@ fieldValue))+    RepeatedField Packed -> buildPackedField info vectorFieldValue+    RepeatedField _ -> "Data.ProtoLens.Encoding.Bytes.foldMapBuilder"+                            @@ lambda [v]+                                    (buildTaggedField info v)+                            @@ vectorFieldValue+  where+    info = plainFieldInfo f+    v = "_v"+    fieldValue = view'+                    @@ fieldOf info+                    @@ x+    maybeFieldValue = view'+                        @@ fieldOfMaybe info+                        @@ x+    vectorFieldValue = view'+                        @@ fieldOfVector info+                        @@ x+    {- Builds a value of the given map entry type+       from the given key/value pair kv.++       ... set (fieldOf {KEY}) (fst kv)+            (set (fieldOf {VALUE}) (snd kv)+                (defMessage :: Foo'Entry)+    -}+    buildEntry entry kv+        = buildTaggedField info+            $ set'+                @@ fieldOf (keyField entry)+                @@ ("Prelude.fst" @@ kv)+                @@ (set' @@ fieldOf (valueField entry)+                         @@ ("Prelude.snd" @@ kv)+                         @@ ("Data.ProtoLens.defMessage"+                                @::@ tyCon (unQual $ mapEntryTypeName entry)))++fieldOf :: FieldInfo -> Exp+fieldOf = fieldOfExp . overloadedFieldName++fieldOfMaybe :: FieldInfo -> Exp+fieldOfMaybe = fieldOfExp . ("maybe'" <>) . overloadedFieldName++fieldOfOneof :: OneofInfo -> Exp+fieldOfOneof =+    fieldOfExp . ("maybe'" <>) . overloadedName . oneofFieldName++fieldOfVector :: FieldInfo -> Exp+fieldOfVector = fieldOfExp . ("vec'" <>) . overloadedFieldName++-- | Build a field along with its tag.+buildTaggedField :: FieldInfo -> Exp -> Exp+buildTaggedField f x = foldMapExp+    [ putVarInt' @@ litInt (fieldTag f)+    , buildField f @@ x+    ]++-- | Encodes a packed field as a byte string, along with+-- its wire type+number.+buildPackedField :: FieldInfo -> Exp -> Exp+{-+    let p = x -- where x might be a complicated expression+    in if null p then mempty+    else putVarInt {TAG}+            <> ... (runBuilder (mconcat (map {BUILD_ELT} p)))+-}+buildPackedField f x = let' [patBind p x]+    $ if' ("Data.Vector.Generic.null" @@ p) mempty'+    $ "Data.Monoid.<>"+        @@ (putVarInt' @@ litInt (packedFieldTag f))+        @@ (buildFieldType lengthy+                @@ ("Data.ProtoLens.Encoding.Bytes.runBuilder"+                    @@ ("Data.ProtoLens.Encoding.Bytes.foldMapBuilder"+                            @@ buildField f+                            @@ p)))+  where+    p = "p"++buildOneofField :: Exp -> OneofInfo -> Exp+buildOneofField x info = case' (view' @@ fieldOfOneof info @@ x) $+    ("Prelude.Nothing" --> mempty')+    : [ pApp "Prelude.Just" [pApp (unQual $ caseConstructorName c)+                                 [v]]+            --> buildTaggedField (caseField c) v+      | c <- oneofCases info+      ]+  where+    v = "v"++-- | Compute the proto encoding's representation of the wire type+-- and field number.+--+-- The last three bits of the number store the wire type, and the+-- rest store the field number as a varint.+makeTag :: Int32 -> FieldEncoding -> Integer+makeTag num enc = fromIntegral $ joinTypeAndTag (fromIntegral num) (wireType enc)++fieldTag :: FieldInfo -> Integer+fieldTag f = makeTag (fieldDescriptor f ^. number) $ fieldInfoEncoding f++packedFieldTag :: FieldInfo -> Integer+packedFieldTag f = makeTag (fieldDescriptor f ^. number) lengthy++groupEndTag :: Int32 -> Integer+groupEndTag num = makeTag num groupEnd++-- | An expression that selects the overloaded field lens of this name.+--+-- field @"fieldName"+fieldOfExp :: Symbol -> Exp+fieldOfExp sym = "Data.ProtoLens.Field.field" @@ typeApp (promoteSymbol sym)++-- | Some functions that are used in multiple places in the generated code.+getVarInt', putVarInt', mempty', view', set', unknownFields', unsafeLiftIO'+    :: Exp+getVarInt' = "Data.ProtoLens.Encoding.Bytes.getVarInt"+putVarInt' = "Data.ProtoLens.Encoding.Bytes.putVarInt"+mempty' = "Data.Monoid.mempty"+view' = "Lens.Family2.view"+set' = "Lens.Family2.set"+unknownFields' = "Data.ProtoLens.unknownFields"+unsafeLiftIO' = "Data.ProtoLens.Encoding.Parser.Unsafe.unsafeLiftIO"++-- | Returns an expression of type @Parser a@ for the given field.+parseField :: FieldInfo -> Exp+parseField f = "Data.ProtoLens.Encoding.Bytes.<?>"+                    @@ (parseFieldType $ fieldInfoEncoding f)+                    @@ stringExp n+  where+    n = Text.unpack (fieldDescriptor f ^. name)++-- | Returns a function corresponding to `a -> Builder`:+buildField :: FieldInfo -> Exp+buildField = buildFieldType . fieldInfoEncoding++fieldInfoEncoding :: FieldInfo -> FieldEncoding+fieldInfoEncoding = fieldEncoding . view type' . fieldDescriptor++growingType :: Env QName -> FieldInfo -> Type+growingType env f+    = "Data.ProtoLens.Encoding.Growing.Growing"+        @@ hsFieldVectorType f+        @@ "Data.ProtoLens.Encoding.Growing.RealWorld"+        @@ hsFieldType env f

@@ -0,0 +1,260 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+-- | This module generates the code for decoding and encoding+-- individual field types.+--+-- Upstream docs:+-- <https://developers.google.com/protocol-buffers/docs/encoding#structure>+module Data.ProtoLens.Compiler.Generate.Field+    ( hsFieldType+    , hsFieldVectorType+    , FieldEncoding(..)+    , fieldEncoding+    , lengthy+    , groupEnd+    , isolatedLengthy+    ) where++import Data.Text (unpack)+import Data.Word (Word8)+import Lens.Family2+import Proto.Google.Protobuf.Descriptor (FieldDescriptorProto'Type(..))+import Proto.Google.Protobuf.Descriptor_Fields (type', typeName)++import Data.ProtoLens.Compiler.Combinators+import Data.ProtoLens.Compiler.Definitions++hsFieldType :: Env QName -> FieldInfo -> Type+hsFieldType env f = let+    fd = fieldDescriptor f+    in case fd ^. type' of+        FieldDescriptorProto'TYPE_DOUBLE -> "Prelude.Double"+        FieldDescriptorProto'TYPE_FLOAT -> "Prelude.Float"+        FieldDescriptorProto'TYPE_INT64 -> "Data.Int.Int64"+        FieldDescriptorProto'TYPE_UINT64 -> "Data.Word.Word64"+        FieldDescriptorProto'TYPE_INT32 -> "Data.Int.Int32"+        FieldDescriptorProto'TYPE_FIXED64 -> "Data.Word.Word64"+        FieldDescriptorProto'TYPE_FIXED32 -> "Data.Word.Word32"+        FieldDescriptorProto'TYPE_BOOL -> "Prelude.Bool"+        FieldDescriptorProto'TYPE_STRING -> "Data.Text.Text"+        FieldDescriptorProto'TYPE_GROUP+            | Message m <- definedFieldType fd env -> tyCon $ messageName m+            | otherwise -> error $ "expected TYPE_GROUP for type name"+                                ++ unpack (fd ^. typeName)+        FieldDescriptorProto'TYPE_MESSAGE+            | Message m <- definedFieldType fd env -> tyCon $ messageName m+            | otherwise -> error $ "expected TYPE_MESSAGE for type name"+                                ++ unpack (fd ^. typeName)+        FieldDescriptorProto'TYPE_BYTES -> "Data.ByteString.ByteString"+        FieldDescriptorProto'TYPE_UINT32 -> "Data.Word.Word32"+        FieldDescriptorProto'TYPE_ENUM+            | Enum e <- definedFieldType fd env -> tyCon $ enumName e+            | otherwise -> error $ "expected TYPE_ENUM for type name"+                                ++ unpack (fd ^. typeName)+        FieldDescriptorProto'TYPE_SFIXED32 -> "Data.Int.Int32"+        FieldDescriptorProto'TYPE_SFIXED64 -> "Data.Int.Int64"+        FieldDescriptorProto'TYPE_SINT32 -> "Data.Int.Int32"+        FieldDescriptorProto'TYPE_SINT64 -> "Data.Int.Int64"++hsFieldVectorType :: FieldInfo -> Type+hsFieldVectorType f = case fieldDescriptor f ^. type' of+    FieldDescriptorProto'TYPE_MESSAGE -> boxed+    -- TODO: store enums in unboxed fields.+    FieldDescriptorProto'TYPE_ENUM -> boxed+    FieldDescriptorProto'TYPE_GROUP -> boxed+    FieldDescriptorProto'TYPE_STRING -> boxed+    FieldDescriptorProto'TYPE_BYTES -> boxed+    _ -> unboxed+  where+    boxed = "Data.Vector.Vector"+    unboxed = "Data.Vector.Unboxed.Vector"++-- | A representation for how to encode and decode a particular field type.+data FieldEncoding = FieldEncoding+    { buildFieldType :: Exp -- ^ :: a -> Builder+    , parseFieldType :: Exp -- ^ :: Parser a+    , wireType :: Word8+    }++-- | A variable-length integer, decoded as an unsigned Word64.+varint :: FieldEncoding+varint = FieldEncoding+            { wireType = 0+            , buildFieldType = putVarInt'+            , parseFieldType = getVarInt'+            }++-- | A fixed-length integer (Word64).+fixed64 :: FieldEncoding+fixed64 = FieldEncoding+            { wireType = 1+            , buildFieldType = "Data.ProtoLens.Encoding.Bytes.putFixed64"+            , parseFieldType = "Data.ProtoLens.Encoding.Bytes.getFixed64"+            }++-- | A fixed-length integer (Word32).+fixed32 :: FieldEncoding+fixed32 = FieldEncoding+            { wireType = 5+            , buildFieldType = "Data.ProtoLens.Encoding.Bytes.putFixed32"+            , parseFieldType = "Data.ProtoLens.Encoding.Bytes.getFixed32"+            }++-- | A ByteString, prefixed by its length (which is encoded as a varint).+lengthy :: FieldEncoding+lengthy = FieldEncoding+            { wireType = 2+            , buildFieldType = buildLengthy+            , parseFieldType = parseLengthy+            }+  where+    bs = "bs"+    len = "len"+    buildLengthy =+        -- Bind x since it may be a nontrivial expression:+        lambda [bs]+            $ "Data.Monoid.<>"+                @@ (putVarInt'+                        @@ (fromIntegral'+                                @@ ("Data.ByteString.length" @@ bs)))+                @@ ("Data.ProtoLens.Encoding.Bytes.putBytes" @@ bs)+    parseLengthy = do'+        [ len <-- getVarInt'+        , stmt $ "Data.ProtoLens.Encoding.Bytes.getBytes"+                    @@ (fromIntegral' @@ len)+        ]++group :: FieldEncoding+group = FieldEncoding+            { wireType = 3+            , buildFieldType = "Data.ProtoLens.buildMessage"+            , parseFieldType = "Data.ProtoLens.parseMessage"+            }++groupEnd :: FieldEncoding+groupEnd = FieldEncoding+            { wireType = 4+            , buildFieldType = "Prelude.const" @@ "Data.Monoid.mempty"+            , parseFieldType = "Prelude.return" @@ unit+            }++-- Wrap a field encoding  with Haskell functions that should always succeed.+bijectField :: Exp -> Exp -> FieldEncoding -> FieldEncoding+bijectField buildF parseF f = FieldEncoding+    { buildFieldType = "Prelude.." @@ buildFieldType f @@ buildF+    , parseFieldType = "Prelude.fmap" @@ parseF @@ parseFieldType f+    , wireType = wireType f+    }++-- | Wrap a field encoding with Haskell functions that may fail during parsing.+partialField :: Exp -> (Exp -> Exp) -> FieldEncoding -> FieldEncoding+partialField buildF parseF f = FieldEncoding+    { buildFieldType = "Prelude.." @@ buildFieldType f @@ buildF+    -- do+    --  value <- ...+    --  runEither $ {parseF} value+    , parseFieldType = do'+        [ value <-- parseFieldType f+        , stmt $ runEither @@ parseF value+        ]+    , wireType = wireType f+    }+  where+    value = "value"+    runEither = "Data.ProtoLens.Encoding.Bytes.runEither"++-- | Convert a field of one integral type to another.+integralField :: FieldEncoding -> FieldEncoding+integralField = bijectField fromIntegral' fromIntegral'++fieldEncoding :: FieldDescriptorProto'Type -> FieldEncoding+fieldEncoding = \case+    FieldDescriptorProto'TYPE_INT64 -> integralField varint+    FieldDescriptorProto'TYPE_UINT64 -> varint+    FieldDescriptorProto'TYPE_INT32 -> integralField varint+    FieldDescriptorProto'TYPE_UINT32 -> integralField varint+    FieldDescriptorProto'TYPE_FIXED64 -> fixed64+    FieldDescriptorProto'TYPE_FIXED32 -> fixed32+    FieldDescriptorProto'TYPE_SFIXED64 -> integralField fixed64+    FieldDescriptorProto'TYPE_SFIXED32 -> integralField fixed32+    FieldDescriptorProto'TYPE_DOUBLE ->+        bijectField+            "Data.ProtoLens.Encoding.Bytes.doubleToWord"+            "Data.ProtoLens.Encoding.Bytes.wordToDouble"+            fixed64+    FieldDescriptorProto'TYPE_FLOAT ->+        bijectField+            "Data.ProtoLens.Encoding.Bytes.floatToWord"+            "Data.ProtoLens.Encoding.Bytes.wordToFloat"+            fixed32+    FieldDescriptorProto'TYPE_BOOL ->+        bijectField+            (lambda ["b"] $ if' "b" (litInt 1) (litInt 0))+            ("Prelude./=" @@ litInt 0)+            varint+    FieldDescriptorProto'TYPE_ENUM ->+        -- TODO: don't throw an exception on unknown proto2 enums.+        bijectField "Prelude.fromEnum" "Prelude.toEnum"+            $ integralField varint+    FieldDescriptorProto'TYPE_SINT64 ->+        bijectField+            "Data.ProtoLens.Encoding.Bytes.signedInt64ToWord"+            "Data.ProtoLens.Encoding.Bytes.wordToSignedInt64"+            $ integralField varint+    FieldDescriptorProto'TYPE_SINT32 ->+        bijectField+            "Data.ProtoLens.Encoding.Bytes.signedInt32ToWord"+            "Data.ProtoLens.Encoding.Bytes.wordToSignedInt32"+            $ integralField varint+    FieldDescriptorProto'TYPE_BYTES -> lengthy+    FieldDescriptorProto'TYPE_STRING -> stringField+    FieldDescriptorProto'TYPE_MESSAGE -> message+    FieldDescriptorProto'TYPE_GROUP -> group++-- | A string, represented as Data.Text.Text.+stringField :: FieldEncoding+stringField = partialField "Data.Text.Encoding.encodeUtf8" decodeUtf8P lengthy+  where+    {- Translates to:+        case decodeUtf8' bytes of+            Left err -> Left (show err)+            Right r -> r+    Equivalently:+        first show $ decodeUtf8' bytes+    but avoids dragging in Data.Bifunctors.+    -}+    decodeUtf8P bytes =+        case' ("Data.Text.Encoding.decodeUtf8'" @@ bytes )+            [ "Prelude.Left" `pApp` ["err"]+                --> "Prelude.Left" @@ ("Prelude.show" @@ "err")+            , "Prelude.Right" `pApp` ["r"]+                --> "Prelude.Right" @@ "r"+            ]++-- | A protobuf message type.+message :: FieldEncoding+message = lengthy+        { buildFieldType = "Prelude.." @@+            buildFieldType lengthy @@+            "Data.ProtoLens.encodeMessage"+        , parseFieldType = isolatedLengthy "Data.ProtoLens.parseMessage"+        }++-- | Takes a @Parser a@, reads a varint and then runs the parser+-- isolated to the given length.+isolatedLengthy :: Exp -> Exp+isolatedLengthy parser = do'+    [ len <-- getVarInt'+    , stmt $ "Data.ProtoLens.Encoding.Bytes.isolate"+                @@ (fromIntegral' @@ len)+                @@ parser+    ]+  where+    len = "len"++-- | Some functions that are used in multiple places in the generated code.+getVarInt', putVarInt', fromIntegral' :: Exp+getVarInt' = "Data.ProtoLens.Encoding.Bytes.getVarInt"+putVarInt' = "Data.ProtoLens.Encoding.Bytes.putVarInt"+fromIntegral' = "Prelude.fromIntegral"