diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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`. diff --git a/app/protoc-gen-haskell.hs b/app/protoc-gen-haskell.hs --- a/app/protoc-gen-haskell.hs +++ b/app/protoc-gen-haskell.hs @@ -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) diff --git a/proto-lens-protoc.cabal b/proto-lens-protoc.cabal --- a/proto-lens-protoc.cabal +++ b/proto-lens-protoc.cabal @@ -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 diff --git a/src/Data/ProtoLens/Compiler/Combinators.hs b/src/Data/ProtoLens/Compiler/Combinators.hs --- a/src/Data/ProtoLens/Compiler/Combinators.hs +++ b/src/Data/ProtoLens/Compiler/Combinators.hs @@ -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 diff --git a/src/Data/ProtoLens/Compiler/Definitions.hs b/src/Data/ProtoLens/Compiler/Definitions.hs --- a/src/Data/ProtoLens/Compiler/Definitions.hs +++ b/src/Data/ProtoLens/Compiler/Definitions.hs @@ -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 diff --git a/src/Data/ProtoLens/Compiler/Generate.hs b/src/Data/ProtoLens/Compiler/Generate.hs --- a/src/Data/ProtoLens/Compiler/Generate.hs +++ b/src/Data/ProtoLens/Compiler/Generate.hs @@ -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) diff --git a/src/Data/ProtoLens/Compiler/Generate/Encoding.hs b/src/Data/ProtoLens/Compiler/Generate/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtoLens/Compiler/Generate/Encoding.hs @@ -0,0 +1,638 @@ +-- | This module generates code for decoding and encoding protocol buffer messages. +-- +-- Upstream docs: +{-# 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 diff --git a/src/Data/ProtoLens/Compiler/Generate/Field.hs b/src/Data/ProtoLens/Compiler/Generate/Field.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtoLens/Compiler/Generate/Field.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module generates the code for decoding and encoding +-- individual field types. +-- +-- Upstream docs: +-- +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"