WIP: use prettyprinter rather than ghc-source-gen

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

@@ -83,7 +83,7 @@ import Proto.Google.Protobuf.Descriptor
     , MethodDescriptorProto
     , ServiceDescriptorProto
     )
-import GHC.SourceGen
+import Prettyprinter.GHC
     ( OccNameStr
     , RdrNameStr
     , ModuleNameStr

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

@@ -10,6 +10,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 module Data.ProtoLens.Compiler.Generate(
     generateModule,
     ) where
@@ -29,32 +30,8 @@ import Data.String (fromString)
 import Data.Text (unpack)
 import qualified Data.Text as T
 import Data.Tuple (swap)
-import GHC.SourceGen
-#if MIN_VERSION_ghc(8,10,0)
-import GHC.Hs (ideclName, ideclAs)
-#else
-import HsSyn (ideclName, ideclAs)
-#endif
-#if MIN_VERSION_ghc(9,10,0)
-import GHC.Parser.Annotation (noAnn)
-#elif MIN_VERSION_ghc(9,2,0)
-import GHC.Parser.Annotation (EpAnn(EpAnnNotUsed), SrcSpanAnn'(SrcSpanAnn))
-#endif
-#if MIN_VERSION_ghc(9,0,0)
-#if MIN_VERSION_ghc(9,6,0)
-import Language.Haskell.Syntax.Module.Name (moduleNameString, mkModuleName)
-#else
-import GHC.Unit.Module.Name (moduleNameString, mkModuleName)
-#endif
-import qualified GHC.Utils.Outputable as Outputable
-import GHC.Types.SrcLoc (unLoc)
-import qualified GHC.Types.SrcLoc as SrcLoc
-#else
-import Module (moduleNameString, mkModuleName)
-import qualified Outputable
-import SrcLoc (unLoc)
-import qualified SrcLoc
-#endif
+import Prettyprinter.GHC
+import Data.Text.Prettyprint.Doc (vsep, line, (<+>), pretty, Doc, vcat, nest)
 import Lens.Family2 ((^.))
 import Text.Printf (printf)
 
@@ -92,26 +69,26 @@ generateModule :: ModuleNameStr
                -> [ServiceInfo]
                -> [CommentedModule]
 generateModule modName fdesc imports publicImports definitions importedEnv services
-    = [ CommentedModule pragmas
+    = [ CommentedModule pragmas modName
             (module' (Just modName)
                 (Just $ serviceExports
                         ++ concatMap generateExports (Map.elems definitions)
-                        ++ map moduleContents publicImports)
+                        ++ map (pretty . import') publicImports)
                 (mainImports ++ sharedImports
                     ++ map importQualified (imports List.\\ publicImports)
                     ++ map import' publicImports)
                 [])
           $ concatMap generateDecls (Map.toList definitions)
          ++ map uncommented (concatMap (generateServiceDecls env) services)
          ++ map uncommented packedFileDescriptorProto
-      , CommentedModule pragmas
+      , CommentedModule pragmas fieldModName
             (module' (Just fieldModName) Nothing
                 (sharedImports ++ map importQualified imports) [])
           $ map uncommented
           $ concatMap generateFieldDecls allLensNames
       ]
   where
-    fieldModName = fromString $ moduleNameString (unModuleNameStr modName) ++ "_Fields"
+    fieldModName = fromString $ moduleNameString modName ++ "_Fields"
     pragmas =
           [ languagePragma $ List.intercalate ", " $ map fromString
               ["ScopedTypeVariables", "DataKinds", "TypeFamilies",
@@ -212,31 +189,24 @@ importQualified = qualified' . import'
 type ModifyImports = ImportDecl' -> ImportDecl'
 
 reexported :: ModifyImports
-reexported imp = imp { ideclName = noLoc m', ideclAs = Just m }
+reexported imp = imp { ideclName = m', ideclAs = Just m }
   where
-#if MIN_VERSION_ghc(9,10,0)
-    noLoc = SrcLoc.L noAnn
-#elif MIN_VERSION_ghc(9,2,0)
-    noLoc = SrcLoc.L (SrcSpanAnn EpAnnNotUsed SrcLoc.noSrcSpan)
-#else
-    noLoc = SrcLoc.noLoc
-#endif
-    m' = mkModuleName $ "Data.ProtoLens.Runtime." ++ moduleNameString (unLoc m)
+    m' = mkModuleName $ "Data.ProtoLens.Runtime." ++ moduleNameString m
     m = ideclName imp
 
-messageComment :: ModuleNameStr -> OccNameStr -> [RecordField] -> Outputable.SDoc
+messageComment :: ModuleNameStr -> OccNameStr -> [RecordField] -> Doc ()
 messageComment fieldModName n fields =
-    Outputable.vcat
-        $ [Outputable.text "Fields :", ""]
+    vcat
+        $ ["Fields :", ""]
             ++ map item (concatMap recordFieldLenses fields)
   where
-    item :: LensInstance -> Outputable.SDoc
-    item l = Outputable.text (printf "    * '%s.%s' @:: "
+    item :: LensInstance -> Doc ()
+    item l = pretty @String (printf "    * '%s.%s' @:: "
                  (moduleNameStrToString fieldModName)
                  (occNameStrToString $ nameFromSymbol $ lensSymbol l))
-             Outputable.<>
-                 Outputable.ppr (var "Lens'" @@ t @@ lensFieldType l)
-             Outputable.<> Outputable.char '@'
+             <>
+                 (var "Lens'" @@ t @@ lensFieldType l)
+             <> "@"
     t = var (unqual n)
 
 generateMessageExports :: MessageInfo OccNameStr -> [IE']
@@ -354,7 +324,7 @@ generateMessageDecls fieldModName env protoName info =
     [ uncommented $ instance'
         (var "Data.ProtoLens.Field.HasField" @@ dataType @@ sym @@ t)
             [funBind "fieldOf" $ match [wildP] $
-                var "Prelude.."
+                var "(Prelude..)"
                     @@ rawFieldAccessor (unqual $ recordFieldName li)
                     @@ lensExp i]
     | li <- allFields
@@ -533,16 +503,16 @@ generateEnumDecls info =
                 $ var "Prelude.show" @@ var "k"
             | Just u <- [unrecognized]
             ]
-        , funBind "readEnum" $ matchGRHSs [bvar "k"] $ guardedRhs $
-              [ guard (var "Prelude.==" @@ var "k" @@ string pn)
+        , "readEnum" <+> "k" <> nest 2 (line <> vsep
+              ([ guard (var "Prelude.==" @@ var "k" @@ string pn)
                     $ var "Prelude.Just" @@ var (unqual n)
               | v <- enumValues info
               , let n = enumValueName v
               , let pn = T.unpack $ enumValueDescriptor v ^. #name
               ]
               ++ [guard (var "Prelude.otherwise") $ var "Prelude.>>="
                                       @@ (var "Text.Read.readMaybe" @@ var "k")
-                                      @@ var "Data.ProtoLens.maybeToEnum"]
+                                      @@ var "Data.ProtoLens.maybeToEnum"]))
         ]
 
       -- instance Bounded Foo where
@@ -630,7 +600,7 @@ generateEnumDecls info =
                       ++ ": "
 
     errorMessageExpr = var "Prelude.error"
-                          @@ (var "Prelude.++" @@ string errorMessage
+                          @@ (var "(Prelude.++)" @@ string errorMessage
                               @@ (var "Prelude.show" @@ var "k__"))
 
     dataType = var $ unqual dataName
@@ -654,7 +624,7 @@ generateEnumDecls info =
 
     constructorNumbers = map (second (fromIntegral . (^. #number))) constructors
 
-    succDecl :: OccNameStr -> OccNameStr -> [(OccNameStr, OccNameStr)] -> RawInstDecl
+    succDecl :: OccNameStr -> OccNameStr -> [(OccNameStr, OccNameStr)] -> Doc' -- RawInstDecl
     succDecl funName boundName thePairs = funBinds funName $
         match [conP_ (unqual boundName)]
             (var "Prelude.error" @@ string (concat
@@ -948,7 +918,7 @@ oneofFieldAccessor o
     setter = lambda [wildP, bvar "y__"]
                 $ var "Prelude.fmap" @@ var (unqual consName) @@ var "y__"
 
-messageInstance :: Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> [RawInstDecl]
+messageInstance :: Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> [Doc']
 messageInstance env protoName m =
     [ funBind "messageName" $ match [wildP] $
           var "Data.Text.pack" @@ string (T.unpack protoName)

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

@@ -1,61 +1,42 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 -- | Enables pretty-printing Haddock comments along with top-level declarations.
 module Data.ProtoLens.Compiler.Generate.Commented where
 
-import GHC.SourceGen
-#if MIN_VERSION_ghc(9,0,0)
-import GHC.Utils.Outputable (Outputable(..), SDoc, (<+>), ($+$), vcat, empty, text)
-#else
-import Outputable (Outputable(..), SDoc, (<+>), ($+$), vcat, empty, text)
-#endif
-#if MIN_VERSION_ghc(8,10,0)
-import GHC.Hs (hsmodName)
-#else
-import HsSyn (hsmodName)
-#endif
-import GHC (ModuleName)
-#if MIN_VERSION_ghc(9,0,0)
-import GHC.Types.SrcLoc (unLoc)
-#else
-import SrcLoc (unLoc)
-#endif
+import Prettyprinter.GHC
+import Data.Text.Prettyprint.Doc (Pretty(..), Doc, hardline, (<+>), unAnnotate, vcat)
 
 -- | A declaration, along with an optional comment.
 --
 -- GHC's pretty-printer omits the contents of comments, so we can't use it here.
-data CommentedDecl = CommentedDecl (Maybe SDoc) HsDecl'
+data CommentedDecl = CommentedDecl (Maybe (Doc ())) HsDecl'
 
-instance Outputable CommentedDecl where
-    ppr (CommentedDecl maybeComment decl) =
-        maybe empty pprComment maybeComment
-        $+$ ppr decl
-      where
-        pprComment c = text "{- |" <+> c <+> text "-}"
+instance Pretty CommentedDecl where
+    pretty (CommentedDecl Nothing decl) = unAnnotate decl
+    pretty (CommentedDecl (Just comment) decl) = unAnnotate $
+        "{- |" <+> comment <+> "-}"  <> hardline <> decl
 
 uncommented :: HsDecl' -> CommentedDecl
 uncommented = CommentedDecl Nothing
 
-commented :: SDoc -> HsDecl' -> CommentedDecl
+commented :: Doc () -> HsDecl' -> CommentedDecl
 commented = CommentedDecl . Just
 
 data CommentedModule = CommentedModule
     { pragmaComments :: [String]
+    , moduleName :: ModuleNameStr
     , moduleHeader :: HsModule'
     , commentedDecls :: [CommentedDecl]
     }
 
-getModuleName :: CommentedModule -> ModuleName
-getModuleName m =
-    maybe
-        (error "getModuleName: No explicit name")
-        unLoc
-        (hsmodName $ moduleHeader m)
-
-instance Outputable CommentedModule where
-    ppr m =
-        vcat (map text $ pragmaComments m)
-        $+$ ppr (moduleHeader m)
-        $+$ vcat (map ppr $ commentedDecls m)
+getModuleName :: CommentedModule -> ModuleNameStr
+getModuleName = moduleName
+
+instance Pretty CommentedModule where
+    pretty m = unAnnotate $
+        vcat (map pretty $ pragmaComments m)
+        <> hardline <> moduleHeader m
+        <> hardline <> vcat (map pretty $ commentedDecls m)
 
 languagePragma, optionsGhcPragma :: String -> String
 languagePragma s = "{-# LANGUAGE " ++ s ++ "#-}"

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

@@ -18,7 +18,7 @@ import Data.Semigroup ((<>))
 #endif
 import qualified Data.Text as Text
 import Lens.Family2 ((^.))
-import GHC.SourceGen
+import Prettyprinter.GHC
 
 import Data.ProtoLens.Compiler.Definitions
 import Data.ProtoLens.Compiler.Generate.Field
@@ -43,7 +43,7 @@ generatedParser env m =
     let' [typeSig loop loopSig
          , funBind loop $ match (bvar <$> loopArgs names) loopExpr
          ]
-        $ var "Data.ProtoLens.Encoding.Bytes.<?>"
+        $ var "(Data.ProtoLens.Encoding.Bytes.<?>)"
            @@ do' (startStmts ++ [stmt $ continue startExp])
            @@ string msgName
   where
@@ -256,7 +256,7 @@ checkMissingFields s =
     let' [valBind missing allMissingFields]
     $ if' (var "Prelude.null" @@ var missing) (var "Prelude.return" @@ unit)
     $ var "Prelude.fail"
-        @@ (var "Prelude.++"
+        @@ (var "(Prelude.++)"
                 @@ string "Missing required fields: "
                 @@ (var "Prelude.show" @@ (var missing @::@ listTy (var "Prelude.String"))))
   where
@@ -381,7 +381,7 @@ unknownFieldCase info loop x = match [wire] $ do' $
             [conP "Data.ProtoLens.Encoding.Wire.TaggedValue"
                 [utag, conP_ "Data.ProtoLens.Encoding.Wire.EndGroup"]]
             $ var "Prelude.fail" @@
-                (var "Prelude.++"
+                (var "(Prelude.++)"
                     @@ string "Mismatched group-end tag number "
                     @@ (var "Prelude.show" @@ utag))
         , match [wildP] $ var "Prelude.return" @@ unit
@@ -415,7 +415,7 @@ overField f = over' (fieldOf f)
 over' :: HsExpr' -> HsExpr' -> HsExpr'
 over' f g = var "Lens.Family2.over"
                 @@ f
-                @@ lambda [strictP t] (g @@ t)
+                @@ lambda ["(!t)"] (g @@ t)
   where
     t = bvar "t"
 
@@ -484,7 +484,7 @@ buildUnknownMessageSet x
 foldMapExp :: [HsExpr'] -> HsExpr'
 foldMapExp [] = mempty'
 foldMapExp [x] = x
-foldMapExp (x:xs) = var "Data.Monoid.<>" @@ x @@ foldMapExp xs
+foldMapExp (x:xs) = var "(Data.Monoid.<>)" @@ x @@ foldMapExp xs
 
 -- | An expression of type @Builder@ which encodes the field value
 -- @x@ based on the kind and type of the field @f@.
@@ -497,7 +497,7 @@ buildPlainField x f = case plainFieldKind f of
                                 $ buildTaggedField info v'
                             ]
     OptionalValueField -> let' [valBind v fieldValue]
-                          $ if' (var "Prelude.==" @@ v' @@ var "Data.ProtoLens.fieldDefault")
+                          $ if' (var "(Prelude.==)" @@ v' @@ var "Data.ProtoLens.fieldDefault")
                                 mempty'
                                 (buildTaggedField info v')
     MapField entryInfo
@@ -571,7 +571,7 @@ buildPackedField :: FieldInfo -> HsExpr' -> HsExpr'
 -}
 buildPackedField f x = let' [valBind p x]
     $ if' (var "Data.Vector.Generic.null" @@ var p) mempty'
-    $ var "Data.Monoid.<>"
+    $ var "(Data.Monoid.<>)"
         @@ (putVarInt' @@ int (packedFieldTag f))
         @@ (buildFieldType lengthy
                 @@ (var "Data.ProtoLens.Encoding.Bytes.runBuilder"
@@ -628,7 +628,7 @@ unsafeLiftIO' = var "Data.ProtoLens.Encoding.Parser.Unsafe.unsafeLiftIO"
 
 -- | Returns an expression of type @Parser a@ for the given field.
 parseField :: FieldInfo -> HsExpr'
-parseField f = var "Data.ProtoLens.Encoding.Bytes.<?>"
+parseField f = var "(Data.ProtoLens.Encoding.Bytes.<?>)"
                     @@ parseFieldType (fieldInfoEncoding f)
                     @@ string n
   where

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

@@ -24,7 +24,7 @@ import Proto.Google.Protobuf.Descriptor (FieldDescriptorProto'Type(..))
 
 import Data.ProtoLens.Compiler.Definitions
 
-import GHC.SourceGen
+import Prettyprinter.GHC
 
 hsFieldType :: Env RdrNameStr -> FieldInfo -> HsType'
 hsFieldType env f = let
@@ -115,7 +115,7 @@ lengthy = FieldEncoding
     buildLengthy =
         -- Bind x since it may be a nontrivial expression:
         lambda [bs]
-            $ var "Data.Monoid.<>"
+            $ var "(Data.Monoid.<>)"
                 @@ (putVarInt'
                         @@ (fromIntegral'
                                 @@ (var "Data.ByteString.length" @@ bs)))
@@ -143,7 +143,7 @@ groupEnd = FieldEncoding
 -- Wrap a field encoding  with Haskell functions that should always succeed.
 bijectField :: HsExpr' -> HsExpr' -> FieldEncoding -> FieldEncoding
 bijectField buildF parseF f = FieldEncoding
-    { buildFieldType = var "Prelude.." @@ buildFieldType f @@ buildF
+    { buildFieldType = var "(Prelude..)" @@ buildFieldType f @@ buildF
     , parseFieldType = var "Prelude.fmap" @@ parseF @@ parseFieldType f
     , wireType = wireType f
     }
@@ -206,7 +206,7 @@ stringField =
     }
   where
     len = bvar "len"
-    buildString = var "Prelude.." @@ buildFieldType lengthy
+    buildString = var "(Prelude..)" @@ buildFieldType lengthy
                                   @@ var "Data.Text.Encoding.encodeUtf8"
     parseString = do'
         [ len <-- getVarInt'
@@ -217,7 +217,7 @@ stringField =
 -- | A protobuf message type.
 message :: FieldEncoding
 message = lengthy
-        { buildFieldType = var "Prelude.." @@
+        { buildFieldType = var "(Prelude..)" @@
             buildFieldType lengthy @@
             var "Data.ProtoLens.encodeMessage"
         , parseFieldType = isolatedLengthy (var "Data.ProtoLens.parseMessage")

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

@@ -27,7 +27,7 @@ import Proto.Google.Protobuf.Descriptor (FileDescriptorProto)
 import Data.ProtoLens.Compiler.Definitions
 import Data.ProtoLens.Compiler.ModuleName
 
-import GHC.SourceGen (ModuleNameStr, OccNameStr, RdrNameStr)
+import Prettyprinter.GHC (ModuleNameStr, OccNameStr, RdrNameStr)
 
 -- | The filename of an input .proto file.
 type ProtoFileName = Text