Skip to content

Commit 25bf880

Browse files
functorafunctora
committed
fix proto-lens-protoc
1 parent 0f0be9e commit 25bf880

File tree

4 files changed

+151
-16
lines changed

4 files changed

+151
-16
lines changed

‎pub/proto-lens/proto-lens-protoc/app/Data/ProtoLens/Compiler/Generate.hs‎

Lines changed: 51 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ import qualified SrcLoc
5757
#endif
5858
import Lens.Family2 ((^.))
5959
import Text.Printf (printf)
60+
import qualified Data.ProtoLens.Compiler.Parameter as Parameter
6061

6162
import Proto.Google.Protobuf.Descriptor
6263
( EnumValueDescriptorProto
@@ -90,14 +91,16 @@ generateModule :: ModuleNameStr
9091
-> Env OccNameStr -- ^ Definitions in this file
9192
-> Env RdrNameStr -- ^ Definitions in the imported modules
9293
-> [ServiceInfo]
94+
-> Parameter.Options
9395
-> [CommentedModule]
9496
generateModule modName fdesc imports publicImports definitions importedEnv services
97+
opts
9598
= [ CommentedModule pragmas
9699
(module' (Just modName)
97100
(Just $ serviceExports
98101
++ concatMap generateExports (Map.elems definitions)
99102
++ map moduleContents publicImports)
100-
(mainImports ++ sharedImports
103+
(mainImports ++ parameterImports ++ sharedImports
101104
++ map importQualified (imports List.\\ publicImports)
102105
++ map import' publicImports)
103106
[])
@@ -113,13 +116,17 @@ generateModule modName fdesc imports publicImports definitions importedEnv servi
113116
where
114117
fieldModName = fromString $ moduleNameString (unModuleNameStr modName) ++ "_Fields"
115118
pragmas =
116-
[ languagePragma $ List.intercalate ", " $ map fromString
119+
[ languagePragma
120+
. List.intercalate ", "
121+
. map fromString
122+
. List.nub $
117123
["ScopedTypeVariables", "DataKinds", "TypeFamilies",
118124
"UndecidableInstances", "GeneralizedNewtypeDeriving",
119125
"MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances",
120126
"PatternSynonyms", "MagicHash", "NoImplicitPrelude",
121127
"DataKinds", "BangPatterns", "TypeApplications",
122128
"OverloadedStrings", "DerivingStrategies"]
129+
++ Parameter.pragmas' opts
123130
-- Allow unused imports in case we don't import anything from
124131
-- Data.Text, Data.Int, etc.
125132
, optionsGhcPragma "-Wno-unused-imports"
@@ -131,6 +138,7 @@ generateModule modName fdesc imports publicImports definitions importedEnv servi
131138
]
132139
mainImports = map (reexported . importQualified)
133140
[ "Control.DeepSeq", "Data.ProtoLens.Prism" ]
141+
parameterImports = map importQualified $ Parameter.imports' opts
134142
sharedImports = map (reexported . importQualified)
135143
[ "Prelude", "Data.Int", "Data.Monoid", "Data.Word"
136144
, "Data.ProtoLens"
@@ -151,9 +159,9 @@ generateModule modName fdesc imports publicImports definitions importedEnv servi
151159
]
152160
env = Map.union (unqualifyEnv definitions) importedEnv
153161
generateDecls (protoName, Message m)
154-
= generateMessageDecls fieldModName env (stripDotPrefix protoName) m
162+
= generateMessageDecls fieldModName env (stripDotPrefix protoName) m opts
155163
++ map uncommented (concatMap (generatePrisms env) (messageOneofFields m))
156-
generateDecls (_, Enum e) = map uncommented $ generateEnumDecls e
164+
generateDecls (_, Enum e) = map uncommented $ generateEnumDecls e opts
157165
generateExports (Message m) = generateMessageExports m
158166
++ concatMap generatePrismExports (messageOneofFields m)
159167
generateExports (Enum e) = generateEnumExports e
@@ -305,8 +313,8 @@ generateServiceDecls env si =
305313
Enum _ -> error "Service must have a message type"
306314

307315

308-
generateMessageDecls :: ModuleNameStr -> Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> [CommentedDecl]
309-
generateMessageDecls fieldModName env protoName info =
316+
generateMessageDecls :: ModuleNameStr -> Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> Parameter.Options -> [CommentedDecl]
317+
generateMessageDecls fieldModName env protoName info opts =
310318
-- data Bar = Bar {
311319
-- foo :: Baz
312320
-- }
@@ -318,7 +326,10 @@ generateMessageDecls fieldModName env protoName info =
318326
]
319327
++ [(messageUnknownFields info, strict $ field $ var "Data.ProtoLens.FieldSet")]
320328
]
321-
[derivingStock [var "Prelude.Eq", var "Prelude.Ord"]]
329+
[derivingStock $
330+
[var "Prelude.Eq", var "Prelude.Ord"]
331+
++ Parameter.stockInstances' opts
332+
]
322333
-- instance Show Bar where
323334
-- showsPrec __x __s = showChar '{' (showString (showMessageShort __x) (showChar '}' s))
324335
, uncommented $
@@ -329,6 +340,7 @@ generateMessageDecls fieldModName env protoName info =
329340
@@ (var "Data.ProtoLens.showMessageShort" @@ var "__x")
330341
@@ (var "Prelude.showChar" @@ char '}' @@ var "__s"))]
331342
] ++
343+
(uncommented <$> Parameter.newDefaultInstances dataType opts) ++
332344
-- oneof field data type declarations
333345
-- proto: message Foo {
334346
-- oneof bar {
@@ -344,9 +356,21 @@ generateMessageDecls fieldModName env protoName info =
344356
, let f = caseField c
345357
, let consName = caseConstructorName c
346358
]
347-
[derivingStock [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]]
359+
[derivingStock $
360+
[var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]
361+
++ Parameter.stockInstances' opts
362+
]
348363
| oneofInfo <- messageOneofFields info
349364
] ++
365+
(
366+
messageOneofFields info >>=
367+
(\oneofInfo ->
368+
uncommented
369+
<$> Parameter.newDefaultInstances
370+
(var . unqual $ oneofTypeName oneofInfo)
371+
opts
372+
)
373+
) ++
350374
-- instance HasField Foo "foo" Bar
351375
-- fieldOf _ = ...
352376
-- Note: for optional fields, this generates an instance both for "foo" and
@@ -458,18 +482,28 @@ generateEnumExports e = [thingAll n, thingWith n aliases] ++ proto3NewType
458482
generateServiceExports :: ServiceInfo -> IE'
459483
generateServiceExports si = thingAll $ unqual $ fromString $ T.unpack $ serviceName si
460484

