diff --git a/proto-lens-protoc.cabal b/proto-lens-protoc.cabal --- a/proto-lens-protoc.cabal +++ b/proto-lens-protoc.cabal @@ -1,9 +1,12 @@ name: proto-lens-protoc -version: 0.1.0.1 +version: 0.1.0.2 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.*) that is not guaranteed to have stable APIs. license: BSD3 license-file: LICENSE author: Judah Jacobson @@ -14,7 +17,14 @@ cabal-version: >=1.21 library - exposed-modules: Data.ProtoLens.Setup + exposed-modules: + Bootstrap.Proto.Google.Protobuf.Compiler.Plugin + Bootstrap.Proto.Google.Protobuf.Descriptor + Data.ProtoLens.Compiler.Combinators + Data.ProtoLens.Compiler.Definitions + Data.ProtoLens.Compiler.Generate + Data.ProtoLens.Compiler.Plugin + Data.ProtoLens.Setup default-language: Haskell2010 hs-source-dirs: src build-depends: @@ -25,29 +35,27 @@ , data-default-class == 0.0.* , directory == 1.2.* , filepath == 1.4.* + , haskell-src-exts == 1.17.* , lens-family == 1.2.* , process >= 1.2 && < 1.5 - , proto-lens == 0.1.0.1 + , proto-lens == 0.1.0.2 , text == 1.2.* reexported-modules: - -- Modules that are needed by the generated Haskell files: - Data.ByteString - , Data.Default.Class - , Data.Map - , Data.ProtoLens - , Data.ProtoLens.Message.Enum - , Data.Text - , Lens.Family2 - , Lens.Family2.Unchecked + -- Modules that are needed by the generated Haskell files. + -- For forwards compatibility, reexport them as new module names so that + -- other packages don't accidentally write non-generated code that + -- relies on these modules being reexported by proto-lens-protoc. + Data.ByteString as Data.ProtoLens.Reexport.Data.ByteString + , Data.Default.Class as Data.ProtoLens.Reexport.Data.Default.Class + , Data.Map as Data.ProtoLens.Reexport.Data.Map + , Data.ProtoLens as Data.ProtoLens.Reexport.Data.ProtoLens + , Data.ProtoLens.Message.Enum as Data.ProtoLens.Reexport.Data.ProtoLens.Message.Enum + , Data.Text as Data.ProtoLens.Reexport.Data.Text + , Lens.Family2 as Data.ProtoLens.Reexport.Lens.Family2 + , Lens.Family2.Unchecked as Data.ProtoLens.Reexport.Lens.Family2.Unchecked executable proto-lens-protoc main-is: protoc-gen-haskell.hs - other-modules: - Bootstrap.Proto.Google.Protobuf.Compiler.Plugin - Bootstrap.Proto.Google.Protobuf.Descriptor - Combinators - Definitions - Generate build-depends: base >= 4.8 && < 4.10 @@ -59,7 +67,15 @@ , lens-family == 1.2.* -- Specify an exact version of `proto-lens`, since it's tied closely -- to the generated code. - , proto-lens == 0.1.0.1 + , proto-lens == 0.1.0.2 , text == 1.2.* hs-source-dirs: src + other-modules: + Bootstrap.Proto.Google.Protobuf.Compiler.Plugin + Bootstrap.Proto.Google.Protobuf.Descriptor + Data.ProtoLens.Compiler.Combinators + Data.ProtoLens.Compiler.Definitions + Data.ProtoLens.Compiler.Generate + Data.ProtoLens.Compiler.Plugin + default-language: Haskell2010 diff --git a/src/Combinators.hs b/src/Combinators.hs deleted file mode 100644 --- a/src/Combinators.hs +++ /dev/null @@ -1,98 +0,0 @@ --- Copyright 2016 Google Inc. All Rights Reserved. --- --- Use of this source code is governed by a BSD-style --- license that can be found in the LICENSE file or at --- https://developers.google.com/open-source/licenses/bsd - -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | Some utility functions, classes and instances for nicer code generation --- with haskell-src-exts. --- --- In particular, we define orphan instances of IsString for various syntax --- datatypes, with some intelligence about Haskell names. For example, @"foo" --- :: Exp@ is treated as a variable and @"Foo" :: Exp@ is treated as a --- constructor. -module Combinators where - -import Data.Char (isAlphaNum, isUpper) -import Data.String (IsString(..)) -import Language.Haskell.Exts.SrcLoc (noLoc) -import Language.Haskell.Exts.Syntax as Syntax - --- | Application of a Haskell type or expression to an argument. --- For example, to represent @f x y@, you can write --- --- > "f" @@ "x" @@ "y" -class App a where - (@@) :: a -> a -> a - infixl 2 @@ - -instance App Type where - (@@) = TyApp - -instance App Exp where - (@@) = App - -instance IsString Name where - fromString s - -- TODO: better handle the case of mixed ident and symbol characters. - | all isIdentChar s = Ident s - | otherwise = Symbol s - --- | Whether this character belongs to an Ident (e.g., "foo") or a symbol --- (e.g., "<$>"). -isIdentChar :: Char -> Bool -isIdentChar c = isAlphaNum c || c `elem` "_'" - -instance IsString ModuleName where - fromString = ModuleName - -instance IsString QName where - fromString f - -- TODO: support qualified operators (e.g., "Control.Applicative.<$>") - -- Currently we ignore them due to edge-cases - -- like the composition operator "Prelude.." - | isIdentChar (last f), '.' `elem` f - -- Split "Foo.Bar.baz" into ("Foo.Bar", "baz") - , (f', '.':f'') <- span (/='.') (reverse f) - = Qual (fromString $ reverse f'') (fromString $ reverse f') - | otherwise = UnQual $ fromString f - -instance IsString Type where - fromString fs@(f:_) - | isUpper f = TyCon $ fromString fs - fromString fs = TyVar $ fromString fs - -instance IsString Exp where - fromString fs@(f:_) - | isUpper f = Con $ fromString fs - fromString fs = Var $ fromString fs - -instance IsString Pat where - fromString = PVar . fromString - -instance IsString TyVarBind where - fromString = UnkindedVar . fromString - - --- Helper functions for literal numbers, since haskell-src-exts doesn't --- put parentheses around negative numbers automatically. - -litInt :: Integer -> Exp -litInt n - | n >= 0 = Lit $ Int n - | otherwise = NegApp $ Lit $ Int $ negate n - -litFrac :: Rational -> Exp -litFrac x - | x >= 0 = Lit $ Frac x - | otherwise = NegApp $ Lit $ Frac $ negate x - -pLitInt :: Integer -> Pat -pLitInt n - | n >= 0 = PLit Signless $ Int n - | otherwise = PLit Negative $ Int $ negate n - --- | A simple clause of a function binding. -match :: Name -> [Pat] -> Exp -> Match -match n ps e = Match noLoc n ps Nothing (UnGuardedRhs e) Nothing diff --git a/src/Data/ProtoLens/Compiler/Combinators.hs b/src/Data/ProtoLens/Compiler/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtoLens/Compiler/Combinators.hs @@ -0,0 +1,98 @@ +-- Copyright 2016 Google Inc. All Rights Reserved. +-- +-- Use of this source code is governed by a BSD-style +-- license that can be found in the LICENSE file or at +-- https://developers.google.com/open-source/licenses/bsd + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Some utility functions, classes and instances for nicer code generation +-- with haskell-src-exts. +-- +-- In particular, we define orphan instances of IsString for various syntax +-- datatypes, with some intelligence about Haskell names. For example, @"foo" +-- :: Exp@ is treated as a variable and @"Foo" :: Exp@ is treated as a +-- constructor. +module Data.ProtoLens.Compiler.Combinators where + +import Data.Char (isAlphaNum, isUpper) +import Data.String (IsString(..)) +import Language.Haskell.Exts.SrcLoc (noLoc) +import Language.Haskell.Exts.Syntax as Syntax + +-- | Application of a Haskell type or expression to an argument. +-- For example, to represent @f x y@, you can write +-- +-- > "f" @@ "x" @@ "y" +class App a where + (@@) :: a -> a -> a + infixl 2 @@ + +instance App Type where + (@@) = TyApp + +instance App Exp where + (@@) = App + +instance IsString Name where + fromString s + -- TODO: better handle the case of mixed ident and symbol characters. + | all isIdentChar s = Ident s + | otherwise = Symbol s + +-- | Whether this character belongs to an Ident (e.g., "foo") or a symbol +-- (e.g., "<$>"). +isIdentChar :: Char -> Bool +isIdentChar c = isAlphaNum c || c `elem` "_'" + +instance IsString ModuleName where + fromString = ModuleName + +instance IsString QName where + fromString f + -- TODO: support qualified operators (e.g., "Control.Applicative.<$>") + -- Currently we ignore them due to edge-cases + -- like the composition operator "Prelude.." + | isIdentChar (last f), '.' `elem` f + -- Split "Foo.Bar.baz" into ("Foo.Bar", "baz") + , (f', '.':f'') <- span (/='.') (reverse f) + = Qual (fromString $ reverse f'') (fromString $ reverse f') + | otherwise = UnQual $ fromString f + +instance IsString Type where + fromString fs@(f:_) + | isUpper f = TyCon $ fromString fs + fromString fs = TyVar $ fromString fs + +instance IsString Exp where + fromString fs@(f:_) + | isUpper f = Con $ fromString fs + fromString fs = Var $ fromString fs + +instance IsString Pat where + fromString = PVar . fromString + +instance IsString TyVarBind where + fromString = UnkindedVar . fromString + + +-- Helper functions for literal numbers, since haskell-src-exts doesn't +-- put parentheses around negative numbers automatically. + +litInt :: Integer -> Exp +litInt n + | n >= 0 = Lit $ Int n + | otherwise = NegApp $ Lit $ Int $ negate n + +litFrac :: Rational -> Exp +litFrac x + | x >= 0 = Lit $ Frac x + | otherwise = NegApp $ Lit $ Frac $ negate x + +pLitInt :: Integer -> Pat +pLitInt n + | n >= 0 = PLit Signless $ Int n + | otherwise = PLit Negative $ Int $ negate n + +-- | A simple clause of a function binding. +match :: Name -> [Pat] -> Exp -> Match +match n ps e = Match noLoc n ps Nothing (UnGuardedRhs e) Nothing diff --git a/src/Data/ProtoLens/Compiler/Definitions.hs b/src/Data/ProtoLens/Compiler/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtoLens/Compiler/Definitions.hs @@ -0,0 +1,261 @@ +-- Copyright 2016 Google Inc. All Rights Reserved. +-- +-- Use of this source code is governed by a BSD-style +-- license that can be found in the LICENSE file or at +-- https://developers.google.com/open-source/licenses/bsd + +-- | 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 #-} +module Data.ProtoLens.Compiler.Definitions + ( Env + , Definition(..) + , MessageInfo(..) + , FieldInfo(..) + , EnumInfo(..) + , EnumValueInfo(..) + , qualifyEnv + , unqualifyEnv + , collectDefinitions + , definedFieldType + ) where + +import Data.Char (toUpper) +import Data.Int (Int32) +import Data.List (mapAccumL) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid +import qualified Data.Set as Set +import Data.Text (Text, cons, splitOn, toLower, uncons, unpack) +import qualified Data.Text as T +import Language.Haskell.Exts.Syntax (Name(..), QName(..), ModuleName(..)) +import Lens.Family2 ((^.)) +import Bootstrap.Proto.Google.Protobuf.Descriptor + ( DescriptorProto + , EnumDescriptorProto + , EnumValueDescriptorProto + , FieldDescriptorProto + , FileDescriptorProto + , enumType + , field + , messageType + , name + , nestedType + , number + , package + , typeName + , value + ) + +-- | 'Env' contains a mapping of proto names (as specified in the .proto file) +-- to Haskell names. The keys are fully-qualified names, for example, +-- ".package.Message.Submessage". (The protocol_compiler tool emits all +-- message field types in this form, even if they refer to local definitions.) +-- +-- The type 'n' can be either a 'Name' (when talking about definitions within +-- the current file) or a (qualified) 'QName' (when talking about definitions +-- either from this or another file). +type Env n = Map.Map Text (Definition n) + +data Definition n = Message (MessageInfo n) | Enum (EnumInfo n) + deriving Functor + +-- | All the information needed to define or use a proto message type. +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. + } 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 + -- module. + , fieldDescriptor :: FieldDescriptorProto + } + +-- | All the information needed to define or use a proto enum type. +data EnumInfo n = EnumInfo + { enumName :: n + , enumDescriptor :: EnumDescriptorProto + , enumValues :: [EnumValueInfo n] + } deriving Functor + +-- | Information about a single value case of a proto enum. +data EnumValueInfo n = EnumValueInfo + { enumValueName :: n + , enumValueDescriptor :: EnumValueDescriptorProto + , enumAliasOf :: Maybe Name + -- ^ If 'Nothing', we turn value into a normal constructor of the enum. + -- If @'Just' n@, we're treating it as an alias of the constructor @n@ + -- (a PatternSynonym in Haskell). This mirrors the behavior of the + -- Java API. + } deriving Functor + +mapEnv :: (n -> n') -> Env n -> Env n' +mapEnv f = fmap $ fmap f + +-- Lift a set of local definitions into references to a specific module. +qualifyEnv :: ModuleName -> Env Name -> Env QName +qualifyEnv m = mapEnv (Qual m) + +-- Lift a set of local definitions into references to the current module. +unqualifyEnv :: Env Name -> Env QName +unqualifyEnv = mapEnv UnQual + +-- | Look up the type definition for a given field. +definedFieldType :: FieldDescriptorProto -> Env QName -> Definition QName +definedFieldType fd env = fromMaybe err $ Map.lookup (fd ^. typeName) env + where + err = error $ "definedFieldType: Field type " ++ unpack (fd ^. typeName) + ++ " not found in environment." + +-- | Collect all the definitions in the given file (including definitions +-- nested in other messages), and assign Haskell names to them. +collectDefinitions :: FileDescriptorProto -> Env Name +collectDefinitions fd = let + protoPrefix = case fd ^. package of + "" -> "." + p -> "." <> p <> "." + hsPrefix = "" + in Map.fromList $ messageAndEnumDefs protoPrefix hsPrefix + (fd ^. messageType) (fd ^. enumType) + +messageAndEnumDefs :: Text -> String -> [DescriptorProto] + -> [EnumDescriptorProto] -> [(Text, Definition Name)] +messageAndEnumDefs protoPrefix hsPrefix messages enums + = concatMap (messageDefs protoPrefix hsPrefix) messages + ++ map (enumDef 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 + = thisDef : subDefs + where + protoName = d ^. name + hsName = unpack $ capitalize $ d ^. name + thisDef = (protoPrefix <> protoName + , Message MessageInfo + { messageName = Ident $ hsPrefix ++ hsName + , messageDescriptor = d + , messageFields = + [ FieldInfo + { overloadedField = n + , recordFieldName = Ident $ "_" ++ 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 ++ "'" + +-- | 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 + camelCase s + -- Preserve any initial underlines (e.g., "_foo_bar" -> "_fooBar"). + | (underlines, rest) <- T.span (== '_') s + = case splitOn "_" rest of + -- splitOn always returns a list with at least one element. + [] -> error $ "camelCase: splitOn returned empty list: " + ++ show rest + [""] -> error "camelCase: name consists only of underscores" + s':ss -> T.concat $ underlines : toLower s' : map capitalize ss + +-- | A list of reserved keywords that aren't valid as variable names. +reservedKeywords :: Set.Set Text +reservedKeywords = Set.fromList $ + -- Haskell2010 keywords: + -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-180002.4 + -- We don't include keywords that are allowed to be variable names, + -- in particular: "as", "forall", and "hiding". + [ "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "else" + , "foreign" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "then" + , "type" + , "where" + ] + ++ -- Nonstandard extensions + [ "mdo" -- RecursiveDo + , "rec" -- Arrows, RecursiveDo + , "pattern" -- PatternSynonyms + , "proc" -- Arrows + ] + +-- | Generate the definition for an enum type. +enumDef :: Text -> String -> EnumDescriptorProto + -> (Text, Definition Name) +enumDef protoPrefix hsPrefix d = let + mkText n = protoPrefix <> n + mkHsName n = Ident $ hsPrefix ++ unpack n + in (mkText (d ^. name) + , Enum EnumInfo + { enumName = mkHsName (d ^. name) + , enumDescriptor = d + , enumValues = collectEnumValues mkHsName $ d ^. value + }) + +-- | Generate the definitions for each enum value. In particular, decide +-- whether it's a true constructor or a PatternSynonym to another +-- constructor. +-- +-- Like Java, we treat the first case of each numeric value as the "real" +-- constructor, and subsequent cases as synonyms. +collectEnumValues :: (Text -> Name) -> [EnumValueDescriptorProto] + -> [EnumValueInfo Name] +collectEnumValues mkHsName = snd . mapAccumL helper Map.empty + where + helper :: Map.Map Int32 Name -> EnumValueDescriptorProto + -> (Map.Map Int32 Name, EnumValueInfo Name) + helper seenNames v + | Just n' <- Map.lookup k seenNames = (seenNames, mkValue (Just n')) + | otherwise = (Map.insert k hsName seenNames, mkValue Nothing) + where + mkValue = EnumValueInfo hsName v + hsName = mkHsName n + n = v ^. name + k = v ^. number + +-- Haskell types must start with an uppercase letter, so we capitalize message +-- and enum names. +-- Name collisions will show up as build errors in the generated haskell file. +capitalize :: Text -> Text +capitalize s + | Just (c, s') <- uncons s = cons (toUpper c) s' + | otherwise = s diff --git a/src/Data/ProtoLens/Compiler/Generate.hs b/src/Data/ProtoLens/Compiler/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtoLens/Compiler/Generate.hs @@ -0,0 +1,672 @@ +-- Copyright 2016 Google Inc. All Rights Reserved. +-- +-- Use of this source code is governed by a BSD-style +-- license that can be found in the LICENSE file or at +-- https://developers.google.com/open-source/licenses/bsd + +-- | This module builds the actual, generated Haskell file +-- for a given input .proto file. +{-# LANGUAGE OverloadedStrings #-} +module Data.ProtoLens.Compiler.Generate( + generateModule, + fileSyntaxType, + ) where + + +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import qualified Data.Foldable as F +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe (isNothing) +import Data.Ord (comparing) +import qualified Data.Set as Set +import Data.String (fromString) +import Data.Text (unpack) +import qualified Data.Text as T +import Data.Tuple (swap) +import Language.Haskell.Exts.Syntax as Syntax +import Language.Haskell.Exts.SrcLoc (noLoc) +import Lens.Family2 ((^.)) +import Bootstrap.Proto.Google.Protobuf.Descriptor + ( EnumValueDescriptorProto + , FieldDescriptorProto + , FieldDescriptorProto'Label(..) + , FieldDescriptorProto'Type(..) + , FileDescriptorProto + , defaultValue + , label + , mapEntry + , maybe'oneofIndex + , name + , number + , options + , packed + , syntax + , type' + , typeName + ) + +import Data.ProtoLens.Compiler.Combinators +import Data.ProtoLens.Compiler.Definitions + +data SyntaxType = Proto2 | Proto3 + deriving 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 + +-- | Generate a Haskell module for the given input file(s). +-- input contains all defined names, incl. those in this module +generateModule :: ModuleName + -> [ModuleName] -- ^ The imported modules + -> SyntaxType + -> Env Name -- ^ Definitions in this file + -> Env QName -- ^ Definitions in the imported modules + -> Module +generateModule modName imports syntaxType definitions importedEnv + = Module noLoc modName + [ LanguagePragma noLoc $ map Ident + ["ScopedTypeVariables", "DataKinds", "TypeFamilies", + "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances", + "PatternSynonyms"] + -- Allow unused imports in case we don't import anything from + -- Data.Text, Data.Int, etc. + , OptionsPragma noLoc (Just GHC) "-fno-warn-unused-imports" + ] + Nothing -- no warning text + Nothing -- no explicit exports; we export everything. + -- TODO: Also export public imports, taking care not to + -- cause a name conflict between field accessors. + (map importSimple + -- Note: we import Prelude explicitly to make it qualified. + [ "Prelude", "Data.Int", "Data.Word"] + ++ map importReexported + [ "Data.ProtoLens", "Data.ProtoLens.Message.Enum" + , "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class" + , "Data.Text", "Data.Map" , "Data.ByteString" + ] + ++ map importSimple imports) + (concatMap generateDecls (Map.elems definitions) + ++ concatMap generateFieldDecls allFieldNames) + 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 + | Message m <- Map.elems definitions + , f <- messageFields m + , i <- fieldInstances (lensInfo syntaxType env f) + ] + +importSimple :: ModuleName -> ImportDecl +importSimple m = ImportDecl + { importLoc = noLoc + , importModule = m + -- Import qualified to avoid clashes with names defined in this module. + , importQualified = True + , importSrc = False + , importSafe = False + , importPkg = Nothing + , importAs = Nothing + , importSpecs = Nothing + } + +importReexported :: ModuleName -> ImportDecl +importReexported m@(ModuleName s) = (importSimple m') { importAs = Just m } + where + m' = ModuleName $ "Data.ProtoLens.Reexport." ++ s + +generateMessageDecls :: SyntaxType -> Env QName -> MessageInfo Name -> [Decl] +generateMessageDecls syntaxType env info = + -- data Bar = Bar { + -- foo :: Baz + -- } + [ DataDecl noLoc DataType [] dataName [] + [QualConDecl noLoc [] [] $ RecDecl dataName + [([recordFieldName f], + internalType (lensInfo syntaxType env f)) + | f <- fields + ] + ] + [("Prelude.Show", []), ("Prelude.Eq", [])] + ] + ++ + -- type instance Field.Field "foo" Bar = Baz + -- instance Field.HasField "foo" Bar where + -- field _ = ... + -- Note: for optional fields, this generates an instance both for "foo" and + -- for "maybe'foo" (see lensInfo below). + concat + [ [ TypeInsDecl noLoc + ("Data.ProtoLens.Field" @@ sym @@ dataType) + (fieldTypeInstance i) + , InstDecl noLoc Nothing [] [] "Data.ProtoLens.HasField" + [sym, dataType, dataType] + [InsDecl $ FunBind [match "field" [PWildCard] $ fieldAccessor i]] + ] + | f <- fields + , i <- fieldInstances (lensInfo syntaxType env f) + , let sym = TyPromoted $ PromotedString $ fieldSymbol i + ] + ++ + -- instance Data.Default.Class.Default Bar where + [ InstDecl noLoc Nothing [] [] "Data.Default.Class.Default" [dataType] + -- def = Bar { _Bar_foo = 0 } + [ InsDecl $ FunBind + [ match "def" [] + $ RecConstr (UnQual dataName) + [ FieldUpdate (UnQual $ recordFieldName f) + (hsFieldDefault syntaxType env (fieldDescriptor f)) + | f <- fields + ] + ] + ] + -- instance Message.Message Bar where + , InstDecl noLoc Nothing [] [] "Data.ProtoLens.Message" [dataType] + [ InsDecl $ FunBind + [ match "descriptor" [] $ descriptorExpr syntaxType env info] + ] + ] + where + dataType = TyCon $ UnQual dataName + MessageInfo { messageName = dataName, messageFields = fields} = info + +generateEnumDecls :: EnumInfo Name -> [Decl] +generateEnumDecls info = + [ DataDecl noLoc DataType [] dataName [] + [QualConDecl noLoc [] [] $ ConDecl n [] | n <- constructorNames] + [(c, []) | c <- ["Prelude.Show", "Prelude.Eq"]] + -- instance Data.Default.Class.Default Foo where + -- def = FirstEnumValue + , InstDecl noLoc Nothing [] [] "Data.Default.Class.Default" [dataType] + [ InsDecl $ FunBind [match "def" [] defaultCon] + ] + -- instance Data.ProtoLens.FieldDefault Foo where + -- fieldDefault = FirstEnumValue + , InstDecl noLoc Nothing [] [] "Data.ProtoLens.FieldDefault" [dataType] + [ InsDecl $ FunBind [match "fieldDefault" [] defaultCon] + ] + -- instance MessageEnum Foo where + -- maybeToEnum 1 = Just Foo1 + -- maybeToEnum 2 = Just Foo2 + -- ... + -- maybeToEnum _ = Nothing + -- showEnum Foo1 = "Foo1" + -- showEnum Foo2 = "Foo2" + -- ... + -- readEnum "Foo1" = Just Foo1 + -- readEnum "Foo2" = Just Foo2 + -- ... + -- readEnum _ = Nothing + , InstDecl noLoc Nothing [] [] "Data.ProtoLens.MessageEnum" [dataType] + [ InsDecl $ FunBind $ + [ match "maybeToEnum" [pLitInt k] + $ "Prelude.Just" @@ Con (UnQual n) + | (n, k) <- constructorNumbers + ] + ++ + [ match "maybeToEnum" [PWildCard] "Prelude.Nothing" + ] + ++ + [ match "showEnum" [PVar n] $ Lit $ Syntax.String $ T.unpack pn + | (n, pn) <- constructorProtoNames + ] + ++ + [ match "readEnum" + [PLit Signless . Syntax.String $ T.unpack pn] + $ "Prelude.Just" @@ Con (UnQual n) + | (n, pn) <- constructorProtoNames + ] + ++ + [ match "readEnum" [PWildCard] "Prelude.Nothing" + ] + ] + -- instance Enum Foo where + -- toEnum k = maybe (error ("Foo.toEnum: unknown argument for enum Foo: " + -- ++ show k)) + -- id (maybeToEnum k) + -- fromEnum Foo1 = 1 + -- fromEnum Foo2 = 2 + -- .. + -- succ FooN = error "Foo.succ: bad argument FooN." + -- succ Foo1 = Foo2 + -- succ Foo2 = Foo3 + -- .. + -- pred Foo1 = error "Foo.succ: bad argument Foo1." + -- pred Foo2 = Foo1 + -- pred Foo3 = Foo2 + -- .. + -- enumFrom = messageEnumFrom + -- enumFromTo = messageEnumFromTo + -- enumFromThen = messageEnumFromThen + -- enumFromThenTo = messageEnumFromThenTo + , InstDecl noLoc Nothing [] [] "Prelude.Enum" [dataType] + [ InsDecl $ FunBind + [ match "toEnum" ["k__"] + $ "Prelude.maybe" @@ errorMessageExpr @@ "Prelude.id" + @@ ("Data.ProtoLens.maybeToEnum" @@ "k__") + ] + , InsDecl $ FunBind + [ match "fromEnum" [PApp (UnQual c) []] $ litInt k + | (c, k) <- constructorNumbers + ] + , succDecl "succ" maxBoundName succPairs + , succDecl "pred" minBoundName $ map swap succPairs + , alias "enumFrom" "Data.ProtoLens.Message.Enum.messageEnumFrom" + , alias "enumFromTo" "Data.ProtoLens.Message.Enum.messageEnumFromTo" + , alias "enumFromThen" "Data.ProtoLens.Message.Enum.messageEnumFromThen" + , alias "enumFromThenTo" + "Data.ProtoLens.Message.Enum.messageEnumFromThenTo" + ] + -- instance Bounded Foo where + -- minBound = Foo1 + -- maxBound = FooN + , InstDecl noLoc Nothing [] [] "Prelude.Bounded" [dataType] + [ InsDecl $ FunBind + [ match "minBound" [] $ Con $ UnQual minBoundName + , match "maxBound" [] $ Con $ UnQual maxBoundName + ] + ] + ] + ++ + -- pattern FooAlias :: Foo + -- pattern FooAlias = FooConstructor + concat + [ [ PatSynSig noLoc aliasName Nothing [] [] dataType + , PatSyn noLoc (PVar aliasName) (PVar originalName) + ImplicitBidirectional + ] + | EnumValueInfo + { enumValueName = aliasName + , enumAliasOf = Just originalName + } <- enumValues info + ] + where + dataType = TyCon $ UnQual dataName + EnumInfo { enumName = dataName, enumDescriptor = ed } = info + constructors :: [(Name, EnumValueDescriptorProto)] + constructors = List.sortBy (comparing ((^. number) . snd)) + [(n, d) | EnumValueInfo + { enumValueName = n + , enumValueDescriptor = d + , enumAliasOf = Nothing + } <- enumValues info + ] + constructorNames = map fst constructors + minBoundName = head constructorNames + maxBoundName = last constructorNames + + constructorProtoNames = map (second (^. name)) constructors + constructorNumbers = map (second (fromIntegral . (^. number))) + constructors + + succPairs = zip constructorNames $ tail constructorNames + succDecl funName boundName thePairs = InsDecl $ FunBind $ + match funName [PApp (UnQual boundName) []] ( + "Prelude.error" @@ Lit (Syntax.String $ concat + [ show dataName, ".", show funName, ": bad argument " + , show boundName, ". This value would be out of bounds." + ])) + : + [ match funName [PApp (UnQual from) []] $ Con $ UnQual to + | (from, to) <- thePairs + ] + alias funName implName = InsDecl $ FunBind [match funName [] implName] + + defaultCon = Con $ UnQual $ head constructorNames + errorMessageExpr = "Prelude.error" + @@ ("Prelude.++" @@ Lit (Syntax.String errorMessage) + @@ ("Prelude.show" @@ "k__")) + errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name) + ++ ": " + +generateFieldDecls :: String -> [Decl] +generateFieldDecls fStr = + -- foo :: forall msg msg' . Field.HasField "foo" msg msg' + -- => Lens.Lens msg msg' (Field.Field "foo" msg) + -- (Field.Field "foo" msg') + -- foo = Field.field (Field.ProxySym :: Field.Proxy "foo") + [ TypeSig noLoc [f] + $ TyForall (Just ["msg", "msg'"]) + [ClassA "Data.ProtoLens.HasField" [fSym, "msg", "msg'"]] + $ "Lens.Family2.Lens" @@ "msg" @@ "msg'" + @@ ("Data.ProtoLens.Field" @@ fSym @@ "msg") + @@ ("Data.ProtoLens.Field" @@ fSym @@ "msg'") + , FunBind [match f [] + $ "Data.ProtoLens.field" + @@ ExpTypeSig noLoc "Data.ProtoLens.ProxySym" + ("Data.ProtoLens.ProxySym" @@ fSym) + ] + ] + where + f = Ident fStr + fSym = TyPromoted $ PromotedString fStr + +------------------------------------------ + +-- | 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 + } + +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 _ = ... + } + +-- | 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 + -- 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_OPTIONAL + | isDefaultingOptional syntaxType fd + -> LensInfo baseType + [FieldInstanceInfo + { fieldSymbol = baseName + , fieldTypeInstance = baseType + , fieldAccessor = 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 + }] + -- data Foo = Foo { _Foo_bar :: [Bar] } + -- type instance Field "bar" Foo = [Bar] + | otherwise -> LensInfo listType + [FieldInstanceInfo + { fieldSymbol = baseName + , fieldTypeInstance = listType + , fieldAccessor = 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 + 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 + +-- 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 + +hsFieldValueDefault :: Env QName -> FieldDescriptorProto -> Exp +hsFieldValueDefault env fd = case fd ^. type' of + FieldDescriptorProto'TYPE_MESSAGE -> "Data.Default.Class.def" + FieldDescriptorProto'TYPE_GROUP -> "Data.Default.Class.def" + FieldDescriptorProto'TYPE_ENUM + | T.null def -> "Data.Default.Class.def" + | Enum e <- definedFieldType fd env + , Just v <- List.lookup def [ (enumValueDescriptor v ^. name, enumValueName v) + | v <- enumValues e + ] + -> Con v + | otherwise -> errorMessage "enum" + -- The rest of the cases are for scalar fields that have a fieldDefault + -- instance. + _ | T.null def -> "Data.ProtoLens.fieldDefault" + FieldDescriptorProto'TYPE_BOOL + | def == "true" -> "Prelude.True" + | def == "false" -> "Prelude.False" + | otherwise -> errorMessage "bool" + FieldDescriptorProto'TYPE_STRING + -> "Data.Text.pack" @@ Lit (String $ T.unpack def) + FieldDescriptorProto'TYPE_BYTES + -> "Data.ByteString.pack" + @@ List ((mkByte . fromEnum) <$> T.unpack def) + where mkByte c + | c > 0 && c < 255 = litInt $ fromIntegral c + | otherwise = errorMessage "bytes" + FieldDescriptorProto'TYPE_FLOAT -> defaultFrac $ T.unpack def + FieldDescriptorProto'TYPE_DOUBLE -> defaultFrac $ T.unpack def + -- Otherwise, assume it's an integral field: + _ -> defaultInt $ T.unpack def + where + def = fd ^. defaultValue + errorMessage fieldType + = error $ "Bad default value " ++ show (T.unpack def) + ++ " in default value for " ++ fieldType ++ " field " + ++ unpack (fd ^. name) + -- float/double fields can use nan, inf and -inf as default values. + -- The Prelude doesn't provide names for them, so we implement + -- them as division by zero. + defaultFrac "nan" = "Prelude./" @@ litFrac 0 @@ litFrac 0 + defaultFrac "inf" = "Prelude./" @@ litFrac 1 @@ litFrac 0 + defaultFrac "-inf" = "Prelude./" @@ litFrac (negate 1) @@ litFrac 0 + defaultFrac s = case reads s of + [(x, "")] -> litFrac $ toRational (x :: Double) + _ -> errorMessage "fractional" + defaultInt s = case reads s of + [(x, "")] -> litInt x + _ -> errorMessage "integral" + +-- | A lens to access an internal field. +-- +-- lens _Foo_bar (\x__ y__ -> x__ { _Foo_bar = y__ }) +rawFieldAccessor :: QName -> Exp +rawFieldAccessor f = "Lens.Family2.Unchecked.lens" @@ getter @@ setter + where + getter = Var f + setter = Lambda noLoc ["x__", "y__"] + $ RecUpdate "x__" [FieldUpdate f "y__"] + +descriptorExpr :: SyntaxType -> Env QName -> MessageInfo Name -> Exp +descriptorExpr syntaxType env m + -- let foo__field_descriptor = ... + -- ... + -- in Message.MessageDescriptor + -- (Data.Map.fromList [(Tag 1, foo__field_descriptor),...]) + -- (Data.Map.fromList [("foo", foo__field_descriptor),...]) + -- + -- (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 (BDecls $ map fieldDescriptorVarBind $ messageFields m) + $ "Data.ProtoLens.MessageDescriptor" + @@ ("Data.Map.fromList" @@ List fieldsByTag) + @@ ("Data.Map.fromList" @@ List fieldsByTextFormatName) + where + fieldsByTag = + [Tuple Boxed + [ t, fieldDescriptorVar f ] + | f <- messageFields m + , let t = "Data.ProtoLens.Tag" + @@ litInt (fromIntegral + $ fieldDescriptor f ^. number) + ] + fieldsByTextFormatName = + [Tuple Boxed + [ t, fieldDescriptorVar f ] + | f <- messageFields m + , let t = Lit $ Syntax.String $ T.unpack + $ textFormatFieldName env (fieldDescriptor f) + ] + fieldDescriptorVar = fromString . fieldDescriptorName + fieldDescriptorName f + = fromString $ overloadedField f ++ "__field_descriptor" + fieldDescriptorVarBind f + = FunBind + [match (fromString $ fieldDescriptorName f) [] + $ fieldDescriptorExpr syntaxType env f + ] + +-- | 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, +-- not the name of the field in the descriptor (e.g. "Foo", not "foo"). +textFormatFieldName :: Env QName -> FieldDescriptorProto -> T.Text +textFormatFieldName env descr = case descr ^. type' of + FieldDescriptorProto'TYPE_GROUP + | Message msg <- definedFieldType descr env + -> messageDescriptor msg ^. name + | otherwise -> error $ "expected TYPE_GROUP for type name" + ++ T.unpack (descr ^. typeName) + _ -> descr ^. name + +fieldDescriptorExpr :: SyntaxType -> Env QName -> FieldInfo + -> Exp +fieldDescriptorExpr syntaxType env f + = "Data.ProtoLens.FieldDescriptor" + -- Record the original .proto name for text format + @@ Lit (Syntax.String (T.unpack $ fd ^. name)) + -- Force the type signature since it can't be inferred for Map entry + -- types. + @@ ExpTypeSig noLoc (fieldTypeDescriptorExpr (fd ^. type')) + ("Data.ProtoLens.FieldTypeDescriptor" + @@ hsFieldType env fd) + @@ fieldAccessorExpr syntaxType env f + where + fd = fieldDescriptor f + +fieldAccessorExpr :: SyntaxType -> Env QName -> FieldInfo -> Exp +-- (PlainField Required foo), (OptionalField foo), etc... +fieldAccessorExpr syntaxType env f = accessorCon @@ Var (UnQual 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 + -> "Data.ProtoLens.MapField" + @@ fromString (overloadedField k) + @@ fromString (overloadedField v) + | otherwise -> "Data.ProtoLens.RepeatedField" + @@ if fd ^. options.packed + then "Data.ProtoLens.Packed" + else "Data.ProtoLens.Unpacked" + hsFieldName + = Ident $ case fd ^. label of + FieldDescriptorProto'LABEL_OPTIONAL + | not (isDefaultingOptional syntaxType fd) + -> "maybe'" ++ overloadedField f + _ -> overloadedField f + +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. + && isNothing (f ^. maybe'oneofIndex) + +fieldTypeDescriptorExpr :: FieldDescriptorProto'Type -> Exp +fieldTypeDescriptorExpr = + (\n -> fromString $ "Data.ProtoLens." ++ n ++ "Field") . \t -> case t of + FieldDescriptorProto'TYPE_DOUBLE -> "Double" + FieldDescriptorProto'TYPE_FLOAT -> "Float" + FieldDescriptorProto'TYPE_INT64 -> "Int64" + FieldDescriptorProto'TYPE_UINT64 -> "UInt64" + FieldDescriptorProto'TYPE_INT32 -> "Int32" + FieldDescriptorProto'TYPE_FIXED64 -> "Fixed64" + FieldDescriptorProto'TYPE_FIXED32 -> "Fixed32" + FieldDescriptorProto'TYPE_BOOL -> "Bool" + FieldDescriptorProto'TYPE_STRING -> "String" + FieldDescriptorProto'TYPE_GROUP -> "Group" + FieldDescriptorProto'TYPE_MESSAGE -> "Message" + FieldDescriptorProto'TYPE_BYTES -> "Bytes" + FieldDescriptorProto'TYPE_UINT32 -> "UInt32" + FieldDescriptorProto'TYPE_ENUM -> "Enum" + FieldDescriptorProto'TYPE_SFIXED32 -> "SFixed32" + FieldDescriptorProto'TYPE_SFIXED64 -> "SFixed64" + FieldDescriptorProto'TYPE_SINT32 -> "SInt32" + FieldDescriptorProto'TYPE_SINT64 -> "SInt64" diff --git a/src/Data/ProtoLens/Compiler/Plugin.hs b/src/Data/ProtoLens/Compiler/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtoLens/Compiler/Plugin.hs @@ -0,0 +1,128 @@ +-- Copyright 2016 Google Inc. All Rights Reserved. +-- +-- Use of this source code is governed by a BSD-style +-- license that can be found in the LICENSE file or at +-- https://developers.google.com/open-source/licenses/bsd +-- +-- Code for writing protocol compiler plugins. + +{-# LANGUAGE OverloadedStrings #-} +module Data.ProtoLens.Compiler.Plugin + ( ProtoFileName + , ProtoFile(..) + , analyzeProtoFiles + , collectEnvFromDeps + , outputFilePath + , moduleName + , moduleNameStr + ) where + +import Data.Char (toUpper) +import Data.List (foldl', intercalate) +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map, unions, (!)) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text (Text) +import Language.Haskell.Exts.Syntax (ModuleName(..), Name(..), QName(..)) +import Lens.Family2 +import Bootstrap.Proto.Google.Protobuf.Descriptor + (FileDescriptorProto, name, dependency, publicDependency) +import System.FilePath (dropExtension, splitDirectories) + + +import Data.ProtoLens.Compiler.Definitions + +-- | The filename of an input .proto file. +type ProtoFileName = Text + +data ProtoFile = ProtoFile + { descriptor :: FileDescriptorProto + , haskellModule :: ModuleName + , definitions :: Env Name + -- | The names of proto files exported (transitively, via "import public" + -- decl) by this file. + , exports :: [ProtoFileName] + , exportedEnv :: Env QName + } + +-- Given a list of FileDescriptorProtos, collect information about each file +-- into a map of 'ProtoFile's keyed by 'ProtoFileName'. +analyzeProtoFiles :: Text -> [FileDescriptorProto] -> Map ProtoFileName ProtoFile +analyzeProtoFiles modulePrefix files = + Map.fromList [ (f ^. name, ingestFile f) | f <- files ] + where + filesByName = Map.fromList [(f ^. name, f) | f <- files] + moduleNames = fmap (moduleName modulePrefix) filesByName + -- The definitions in each input proto file, indexed by filename. + definitionsByName = fmap collectDefinitions filesByName + -- The exports from each .proto file (including any "public import" + -- dependencies), as they appear to other modules that are importing them; + -- i.e., qualified by module name. + exportsByName = transitiveExports files + localExports = Map.intersectionWith qualifyEnv moduleNames definitionsByName + exportedEnvs = fmap (\es -> unions [localExports ! e | e <- es]) exportsByName + + ingestFile f = ProtoFile + { descriptor = f + , haskellModule = moduleNames ! n + , definitions = definitionsByName ! n + , exports = exportsByName ! n + , exportedEnv = exportedEnvs ! n + } + where + n = f ^. name + +collectEnvFromDeps :: [ProtoFileName] -> Map ProtoFileName ProtoFile -> Env QName +collectEnvFromDeps deps filesByName = + unions $ fmap (exportedEnv . (filesByName !)) deps + +-- | Get the output file path (for CodeGeneratorResponse.File) for a Haskell +-- ModuleName. +outputFilePath :: String -> Text +outputFilePath n = T.replace "." "/" (T.pack n) <> ".hs" + +-- | Get the Haskell 'ModuleName' corresponding to a given .proto file. +moduleName :: Text -> FileDescriptorProto -> ModuleName +moduleName modulePrefix fd = ModuleName (moduleNameStr modulePrefix fd) + +-- | Get the Haskell module name corresponding to a given .proto file. +moduleNameStr :: Text -> FileDescriptorProto -> String +moduleNameStr modulePrefix fd = fixModuleName rawModuleName + where + path = fd ^. name + prefix + | T.null modulePrefix = "Proto" + | otherwise = modulePrefix + fixModuleName "" = "" + -- Characters allowed in Bazel filenames but not in module names: + fixModuleName ('.':c:cs) = '.' : toUpper c : fixModuleName cs + fixModuleName ('_':c:cs) = toUpper c : fixModuleName cs + fixModuleName ('-':c:cs) = toUpper c : fixModuleName cs + fixModuleName (c:cs) = c : fixModuleName cs + rawModuleName = intercalate "." $ (T.unpack prefix :) + $ splitDirectories $ dropExtension + $ T.unpack path + +-- | Given a list of .proto files (topologically sorted), determine which +-- files' definitions are exported by which files. +-- +-- Files only export their own definitions, along with the definitions exported +-- by any "import public" declarations. +transitiveExports :: [FileDescriptorProto] -> Map ProtoFileName [ProtoFileName] +-- Accumulate the transitive dependencies by folding over the files in +-- topological order. +transitiveExports = foldl' setExportsFromFile Map.empty + where + setExportsFromFile :: Map ProtoFileName [ProtoFileName] + -> FileDescriptorProto + -> Map ProtoFileName [ProtoFileName] + setExportsFromFile prevExports fd + = flip (Map.insert n) prevExports $ + n : concat [ prevExports ! ((fd ^. dependency) !! fromIntegral i) + -- Note that publicDependency is a list of indices into + -- the dependency list. + | i <- fd ^. publicDependency + ] + where n = fd ^. name + 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 @@ -77,6 +77,8 @@ generatingProtos root hooks = hooks { buildHook = \p l h f -> generateSources p l >> buildHook hooks p l h f , haddockHook = \p l h f -> generateSources p l >> haddockHook hooks p l h f + , replHook = \p l h f args -> generateSources p l + >> replHook hooks p l h f args , sDistHook = \p maybe_l h f -> case maybe_l of Nothing -> error "Can't run protoc; run 'cabal configure' first." Just l -> do diff --git a/src/Definitions.hs b/src/Definitions.hs deleted file mode 100644 --- a/src/Definitions.hs +++ /dev/null @@ -1,225 +0,0 @@ --- Copyright 2016 Google Inc. All Rights Reserved. --- --- Use of this source code is governed by a BSD-style --- license that can be found in the LICENSE file or at --- https://developers.google.com/open-source/licenses/bsd - --- | 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 #-} -module Definitions - ( Env - , Definition(..) - , MessageInfo(..) - , FieldInfo(..) - , EnumInfo(..) - , qualifyEnv - , unqualifyEnv - , collectDefinitions - , definedFieldType - ) where - -import Data.Char (toUpper) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Monoid -import qualified Data.Set as Set -import Data.Text (Text, cons, splitOn, toLower, uncons, unpack) -import qualified Data.Text as T -import Language.Haskell.Exts.Syntax (Name(..), QName(..), ModuleName(..)) -import Lens.Family2 ((^.)) -import Bootstrap.Proto.Google.Protobuf.Descriptor - ( DescriptorProto - , EnumDescriptorProto - , FieldDescriptorProto - , FileDescriptorProto - , enumType - , field - , messageType - , name - , nestedType - , package - , typeName - , value - ) - --- | 'Env' contains a mapping of proto names (as specified in the .proto file) --- to Haskell names. The keys are fully-qualified names, for example, --- ".package.Message.Submessage". (The protocol_compiler tool emits all --- message field types in this form, even if they refer to local definitions.) --- --- The type 'n' can be either a 'Name' (when talking about definitions within --- the current file) or a (qualified) 'QName' (when talking about definitions --- either from this or another file). -type Env n = Map.Map Text (Definition n) - -data Definition n = Message (MessageInfo n) | Enum (EnumInfo n) - deriving Functor - --- | All the information needed to define or use a proto message type. -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. - } 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 - -- module. - , fieldDescriptor :: FieldDescriptorProto - } - --- | All the information needed to define or use a proto enum type. -data EnumInfo n = EnumInfo - { enumName :: n - , enumDescriptor :: EnumDescriptorProto - , enumValueNames :: [n] - -- ^ The Haskell name of each enum value. - -- This corresponds 1-1 with "value" in EnumDescriptorProto. - } deriving Functor - -mapEnv :: (n -> n') -> Env n -> Env n' -mapEnv f = fmap $ fmap f - --- Lift a set of local definitions into references to a specific module. -qualifyEnv :: ModuleName -> Env Name -> Env QName -qualifyEnv m = mapEnv (Qual m) - --- Lift a set of local definitions into references to the current module. -unqualifyEnv :: Env Name -> Env QName -unqualifyEnv = mapEnv UnQual - --- | Look up the type definition for a given field. -definedFieldType :: FieldDescriptorProto -> Env QName -> Definition QName -definedFieldType fd env = fromMaybe err $ Map.lookup (fd ^. typeName) env - where - err = error $ "definedFieldType: Field type " ++ unpack (fd ^. typeName) - ++ " not found in environment." - --- | Collect all the definitions in the given file (including definitions --- nested in other messages), and assign Haskell names to them. -collectDefinitions :: FileDescriptorProto -> Env Name -collectDefinitions fd = let - protoPrefix = case fd ^. package of - "" -> "." - p -> "." <> p <> "." - hsPrefix = "" - in Map.fromList $ messageAndEnumDefs protoPrefix hsPrefix - (fd ^. messageType) (fd ^. enumType) - -messageAndEnumDefs :: Text -> String -> [DescriptorProto] - -> [EnumDescriptorProto] -> [(Text, Definition Name)] -messageAndEnumDefs protoPrefix hsPrefix messages enums - = concatMap (messageDefs protoPrefix hsPrefix) messages - ++ map (enumDef 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 - = thisDef : subDefs - where - protoName = d ^. name - hsName = unpack $ capitalize $ d ^. name - thisDef = (protoPrefix <> protoName - , Message MessageInfo - { messageName = Ident $ hsPrefix ++ hsName - , messageDescriptor = d - , messageFields = - [ FieldInfo - { overloadedField = n - , recordFieldName = Ident $ "_" ++ 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 ++ "'" - --- | 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 - camelCase s - -- Preserve any initial underlines (e.g., "_foo_bar" -> "_fooBar"). - | (underlines, rest) <- T.span (== '_') s - = case splitOn "_" rest of - -- splitOn always returns a list with at least one element. - [] -> error $ "camelCase: splitOn returned empty list: " - ++ show rest - [""] -> error "camelCase: name consists only of underscores" - s':ss -> T.concat $ underlines : toLower s' : map capitalize ss - --- | A list of reserved keywords that aren't valid as variable names. -reservedKeywords :: Set.Set Text -reservedKeywords = Set.fromList $ - -- Haskell2010 keywords: - -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-180002.4 - -- We don't include keywords that are allowed to be variable names, - -- in particular: "as", "forall", and "hiding". - [ "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "else" - , "foreign" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "then" - , "type" - , "where" - ] - ++ -- Nonstandard extensions - [ "mdo" -- RecursiveDo - , "rec" -- Arrows, RecursiveDo - , "proc" -- Arrows - ] - --- | Generate the definition for an enum type. -enumDef :: Text -> String -> EnumDescriptorProto - -> (Text, Definition Name) -enumDef protoPrefix hsPrefix d = let - mkText n = protoPrefix <> n - mkHsName n = Ident $ hsPrefix ++ unpack n - in (mkText (d ^. name) - , Enum EnumInfo - { enumName = mkHsName (d ^. name) - , enumDescriptor = d - , enumValueNames = fmap (mkHsName . (^. name)) (d ^. value) - }) - --- Haskell types must start with an uppercase letter, so we capitalize message --- and enum names. --- Name collisions will show up as build errors in the generated haskell file. -capitalize :: Text -> Text -capitalize s - | Just (c, s') <- uncons s = cons (toUpper c) s' - | otherwise = s diff --git a/src/Generate.hs b/src/Generate.hs deleted file mode 100644 --- a/src/Generate.hs +++ /dev/null @@ -1,648 +0,0 @@ --- Copyright 2016 Google Inc. All Rights Reserved. --- --- Use of this source code is governed by a BSD-style --- license that can be found in the LICENSE file or at --- https://developers.google.com/open-source/licenses/bsd - --- | This module builds the actual, generated Haskell file --- for a given input .proto file. -{-# LANGUAGE OverloadedStrings #-} -module Generate( - generateModule, - fileSyntaxType, - ) where - - -import Control.Applicative ((<$>)) -import Control.Arrow (second) -import qualified Data.Foldable as F -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Maybe (isNothing) -import Data.Ord (comparing) -import qualified Data.Set as Set -import Data.String (fromString) -import Data.Text (unpack) -import qualified Data.Text as T -import Data.Tuple (swap) -import Language.Haskell.Exts.Syntax as Syntax -import Language.Haskell.Exts.SrcLoc (noLoc) -import Lens.Family2 ((^.)) -import Bootstrap.Proto.Google.Protobuf.Descriptor - ( FieldDescriptorProto - , FieldDescriptorProto'Label(..) - , FieldDescriptorProto'Type(..) - , FileDescriptorProto - , defaultValue - , label - , mapEntry - , maybe'oneofIndex - , name - , number - , options - , packed - , syntax - , type' - , typeName - , value - ) - -import Combinators -import Definitions - -data SyntaxType = Proto2 | Proto3 - deriving 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 - --- | Generate a Haskell module for the given input file(s). --- input contains all defined names, incl. those in this module -generateModule :: ModuleName - -> [ModuleName] -- ^ The imported modules - -> SyntaxType - -> Env Name -- ^ Definitions in this file - -> Env QName -- ^ Definitions in the imported modules - -> Module -generateModule modName imports syntaxType definitions importedEnv - = Module noLoc modName - [ LanguagePragma noLoc $ map Ident - ["ScopedTypeVariables", "DataKinds", "TypeFamilies", - "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances"] - -- Allow unused imports in case we don't import anything from - -- Data.Text, Data.Int, etc. - , OptionsPragma noLoc (Just GHC) "-fno-warn-unused-imports" - ] - Nothing -- no warning text - Nothing -- no explicit exports; we export everything. - -- TODO: Also export public imports, taking care not to - -- cause a name conflict between field accessors. - (map importDecl - -- Note: we import Prelude explicitly to make it qualified. - $ [ "Prelude", "Data.ProtoLens", "Data.ProtoLens.Message.Enum" - , "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class" - , "Data.Text", "Data.Int" - , "Data.Word", "Data.Map" , "Data.ByteString" - ] - ++ imports) - (concatMap generateDecls (Map.elems definitions) - ++ concatMap generateFieldDecls allFieldNames) - 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 - | Message m <- Map.elems definitions - , f <- messageFields m - , i <- fieldInstances (lensInfo syntaxType env f) - ] - -importDecl :: ModuleName -> ImportDecl -importDecl m = ImportDecl - { importLoc = noLoc - , importModule = m - -- Import qualified to avoid clashes with names defined in this module. - , importQualified = True - , importSrc = False - , importSafe = False - , importPkg = Nothing - , importAs = Nothing - , importSpecs = Nothing - } - -generateMessageDecls :: SyntaxType -> Env QName -> MessageInfo Name -> [Decl] -generateMessageDecls syntaxType env info = - -- data Bar = Bar { - -- foo :: Baz - -- } - [ DataDecl noLoc DataType [] dataName [] - [QualConDecl noLoc [] [] $ RecDecl dataName - [([recordFieldName f], - internalType (lensInfo syntaxType env f)) - | f <- fields - ] - ] - [("Prelude.Show", []), ("Prelude.Eq", [])] - ] - ++ - -- type instance Field.Field "foo" Bar = Baz - -- instance Field.HasField "foo" Bar where - -- field _ = ... - -- Note: for optional fields, this generates an instance both for "foo" and - -- for "maybe'foo" (see lensInfo below). - concat - [ [ TypeInsDecl noLoc - ("Data.ProtoLens.Field" @@ sym @@ dataType) - (fieldTypeInstance i) - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.HasField" - [sym, dataType, dataType] - [InsDecl $ FunBind [match "field" [PWildCard] $ fieldAccessor i]] - ] - | f <- fields - , i <- fieldInstances (lensInfo syntaxType env f) - , let sym = TyPromoted $ PromotedString $ fieldSymbol i - ] - ++ - -- instance Data.Default.Class.Default Bar where - [ InstDecl noLoc Nothing [] [] "Data.Default.Class.Default" [dataType] - -- def = Bar { _Bar_foo = 0 } - [ InsDecl $ FunBind - [ match "def" [] - $ RecConstr (UnQual dataName) - [ FieldUpdate (UnQual $ recordFieldName f) - (hsFieldDefault syntaxType env (fieldDescriptor f)) - | f <- fields - ] - ] - ] - -- instance Message.Message Bar where - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.Message" [dataType] - [ InsDecl $ FunBind - [ match "descriptor" [] $ descriptorExpr syntaxType env info] - ] - ] - where - dataType = TyCon $ UnQual dataName - MessageInfo { messageName = dataName, messageFields = fields} = info - -generateEnumDecls :: EnumInfo Name -> [Decl] -generateEnumDecls info = - [ DataDecl noLoc DataType [] dataName [] - [QualConDecl noLoc [] [] $ ConDecl n [] | (n, _) <- values] - [(c, []) | c <- ["Prelude.Show", "Prelude.Eq"]] - -- instance Data.Default.Class.Default Foo where - -- def = FirstEnumValue - , InstDecl noLoc Nothing [] [] "Data.Default.Class.Default" [dataType] - [ InsDecl $ FunBind [match "def" [] defaultCon] - ] - -- instance Data.ProtoLens.FieldDefault Foo where - -- fieldDefault = FirstEnumValue - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.FieldDefault" [dataType] - [ InsDecl $ FunBind [match "fieldDefault" [] defaultCon] - ] - -- instance MessageEnum Foo where - -- maybeToEnum 1 = Just Foo1 - -- maybeToEnum 2 = Just Foo2 - -- ... - -- maybeToEnum _ = Nothing - -- showEnum Foo1 = "Foo1" - -- showEnum Foo2 = "Foo2" - -- ... - -- readEnum "Foo1" = Just Foo1 - -- readEnum "Foo2" = Just Foo2 - -- ... - -- readEnum _ = Nothing - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.MessageEnum" [dataType] - [ InsDecl $ FunBind $ - [ match "maybeToEnum" [pLitInt k] $ "Prelude.Just" @@ Con (UnQual n) - | (n, k) <- values - ] - ++ - [ match "maybeToEnum" [PWildCard] "Prelude.Nothing" - ] - ++ - [ match "showEnum" [PVar n] $ Lit $ Syntax.String $ T.unpack ev - | (n, ev) <- names - ] - ++ - [ match "readEnum" - [PLit Signless . Syntax.String $ T.unpack ev] - $ "Prelude.Just" @@ Con (UnQual n) - | (n, ev) <- names - ] - ++ - [ match "readEnum" [PWildCard] "Prelude.Nothing" - ] - ] - -- instance Enum Foo where - -- toEnum k = maybe (error ("Foo.toEnum: unknown argument for enum Foo: " - -- ++ show k)) - -- id (maybeToEnum k) - -- fromEnum Foo1 = 1 - -- fromEnum Foo2 = 2 - -- .. - -- succ FooN = error "Foo.succ: bad argument FooN." - -- succ Foo1 = Foo2 - -- succ Foo2 = Foo3 - -- .. - -- pred Foo1 = error "Foo.succ: bad argument Foo1." - -- pred Foo2 = Foo1 - -- pred Foo3 = Foo2 - -- .. - -- enumFrom = messageEnumFrom - -- enumFromTo = messageEnumFromTo - -- enumFromThen = messageEnumFromThen - -- enumFromThenTo = messageEnumFromThenTo - , InstDecl noLoc Nothing [] [] "Prelude.Enum" [dataType] - [ InsDecl $ FunBind - [ match "toEnum" ["k__"] - $ "Prelude.maybe" @@ errorMessageExpr @@ "Prelude.id" - @@ ("Data.ProtoLens.maybeToEnum" @@ "k__") - ] - , InsDecl $ FunBind - [ match "fromEnum" [PApp (UnQual c) []] $ litInt k - | (c, k) <- values - ] - , succDecl "succ" maxBoundName succPairs - , succDecl "pred" minBoundName $ map swap succPairs - , alias "enumFrom" "Data.ProtoLens.Message.Enum.messageEnumFrom" - , alias "enumFromTo" "Data.ProtoLens.Message.Enum.messageEnumFromTo" - , alias "enumFromThen" "Data.ProtoLens.Message.Enum.messageEnumFromThen" - , alias "enumFromThenTo" - "Data.ProtoLens.Message.Enum.messageEnumFromThenTo" - ] - -- instance Bounded Foo where - -- minBound = Foo1 - -- maxBound = FooN - , InstDecl noLoc Nothing [] [] "Prelude.Bounded" [dataType] - [ InsDecl $ FunBind - [ match "minBound" [] $ Con $ UnQual minBoundName - , match "maxBound" [] $ Con $ UnQual maxBoundName - ] - ] - ] - where - dataType = TyCon $ UnQual dataName - EnumInfo - { enumName = dataName - , enumValueNames = valueNames - , enumDescriptor = ed - } = info - namesAndValues = zip valueNames (ed ^. value) - names = map (second (^. name)) namesAndValues - values = List.sortBy (comparing snd) $ - map (second (fromIntegral . (^. number))) namesAndValues - minBoundName = fst $ head values - maxBoundName = fst $ last values - - succPairs = zip ctorNames $ tail ctorNames - where ctorNames = map fst values - succDecl funName boundName thePairs = InsDecl $ FunBind $ - match funName [PApp (UnQual boundName) []] ( - "Prelude.error" @@ Lit (Syntax.String $ concat - [ show dataName, ".", show funName, ": bad argument " - , show boundName, ". This value would be out of bounds." - ])) - : - [ match funName [PApp (UnQual from) []] $ Con $ UnQual to - | (from, to) <- thePairs - ] - alias funName implName = InsDecl $ FunBind [match funName [] implName] - - defaultCon = Con $ UnQual $ fst $ head names - errorMessageExpr = "Prelude.error" - @@ ("Prelude.++" @@ Lit (Syntax.String errorMessage) - @@ ("Prelude.show" @@ "k__")) - errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name) - ++ ": " - -generateFieldDecls :: String -> [Decl] -generateFieldDecls fStr = - -- foo :: forall msg msg' . Field.HasField "foo" msg msg' - -- => Lens.Lens msg msg' (Field.Field "foo" msg) - -- (Field.Field "foo" msg') - -- foo = Field.field (Field.ProxySym :: Field.Proxy "foo") - [ TypeSig noLoc [f] - $ TyForall (Just ["msg", "msg'"]) - [ClassA "Data.ProtoLens.HasField" [fSym, "msg", "msg'"]] - $ "Lens.Family2.Lens" @@ "msg" @@ "msg'" - @@ ("Data.ProtoLens.Field" @@ fSym @@ "msg") - @@ ("Data.ProtoLens.Field" @@ fSym @@ "msg'") - , FunBind [match f [] - $ "Data.ProtoLens.field" - @@ ExpTypeSig noLoc "Data.ProtoLens.ProxySym" - ("Data.ProtoLens.ProxySym" @@ fSym) - ] - ] - where - f = Ident fStr - fSym = TyPromoted $ PromotedString fStr - ------------------------------------------- - --- | 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 - } - -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 _ = ... - } - --- | 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 - -- 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_OPTIONAL - | isDefaultingOptional syntaxType fd - -> LensInfo baseType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = baseType - , fieldAccessor = 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 - }] - -- data Foo = Foo { _Foo_bar :: [Bar] } - -- type instance Field "bar" Foo = [Bar] - | otherwise -> LensInfo listType - [FieldInstanceInfo - { fieldSymbol = baseName - , fieldTypeInstance = listType - , fieldAccessor = 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 - 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 - --- 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 - -hsFieldValueDefault :: Env QName -> FieldDescriptorProto -> Exp -hsFieldValueDefault env fd = case fd ^. type' of - FieldDescriptorProto'TYPE_MESSAGE -> "Data.Default.Class.def" - FieldDescriptorProto'TYPE_GROUP -> "Data.Default.Class.def" - FieldDescriptorProto'TYPE_ENUM - | T.null def -> "Data.Default.Class.def" - | Enum e <- definedFieldType fd env - , Just v <- List.lookup def [ (vd ^. name, n) - | (vd, n) <- zip (enumDescriptor e ^. value) - (enumValueNames e) - ] - -> Con v - | otherwise -> errorMessage "enum" - -- The rest of the cases are for scalar fields that have a fieldDefault - -- instance. - _ | T.null def -> "Data.ProtoLens.fieldDefault" - FieldDescriptorProto'TYPE_BOOL - | def == "true" -> "Prelude.True" - | def == "false" -> "Prelude.False" - | otherwise -> errorMessage "bool" - FieldDescriptorProto'TYPE_STRING - -> "Data.Text.pack" @@ Lit (String $ T.unpack def) - FieldDescriptorProto'TYPE_BYTES - -> "Data.ByteString.pack" - @@ List ((mkByte . fromEnum) <$> T.unpack def) - where mkByte c - | c > 0 && c < 255 = litInt $ fromIntegral c - | otherwise = errorMessage "bytes" - FieldDescriptorProto'TYPE_FLOAT -> defaultFrac $ T.unpack def - FieldDescriptorProto'TYPE_DOUBLE -> defaultFrac $ T.unpack def - -- Otherwise, assume it's an integral field: - _ -> defaultInt $ T.unpack def - where - def = fd ^. defaultValue - errorMessage fieldType - = error $ "Bad default value " ++ show (T.unpack def) - ++ " in default value for " ++ fieldType ++ " field " - ++ unpack (fd ^. name) - -- float/double fields can use nan, inf and -inf as default values. - -- The Prelude doesn't provide names for them, so we implement - -- them as division by zero. - defaultFrac "nan" = "Prelude./" @@ litFrac 0 @@ litFrac 0 - defaultFrac "inf" = "Prelude./" @@ litFrac 1 @@ litFrac 0 - defaultFrac "-inf" = "Prelude./" @@ litFrac (negate 1) @@ litFrac 0 - defaultFrac s = case reads s of - [(x, "")] -> litFrac $ toRational (x :: Double) - _ -> errorMessage "fractional" - defaultInt s = case reads s of - [(x, "")] -> litInt x - _ -> errorMessage "integral" - --- | A lens to access an internal field. --- --- lens _Foo_bar (\x__ y__ -> x__ { _Foo_bar = y__ }) -rawFieldAccessor :: QName -> Exp -rawFieldAccessor f = "Lens.Family2.Unchecked.lens" @@ getter @@ setter - where - getter = Var f - setter = Lambda noLoc ["x__", "y__"] - $ RecUpdate "x__" [FieldUpdate f "y__"] - -descriptorExpr :: SyntaxType -> Env QName -> MessageInfo Name -> Exp -descriptorExpr syntaxType env m - -- let foo__field_descriptor = ... - -- ... - -- in Message.MessageDescriptor - -- (Data.Map.fromList [(Tag 1, foo__field_descriptor),...]) - -- (Data.Map.fromList [("foo", foo__field_descriptor),...]) - -- - -- (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 (BDecls $ map fieldDescriptorVarBind $ messageFields m) - $ "Data.ProtoLens.MessageDescriptor" - @@ ("Data.Map.fromList" @@ List fieldsByTag) - @@ ("Data.Map.fromList" @@ List fieldsByTextFormatName) - where - fieldsByTag = - [Tuple Boxed - [ t, fieldDescriptorVar f ] - | f <- messageFields m - , let t = "Data.ProtoLens.Tag" - @@ litInt (fromIntegral - $ fieldDescriptor f ^. number) - ] - fieldsByTextFormatName = - [Tuple Boxed - [ t, fieldDescriptorVar f ] - | f <- messageFields m - , let t = Lit $ Syntax.String $ T.unpack - $ textFormatFieldName env (fieldDescriptor f) - ] - fieldDescriptorVar = fromString . fieldDescriptorName - fieldDescriptorName f - = fromString $ overloadedField f ++ "__field_descriptor" - fieldDescriptorVarBind f - = FunBind - [match (fromString $ fieldDescriptorName f) [] - $ fieldDescriptorExpr syntaxType env f - ] - --- | 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, --- not the name of the field in the descriptor (e.g. "Foo", not "foo"). -textFormatFieldName :: Env QName -> FieldDescriptorProto -> T.Text -textFormatFieldName env descr = case descr ^. type' of - FieldDescriptorProto'TYPE_GROUP - | Message msg <- definedFieldType descr env - -> messageDescriptor msg ^. name - | otherwise -> error $ "expected TYPE_GROUP for type name" - ++ T.unpack (descr ^. typeName) - _ -> descr ^. name - -fieldDescriptorExpr :: SyntaxType -> Env QName -> FieldInfo - -> Exp -fieldDescriptorExpr syntaxType env f - = "Data.ProtoLens.FieldDescriptor" - -- Record the original .proto name for text format - @@ Lit (Syntax.String (T.unpack $ fd ^. name)) - -- Force the type signature since it can't be inferred for Map entry - -- types. - @@ ExpTypeSig noLoc (fieldTypeDescriptorExpr (fd ^. type')) - ("Data.ProtoLens.FieldTypeDescriptor" - @@ hsFieldType env fd) - @@ fieldAccessorExpr syntaxType env f - where - fd = fieldDescriptor f - -fieldAccessorExpr :: SyntaxType -> Env QName -> FieldInfo -> Exp --- (PlainField Required foo), (OptionalField foo), etc... -fieldAccessorExpr syntaxType env f = accessorCon @@ Var (UnQual 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 - -> "Data.ProtoLens.MapField" - @@ fromString (overloadedField k) - @@ fromString (overloadedField v) - | otherwise -> "Data.ProtoLens.RepeatedField" - @@ if fd ^. options.packed - then "Data.ProtoLens.Packed" - else "Data.ProtoLens.Unpacked" - hsFieldName - = Ident $ case fd ^. label of - FieldDescriptorProto'LABEL_OPTIONAL - | not (isDefaultingOptional syntaxType fd) - -> "maybe'" ++ overloadedField f - _ -> overloadedField f - -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. - && isNothing (f ^. maybe'oneofIndex) - -fieldTypeDescriptorExpr :: FieldDescriptorProto'Type -> Exp -fieldTypeDescriptorExpr = - (\n -> fromString $ "Data.ProtoLens." ++ n ++ "Field") . \t -> case t of - FieldDescriptorProto'TYPE_DOUBLE -> "Double" - FieldDescriptorProto'TYPE_FLOAT -> "Float" - FieldDescriptorProto'TYPE_INT64 -> "Int64" - FieldDescriptorProto'TYPE_UINT64 -> "UInt64" - FieldDescriptorProto'TYPE_INT32 -> "Int32" - FieldDescriptorProto'TYPE_FIXED64 -> "Fixed64" - FieldDescriptorProto'TYPE_FIXED32 -> "Fixed32" - FieldDescriptorProto'TYPE_BOOL -> "Bool" - FieldDescriptorProto'TYPE_STRING -> "String" - FieldDescriptorProto'TYPE_GROUP -> "Group" - FieldDescriptorProto'TYPE_MESSAGE -> "Message" - FieldDescriptorProto'TYPE_BYTES -> "Bytes" - FieldDescriptorProto'TYPE_UINT32 -> "UInt32" - FieldDescriptorProto'TYPE_ENUM -> "Enum" - FieldDescriptorProto'TYPE_SFIXED32 -> "SFixed32" - FieldDescriptorProto'TYPE_SFIXED64 -> "SFixed64" - FieldDescriptorProto'TYPE_SINT32 -> "SInt32" - FieldDescriptorProto'TYPE_SINT64 -> "SInt64" diff --git a/src/protoc-gen-haskell.hs b/src/protoc-gen-haskell.hs --- a/src/protoc-gen-haskell.hs +++ b/src/protoc-gen-haskell.hs @@ -18,7 +18,7 @@ import Data.Text (Text, pack) import Data.ProtoLens (decodeMessage, def, encodeMessage) import Language.Haskell.Exts.Pretty (prettyPrint) -import Language.Haskell.Exts.Syntax (ModuleName(..)) +import Language.Haskell.Exts.Syntax (ModuleName(..), Name(..), QName(..)) import Lens.Family2 import Bootstrap.Proto.Google.Protobuf.Compiler.Plugin ( CodeGeneratorRequest @@ -37,8 +37,9 @@ import System.FilePath (dropExtension, replaceExtension, splitDirectories) -import Definitions -import Generate +import Data.ProtoLens.Compiler.Definitions +import Data.ProtoLens.Compiler.Generate +import Data.ProtoLens.Compiler.Plugin main = do contents <- B.getContents @@ -61,82 +62,27 @@ | (outputName, outputContent) <- outputFiles ] --- | The filename of an input .proto file. -type ProtoFileName = Text generateFiles :: Text -> (FileDescriptorProto -> Text) -> [FileDescriptorProto] -> [ProtoFileName] -> [(Text, Text)] generateFiles modulePrefix header files toGenerate = let - filesByName = Map.fromList [(f ^. name, f) | f <- files] - moduleNames = fmap (moduleName modulePrefix) filesByName - -- The definitions in each input proto file, indexed by filename. - definitions = fmap collectDefinitions filesByName - -- The exports from each .proto file (including any "public import" - -- dependencies), as they appear to other modules that are importing them; - -- i.e., qualified by module name. - exports = transitiveExports files - localExports = Map.intersectionWith qualifyEnv moduleNames definitions - exportedEnvs = fmap (\es -> unions [localExports ! e | e <- es]) exports + filesByName = analyzeProtoFiles modulePrefix files -- The contents of the generated Haskell file for a given .proto file. - buildFile fileName = let - f = filesByName ! fileName - deps = f ^. dependency - env = unions $ fmap (exportedEnvs !) deps + buildFile file = let + deps = descriptor file ^. dependency imports = Set.toAscList $ Set.fromList - [ moduleNames ! exportName + [ haskellModule (filesByName ! exportName) | dep <- deps - , exportName <- exports ! dep + , exportName <- exports (filesByName ! dep) ] - in generateModule (moduleNames ! fileName) imports (fileSyntaxType f) - (definitions ! fileName) env - in [ ( outputFilePath (moduleNames ! f) - , header fd <> pack (prettyPrint $ buildFile f) + in generateModule (haskellModule file) imports + (fileSyntaxType (descriptor file)) + (definitions file) + (collectEnvFromDeps deps filesByName) + in [ ( outputFilePath . (\(ModuleName n) -> n) . haskellModule $ file + , header (descriptor file) <> pack (prettyPrint $ buildFile file) ) - | f <- toGenerate - , let fd = filesByName ! f + | fileName <- toGenerate + , let file = filesByName ! fileName ] - --- | Given a list of .proto files (topologically sorted), determine which --- files' definitions are exported by which files. --- --- Files only export their own definitions, along with the definitions exported --- by any "import public" declarations. -transitiveExports :: [FileDescriptorProto] -> Map ProtoFileName [ProtoFileName] --- Accumulate the transitive dependencies by folding over the files in --- topological order. -transitiveExports = foldl' setExportsFromFile Map.empty - where - setExportsFromFile :: Map ProtoFileName [ProtoFileName] - -> FileDescriptorProto - -> Map ProtoFileName [ProtoFileName] - setExportsFromFile prevExports fd - = flip (Map.insert n) prevExports $ - n : concat [ prevExports ! ((fd ^. dependency) !! fromIntegral i) - -- Note that publicDependency is a list of indices into - -- the dependency list. - | i <- fd ^. publicDependency - ] - where n = fd ^. name - -outputFilePath :: ModuleName -> Text -outputFilePath (ModuleName n) = T.replace "." "/" (T.pack n) <> ".hs" - --- | Get the module name of a .proto file. -moduleName :: Text -> FileDescriptorProto -> ModuleName -moduleName modulePrefix fd = ModuleName $ fixModuleName rawModuleName - where - path = fd ^. name - prefix - | T.null modulePrefix = "Proto" - | otherwise = modulePrefix - fixModuleName "" = "" - -- Characters allowed in Bazel filenames but not in module names: - fixModuleName ('.':c:cs) = '.' : toUpper c : fixModuleName cs - fixModuleName ('_':c:cs) = toUpper c : fixModuleName cs - fixModuleName ('-':c:cs) = toUpper c : fixModuleName cs - fixModuleName (c:cs) = c : fixModuleName cs - rawModuleName = intercalate "." $ (T.unpack prefix :) - $ splitDirectories $ dropExtension - $ T.unpack path -