From 9a9d953942ef1f4c2726010a72a76229a342c6dc Mon Sep 17 00:00:00 2001
From: Hiroki Tokunaga <tokusan441@gmail.com>
Date: Sun, 9 Jun 2024 23:12:32 +0900
Subject: [PATCH] Implement `Splice` (#911)

---
 hindent.cabal                         |  1 +
 src/HIndent/Ast/Declaration/Splice.hs |  4 +-
 src/HIndent/Ast/Expression/Splice.hs  | 58 +++++++++++++++++++++++++++
 src/HIndent/Pretty.hs                 | 55 +++----------------------
 src/HIndent/Pretty.hs-boot            |  6 +--
 5 files changed, 69 insertions(+), 55 deletions(-)
 create mode 100644 src/HIndent/Ast/Expression/Splice.hs

diff --git a/hindent.cabal b/hindent.cabal
index 602a649fb..ba80384ee 100644
--- a/hindent.cabal
+++ b/hindent.cabal
@@ -88,6 +88,7 @@ library
       HIndent.Ast.Declaration.Warning
       HIndent.Ast.Declaration.Warning.Collection
       HIndent.Ast.Declaration.Warning.Kind
+      HIndent.Ast.Expression.Splice
       HIndent.Ast.FileHeaderPragma
       HIndent.Ast.FileHeaderPragma.Collection
       HIndent.Ast.Import
diff --git a/src/HIndent/Ast/Declaration/Splice.hs b/src/HIndent/Ast/Declaration/Splice.hs
index e29c6ed65..988bf132e 100644
--- a/src/HIndent/Ast/Declaration/Splice.hs
+++ b/src/HIndent/Ast/Declaration/Splice.hs
@@ -3,6 +3,7 @@ module HIndent.Ast.Declaration.Splice
   , mkSpliceDeclaration
   ) where
 
+import HIndent.Ast.Expression.Splice
 import HIndent.Ast.NodeComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
@@ -15,7 +16,8 @@ instance CommentExtraction SpliceDeclaration where
   nodeComments SpliceDeclaration {} = NodeComments [] [] []
 
 instance Pretty SpliceDeclaration where
-  pretty' (SpliceDeclaration (GHC.SpliceDecl _ sp _)) = pretty sp
+  pretty' (SpliceDeclaration (GHC.SpliceDecl _ sp _)) =
+    pretty $ fmap mkSplice sp
 
 mkSpliceDeclaration :: GHC.SpliceDecl GHC.GhcPs -> SpliceDeclaration
 mkSpliceDeclaration = SpliceDeclaration
