Implement Bracket (#912)

hindent.cabal

@@ -88,6 +88,7 @@ library
       HIndent.Ast.Declaration.Warning
       HIndent.Ast.Declaration.Warning.Collection
       HIndent.Ast.Declaration.Warning.Kind
+      HIndent.Ast.Expression.Bracket
       HIndent.Ast.Expression.Splice
       HIndent.Ast.FileHeaderPragma
       HIndent.Ast.FileHeaderPragma.Collection

src/HIndent/Ast/Expression/Bracket.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE CPP #-}
+
+module HIndent.Ast.Expression.Bracket
+  ( Bracket
+  , mkBracket
+  ) where
+
+import HIndent.Ast.Declaration
+import HIndent.Ast.NodeComments
+import HIndent.Ast.WithComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data Bracket
+  = TypedExpression (GHC.LHsExpr GHC.GhcPs)
+  | UntypedExpression (GHC.LHsExpr GHC.GhcPs)
+  | Pattern (GHC.LPat GHC.GhcPs)
+  | Declaration [WithComments Declaration]
+  | Type (GHC.LHsType GHC.GhcPs)
+  | Variable Bool (GHC.LIdP GHC.GhcPs)
+
+instance CommentExtraction Bracket where
+  nodeComments TypedExpression {} = NodeComments [] [] []
+  nodeComments UntypedExpression {} = NodeComments [] [] []
+  nodeComments Pattern {} = NodeComments [] [] []
+  nodeComments Declaration {} = NodeComments [] [] []
+  nodeComments Type {} = NodeComments [] [] []
+  nodeComments Variable {} = NodeComments [] [] []
+
+instance Pretty Bracket where
+  pretty' (TypedExpression x) = typedBrackets $ pretty x
+  pretty' (UntypedExpression x) = brackets $ wrapWithBars $ pretty x
+  pretty' (Pattern x) = brackets $ string "p" >> wrapWithBars (pretty x)
+  pretty' (Declaration decls) =
+    brackets $ string "d| " |=> lined (fmap pretty decls) >> string " |"
+  pretty' (Type x) = brackets $ string "t" >> wrapWithBars (pretty x)
+  pretty' (Variable True var) = string "'" >> pretty var
+  pretty' (Variable False var) = string "''" >> pretty var
+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)
+mkBracket :: GHC.HsQuote GHC.GhcPs -> Bracket
+#else
+mkBracket :: GHC.HsBracket GHC.GhcPs -> Bracket
+#endif
+mkBracket (GHC.ExpBr _ x) = UntypedExpression x
+mkBracket (GHC.PatBr _ x) = Pattern x
+mkBracket (GHC.DecBrL _ x) =
+  Declaration $ fmap (fmap mkDeclaration . fromGenLocated) x
+mkBracket (GHC.TypBr _ x) = Type x
+mkBracket (GHC.VarBr _ b x) = Variable b x
+mkBracket (GHC.DecBrG {}) = error "This AST node should never appear."
+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)
+mkBracket (GHC.TExpBr _ x) = TypedExpression x
+#endif

src/HIndent/Pretty.hs

@@ -35,12 +35,12 @@ import qualified GHC.Types.Name as GHC
 import qualified GHC.Types.Name.Reader as GHC
 import qualified GHC.Types.SourceText as GHC
 import qualified GHC.Types.SrcLoc as GHC
-import HIndent.Ast.Declaration
 import HIndent.Ast.Declaration.Bind
 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.Bracket
 import HIndent.Ast.Expression.Splice
 import HIndent.Ast.NodeComments
 import HIndent.Ast.Operator.Infix
@@ -429,7 +429,7 @@ prettyHsExpr (GHC.HsPragE _ p x) = spaced [pretty p, pretty x]
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 prettyHsExpr GHC.HsRecSel {} = notGeneratedByParser
 prettyHsExpr (GHC.HsTypedBracket _ inner) = typedBrackets $ pretty inner
