Using protoc cli parameter to specify additional class derivations

.gitignore

@@ -5,3 +5,5 @@ dist/
 # For "cabal sandbox"
 .cabal-sandbox
 cabal.sandbox.config
+dist-newstyle/
+result

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

@@ -47,6 +47,7 @@ import SrcLoc (unLoc, noLoc)
 import Lens.Family2 ((^.))
 import Text.Printf (printf)
 
+import qualified Data.ProtoLens.Compiler.Parameter as Parameter
 import Proto.Google.Protobuf.Descriptor
     ( EnumValueDescriptorProto
     , FileDescriptorProto
@@ -79,14 +80,15 @@ generateModule :: ModuleNameStr
                -> Env OccNameStr      -- ^ Definitions in this file
                -> Env RdrNameStr     -- ^ Definitions in the imported modules
                -> [ServiceInfo]
+               -> Parameter.Options
                -> [CommentedModule]
-generateModule modName fdesc imports publicImports definitions importedEnv services
+generateModule modName fdesc imports publicImports definitions importedEnv services opts
     = [ CommentedModule pragmas
             (module' (Just modName)
                 (Just $ serviceExports
                         ++ concatMap generateExports (Map.elems definitions)
                         ++ map moduleContents publicImports)
-                (mainImports ++ sharedImports
+                (mainImports ++ parameterImports ++ sharedImports
                     ++ map importQualified (imports List.\\ publicImports)
                     ++ map import' publicImports)
                 [])
@@ -102,13 +104,14 @@ generateModule modName fdesc imports publicImports definitions importedEnv servi
   where
     fieldModName = fromString $ moduleNameString (unModuleNameStr modName) ++ "_Fields"
     pragmas =
-          [ languagePragma $ List.intercalate ", " $ map fromString
+          [ languagePragma . List.intercalate ", " . map fromString $ List.nub
               ["ScopedTypeVariables", "DataKinds", "TypeFamilies",
                "UndecidableInstances", "GeneralizedNewtypeDeriving",
                "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances",
                "PatternSynonyms", "MagicHash", "NoImplicitPrelude",
                "DataKinds", "BangPatterns", "TypeApplications",
                "OverloadedStrings", "DerivingStrategies"]
+              ++ Parameter.pragmas' opts
               -- Allow unused imports in case we don't import anything from
               -- Data.Text, Data.Int, etc.
           , optionsGhcPragma "-Wno-unused-imports"
@@ -120,6 +123,7 @@ generateModule modName fdesc imports publicImports definitions importedEnv servi
           ]
     mainImports = map (reexported . importQualified)
                     [ "Control.DeepSeq", "Data.ProtoLens.Prism" ]
+    parameterImports = map importQualified $ Parameter.imports' opts
     sharedImports = map (reexported . importQualified)
               [ "Prelude", "Data.Int", "Data.Monoid", "Data.Word"
               , "Data.ProtoLens"
@@ -140,9 +144,9 @@ generateModule modName fdesc imports publicImports definitions importedEnv servi
               ]
     env = Map.union (unqualifyEnv definitions) importedEnv
     generateDecls (protoName, Message m)
-        = generateMessageDecls fieldModName env (stripDotPrefix protoName) m
+        = generateMessageDecls fieldModName env (stripDotPrefix protoName) m opts
        ++ map uncommented (concatMap (generatePrisms env) (messageOneofFields m))
-    generateDecls (_, Enum e) = map uncommented $ generateEnumDecls e
+    generateDecls (_, Enum e) = map uncommented $ generateEnumDecls e opts
     generateExports (Message m) = generateMessageExports m
                                ++ concatMap generatePrismExports (messageOneofFields m)
     generateExports (Enum e) = generateEnumExports e
@@ -287,8 +291,10 @@ generateServiceDecls env si =
                        Enum _ -> error "Service must have a message type"
 
 
-generateMessageDecls :: ModuleNameStr -> Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> [CommentedDecl]
-generateMessageDecls fieldModName env protoName info =
+generateMessageDecls :: ModuleNameStr -> Env RdrNameStr -> T.Text
+                        -> MessageInfo OccNameStr -> Parameter.Options
+                        -> [CommentedDecl]
+generateMessageDecls fieldModName env protoName info opts =
     -- data Bar = Bar {
     --    foo :: Baz
     -- }
@@ -300,7 +306,10 @@ generateMessageDecls fieldModName env protoName info =
                 ]
                 ++ [(messageUnknownFields info, strict $ field $ var "Data.ProtoLens.FieldSet")]
             ]
-            [derivingStock [var "Prelude.Eq", var "Prelude.Ord"]]
+            [derivingStock $
+               [var "Prelude.Eq", var "Prelude.Ord"]
+               ++ Parameter.stockInstances' opts
+            ]
     -- instance Show Bar where
     --   showsPrec __x __s = showChar '{' (showString (showMessageShort __x) (showChar '}' s))
     , uncommented $
@@ -311,6 +320,8 @@ generateMessageDecls fieldModName env protoName info =
                             @@ (var "Data.ProtoLens.showMessageShort" @@ var "__x")
                         @@ (var "Prelude.showChar" @@ char '}' @@ var "__s"))]
     ] ++