diff --git a/src/HIndent/Ast/Expression/Splice.hs b/src/HIndent/Ast/Expression/Splice.hs
new file mode 100644
index 000000000..a36a4266b
--- /dev/null
+++ b/src/HIndent/Ast/Expression/Splice.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP #-}
+
+module HIndent.Ast.Expression.Splice
+  ( Splice
+  , mkSplice
+  ) where
+
+import qualified GHC.Data.FastString as GHC
+import qualified GHC.Types.Name.Reader as GHC
+import HIndent.Ast.NodeComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)
+import qualified GHC.Types.SrcLoc as GHC
+#endif
+data Splice
+  = Typed (GHC.LHsExpr GHC.GhcPs)
+  | UntypedDollar (GHC.LHsExpr GHC.GhcPs)
+  | UntypedBare (GHC.LHsExpr GHC.GhcPs)
+  | QuasiQuote GHC.RdrName GHC.FastString
+
+instance CommentExtraction Splice where
+  nodeComments Typed {} = NodeComments [] [] []
+  nodeComments UntypedDollar {} = NodeComments [] [] []
+  nodeComments UntypedBare {} = NodeComments [] [] []
+  nodeComments QuasiQuote {} = NodeComments [] [] []
+
+instance Pretty Splice where
+  pretty' (Typed x) = string "$$" >> pretty x
+  pretty' (UntypedDollar x) = string "$" >> pretty x
+  pretty' (UntypedBare x) = pretty x
+  pretty' (QuasiQuote l r) =
+    brackets $ do
+      pretty l
+      wrapWithBars
+        $ indentedWithFixedLevel 0
+        $ sequence_
+        $ printers [] ""
+        $ GHC.unpackFS r
+    where
+      printers ps s [] = reverse (string (reverse s) : ps)
+      printers ps s ('\n':xs) =
+        printers (newline : string (reverse s) : ps) "" xs
+      printers ps s (x:xs) = printers ps (x : s) xs
+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)
+mkSplice :: GHC.HsUntypedSplice GHC.GhcPs -> Splice
+mkSplice (GHC.HsUntypedSpliceExpr _ x) = UntypedDollar x
+mkSplice (GHC.HsQuasiQuote _ l (GHC.L _ r)) = QuasiQuote l r
+#else
+mkSplice :: GHC.HsSplice GHC.GhcPs -> Splice
+mkSplice (GHC.HsTypedSplice _ _ _ body) = Typed body
+mkSplice (GHC.HsUntypedSplice _ GHC.DollarSplice _ body) = UntypedDollar body
+mkSplice (GHC.HsUntypedSplice _ GHC.BareSplice _ body) = UntypedBare body
+mkSplice (GHC.HsQuasiQuote _ _ l _ r) = QuasiQuote l r
+mkSplice GHC.HsSpliced {} = error "This AST node should never appear."
+#endif
diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs
index 1c1d6a936..1d6f5d0ed 100644
--- a/src/HIndent/Pretty.hs
+++ b/src/HIndent/Pretty.hs
@@ -41,6 +41,7 @@ import HIndent.Ast.Declaration.Data.Body
 import HIndent.Ast.Declaration.Data.Record.Field
 import HIndent.Ast.Declaration.Family.Type
 import HIndent.Ast.Declaration.Signature
+import HIndent.Ast.Expression.Splice
 import HIndent.Ast.NodeComments
 import HIndent.Ast.Operator.Infix
 import HIndent.Ast.Operator.Prefix
@@ -409,7 +410,7 @@ prettyHsExpr (GHC.ExprWithTySig _ e sig) = do
   pretty $ GHC.hswc_body sig
 prettyHsExpr (GHC.ArithSeq _ _ x) = pretty x
 #if !MIN_VERSION_ghc_lib_parser(9,6,1)
-prettyHsExpr (GHC.HsSpliceE _ x) = pretty x
+prettyHsExpr (GHC.HsSpliceE _ x) = pretty $ mkSplice x
 #endif
 prettyHsExpr (GHC.HsProc _ pat x@(GHC.L _ (GHC.HsCmdTop _ (GHC.L _ (GHC.HsCmdDo _ xs))))) = do
   spaced [string "proc", pretty pat, string "-> do"]
@@ -444,7 +445,7 @@ prettyHsExpr GHC.HsTcBracketOut {} = notGeneratedByParser
 #endif
 #if MIN_VERSION_ghc_lib_parser(9,6,1)
 prettyHsExpr (GHC.HsTypedSplice _ x) = string "$$" >> pretty x
-prettyHsExpr (GHC.HsUntypedSplice _ x) = pretty x
+prettyHsExpr (GHC.HsUntypedSplice _ x) = pretty $ mkSplice x
 #endif
 instance Pretty LambdaCase where
   pretty' (LambdaCase matches caseOrCases) = do
@@ -752,7 +753,7 @@ prettyHsType (GHC.HsIParamTy _ x ty) =
   spaced [string "?" >> pretty x, string "::", pretty ty]
 prettyHsType GHC.HsStarTy {} = string "*"
 prettyHsType (GHC.HsKindSig _ t k) = spaced [pretty t, string "::", pretty k]
-prettyHsType (GHC.HsSpliceTy _ sp) = pretty sp
+prettyHsType (GHC.HsSpliceTy _ sp) = pretty $ mkSplice sp
 prettyHsType GHC.HsDocTy {} = docNode
 prettyHsType (GHC.HsBangTy _ pack x) = pretty pack >> pretty x
 prettyHsType (GHC.HsRecTy _ xs) =