-prettyHsExpr (GHC.HsUntypedBracket _ inner) = pretty inner
+prettyHsExpr (GHC.HsUntypedBracket _ inner) = pretty $ mkBracket inner
 #else
 prettyHsExpr GHC.HsConLikeOut {} = notGeneratedByParser
 prettyHsExpr GHC.HsRecFld {} = notGeneratedByParser
@@ -439,7 +439,7 @@ prettyHsExpr (GHC.HsDo _ GHC.ParStmtCtxt {} _) = notGeneratedByParser
 prettyHsExpr (GHC.HsDo _ GHC.TransStmtCtxt {} _) = notGeneratedByParser
 prettyHsExpr GHC.HsTick {} = forHpc
 prettyHsExpr GHC.HsBinTick {} = forHpc
-prettyHsExpr (GHC.HsBracket _ inner) = pretty inner
+prettyHsExpr (GHC.HsBracket _ inner) = pretty $ mkBracket inner
 prettyHsExpr GHC.HsRnBracketOut {} = notGeneratedByParser
 prettyHsExpr GHC.HsTcBracketOut {} = notGeneratedByParser
 #endif
@@ -986,23 +986,7 @@ instance Pretty RecConPat where
       fieldPrinters =
         fmap (pretty . fmap RecConField) rec_flds
           ++ maybeToList (fmap (const (string "..")) rec_dotdot)
-#if !MIN_VERSION_ghc_lib_parser(9,4,1)
-instance Pretty (GHC.HsBracket GHC.GhcPs) where
-  pretty' (GHC.ExpBr _ expr) = brackets $ wrapWithBars $ pretty expr
-  pretty' (GHC.PatBr _ expr) =
-    brackets $ string "p" >> wrapWithBars (pretty expr)
-  pretty' (GHC.DecBrL _ decls) =
-    brackets
-      $ string "d| "
-          |=> lined (fmap (pretty . fmap mkDeclaration . fromGenLocated) decls)
-          >> string " |"
-  pretty' GHC.DecBrG {} = notGeneratedByParser
-  pretty' (GHC.TypBr _ expr) =
-    brackets $ string "t" >> wrapWithBars (pretty expr)
-  pretty' (GHC.VarBr _ True var) = string "'" >> pretty var
-  pretty' (GHC.VarBr _ False var) = string "''" >> pretty var
-  pretty' (GHC.TExpBr _ x) = typedBrackets $ pretty x
-#endif
+
 instance Pretty SBF.SigBindFamily where
   pretty' (SBF.Sig x) = pretty $ mkSignature x
   pretty' (SBF.Bind x) = pretty $ mkBind x
@@ -1329,20 +1313,6 @@ instance Pretty
   pretty' GHC.HsArgPar {} = notUsedInParsedStage
 #endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
-instance Pretty (GHC.HsQuote GHC.GhcPs) where
-  pretty' (GHC.ExpBr _ x) = brackets $ wrapWithBars $ pretty x
-  pretty' (GHC.PatBr _ x) = brackets $ string "p" >> wrapWithBars (pretty x)
-  pretty' (GHC.DecBrL _ decls) =
-    brackets
-      $ string "d| "
-          |=> lined (fmap (pretty . fmap mkDeclaration . fromGenLocated) decls)
-          >> string " |"
-  pretty' GHC.DecBrG {} = notUsedInParsedStage
-  pretty' (GHC.TypBr _ x) = brackets $ string "t" >> wrapWithBars (pretty x)
-  pretty' (GHC.VarBr _ True x) = string "'" >> pretty x
-  pretty' (GHC.VarBr _ False x) = string "''" >> pretty x
-#endif
-#if MIN_VERSION_ghc_lib_parser(9,4,1)
 instance Pretty (GHC.WithHsDocIdentifiers GHC.StringLiteral GHC.GhcPs) where
   pretty' GHC.WithHsDocIdentifiers {..} = pretty hsDocString
 #endif