+    -- instance CustomClass Bar
+    (uncommented <$> Parameter.newDefaultInstances dataType opts) ++
     -- oneof field data type declarations
     -- proto: message Foo {
     --          oneof bar {
@@ -326,9 +337,22 @@ generateMessageDecls fieldModName env protoName info =
       , let f = caseField c
       , let consName = caseConstructorName c
       ]
-      [derivingStock [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]]
+      [derivingStock $
+         [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]
+         ++ Parameter.stockInstances' opts
+      ]
     | oneofInfo <- messageOneofFields info
     ] ++
+    -- instance CustomClass Foo'Bar
+    (
+      messageOneofFields info >>=
+        (\oneofInfo ->
+            uncommented
+              <$> Parameter.newDefaultInstances
+                    (var . unqual $ oneofTypeName oneofInfo)
+                    opts
+        )
+    ) ++
     -- instance HasField Foo "foo" Bar
     --   fieldOf _ = ...
     -- Note: for optional fields, this generates an instance both for "foo" and
@@ -441,18 +465,29 @@ generateEnumExports e = [thingAll n, thingWith n aliases] ++ proto3NewType
 generateServiceExports :: ServiceInfo -> IE'
 generateServiceExports si = thingAll $ unqual $ fromString $ T.unpack $ serviceName si
 
-generateEnumDecls :: EnumInfo OccNameStr -> [HsDecl']
-generateEnumDecls info =
+generateEnumDecls :: EnumInfo OccNameStr -> Parameter.Options -> [HsDecl']
+generateEnumDecls info opts =
     -- Proto3-only:
     -- newtype FooEnum'UnrecognizedValue = FooEnum'UnrecognizedValue Data.Int.Int32
     --   deriving (Prelude.Eq, Prelude.Ord, Prelude.Show, Prelude.Read)
     [ newtype' (unrecognizedValueName u) []
        (prefixCon (unrecognizedValueName u) [field $ var "Data.Int.Int32"])
-       [derivingStock [var "Prelude.Eq", var "Prelude.Ord", var "Prelude.Show"]]
+       [derivingStock $
+          [var "Prelude.Eq", var "Prelude.Ord", var "Prelude.Show"]
+          ++ Parameter.stockInstances' opts
+       ]
     | Just u <- [unrecognized]
     ]
     ++
-
+    -- instance CustomClass FooEnum'UnrecognizedValue
+    (
+      case unrecognized of
+        Nothing -> []
+        Just u ->
+          Parameter.newDefaultInstances
+            (var . unqual $ unrecognizedValueName u)
+            opts
+    ) ++
     -- data FooEnum
     --     = Enum1
     --     | Enum2
@@ -465,7 +500,10 @@ generateEnumDecls info =
            | Just u <- [unrecognized]
            ]
         )
-        [derivingStock [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]]
+        [derivingStock $
+           [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]
+           ++ Parameter.stockInstances' opts
+        ]
 
     -- instance Data.ProtoLens.MessageEnum FooEnum where
     --       maybeToEnum 0 = Prelude.Just Enum1
@@ -591,7 +629,8 @@ generateEnumDecls info =
         [ funBind "rnf" $ match [bvar "x__"]
             $ var "Prelude.seq" @@ var "x__" @@ var "()" ]
     ] ++
-
+    -- instance CustomClass FooEnum
+    Parameter.newDefaultInstances dataType opts ++
     -- pattern Enum2a :: FooEnum
     -- pattern Enum2a = Enum2
     concat

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

