Implement Bind (#862)

hindent.cabal

@@ -39,6 +39,7 @@ library
       HIndent.Ast
       HIndent.Ast.Context
       HIndent.Ast.Declaration
+      HIndent.Ast.Declaration.Bind
       HIndent.Ast.Declaration.Class
       HIndent.Ast.Declaration.Class.FunctionalDependency
       HIndent.Ast.Declaration.Class.NameAndTypeVariables

src/HIndent/Ast/Declaration.hs

@@ -8,6 +8,7 @@ module HIndent.Ast.Declaration
 
 import Control.Applicative
 import Data.Maybe
+import HIndent.Ast.Declaration.Bind
 import HIndent.Ast.Declaration.Class
 import HIndent.Ast.Declaration.Data
 import HIndent.Ast.Declaration.Family.Data
@@ -33,7 +34,7 @@ data Declaration
   | DataFamilyInstance DataFamilyInstance
   | TypeFamilyInstance TypeFamilyInstance
   | StandAloneDeriving StandAloneDeriving
-  | ValDecl (GHC.HsBind GHC.GhcPs)
+  | Bind Bind
   | Signature Signature
   | KindSigDecl (GHC.StandaloneKindSig GHC.GhcPs)
   | DefDecl (GHC.DefaultDecl GHC.GhcPs)
@@ -54,7 +55,7 @@ instance CommentExtraction Declaration where
   nodeComments DataFamilyInstance {} = NodeComments [] [] []
   nodeComments TypeFamilyInstance {} = NodeComments [] [] []
   nodeComments StandAloneDeriving {} = NodeComments [] [] []
-  nodeComments ValDecl {} = NodeComments [] [] []
+  nodeComments Bind {} = NodeComments [] [] []
   nodeComments Signature {} = NodeComments [] [] []
   nodeComments KindSigDecl {} = NodeComments [] [] []
   nodeComments DefDecl {} = NodeComments [] [] []
@@ -75,7 +76,7 @@ instance Pretty Declaration where
   pretty' (DataFamilyInstance x) = pretty x
   pretty' (TypeFamilyInstance x) = pretty x
   pretty' (StandAloneDeriving x) = pretty x
-  pretty' (ValDecl x) = pretty x
+  pretty' (Bind x) = pretty x
   pretty' (Signature x) = pretty x
   pretty' (KindSigDecl x) = pretty x
   pretty' (DefDecl x) = pretty x
@@ -102,7 +103,7 @@ mkDeclaration (GHC.InstD _ GHC.DataFamInstD {GHC.dfid_inst = GHC.DataFamInstDecl
 mkDeclaration (GHC.InstD _ x@GHC.TyFamInstD {}) =
   maybe (error "Unreachable.") TypeFamilyInstance $ mkTypeFamilyInstance x
 mkDeclaration (GHC.DerivD _ x) = StandAloneDeriving $ mkStandAloneDeriving x
-mkDeclaration (GHC.ValD _ x) = ValDecl x
+mkDeclaration (GHC.ValD _ x) = Bind $ mkBind x
 mkDeclaration (GHC.SigD _ x) = Signature $ mkSignature x
 mkDeclaration (GHC.KindSigD _ x) = KindSigDecl x
 mkDeclaration (GHC.DefD _ x) = DefDecl x

src/HIndent/Ast/Declaration/Bind.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Bind
+  ( Bind
+  , mkBind
+  ) where
+
+import HIndent.Ast.NodeComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+import HIndent.Pretty.Types
+
+-- The difference between `Function` and `Pattern` is the same as the difference
+-- between `FunBind` and `PatBind` in GHC AST. See
+-- https://hackage.haskell.org/package/ghc-lib-parser-9.8.2.20240223/docs/src/Language.Haskell.Syntax.Binds.html.
+--
+-- TODO: Merge them.
+data Bind
+  = Function
+      { fun_matches :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
+      }
+  | Pattern
+      { lhs :: GHC.LPat GHC.GhcPs
+      , rhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
+      }
+  | PatternSynonym
+      { name :: GHC.LIdP GHC.GhcPs
+      , parameters :: GHC.HsPatSynDetails GHC.GhcPs
+      , direction :: GHC.HsPatSynDir GHC.GhcPs
+      , definition :: GHC.LPat GHC.GhcPs
+      }
+
+instance CommentExtraction Bind where
+  nodeComments Function {} = NodeComments [] [] []
+  nodeComments Pattern {} = NodeComments [] [] []
+  nodeComments PatternSynonym {} = NodeComments [] [] []
+
+instance Pretty Bind where
+  pretty' Function {..} = pretty fun_matches
+  pretty' Pattern {..} = pretty lhs >> pretty rhs
+  pretty' PatternSynonym {..} = do
+    string "pattern "
+    case parameters of
+      GHC.InfixCon l r ->
+        spaced [pretty l, pretty $ fmap InfixOp name, pretty r]
+      GHC.PrefixCon _ [] -> pretty name
+      _ -> spaced [pretty name, pretty parameters]
+    spacePrefixed [pretty direction, pretty $ fmap PatInsidePatDecl definition]
+    case direction of
+      GHC.ExplicitBidirectional matches -> do
+        newline
+        indentedBlock $ string "where " |=> pretty matches
+      _ -> pure ()
+
+mkBind :: GHC.HsBind GHC.GhcPs -> Bind
+mkBind GHC.FunBind {..} = Function {..}
+mkBind GHC.PatBind {..} = Pattern {..}
+  where
+    lhs = pat_lhs
+    rhs = pat_rhs
+mkBind (GHC.PatSynBind _ GHC.PSB {..}) = PatternSynonym {..}
+  where
+    name = psb_id
+    parameters = psb_args
+    direction = psb_dir
+    definition = psb_def
+mkBind _ = error "This AST node should not appear."

src/HIndent/Pretty.hs

@@ -40,6 +40,7 @@ import qualified GHC.Types.SrcLoc as GHC
 import qualified GHC.Unit.Module.Warnings as GHC
 import HIndent.Applicative
 import HIndent.Ast.Declaration
+import HIndent.Ast.Declaration.Bind
 import HIndent.Ast.Declaration.Data.Body
 import HIndent.Ast.Declaration.Signature
 import HIndent.Ast.NodeComments
@@ -133,18 +134,6 @@ class CommentExtraction a =>
 instance (CommentExtraction l, Pretty e) => Pretty (GHC.GenLocated l e) where
   pretty' (GHC.L _ e) = pretty e
 
-instance Pretty (GHC.HsBind GHC.GhcPs) where
-  pretty' = prettyHsBind
-
-prettyHsBind :: GHC.HsBind GHC.GhcPs -> Printer ()
-prettyHsBind GHC.FunBind {..} = pretty fun_matches
-prettyHsBind GHC.PatBind {..} = pretty pat_lhs >> pretty pat_rhs
-prettyHsBind GHC.VarBind {} = notGeneratedByParser
-#if !MIN_VERSION_ghc_lib_parser(9,4,1)
-prettyHsBind GHC.AbsBinds {} = notGeneratedByParser
-#endif
-prettyHsBind (GHC.PatSynBind _ x) = pretty x
-
 instance Pretty (GHC.ClsInstDecl GHC.GhcPs) where
   pretty' GHC.ClsInstDecl {..} = do
     string "instance " |=> do
@@ -1050,7 +1039,7 @@ instance Pretty (GHC.HsBracket GHC.GhcPs) where
 #endif
 instance Pretty SBF.SigBindFamily where
   pretty' (SBF.Sig x) = pretty $ mkSignature x
-  pretty' (SBF.Bind x) = pretty x
+  pretty' (SBF.Bind x) = pretty $ mkBind x
   pretty' (SBF.TypeFamily x) = pretty x
   pretty' (SBF.TyFamInst x) = pretty x
   pretty' (SBF.DataFamInst x) = pretty $ DataFamInstDeclInsideClassInst x
@@ -1694,21 +1683,6 @@ instance Pretty DataFamInstDecl' where
   pretty' DataFamInstDecl' {dataFamInstDecl = GHC.DataFamInstDecl {..}, ..} =
     pretty $ FamEqn' dataFamInstDeclFor dfid_eqn
 
-instance Pretty (GHC.PatSynBind GHC.GhcPs GHC.GhcPs) where
-  pretty' GHC.PSB {..} = do
-    string "pattern "
-    case psb_args of
-      GHC.InfixCon l r ->
-        spaced [pretty l, pretty $ fmap InfixOp psb_id, pretty r]
-      GHC.PrefixCon _ [] -> pretty psb_id
-      _ -> spaced [pretty psb_id, pretty psb_args]
-    spacePrefixed [pretty psb_dir, pretty $ fmap PatInsidePatDecl psb_def]
-    case psb_dir of
-      GHC.ExplicitBidirectional matches -> do
-        newline
-        indentedBlock $ string "where " |=> pretty matches
-      _ -> pure ()
-
 -- | 'Pretty' for 'HsPatSynDetails'.
 instance Pretty
            (GHC.HsConDetails

src/HIndent/Pretty.hs-boot

@@ -7,6 +7,7 @@ module HIndent.Pretty
   , printCommentsAnd
   ) where
 
+import           Data.Void
 import qualified GHC.Core.Type                      as GHC
 import qualified GHC.Types.Basic                    as GHC
 import qualified GHC.Types.Name.Reader              as GHC
@@ -58,7 +59,27 @@ instance Pretty GHC.OverlapMode
 
 instance Pretty HsSigType'
 
-instance Pretty (GHC.HsBind GHC.GhcPs)
+instance Pretty
+           (GHC.MatchGroup
+              GHC.GhcPs
+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs)))
+
+instance Pretty (GHC.Pat GHC.GhcPs)
+
+instance Pretty
+           (GHc.GRHSs
+              GHC.GhcPs
+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs)))
+
+instance Pretty
+           (GHC.HsConDetails
+              Void
+              (GHC.GenLocated GHC.SrcSpanAnnN GHC.RdrName)
+              [GHC.RecordPatSynField GHC.GhcPs])
+
+instance Pretty (GHC.HsPatSynDir GHC.GhcPs)
+
+instance Pretty PatInsidePatDecl
 
 instance Pretty (GHC.StandaloneKindSig GHC.GhcPs)