461-
generateEnumDecls :: EnumInfo OccNameStr -> [HsDecl']
462-
generateEnumDecls info =
485+
generateEnumDecls :: EnumInfo OccNameStr -> Parameter.Options -> [HsDecl']
486+
generateEnumDecls info opts =
463487
-- Proto3-only:
464488
-- newtype FooEnum'UnrecognizedValue = FooEnum'UnrecognizedValue Data.Int.Int32
465489
-- deriving (Prelude.Eq, Prelude.Ord, Prelude.Show, Prelude.Read)
466490
[ newtype' (unrecognizedValueName u) []
467491
(prefixCon (unrecognizedValueName u) [field $ var "Data.Int.Int32"])
468-
[derivingStock [var "Prelude.Eq", var "Prelude.Ord", var "Prelude.Show"]]
492+
[derivingStock $
493+
[var "Prelude.Eq", var "Prelude.Ord", var "Prelude.Show"]
494+
++ Parameter.stockInstances' opts
495+
]
469496
| Just u <- [unrecognized]
470497
]
471498
++
472-
499+
(
500+
case unrecognized of
501+
Nothing -> []
502+
Just u ->
503+
Parameter.newDefaultInstances
504+
(var . unqual $ unrecognizedValueName u)
505+
opts
506+
) ++
473507
-- data FooEnum
474508
-- = Enum1
475509
-- | Enum2
@@ -482,7 +516,10 @@ generateEnumDecls info =
482516
| Just u <- [unrecognized]
483517
]
484518
)
485-
[derivingStock [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]]
519+
[derivingStock $
520+
[var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]
521+
++ Parameter.stockInstances' opts
522+
]
486523

487524
-- instance Data.ProtoLens.MessageEnum FooEnum where
488525
-- maybeToEnum 0 = Prelude.Just Enum1
@@ -608,7 +645,7 @@ generateEnumDecls info =
608645
[ funBind "rnf" $ match [bvar "x__"]
609646
$ var "Prelude.seq" @@ var "x__" @@ var "()" ]
610647
] ++
611-
648+
Parameter.newDefaultInstances dataType opts ++
612649
-- pattern Enum2a :: FooEnum
613650
-- pattern Enum2a = Enum2
614651
concat

‎pub/proto-lens/proto-lens-protoc/app/Data/ProtoLens/Compiler/Parameter.hs‎

