Implement Signature

hindent.cabal

@@ -56,6 +56,12 @@ library
       HIndent.Ast.Declaration.Instance.Class
       HIndent.Ast.Declaration.Instance.Family.Data
       HIndent.Ast.Declaration.Instance.Family.Type
+      HIndent.Ast.Declaration.Signature
+      HIndent.Ast.Declaration.Signature.BooleanFormula
+      HIndent.Ast.Declaration.Signature.Fixity
+      HIndent.Ast.Declaration.Signature.Fixity.Associativity
+      HIndent.Ast.Declaration.Signature.Inline.Phase
+      HIndent.Ast.Declaration.Signature.Inline.Spec
       HIndent.Ast.Declaration.TypeSynonym
       HIndent.Ast.Declaration.TypeSynonym.Lhs
       HIndent.Ast.FileHeaderPragma

src/HIndent/Ast/Declaration.hs

@@ -15,6 +15,7 @@ import qualified HIndent.Ast.Declaration.Family.Type
 import qualified HIndent.Ast.Declaration.Instance.Class
 import qualified HIndent.Ast.Declaration.Instance.Family.Data
 import qualified HIndent.Ast.Declaration.Instance.Family.Type
+import HIndent.Ast.Declaration.Signature
 import qualified HIndent.Ast.Declaration.TypeSynonym
 import HIndent.Ast.NodeComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
@@ -34,7 +35,7 @@ data Declaration
       HIndent.Ast.Declaration.Instance.Family.Type.TypeFamilyInstance
   | DerivDecl (GHC.DerivDecl GHC.GhcPs)
   | ValDecl (GHC.HsBind GHC.GhcPs)
-  | SigDecl (GHC.Sig GHC.GhcPs)
+  | Signature Signature
   | KindSigDecl (GHC.StandaloneKindSig GHC.GhcPs)
   | DefDecl (GHC.DefaultDecl GHC.GhcPs)
   | ForDecl (GHC.ForeignDecl GHC.GhcPs)
@@ -56,7 +57,7 @@ instance CommentExtraction Declaration where
   nodeComments TypeFamilyInstance {} = NodeComments [] [] []
   nodeComments DerivDecl {} = NodeComments [] [] []
   nodeComments ValDecl {} = NodeComments [] [] []
-  nodeComments SigDecl {} = NodeComments [] [] []
+  nodeComments Signature {} = NodeComments [] [] []
   nodeComments KindSigDecl {} = NodeComments [] [] []
   nodeComments DefDecl {} = NodeComments [] [] []
   nodeComments ForDecl {} = NodeComments [] [] []
@@ -77,7 +78,7 @@ instance Pretty Declaration where
   pretty' (HIndent.Ast.Declaration.TypeFamilyInstance x) = pretty x
   pretty' (DerivDecl x) = pretty x
   pretty' (ValDecl x) = pretty x
-  pretty' (SigDecl x) = pretty x
+  pretty' (HIndent.Ast.Declaration.Signature x) = pretty x
   pretty' (KindSigDecl x) = pretty x
   pretty' (DefDecl x) = pretty x
   pretty' (ForDecl x) = pretty x
@@ -117,7 +118,8 @@ mkDeclaration (GHC.InstD _ x@GHC.TyFamInstD {}) =
     $ HIndent.Ast.Declaration.Instance.Family.Type.mkTypeFamilyInstance x
 mkDeclaration (GHC.DerivD _ x) = DerivDecl x
 mkDeclaration (GHC.ValD _ x) = ValDecl x
-mkDeclaration (GHC.SigD _ x) = SigDecl x
+mkDeclaration (GHC.SigD _ x) =
+  Signature $ HIndent.Ast.Declaration.Signature.mkSignature x
 mkDeclaration (GHC.KindSigD _ x) = KindSigDecl x
 mkDeclaration (GHC.DefD _ x) = DefDecl x
 mkDeclaration (GHC.ForD _ x) = ForDecl x
@@ -131,5 +133,5 @@ mkDeclaration GHC.DocD {} =
     "This node should never appear in the AST. If you see this error, please report it to the HIndent maintainers."
 
 isSignature :: Declaration -> Bool
