proto-lens-protoc 0.1.0.1 → 0.1.0.2

raw patch · 10 files changed

+1213/−1061 lines, 10 filesdep ~proto-lensnew-uploaderPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: proto-lens

API changes (from Hackage documentation)

Files

• proto-lens-protoc.cabal +35/−19
• src/Combinators.hs +0/−98
• src/Data/ProtoLens/Compiler/Combinators.hs +98/−0
• src/Data/ProtoLens/Compiler/Definitions.hs +261/−0
• src/Data/ProtoLens/Compiler/Generate.hs +672/−0
• src/Data/ProtoLens/Compiler/Plugin.hs +128/−0
• src/Data/ProtoLens/Setup.hs +2/−0
• src/Definitions.hs +0/−225
• src/Generate.hs +0/−648
• src/protoc-gen-haskell.hs +17/−71

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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+

@@ -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

@@ -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

@@ -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"

@@ -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-