Lines changed: 94 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,94 @@
1+
-- Copyright 2016 Google Inc. All Rights Reserved.
2+
--
3+
-- Use of this source code is governed by a BSD-style
4+
-- license that can be found in the LICENSE file or at
5+
-- https://developers.google.com/open-source/licenses/bsd
6+
--
7+
{-# LANGUAGE CPP #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
10+
-- | Protoc plugin command-line argument aka "parameter" from
11+
-- plugin.proto document. Example which enables stock deriving
12+
-- of 'GHC.Generics.Generic' class for all generated haskell types:
13+
-- --haskell_opt='Opt{ imports = [], pragmas = ["DeriveGeneric"], stockInstances = ["GHC.Generics.Generic"], defaultInstances = [] }'
14+
module Data.ProtoLens.Compiler.Parameter
15+
( Options (..),
16+
newOptions,
17+
newDefaultInstances,
18+
)
19+
where
20+
21+
#if MIN_VERSION_ghc(9,0,0)
22+
import GHC.Unit.Module.Name (mkModuleName)
23+
#else
24+
import Module (mkModuleName)
25+
#endif
26+
27+
import qualified Data.List as List
28+
import qualified Data.String as String
29+
import qualified Data.Text as T
30+
import qualified GHC.SourceGen as GHC
31+
import qualified Text.Read as T
32+
33+
data Options = Options
34+
{ imports' :: [GHC.ModuleNameStr],
35+
pragmas' :: [String],
36+
stockInstances' :: [GHC.HsType'],
37+
deafultInstances' :: [GHC.HsType']
38+
}
39+
40+
data Opt = Opt
41+
{ imports :: [String],
42+
pragmas :: [String],
43+
stockInstances :: [T.Text],
44+
defaultInstances :: [T.Text]
45+
}
46+
deriving (Read)
47+
48+
newDefaultInstances ::
49+
GHC.HsType' ->
50+
Options ->
51+
[GHC.HsDecl']
52+
newDefaultInstances dataType opts =
53+
( \class' ->
54+
GHC.instance'
55+
(class' GHC.@@ dataType)
56+
[]
57+
)
58+
<$> deafultInstances' opts
59+
60+
newOptions :: T.Text -> Options
61+
newOptions "" = Options [] [] [] []
62+
newOptions rawTxt =
63+
case T.readMaybe rawStr of
64+
Nothing ->
65+
error $ "Can not read options from " ++ show rawStr
66+
Just opts ->
67+
let stock = List.nub $ stockInstances opts
68+
alone = List.nub $ defaultInstances opts
69+
in Options
70+
{ imports' =
71+
List.nub $
72+
(GHC.ModuleNameStr . mkModuleName <$> imports opts)
73+
++ (newModuleName <$> (List.nub $ stock ++ alone)),
74+
pragmas' = List.nub $ pragmas opts,
75+
stockInstances' = newTy <$> stock,
76+
deafultInstances' = newTy <$> alone
77+
}
78+
where
79+
rawStr = T.unpack rawTxt
80+
newTy = GHC.var . String.fromString . T.unpack
81+
82+
newModuleName :: T.Text -> GHC.ModuleNameStr
83+
newModuleName rawTxt =
84+
case reverse $ T.splitOn sep rawTxt of
85+
[] ->
86+
error $ "Can not create GHC.ModuleNameStr from " ++ show rawTxt
87+
(_ : xs) ->
88+
GHC.ModuleNameStr
89+
. mkModuleName
90+
. T.unpack
91+
. T.intercalate sep
92+
$ reverse xs
93+
where
94+
sep = "."

‎pub/proto-lens/proto-lens-protoc/app/protoc-gen-haskell.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ import System.IO as IO
3838
import Data.ProtoLens.Compiler.Generate.Commented (getModuleName)
3939
import Data.ProtoLens.Compiler.Generate
4040
import Data.ProtoLens.Compiler.Plugin
41+
import qualified Data.ProtoLens.Compiler.Parameter as Parameter
4142

4243
#if MIN_VERSION_ghc(9,0,0)
4344
import GHC.Driver.Session (DynFlags, getDynFlags)
@@ -64,6 +65,7 @@ makeResponse dflags prog request = let
6465
outputFiles = generateFiles dflags header
6566
(request ^. #protoFile)
6667
(request ^. #fileToGenerate)
68+
(Parameter.newOptions $ request ^. #parameter)
6769
header :: FileDescriptorProto -> Text
6870
header f = "{- This file was auto-generated from "
6971
<> (f ^. #name)
@@ -88,8 +90,8 @@ makeResponse dflags prog request = let
8890

8991
generateFiles :: DynFlags -> (FileDescriptorProto -> Text)
9092
-> [FileDescriptorProto] -> [ProtoFileName]
91-
-> Either Text [(Text, Text)]
92-
generateFiles dflags header files toGenerate = do
93+
-> Parameter.Options -> Either Text [(Text, Text)]
94+
generateFiles dflags header files toGenerate opts = do
9395
filesByName <- analyzeProtoFiles files
9496

9597
let modulesToBuild f =
@@ -98,6 +100,7 @@ generateFiles dflags header files toGenerate = do
98100
(definitions f)
99101
(collectEnvFromDeps deps filesByName)
100102
(services f)
103+
opts
101104
where
102105
deps = descriptor f ^. #dependency
103106
imports = Set.toAscList $ Set.fromList

‎pub/proto-lens/proto-lens-protoc/proto-lens-protoc.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ executable proto-lens-protoc
4848
Data.ProtoLens.Compiler.Generate.Commented
4949
Data.ProtoLens.Compiler.Generate.Encoding
5050
Data.ProtoLens.Compiler.Generate.Field
51+
Data.ProtoLens.Compiler.Parameter
5152
Data.ProtoLens.Compiler.Plugin
5253
Proto.Google.Protobuf.Compiler.Plugin
5354
Proto.Google.Protobuf.Compiler.Plugin_Fields

0 commit comments

Comments
 (0)