-isSignature SigDecl {} = True
+isSignature Signature {} = True
 isSignature _ = False

src/HIndent/Ast/Declaration/Signature.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Signature
+  ( Signature
+  , mkSignature
+  ) where
+
+import qualified GHC.Types.Basic as GHC
+import HIndent.Applicative
+import HIndent.Ast.Declaration.Signature.BooleanFormula
+import HIndent.Ast.Declaration.Signature.Fixity
+import HIndent.Ast.Declaration.Signature.Inline.Phase
+import HIndent.Ast.Declaration.Signature.Inline.Spec
+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
+import HIndent.Pretty.Types
+
+-- We want to use the same name for `parameters` and `signature`, but GHC
+-- doesn't allow it.
+data Signature
+  = Type
+      { names :: [GHC.LIdP GHC.GhcPs]
+      , parameters :: GHC.LHsSigWcType GHC.GhcPs
+      }
+  | Pattern
+      { names :: [GHC.LIdP GHC.GhcPs]
+      , signature :: GHC.LHsSigType GHC.GhcPs
+      }
+  | DefaultClassMethod
+      { names :: [GHC.LIdP GHC.GhcPs]
+      , signature :: GHC.LHsSigType GHC.GhcPs
+      }
+  | ClassMethod
+      { names :: [GHC.LIdP GHC.GhcPs]
+      , signature :: GHC.LHsSigType GHC.GhcPs
+      }
+  | Fixity
+      { names :: [GHC.LIdP GHC.GhcPs]
+      , fixity :: Fixity
+      }
+  | Inline
+      { name :: GHC.LIdP GHC.GhcPs
+      , spec :: InlineSpec
+      , phase :: Maybe InlinePhase
+      }
+  | Specialise
+      { name :: GHC.LIdP GHC.GhcPs
+      , sigs :: [GHC.LHsSigType GHC.GhcPs]
+      }
+  | SpecialiseInstance (GHC.LHsSigType GHC.GhcPs)
+  | Minimal (WithComments BooleanFormula)
+  | Scc (GHC.LIdP GHC.GhcPs)
+  | Complete (GHC.XRec GHC.GhcPs [GHC.LIdP GHC.GhcPs])
+
+instance CommentExtraction Signature where
+  nodeComments Type {} = NodeComments [] [] []
+  nodeComments Pattern {} = NodeComments [] [] []
+  nodeComments DefaultClassMethod {} = NodeComments [] [] []
+  nodeComments ClassMethod {} = NodeComments [] [] []
+  nodeComments Fixity {} = NodeComments [] [] []
+  nodeComments Inline {} = NodeComments [] [] []
+  nodeComments Specialise {} = NodeComments [] [] []
+  nodeComments SpecialiseInstance {} = NodeComments [] [] []
+  nodeComments Minimal {} = NodeComments [] [] []
+  nodeComments Scc {} = NodeComments [] [] []
+  nodeComments Complete {} = NodeComments [] [] []
+
+instance Pretty Signature where
+  pretty' Type {..} = do
+    printFunName
+    string " ::"
+    horizontal <-|> vertical
+    where
+      horizontal = do
+        space
+        pretty $ HsSigTypeInsideDeclSig <$> GHC.hswc_body parameters
+      vertical = do
+        headLen <- printerLength printFunName
+        indentSpaces <- getIndentSpaces
+        if headLen < indentSpaces
+          then space
+                 |=> pretty
+                       (HsSigTypeInsideDeclSig <$> GHC.hswc_body parameters)
+          else do
+            newline
+            indentedBlock
+              $ indentedWithSpace 3
+              $ pretty
+              $ HsSigTypeInsideDeclSig <$> GHC.hswc_body parameters
+      printFunName = hCommaSep $ fmap pretty names
+  pretty' Pattern {..} =
+    spaced
+      [ string "pattern"
+      , hCommaSep $ fmap pretty names
+      , string "::"
+      , pretty signature
+      ]
+  pretty' DefaultClassMethod {..} =
+    spaced
+      [ string "default"
+      , hCommaSep $ fmap pretty names
+      , string "::"
+      , printCommentsAnd signature pretty
+      ]
+  pretty' ClassMethod {..} = do
+    hCommaSep $ fmap pretty names
+    string " ::"
+    hor <-|> ver
+    where
+      hor =
+        space >> printCommentsAnd signature (pretty . HsSigTypeInsideDeclSig)
+      ver = do
+        newline
+        indentedBlock
+          $ indentedWithSpace 3
+          $ printCommentsAnd signature (pretty . HsSigTypeInsideDeclSig)
+  pretty' Fixity {..} =
+    spaced [pretty fixity, hCommaSep $ fmap (pretty . fmap InfixOp) names]
+  pretty' Inline {..} = do
+    string "{-# "
+    pretty spec
+    whenJust phase $ \x -> space >> pretty x
+    space
+    pretty name
+    string " #-}"
+  pretty' Specialise {..} =
+    spaced
+      [ string "{-# SPECIALISE"
+      , pretty name
+      , string "::"
+      , hCommaSep $ fmap pretty sigs
+      , string "#-}"
+      ]
+  pretty' (SpecialiseInstance sig) =
+    spaced [string "{-# SPECIALISE instance", pretty sig, string "#-}"]
+  pretty' (Minimal xs) =
+    string "{-# MINIMAL " |=> do
+      pretty xs
+      string " #-}"
+  pretty' (Scc name) = spaced [string "{-# SCC", pretty name, string "#-}"]
+  pretty' (Complete names) =
+    spaced
+      [ string "{-# COMPLETE"
+      , printCommentsAnd names (hCommaSep . fmap pretty)
+      , string "#-}"
+      ]
+
+mkSignature :: GHC.Sig GHC.GhcPs -> Signature
+mkSignature (GHC.TypeSig _ names parameters) = Type {..}
+mkSignature (GHC.PatSynSig _ names signature) = Pattern {..}
+mkSignature (GHC.ClassOpSig _ True names signature) = DefaultClassMethod {..}
+mkSignature (GHC.ClassOpSig _ False names signature) = ClassMethod {..}
+mkSignature (GHC.FixSig _ (GHC.FixitySig _ names fixity)) =
+  Fixity {fixity = mkFixity fixity, ..}
+mkSignature (GHC.InlineSig _ name GHC.InlinePragma {..}) = Inline {..}
+  where
+    spec = mkInlineSpec inl_inline
+    phase = mkInlinePhase inl_act
+mkSignature (GHC.SpecSig _ name sigs _) = Specialise {..}
+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)
+mkSignature (GHC.SpecInstSig _ sig) = SpecialiseInstance sig
+mkSignature (GHC.MinimalSig _ xs) =
+  Minimal $ mkBooleanFormula <$> fromGenLocated xs
+mkSignature (GHC.SCCFunSig _ name _) = Scc name
+mkSignature (GHC.CompleteMatchSig _ names _) = Complete names
+#else
+mkSignature (GHC.SpecInstSig _ _ sig) = SpecialiseInstance sig
+mkSignature (GHC.MinimalSig _ _ xs) =
+  Minimal $ mkBooleanFormula <$> fromGenLocated xs
+mkSignature (GHC.SCCFunSig _ _ name _) = Scc name
+mkSignature (GHC.CompleteMatchSig _ _ names _) = Complete names
+mkSignature GHC.IdSig {} =
+  error "`ghc-lib-parser` never generates this AST node."
+#endif