@@ -0,0 +1,94 @@
+-- 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
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Protoc plugin command-line argument aka "parameter" from
+-- plugin.proto document. Example which enables stock deriving
+-- of 'GHC.Generics.Generic' class for all generated haskell types:
+-- --haskell_opt='Opt{ imports = [], pragmas = ["DeriveGeneric"], stockInstances = ["GHC.Generics.Generic"], defaultInstances = [] }'
+module Data.ProtoLens.Compiler.Parameter
+  ( Options (..),
+    newOptions,
+    newDefaultInstances,
+  )
+where
+
+#if MIN_VERSION_ghc(9,0,0)
+import GHC.Unit.Module.Name (mkModuleName)
+#else
+import Module (mkModuleName)
+#endif
+
+import qualified Data.List as List
+import qualified Data.String as String
+import qualified Data.Text as T
+import qualified GHC.SourceGen as GHC
+import qualified Text.Read as T
+
+data Options = Options
+  { imports' :: [GHC.ModuleNameStr],
+    pragmas' :: [String],
+    stockInstances' :: [GHC.HsType'],
+    deafultInstances' :: [GHC.HsType']
+  }
+
+data Opt = Opt
+  { imports :: [String],
+    pragmas :: [String],
+    stockInstances :: [T.Text],
+    defaultInstances :: [T.Text]
+  }
+  deriving (Read)
+
+newDefaultInstances ::
+  GHC.HsType' ->
+  Options ->
+  [GHC.HsDecl']
+newDefaultInstances dataType opts =
+  ( \class' ->
+      GHC.instance'
+        (class' GHC.@@ dataType)
+        []
+  )
+    <$> deafultInstances' opts
+
+newOptions :: T.Text -> Options
+newOptions "" = Options [] [] [] []
+newOptions rawTxt =
+  case T.readMaybe rawStr of
+    Nothing ->
+      error $ "Can not read options from " ++ show rawStr
+    Just opts ->
+      let stock = List.nub $ stockInstances opts
+          alone = List.nub $ defaultInstances opts
+       in Options
+            { imports' =
+                List.nub $
+                  (GHC.ModuleNameStr . mkModuleName <$> imports opts)
+                    ++ (newModuleName <$> (List.nub $ stock ++ alone)),
+              pragmas' = List.nub $ pragmas opts,
+              stockInstances' = newTy <$> stock,
+              deafultInstances' = newTy <$> alone
+            }
+  where
+    rawStr = T.unpack rawTxt
+    newTy = GHC.var . String.fromString . T.unpack
+
+newModuleName :: T.Text -> GHC.ModuleNameStr
+newModuleName rawTxt =
+  case reverse $ T.splitOn sep rawTxt of
+    [] ->
+      error $ "Can not create GHC.ModuleNameStr from " ++ show rawTxt
+    (_ : xs) ->
+      GHC.ModuleNameStr
+        . mkModuleName
+        . T.unpack
+        . T.intercalate sep
+        $ reverse xs
+  where
+    sep = "."

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

@@ -39,6 +39,7 @@ import System.IO as IO
 import Data.ProtoLens.Compiler.Generate.Commented (CommentedModule, getModuleName)
 import Data.ProtoLens.Compiler.Generate
 import Data.ProtoLens.Compiler.Plugin
+import qualified Data.ProtoLens.Compiler.Parameter as Parameter
 
 #if MIN_VERSION_ghc(9,0,0)
 import GHC.Driver.Session (DynFlags, getDynFlags)
@@ -65,6 +66,7 @@ makeResponse dflags prog request = let
     outputFiles = generateFiles dflags header
                       (request ^. #protoFile)
                       (request ^. #fileToGenerate)
+                      (Parameter.newOptions $ request ^. #parameter)
     header :: FileDescriptorProto -> Text
     header f = "{- This file was auto-generated from "
                 <> (f ^. #name)
@@ -81,8 +83,9 @@ makeResponse dflags prog request = let
 
 
 generateFiles :: DynFlags -> (FileDescriptorProto -> Text)
-              -> [FileDescriptorProto] -> [ProtoFileName] -> [(Text, Text)]
-generateFiles dflags header files toGenerate = let
+              -> [FileDescriptorProto] -> [ProtoFileName]
+              -> Parameter.Options -> [(Text, Text)]
+generateFiles dflags header files toGenerate opts = let
   filesByName = analyzeProtoFiles files
   -- The contents of the generated Haskell file for a given .proto file.
   modulesToBuild :: ProtoFile -> [CommentedModule]
@@ -95,6 +98,7 @@ generateFiles dflags header files toGenerate = let
              (definitions f)
              (collectEnvFromDeps deps filesByName)
              (services f)
+             opts
   in [ ( moduleFilePath $ pack $ showPpr dflags (getModuleName modul)
        , header (descriptor f) <> pack (showPpr dflags modul)
        )

proto-lens-protoc/package.yaml

@@ -4,7 +4,7 @@ synopsis: Protocol buffer compiler for the proto-lens library.
 description: >
   Turn protocol buffer files (.proto) into Haskell files (.hs) which
   can be used with the proto-lens package.
- 
+
   The library component of this package contains compiler code (namely
   Data.ProtoLens.Compiler.*) is not guaranteed to have stable APIs.'
 category: Data

proto-lens-protoc/proto-lens-protoc.cabal

@@ -46,6 +46,7 @@ executable proto-lens-protoc
       Data.ProtoLens.Compiler.Generate.Commented
       Data.ProtoLens.Compiler.Generate.Encoding
       Data.ProtoLens.Compiler.Generate.Field
+      Data.ProtoLens.Compiler.Parameter
       Data.ProtoLens.Compiler.Plugin
       Proto.Google.Protobuf.Compiler.Plugin
       Proto.Google.Protobuf.Compiler.Plugin_Fields