diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,16 @@ +# Changelog for `proto-lens-protoc` + +## Unreleased changes + +## v0.2.2.0 +- Bump the dependency on `base` to support `ghc-8.2.1` and `Cabal-2.0`. +- Bump the dependency for `haskell-src-exts-0.19`. +- Improve the semantics of oneof fields, and add a lens to access the + underlying sum type. +- Generate Ord instances for all exported datatypes. +- Print a better error message when missing `protoc` or `proto-lens-protoc`. +- Expose message names to support `Data.ProtoLens.Any`. +- CamelCase the names of Haskell message types. + +## v0.2.1.0 and older +See `Changelog.md` for `proto-lens`. diff --git a/proto-lens-protoc.cabal b/proto-lens-protoc.cabal --- a/proto-lens-protoc.cabal +++ b/proto-lens-protoc.cabal @@ -1,5 +1,5 @@ name: proto-lens-protoc -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Protocol buffer compiler for the proto-lens library. description: Turn protocol buffer files (.proto) into Haskell files (.hs) which @@ -15,6 +15,7 @@ category: Data build-type: Simple cabal-version: >=1.21 +extra-source-files: Changelog.md -- Work around stack bug, since we don't want to build the library -- during bootstrapping: @@ -36,19 +37,21 @@ default-language: Haskell2010 hs-source-dirs: src build-depends: - Cabal >= 1.22 && < 1.25 - , base >= 4.8 && < 4.10 + Cabal >= 1.22 && < 2.1 + , base >= 4.8 && < 4.11 , bytestring == 0.10.* , containers == 0.5.* , data-default-class >= 0.0 && < 0.2 , directory >= 1.2 && < 1.4 - , filepath == 1.4.* - , haskell-src-exts >= 1.17 && < 1.19 + , filepath >= 1.4 && < 1.6 + , haskell-src-exts >= 1.17 && < 1.20 , lens-family == 1.2.* , lens-labels == 0.1.* , process >= 1.2 && < 1.5 - , proto-lens == 0.2.1.0 - , proto-lens-descriptors == 0.2.1.0 + -- Specify a more precise version of `proto-lens`, since it depends on + -- the exact definition of the Message class. + , proto-lens == 0.2.2.* + , proto-lens-descriptors == 0.2.2.* , text == 1.2.* reexported-modules: -- Modules that are needed by the generated Haskell files. @@ -73,17 +76,17 @@ main-is: protoc-gen-haskell.hs build-depends: - base >= 4.8 && < 4.10 + base >= 4.8 && < 4.11 , bytestring == 0.10.* , containers == 0.5.* , data-default-class >= 0.0 && < 0.2 - , filepath == 1.4.* - , haskell-src-exts >= 1.17 && < 1.19 + , filepath >= 1.4 && < 1.6 + , haskell-src-exts >= 1.17 && < 1.20 , lens-family == 1.2.* - -- Specify an exact version of `proto-lens`, since it's tied closely - -- to the generated code. - , proto-lens == 0.2.1.0 - , proto-lens-descriptors == 0.2.1.0 + -- Specify a more precise version of `proto-lens`, since it depends on + -- the exact definition of the Message class. + , proto-lens == 0.2.2.* + , proto-lens-descriptors == 0.2.2.* , text == 1.2.* hs-source-dirs: src other-modules: 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 @@ -54,7 +54,9 @@ type ConDecl = Syntax.ConDecl () conDecl :: Name -> [Type] -> ConDecl -conDecl = Syntax.ConDecl () +conDecl constructorName paramTypes + = Syntax.ConDecl () constructorName $ + fmap tyBang paramTypes recDecl :: Name -> [(Name, Type)] -> ConDecl recDecl dataName fields @@ -102,6 +104,14 @@ let' :: [Decl] -> Exp -> Exp let' ds e = Syntax.Let () (Syntax.BDecls () ds) e + +type Alt = Syntax.Alt () + +case' :: Exp -> [Alt] -> Exp +case' = Syntax.Case () + +alt :: Pat -> Exp -> Alt +alt p e = Syntax.Alt () p (Syntax.UnGuardedRhs () e) Nothing stringExp :: String -> Exp stringExp = Syntax.Lit () . string 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 @@ -7,12 +7,20 @@ -- | This module takes care of collecting all the definitions in a .proto file -- and assigning Haskell names to all of the defined things (messages, enums -- and field names). -{-# LANGUAGE DeriveFunctor, OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Data.ProtoLens.Compiler.Definitions ( Env , Definition(..) , MessageInfo(..) , FieldInfo(..) + , OneofInfo(..) + , OneofCase(..) + , FieldName(..) + , Symbol + , nameFromSymbol + , promoteSymbol , EnumInfo(..) , EnumValueInfo(..) , qualifyEnv @@ -28,10 +36,10 @@ import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Set as Set -import Data.String (fromString) +import Data.String (IsString(..)) import Data.Text (Text, cons, splitOn, toLower, uncons, unpack) import qualified Data.Text as T -import Lens.Family2 ((^.)) +import Lens.Family2 ((^.), (^..)) import Proto.Google.Protobuf.Descriptor ( DescriptorProto , EnumDescriptorProto @@ -40,10 +48,12 @@ , FileDescriptorProto , enumType , field + , maybe'oneofIndex , messageType , name , nestedType , number + , oneofDecl , package , typeName , value @@ -53,7 +63,9 @@ ( Name , QName , ModuleName + , Type , qual + , tyPromotedString , unQual ) @@ -74,22 +86,68 @@ data MessageInfo n = MessageInfo { messageName :: n -- ^ Haskell type name , messageDescriptor :: DescriptorProto - , messageFields :: [FieldInfo] - -- ^ The Haskell names for each field. - -- This list corresponds 1-1 with "field" in messageDescriptor. + , messageFields :: [FieldInfo] -- ^ Fields not belonging to a oneof. + , messageOneofFields :: [OneofInfo] + -- ^ The oneofs in this message, associated with the fields that + -- belong to them. } deriving Functor -- | Information about a single field of a proto message. data FieldInfo = FieldInfo - { overloadedField :: String - -- ^ The Haskell overloaded name of this field; may be shared between two - -- different message data types. - , recordFieldName :: Name - -- ^ The Haskell name of this internal record field. Unique within each + { fieldDescriptor :: FieldDescriptorProto + , plainFieldName :: FieldName + } + +data OneofInfo = OneofInfo + { oneofFieldName :: FieldName + , oneofTypeName :: Name + -- ^ The name of the sum type corresponding to this oneof. + , oneofCases :: [OneofCase] + -- ^ The individual fields that make up this oneof. + } + +data OneofCase = OneofCase + { caseField :: FieldInfo + , caseConstructorName :: Name + -- ^ The constructor for building a 'oneofTypeName' from the + -- value in this field. + } + +data FieldName = FieldName + { overloadedName :: Symbol + -- ^ The overloaded name of lenses that access this field. + -- For example, if the field is called "foo_bar" in the .proto + -- then @overloadedName == "fooBar"@ and we might generate + -- @fooBar@ and/or @maybe'fooBar@ lenses to access the data. + -- + -- May be shared between two different message data types in the same -- module. - , fieldDescriptor :: FieldDescriptorProto + , haskellRecordFieldName :: Name + -- ^ The Haskell name of this internal record field; for example, + -- "_Foo'Bar'baz. Unique within each module. } +-- | A string that refers to the name (in Haskell) of a lens that accesses a +-- field. +-- +-- For example, in the signature of the overloaded lens +-- +-- @ +-- foo :: HasLens "foo" ... => Lens ... +-- @ +-- +-- a 'Symbol' is used to construct both the type-level argument to +-- @HasLens@ and the name of the function @foo@. +newtype Symbol = Symbol String + deriving (Eq, Ord, IsString, Monoid) + +nameFromSymbol :: Symbol -> Name +nameFromSymbol (Symbol s) = fromString s + +-- | Construct a promoted, type-level string. +promoteSymbol :: Symbol -> Type +promoteSymbol (Symbol s) = tyPromotedString s + -- | All the information needed to define or use a proto enum type. data EnumInfo n = EnumInfo { enumName :: n @@ -119,7 +177,7 @@ unqualifyEnv :: Env Name -> Env QName unqualifyEnv = mapEnv unQual --- | Look up the type definition for a given field. +-- | Look up the Haskell name for the type of a given field (message or enum). definedFieldType :: FieldDescriptorProto -> Env QName -> Definition QName definedFieldType fd env = fromMaybe err $ Map.lookup (fd ^. typeName) env where @@ -147,36 +205,67 @@ messageDefs :: Text -> String -> DescriptorProto -> [(Text, Definition Name)] messageDefs protoPrefix hsPrefix d - = thisDef : subDefs + = (protoName, thisDef) + : messageAndEnumDefs + (protoName <> ".") + hsPrefix' + (d ^. nestedType) + (d ^. enumType) where - protoName = d ^. name - hsName = unpack $ capitalize $ d ^. name - thisDef = (protoPrefix <> protoName - , Message MessageInfo - { messageName = fromString $ hsPrefix ++ hsName - , messageDescriptor = d - , messageFields = - [ FieldInfo - { overloadedField = n - , recordFieldName = fromString $ "_" ++ hsPrefix' ++ n - , fieldDescriptor = f - } - | f <- d ^. field - , let n = fieldName (f ^. name) - ] - }) - subDefs = messageAndEnumDefs protoPrefix' hsPrefix' - (d ^. nestedType) (d ^. enumType) - protoPrefix' = protoPrefix <> protoName <> "." - hsPrefix' = hsPrefix ++ hsName ++ "'" + protoName = protoPrefix <> d ^. name + hsPrefix' = hsPrefix ++ hsName (d ^. name) ++ "'" + hsName = unpack . capitalize . camelCase + allFields = collectFieldsByOneofIndex (d ^. field) + thisDef = + Message MessageInfo + { messageName = fromString $ hsPrefix ++ hsName (d ^. name) + , messageDescriptor = d + , messageFields = + map fieldInfo $ Map.findWithDefault [] Nothing allFields + , messageOneofFields = + zipWith oneofInfo [0..] + $ d ^.. oneofDecl . traverse . name + } + fieldInfo f = FieldInfo f $ mkFieldName $ f ^. name + mkFieldName n = FieldName + { overloadedName = fromString n' + , haskellRecordFieldName = fromString $ "_" ++ hsPrefix' ++ n' + } + where + n' = fieldName n + oneofInfo :: Int32 -> Text -> OneofInfo + oneofInfo idx n = OneofInfo + { oneofFieldName = mkFieldName n + , oneofTypeName = fromString $ hsPrefix' ++ hsName n + , oneofCases = map oneofCase + $ Map.findWithDefault [] (Just idx) + allFields + } + oneofCase f = OneofCase + { caseField = fieldInfo f + , caseConstructorName = + -- Note: oneof case constructors aren't prefixed + -- by the oneof name; field names (even inside + -- of a oneof) are unique within a message. + fromString $ hsPrefix' ++ hsName (f ^. name) + } + +-- | Group fields by the index of the oneof field that they belong to. +-- (Or 'Nothing' if they don't belong to a oneof.) +collectFieldsByOneofIndex + :: [FieldDescriptorProto] -> Map.Map (Maybe Int32) [FieldDescriptorProto] +collectFieldsByOneofIndex = + fmap reverse + . Map.fromListWith (++) + . fmap (\f -> (f ^. maybe'oneofIndex, [f])) + -- | 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 where disambiguate s - -- TODO: use a more comprehensive blacklist of Haskell keywords. | s `Set.member` reservedKeywords = s <> "'" | otherwise = s 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 @@ -20,6 +20,7 @@ import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe (isNothing) +import Data.Monoid ((<>)) import Data.Ord (comparing) import qualified Data.Set as Set import Data.String (fromString) @@ -92,19 +93,31 @@ , "Lens.Labels" ] ++ map importSimple imports) - (concatMap generateDecls (Map.elems definitions) - ++ concatMap generateFieldDecls allFieldNames) + (concatMap generateDecls (Map.toList definitions) + ++ concatMap generateFieldDecls allLensNames) where env = Map.union (unqualifyEnv definitions) importedEnv - generateDecls (Message m) = generateMessageDecls syntaxType env m - generateDecls (Enum e) = generateEnumDecls e - allFieldNames = F.toList $ Set.fromList - [ fieldSymbol i + generateDecls (protoName, Message m) + = generateMessageDecls syntaxType env (stripDotPrefix protoName) m + generateDecls (_, Enum e) = generateEnumDecls e + allLensNames = F.toList $ Set.fromList + [ lensSymbol inst | Message m <- Map.elems definitions - , f <- messageFields m - , i <- fieldInstances (lensInfo syntaxType env f) + , info <- allMessageFields syntaxType env m + , inst <- recordFieldLenses info ] + -- The Env uses the convention that Message names are prefixed with '.' + -- (since that's how the FileDescriptorProto refers to them). + -- Strip that off when defining MessageDescriptor.messageName. + stripDotPrefix s + | 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) + ++ map (oneofRecordField env) (messageOneofFields info) + importSimple :: ModuleName -> ImportDecl () importSimple m = ImportDecl { importAnn = () @@ -126,19 +139,39 @@ where m' = fromString $ "Data.ProtoLens.Reexport." ++ prettyPrint m -generateMessageDecls :: SyntaxType -> Env QName -> MessageInfo Name -> [Decl] -generateMessageDecls syntaxType env info = +generateMessageDecls :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [Decl] +generateMessageDecls syntaxType env protoName info = -- data Bar = Bar { -- foo :: Baz -- } [ dataDecl dataName - [recDecl dataName - [ (recordFieldName f, internalType (lensInfo syntaxType env f)) - | f <- fields + [recDecl dataName $ + [ (recordFieldName f, recordFieldType f) + | f <- allFields ] ] - ["Prelude.Show", "Prelude.Eq"] + ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] ] ++ + + -- oneof field data type declarations + -- proto: message Foo { + -- oneof bar { + -- float c = 1; + -- Sub s = 2; + -- } + -- } + -- haskell: data Foo'Bar = Foo'Bar'c !Prelude.Float + -- | Foo'Bar's !Sub + [ dataDecl (oneofTypeName oneofInfo) + [ conDecl consName [hsFieldType env $ fieldDescriptor f] + | c <- oneofCases oneofInfo + , let f = caseField c + , let consName = caseConstructorName c + ] + ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] + | oneofInfo <- messageOneofFields info + ] ++ + -- type instance (Functor f, a ~ Baz, b ~ Baz) -- => HasLens "foo" f Bar Bar a b where -- lensOf _ = ... @@ -147,38 +180,46 @@ [ instDecl [equalP "a" t, equalP "b" t, classA "Prelude.Functor" ["f"]] ("Lens.Labels.HasLens" `ihApp` [sym, "f", dataType, dataType, "a", "b"]) - [[match "lensOf" [pWildCard] $ fieldAccessor i]] - | f <- fields - , i <- fieldInstances (lensInfo syntaxType env f) - , let t = fieldTypeInstance i - , let sym = tyPromotedString $ fieldSymbol i + [[match "lensOf" [pWildCard] $ + "Prelude.." + @@ rawFieldAccessor (unQual $ recordFieldName li) + @@ lensExp i]] + | li <- allFields + , i <- recordFieldLenses li + , let t = lensFieldType i + , let sym = promoteSymbol $ lensSymbol i ] ++ -- instance Data.Default.Class.Default Bar where [ instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) -- def = Bar { _Bar_foo = 0 } - [ + [ [ match "def" [] - $ recConstr (unQual dataName) - [ fieldUpdate (unQual $ recordFieldName f) + $ recConstr (unQual dataName) $ + [ fieldUpdate (unQual $ haskellRecordFieldName $ plainFieldName f) (hsFieldDefault syntaxType env (fieldDescriptor f)) - | f <- fields + | f <- messageFields info + ] ++ + [ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o) + "Prelude.Nothing" + | o <- messageOneofFields info ] ] ] -- instance Message.Message Bar where , instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType]) - [[match "descriptor" [] $ descriptorExpr syntaxType env info]] + [[match "descriptor" [] $ descriptorExpr syntaxType env protoName info]] ] where dataType = tyCon $ unQual dataName - MessageInfo { messageName = dataName, messageFields = fields} = info + dataName = messageName info + allFields = allMessageFields syntaxType env info generateEnumDecls :: EnumInfo Name -> [Decl] generateEnumDecls info = [ dataDecl dataName [conDecl n [] | n <- constructorNames] - ["Prelude.Show", "Prelude.Eq"] + ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] -- instance Data.Default.Class.Default Foo where -- def = FirstEnumValue , instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) @@ -314,7 +355,7 @@ errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name) ++ ": " -generateFieldDecls :: String -> [Decl] +generateFieldDecls :: Symbol -> [Decl] generateFieldDecls xStr = -- foo :: forall x f s t a b -- . HasLens x f s t a b => LensLike f s t a b @@ -331,96 +372,152 @@ ] ] where - x = fromString xStr - xSym = tyPromotedString xStr + x = nameFromSymbol xStr + xSym = promoteSymbol xStr ------------------------------------------ --- | The Haskell types and lenses for an individual field of a message. --- This is used to generate both the data record Decl and the instances of --- HasField. -data LensInfo = LensInfo - { internalType :: Type -- ^ Internal type in the record - , fieldInstances :: [FieldInstanceInfo] -- ^ All instances of Field/HasField +-- | An individual field of the Haskell type corresponding to a proto message. +data RecordField = RecordField + { recordFieldName :: Name -- ^ The Haskell name of this field (unique + -- within the module). + , recordFieldType :: Type -- ^ Internal type in the record + , recordFieldLenses :: [LensInstance] + -- ^ All of the (overloaded) lenses accessing this record field. } -data FieldInstanceInfo = FieldInstanceInfo - { fieldSymbol :: String -- ^ The name of the Symbol corresponding to - -- this field. - , fieldTypeInstance :: Type -- ^ The type instance for Field, i.e., - -- type instance Field "foo" Bar = ... - , fieldAccessor :: Exp -- ^ The value of the "field" lens for this - -- field, i.e., - -- field _ = ... +-- | An instance of HasLens for a particualr field. +data LensInstance = LensInstance + { lensSymbol :: Symbol + -- ^ The overloaded name for this lens. + , lensFieldType :: Type + -- ^ The type pointed to from this lens. + , lensExp :: Exp + -- ^ A lens from the recordFieldType to the lensFieldType; i.e., + -- from how it's actually stored in the Haskell record to how the + -- lens views it. } -- | Compile information about the record field type and type/class instances -- for this particular field. -lensInfo :: SyntaxType -> Env QName -> FieldInfo -> LensInfo -lensInfo syntaxType env f = case fd ^. label of +-- +-- 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 -- data Foo = Foo { _Foo_bar :: Bar } -- type instance Field "bar" Foo = Bar - FieldDescriptorProto'LABEL_REQUIRED -> LensInfo baseType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = baseType - , fieldAccessor = rawAccessor + FieldDescriptorProto'LABEL_REQUIRED + -> recordField baseType + [LensInstance + { lensSymbol = baseName + , lensFieldType = baseType + , lensExp = rawAccessor }] FieldDescriptorProto'LABEL_OPTIONAL | isDefaultingOptional syntaxType fd - -> LensInfo baseType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = baseType - , fieldAccessor = rawAccessor + -> recordField baseType + [LensInstance + { lensSymbol = baseName + , lensFieldType = baseType + , lensExp = rawAccessor }] + -- data Foo = Foo { _Foo_bar :: Maybe Bar } + -- type instance Field "bar" Foo = Bar + -- type instance Field "maybe'bar" Foo = Maybe Bar + | otherwise -> + recordField maybeType + [LensInstance + { lensSymbol = baseName + , lensFieldType = baseType + , lensExp = maybeAccessor + } + , LensInstance + { lensSymbol = "maybe'" <> baseName + , lensFieldType = maybeType + , 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) - in LensInfo mapType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = mapType - , fieldAccessor = rawAccessor + in recordField mapType + [LensInstance + { lensSymbol = baseName + , lensFieldType = mapType + , lensExp = rawAccessor }] -- data Foo = Foo { _Foo_bar :: [Bar] } -- type instance Field "bar" Foo = [Bar] - | otherwise -> LensInfo listType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = listType - , fieldAccessor = rawAccessor + | otherwise -> recordField listType + [LensInstance + { lensSymbol = baseName + , lensFieldType = listType + , lensExp = rawAccessor }] - -- data Foo = Foo { _Foo_bar :: Maybe Bar } - -- type instance Field "bar" Foo = Bar - -- type instance Field "maybe'bar" Foo = Maybe Bar - FieldDescriptorProto'LABEL_OPTIONAL -> LensInfo maybeType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = baseType - , fieldAccessor = maybeAccessor - } - , FieldInstanceInfo - { fieldSymbol = maybeName - , fieldTypeInstance = "Prelude.Maybe" @@ baseType - , fieldAccessor = rawAccessor - } - ] where - baseName = overloadedField f + recordField = RecordField (haskellRecordFieldName $ plainFieldName f) + baseName = overloadedName $ plainFieldName f fd = fieldDescriptor f baseType = hsFieldType env fd - listType = tyList baseType maybeType = "Prelude.Maybe" @@ baseType - maybeName = "maybe'" ++ baseName - maybeAccessor = "Prelude.." @@ fromString maybeName - @@ ("Data.ProtoLens.maybeLens" - @@ hsFieldValueDefault env fd) - rawAccessor = rawFieldAccessor $ unQual $ recordFieldName f + listType = tyList baseType + rawAccessor = "Prelude.id" + maybeAccessor = "Data.ProtoLens.maybeLens" + @@ hsFieldValueDefault env fd + +oneofRecordField :: Env QName -> OneofInfo -> RecordField +oneofRecordField env oneofInfo + = RecordField + { recordFieldName = haskellRecordFieldName $ oneofFieldName oneofInfo + , recordFieldType = + "Prelude.Maybe" @@ tyCon (unQual $ oneofTypeName oneofInfo) + , recordFieldLenses = lenses + } + where + lenses = + -- Only generate a "maybe" version of this lens, + -- since oneofs don't have a notion of a "default" case. + -- data Foo = Foo { _Foo'bar = Maybe Foo'Bar } + -- type instance Field "maybe'bar" Foo = Maybe Foo'Bar + [LensInstance + { lensSymbol = "maybe'" <> overloadedName + (oneofFieldName oneofInfo) + , lensFieldType = + "Prelude.Maybe" @@ tyCon (unQual $ oneofTypeName oneofInfo) + , lensExp = "Prelude.id" + } + ] + ++ concat + -- Generate the same lenses for each sub-field of the oneof + -- as if they were proto2 optional fields. + -- type instance Field "bar" Foo = Bar + -- type instance Field "maybe'bar" Foo = Maybe Bar + [ [ LensInstance + { lensSymbol = maybeName + , lensFieldType = "Prelude.Maybe" @@ baseType + , lensExp = oneofFieldAccessor c + } + , LensInstance + { lensSymbol = baseName + , lensFieldType = baseType + , lensExp = "Prelude.." + @@ oneofFieldAccessor c + @@ ("Data.ProtoLens.maybeLens" + @@ hsFieldValueDefault env + (fieldDescriptor f)) + } + ] + | c <- oneofCases oneofInfo + , let f = caseField c + , let baseName = overloadedName $ plainFieldName f + , let baseType = hsFieldType env $ fieldDescriptor 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) @@ -533,8 +630,40 @@ setter = lambda ["x__", "y__"] $ recUpdate "x__" [fieldUpdate f "y__"] -descriptorExpr :: SyntaxType -> Env QName -> MessageInfo Name -> Exp -descriptorExpr syntaxType env m +-- | A lens that maps from a oneof sum type to one of its individual cases. +-- +-- For example, with +-- data Foo = Bar Int32 | Baz Int64 +-- +-- this will generate a lens of type @Lens' (Maybe Foo) (Maybe Int32)@. +-- +-- (Recall that oneofs are stored in a proto message as @Maybe Foo@, where +-- 'Nothing' means that it's either set to an unknown value or unset.) +-- +-- lens +-- (\ x__ -> case x__ of +-- Prelude.Just (Foo'c x__val) -> Prelude.Just x__val +-- otherwise -> Prelude.Nothing) +-- (\ _ y__ -> fmap Foo'c y__ +oneofFieldAccessor :: OneofCase -> Exp +oneofFieldAccessor o + = "Lens.Family2.Unchecked.lens" @@ getter @@ setter + where + 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" + ] + setter = lambda ["_", "y__"] + $ "Prelude.fmap" @@ con (unQual consName) @@ "y__" + +descriptorExpr :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> Exp +descriptorExpr syntaxType env protoName m -- let foo__field_descriptor = ... -- ... -- in Message.MessageDescriptor @@ -543,15 +672,16 @@ -- -- (Note that the two maps have the same elements but different keys. We -- use the "let" expression to share elements between the two maps.) - = let' (map (fieldDescriptorVarBind $ messageName m) $ messageFields m) + = let' (map (fieldDescriptorVarBind $ messageName m) $ fields) $ "Data.ProtoLens.MessageDescriptor" + @@ ("Data.Text.pack" @@ stringExp (T.unpack protoName)) @@ ("Data.Map.fromList" @@ list fieldsByTag) @@ ("Data.Map.fromList" @@ list fieldsByTextFormatName) where fieldsByTag = [tuple [ t, fieldDescriptorVar f ] - | f <- messageFields m + | f <- fields , let t = "Data.ProtoLens.Tag" @@ litInt (fromIntegral $ fieldDescriptor f ^. number) @@ -559,18 +689,20 @@ fieldsByTextFormatName = [tuple [ t, fieldDescriptorVar f ] - | f <- messageFields m + | f <- fields , let t = stringExp $ T.unpack $ textFormatFieldName env (fieldDescriptor f) ] - fieldDescriptorVar = fromString . fieldDescriptorName + fieldDescriptorVar = var . unQual . fieldDescriptorName fieldDescriptorName f - = fromString $ overloadedField f ++ "__field_descriptor" + = nameFromSymbol $ overloadedName (plainFieldName f) <> "__field_descriptor" fieldDescriptorVarBind n f = funBind - [match (fromString $ fieldDescriptorName f) [] + [match (fieldDescriptorName f) [] $ fieldDescriptorExpr syntaxType env n f ] + fields = messageFields m + ++ (messageOneofFields m >>= fmap caseField . oneofCases) -- | 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, @@ -618,25 +750,29 @@ FieldDescriptorProto'LABEL_REPEATED | Just (k, v) <- getMapFields env fd -> "Data.ProtoLens.MapField" - @@ fromString (overloadedField k) - @@ fromString (overloadedField v) + @@ con (unQual $ nameFromSymbol $ overloadedField k) + @@ con (unQual $ nameFromSymbol $ overloadedField v) | otherwise -> "Data.ProtoLens.RepeatedField" @@ if isPackedField syntaxType fd then "Data.ProtoLens.Packed" else "Data.ProtoLens.Unpacked" hsFieldName - = fromString $ case fd ^. label of + = nameFromSymbol $ case fd ^. label of FieldDescriptorProto'LABEL_OPTIONAL | not (isDefaultingOptional syntaxType fd) - -> "maybe'" ++ overloadedField f + -> "maybe'" <> overloadedField f _ -> overloadedField f +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 - -- For now, we treat oneof's like proto2 optional fields. + -- 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 diff --git a/src/Data/ProtoLens/Setup.hs b/src/Data/ProtoLens/Setup.hs --- a/src/Data/ProtoLens/Setup.hs +++ b/src/Data/ProtoLens/Setup.hs @@ -38,14 +38,17 @@ , libBuildInfo , testBuildInfo ) -import Distribution.Simple.BuildPaths (autogenModulesDir) +import qualified Distribution.Simple.BuildPaths as BuildPaths import Distribution.Simple.InstallDirs (datadir) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) , absoluteInstallDirs , componentPackageDeps +#if MIN_VERSION_Cabal(2,0,0) + , allComponentsInBuildOrder +#endif ) -import Distribution.Simple.PackageIndex (lookupSourcePackageId) +import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Setup (fromFlag, copyDest, copyVerbosity) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose @@ -72,6 +75,7 @@ , findExecutable , removeDirectoryRecursive ) +import System.IO (hPutStrLn, stderr) import System.Process (callProcess) -- | This behaves the same as 'Distribution.Simple.defaultMain', but @@ -172,9 +176,7 @@ -- Collect import paths from build-depends of this package. importDirs <- filterM doesDirectoryExist [ InstalledPackageInfo.dataDir info protoLensImportsPrefix - | (_, c, _) <- componentsConfigs l - , (_, i) <- componentPackageDeps c - , info <- lookupSourcePackageId (installedPkgs l) i + | info <- collectDeps l ] generateProtosWithImports (root : importDirs) (autogenModulesDir l) -- Applying 'root ' does nothing if the path is already @@ -263,14 +265,63 @@ -> [FilePath] -- ^ The .proto files to process. -> IO () generateProtosWithImports imports output files = do - maybeProtoLensProtoc <- findExecutable "proto-lens-protoc" - case maybeProtoLensProtoc of - Nothing -> error "Couldn't find executable proto-lens-protoc." - Just protoLensProtoc -> do - createDirectoryIfMissing True output - callProcess "protoc" $ - [ "--plugin=protoc-gen-haskell=" ++ protoLensProtoc - , "--haskell_out=" ++ output - ] - ++ ["--proto_path=" ++ p | p <- imports] - ++ files + protoLensProtoc + <- findExecutableOrDie "proto-lens-protoc" + $ "Please file a bug at " + ++ "https://github.com/google/proto-lens/issues ." + protoc <- findExecutableOrDie "protoc" + $ "Follow the installation instructions at " + ++ "https://google.github.io/proto-lens/installing-protoc.html ." + createDirectoryIfMissing True output + callProcess protoc $ + [ "--plugin=protoc-gen-haskell=" ++ protoLensProtoc + , "--haskell_out=" ++ output + ] + ++ ["--proto_path=" ++ p | p <- imports] + ++ files + +-- | Search the PATH for an executable, printing an error message if it's not +-- found. +findExecutableOrDie :: String -> String -> IO FilePath +findExecutableOrDie name debugMsg = do + maybePath <- findExecutable name + case maybePath of + Just path -> return path + Nothing -> do + let sep = "==========" + hPutStrLn stderr sep + hPutStrLn stderr $ "Error: couldn't find the executable " ++ show name + ++ " in your $PATH." + ++ "\n " ++ debugMsg + hPutStrLn stderr sep + error $ "Missing executable " ++ show name + +------------------------------------------------------- +-- Compatibility layer between Cabal-1.* and Cabal-2.* + +-- | List all the packages that this one depends on. +collectDeps :: LocalBuildInfo -> [InstalledPackageInfo.InstalledPackageInfo] +#if MIN_VERSION_Cabal(2,0,0) +collectDeps l = do + c <- allComponentsInBuildOrder l + (i,_) <- componentPackageDeps c + Just p <- [PackageIndex.lookupUnitId (installedPkgs l) i] + return p +#else +collectDeps l = do + (_, c ,_) <- componentsConfigs l + (_, i) <- componentPackageDeps c + PackageIndex.lookupSourcePackageId (installedPkgs l) i +#endif + +-- | Get the package-level "autogen" directory where we're putting the +-- generated .hs files. (The 'BuildPaths.autogenModulesDir' file was +-- deprecated in Cabal-2.0 in favor of module-specific directories +-- (@autogenComponentModulesDir@), but our setup currently needs the more +-- global location.) +autogenModulesDir :: LocalBuildInfo -> FilePath +#if MIN_VERSION_Cabal(2,0,0) +autogenModulesDir = BuildPaths.autogenPackageModulesDir +#else +autogenModulesDir = BuildPaths.autogenModulesDir +#endif