src/HIndent/Ast/Declaration/Signature/BooleanFormula.hs

@@ -0,0 +1,38 @@
+module HIndent.Ast.Declaration.Signature.BooleanFormula
+  ( BooleanFormula
+  , mkBooleanFormula
+  ) where
+
+import qualified GHC.Data.BooleanFormula as GHC
+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 BooleanFormula
+  = Var (GHC.LIdP GHC.GhcPs)
+  | And [WithComments BooleanFormula]
+  | Or [WithComments BooleanFormula]
+  | Parens (WithComments BooleanFormula)
+
+instance CommentExtraction BooleanFormula where
+  nodeComments Var {} = NodeComments [] [] []
+  nodeComments And {} = NodeComments [] [] []
+  nodeComments Or {} = NodeComments [] [] []
+  nodeComments Parens {} = NodeComments [] [] []
+
+instance Pretty BooleanFormula where
+  pretty' (Var x) = pretty x
+  pretty' (And xs) = hvCommaSep $ fmap pretty xs
+  pretty' (Or xs) = hvBarSep $ fmap pretty xs
+  pretty' (Parens x) = parens $ pretty x
+
+mkBooleanFormula :: GHC.BooleanFormula (GHC.LIdP GHC.GhcPs) -> BooleanFormula
+mkBooleanFormula (GHC.Var x) = Var x
+mkBooleanFormula (GHC.And xs) =
+  And $ fmap (fmap mkBooleanFormula . fromGenLocated) xs
+mkBooleanFormula (GHC.Or xs) =
+  Or $ fmap (fmap mkBooleanFormula . fromGenLocated) xs
+mkBooleanFormula (GHC.Parens x) = Parens $ mkBooleanFormula <$> fromGenLocated x