@@ -921,29 +922,7 @@ instance Pretty GHC.EpaCommentTok where
         -- contains indent spaces for all lines except the first one.
         indentedWithFixedLevel 0 $ lined $ fmap string xs
   pretty' _ = docNode
-#if !MIN_VERSION_ghc_lib_parser(9,6,1)
-instance Pretty (GHC.HsSplice GHC.GhcPs) where
-  pretty' (GHC.HsTypedSplice _ _ _ body) = string "$$" >> pretty body
-  pretty' (GHC.HsUntypedSplice _ GHC.DollarSplice _ body) =
-    string "$" >> pretty body
-  pretty' (GHC.HsUntypedSplice _ GHC.BareSplice _ body) = pretty body
-  -- The body of a quasi-quote must not be changed by a formatter.
-  -- Changing it will modify the actual behavior of the code.
-  pretty' (GHC.HsQuasiQuote _ _ l _ r) =
-    brackets $ do
-      pretty l
-      wrapWithBars
-        $ indentedWithFixedLevel 0
-        $ sequence_
-        $ printers [] ""
-        $ GHC.unpackFS r
-    where
-      printers ps s [] = reverse (string (reverse s) : ps)
-      printers ps s ('\n':xs) =
-        printers (newline : string (reverse s) : ps) "" xs
-      printers ps s (x:xs) = printers ps (x : s) xs
-  pretty' GHC.HsSpliced {} = notGeneratedByParser
-#endif
+
 instance Pretty (GHC.Pat GHC.GhcPs) where
   pretty' = prettyPat
 
@@ -991,7 +970,7 @@ prettyPat GHC.ConPat {..} =
       unlessSpecialOp (GHC.unLoc pat_con) space
       pretty b
 prettyPat (GHC.ViewPat _ l r) = spaced [pretty l, string "->", pretty r]
-prettyPat (GHC.SplicePat _ x) = pretty x
+prettyPat (GHC.SplicePat _ x) = pretty $ mkSplice x
 prettyPat (GHC.LitPat _ x) = pretty x
 prettyPat (GHC.NPat _ x _ _) = pretty x
 prettyPat (GHC.NPlusKPat _ n k _ _ _) = pretty n >> string "+" >> pretty k
@@ -1639,28 +1618,6 @@ instance Pretty GHC.SrcStrictness where
 #if MIN_VERSION_ghc_lib_parser(9,6,1)
 instance Pretty GHC.FieldLabelString where
   pretty' = output
-
-instance Pretty (GHC.HsUntypedSplice GHC.GhcPs) where
-  pretty' (GHC.HsUntypedSpliceExpr _ x) = string "$" >> pretty x
-  -- The body of a quasi-quote must not be changed by a formatter.
-  -- Changing it will modify the actual behavior of the code.
-  --
-  -- TODO: Remove duplicated code
-  pretty' (GHC.HsQuasiQuote _ l r) =
-    brackets $ do
-      pretty l
-      printCommentsAnd
-        r
-        (wrapWithBars
-           . indentedWithFixedLevel 0
-           . sequence_
-           . printers [] ""
-           . GHC.unpackFS)
-    where
-      printers ps s [] = reverse (string (reverse s) : ps)
-      printers ps s ('\n':xs) =
-        printers (newline : string (reverse s) : ps) "" xs
-      printers ps s (x:xs) = printers ps (x : s) xs
 #endif
 -- | Marks an AST node as never appearing in an AST.
 --
diff --git a/src/HIndent/Pretty.hs-boot b/src/HIndent/Pretty.hs-boot
index 1466bdee9..ea1ebd9a8 100644
--- a/src/HIndent/Pretty.hs-boot
+++ b/src/HIndent/Pretty.hs-boot
@@ -92,11 +92,7 @@ instance Pretty
               (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))
 #endif
 instance Pretty (GHC.HsExpr GHC.GhcPs)
-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)
-instance Pretty (GHC.HsUntypedSplice GHC.GhcPs)
-#else
-instance Pretty (GHC.HsSplice GHC.GhcPs)
-#endif
+
 instance Pretty (GHC.FieldOcc GHC.GhcPs)
 
 instance Pretty GHC.OccName