src/HIndent/Ast/Declaration/Signature/Fixity.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Signature.Fixity
+  ( Fixity
+  , mkFixity
+  ) where
+
+import qualified GHC.Types.Fixity as GHC
+import HIndent.Ast.Declaration.Signature.Fixity.Associativity
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data Fixity = Fixity
+  { level :: Int
+  , associativity :: Associativity
+  }
+
+instance CommentExtraction Fixity where
+  nodeComments Fixity {} = NodeComments [] [] []
+
+instance Pretty Fixity where
+  pretty' Fixity {..} = spaced [pretty associativity, string $ show level]
+
+mkFixity :: GHC.Fixity -> Fixity
+mkFixity (GHC.Fixity _ level associativity) =
+  Fixity level (mkAssociativity associativity)

src/HIndent/Ast/Declaration/Signature/Fixity/Associativity.hs

@@ -0,0 +1,30 @@
+module HIndent.Ast.Declaration.Signature.Fixity.Associativity
+  ( Associativity
+  , mkAssociativity
+  ) where
+
+import qualified GHC.Types.Fixity as GHC
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data Associativity
+  = LeftAssoc
+  | RightAssoc
+  | None
+
+instance CommentExtraction Associativity where
+  nodeComments LeftAssoc = NodeComments [] [] []
+  nodeComments RightAssoc = NodeComments [] [] []
+  nodeComments None = NodeComments [] [] []
+
+instance Pretty Associativity where
+  pretty' LeftAssoc = string "infixl"
+  pretty' RightAssoc = string "infixr"
+  pretty' None = string "infix"
+
+mkAssociativity :: GHC.FixityDirection -> Associativity
+mkAssociativity GHC.InfixL = LeftAssoc
+mkAssociativity GHC.InfixR = RightAssoc
+mkAssociativity GHC.InfixN = None

src/HIndent/Ast/Declaration/Signature/Inline/Phase.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Signature.Inline.Phase
+  ( InlinePhase
+  , mkInlinePhase
+  ) where
+
+import qualified GHC.Types.Basic as GHC
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data BeforeOrAfter
+  = Before
+  | After
+
+data InlinePhase = InlinePhase
+  { beforeOrAfter :: BeforeOrAfter
+  , phase :: Int
+  }
+
+instance CommentExtraction InlinePhase where
+  nodeComments InlinePhase {} = NodeComments [] [] []
+
+instance Pretty InlinePhase where
+  pretty' InlinePhase {beforeOrAfter = Before, ..} =
+    brackets (string $ '~' : show phase)
+  pretty' InlinePhase {beforeOrAfter = After, ..} =
+    brackets (string $ show phase)
+
+mkInlinePhase :: GHC.Activation -> Maybe InlinePhase
+mkInlinePhase (GHC.ActiveBefore _ phase) = Just $ InlinePhase Before phase
+mkInlinePhase (GHC.ActiveAfter _ phase) = Just $ InlinePhase After phase
+mkInlinePhase _ = Nothing