hindent 6.2.1 → 6.3.0

raw patch · 105 files changed

+5895/−3217 lines, 105 filesdep ~Cabaldep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, ghc-lib-parser

API changes (from Hackage documentation)

Files

CHANGELOG.md +39/−1
TESTS.md +149/−17
elisp/hindent.el +49/−53
hindent.cabal +48/−13
internal/HIndent/Internal/Test/Markdone.hs +1/−3
src/HIndent/Ast/Cmd.hs +237/−0
src/HIndent/Ast/Cmd.hs-boot +10/−0
src/HIndent/Ast/Comment.hs +35/−0
src/HIndent/Ast/Declaration/Annotation.hs +11/−5
src/HIndent/Ast/Declaration/Bind.hs +19/−46
src/HIndent/Ast/Declaration/Bind/GuardedRhs.hs +91/−0
src/HIndent/Ast/Declaration/Class.hs +23/−3
src/HIndent/Ast/Declaration/Data/Body.hs +16/−3
src/HIndent/Ast/Declaration/Data/Constructor/Field.hs +28/−0
src/HIndent/Ast/Declaration/Data/Deriving.hs +9/−5
src/HIndent/Ast/Declaration/Data/Deriving/Strategy.hs +5/−2
src/HIndent/Ast/Declaration/Data/GADT/Constructor/Signature.hs +29/−21
src/HIndent/Ast/Declaration/Data/Haskell98/Constructor/Body.hs +11/−6
src/HIndent/Ast/Declaration/Data/Record/Field.hs +7/−4
src/HIndent/Ast/Declaration/Default.hs +12/−2
src/HIndent/Ast/Declaration/Family/Type/ResultSignature.hs +3/−2
src/HIndent/Ast/Declaration/Foreign.hs +15/−8
src/HIndent/Ast/Declaration/Instance/Class.hs +30/−11
src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs +9/−0
src/HIndent/Ast/Declaration/Instance/Family/Type.hs +4/−3
src/HIndent/Ast/Declaration/Instance/Family/Type/Associated.hs +24/−0
src/HIndent/Ast/Declaration/Instance/Family/Type/Associated/Default.hs +27/−0
src/HIndent/Ast/Declaration/PatternSynonym.hs +97/−0
src/HIndent/Ast/Declaration/Rule.hs +10/−14
src/HIndent/Ast/Declaration/Rule.hs-boot +15/−0
src/HIndent/Ast/Declaration/Rule/Binder.hs +3/−2
src/HIndent/Ast/Declaration/Rule/Collection.hs +1/−1
src/HIndent/Ast/Declaration/Rule/Name.hs +23/−0
src/HIndent/Ast/Declaration/Signature.hs +38/−33
src/HIndent/Ast/Declaration/Signature/Fixity.hs +6/−0
src/HIndent/Ast/Declaration/Signature/StandaloneKind.hs +4/−2
src/HIndent/Ast/Declaration/Splice.hs +5/−4
src/HIndent/Ast/Declaration/StandAloneDeriving.hs +4/−2
src/HIndent/Ast/Declaration/TypeSynonym/Lhs.hs +4/−3
src/HIndent/Ast/Expression.hs +676/−0
src/HIndent/Ast/Expression.hs-boot +25/−0
src/HIndent/Ast/Expression/Bracket.hs +14/−10
src/HIndent/Ast/Expression/FieldSelector.hs +34/−0
src/HIndent/Ast/Expression/ListComprehension.hs +53/−0
src/HIndent/Ast/Expression/OverloadedLabel.hs +23/−0
src/HIndent/Ast/Expression/Pragmatic.hs +41/−0
src/HIndent/Ast/Expression/RangeExpression.hs +64/−0
src/HIndent/Ast/Expression/RecordConstructionField.hs +36/−0
src/HIndent/Ast/Expression/RecordUpdateField.hs +124/−0
src/HIndent/Ast/Expression/Splice.hs +39/−10
src/HIndent/Ast/FileHeaderPragma.hs +1/−1
src/HIndent/Ast/Guard.hs +130/−0
src/HIndent/Ast/Import.hs +16/−30
src/HIndent/Ast/Import/Collection.hs +1/−1
src/HIndent/Ast/Import/Entry.hs +34/−85
src/HIndent/Ast/LocalBinds.hs +59/−0
src/HIndent/Ast/LocalBinds/ImplicitBinding.hs +48/−0
src/HIndent/Ast/LocalBinds/ImplicitBindings.hs +30/−0
src/HIndent/Ast/Match.hs +317/−0
src/HIndent/Ast/MatchGroup.hs +46/−0
src/HIndent/Ast/MatchGroup.hs-boot +17/−0
src/HIndent/Ast/Module/Declaration.hs +7/−4
src/HIndent/Ast/Module/Export/Entry.hs +25/−29
src/HIndent/Ast/Module/Name.hs +3/−2
src/HIndent/Ast/Module/Name.hs-boot +5/−0
src/HIndent/Ast/Module/Warning.hs +3/−1
src/HIndent/Ast/Name/ImportExport.hs +105/−0
src/HIndent/Ast/Name/Infix.hs +25/−8
src/HIndent/Ast/Name/Prefix.hs +37/−3
src/HIndent/Ast/Name/RecordField.hs +66/−0
src/HIndent/Ast/NodeComments.hs +13/−0
src/HIndent/Ast/Pattern.hs +212/−0
src/HIndent/Ast/Pattern.hs-boot +17/−0
src/HIndent/Ast/Pattern/RecordFields.hs +41/−0
src/HIndent/Ast/Record/Field.hs +102/−0
src/HIndent/Ast/Statement.hs +133/−0
src/HIndent/Ast/Type.hs +384/−5
src/HIndent/Ast/Type.hs-boot +12/−0
src/HIndent/Ast/Type/Bang.hs +37/−0
src/HIndent/Ast/Type/Forall.hs +51/−0
src/HIndent/Ast/Type/ImplicitParameterName.hs +23/−0
src/HIndent/Ast/Type/Literal.hs +30/−0
src/HIndent/Ast/Type/Multiplicity.hs +44/−0
src/HIndent/Ast/Type/Strictness.hs +29/−0
src/HIndent/Ast/Type/Unpackedness.hs +29/−0
src/HIndent/Ast/Type/Variable.hs +18/−2
src/HIndent/Ast/WithComments.hs +56/−2
src/HIndent/ByteString.hs +1/−1
src/HIndent/CabalFile.hs +35/−2
src/HIndent/Config.hs +1/−1
src/HIndent/GhcLibParserWrapper/GHC/Parser/Annotation.hs +19/−0
src/HIndent/Language.hs +10/−1
src/HIndent/LanguageExtension.hs +1/−1
src/HIndent/ModulePreprocessing.hs +34/−8
src/HIndent/ModulePreprocessing/CommentRelocation.hs +259/−31
src/HIndent/Path/Find.hs +1/−1
src/HIndent/Pragma.hs +1/−1
src/HIndent/Pretty.hs +439/−1875
src/HIndent/Pretty.hs-boot +18/−41
src/HIndent/Pretty/Combinators.hs +0/−2
src/HIndent/Pretty/Combinators/Lineup.hs +63/−55
src/HIndent/Pretty/Combinators/RhsSeparator.hs +0/−16
src/HIndent/Pretty/NodeComments.hs +497/−490
src/HIndent/Pretty/SigBindFamily.hs +27/−13
src/HIndent/Pretty/Types.hs +3/−216

CHANGELOG.md view

@@ -10,6 +10,31 @@  ### Removed +## [6.3.0] - 2026-01-24++### Added++- Support for GHC 9.12 ([#1000])+- Support for GHC2024 ([#1040])+- Support for linear types ([#1077])++### Changed++- Unified `where` clause formatting and respect `configIndentSpaces` for bindings ([#1118])+- `hindent-mode`: Show an error string on any return code that's not 0 ([#1096])+- `hindent-mode`: The `hindent-extra-args` variable may now be a function ([#1096])++### Fixed++- Template Haskell functions no longer get unwanted '$' symbols prepended ([#1033])+- Default method signatures with constraints are now properly indented ([#1042])+- Fix formatting of associated data families in type classes ([#1051])+- Kind signatures and deriving clauses in GADTs are now properly printed ([#1053])+- Visible forall (`forall a ->`) is now correctly formatted instead of being converted to invisible forall ([#1060])+- Keep `where` clauses that contain implicit parameter bindings ([#1121])+- Keep `as Foo` module aliases also with unqualified modules ([#1140])+- Preserve default associated type families in classes instead of dropping them ([#1143])+ ## [6.2.1] - 2024-11-28  ### Removed@@ -367,7 +392,8 @@  - A bug in printing operators in statements. -[unreleased]: https://github.com/mihaimaruseac/hindent/compare/v6.2.1...HEAD+[unreleased]: https://github.com/mihaimaruseac/hindent/compare/v6.3.0...HEAD+[6.3.0]: https://github.com/mihaimaruseac/hindent/compare/v6.2.1...v6.3.0 [6.2.1]: https://github.com/mihaimaruseac/hindent/compare/v6.2.0...v6.2.1 [6.2.0]: https://github.com/mihaimaruseac/hindent/compare/v6.1.0...v6.2.0 [6.1.0]: https://github.com/mihaimaruseac/hindent/compare/v6.0.0...v6.1.0@@ -400,6 +426,18 @@ [@uhbif19]: https://github.com/uhbif19 [@toku-sa-n]: https://github.com/toku-sa-n +[#1143]: https://github.com/mihaimaruseac/hindent/pull/1143+[#1140]: https://github.com/mihaimaruseac/hindent/pull/1140+[#1121]: https://github.com/mihaimaruseac/hindent/pull/1121+[#1096]: https://github.com/mihaimaruseac/hindent/pull/1096+[#1077]: https://github.com/mihaimaruseac/hindent/pull/1077+[#1060]: https://github.com/mihaimaruseac/hindent/pull/1060+[#1053]: https://github.com/mihaimaruseac/hindent/pull/1053+[#1051]: https://github.com/mihaimaruseac/hindent/pull/1051+[#1042]: https://github.com/mihaimaruseac/hindent/pull/1042+[#1040]: https://github.com/mihaimaruseac/hindent/pull/1040+[#1033]: https://github.com/mihaimaruseac/hindent/pull/1033+[#1000]: https://github.com/mihaimaruseac/hindent/pull/1000 [#967]: https://github.com/mihaimaruseac/hindent/pull/967 [#950]: https://github.com/mihaimaruseac/hindent/pull/950 [#918]: https://github.com/mihaimaruseac/hindent/pull/918

TESTS.md view

@@ -218,6 +218,7 @@  ```haskell import Control.Lens (_2, _Just)+import Control.Lens as Optic import Data.Text import Data.Text import qualified Data.Text as T@@ -459,6 +460,25 @@   bar = mappend ``` +Default signatures with constraints++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/492+class HasEnvExpr m =>+      MonadRecordEnvExpr m+  where+  addEnvExpression :: EnvExpr m -> m HostExpr+  default addEnvExpression ::+       ( MonadTrans t+       , Monad n+       , MonadRecordEnvExpr n+       , t n ~ m+       , EnvExpr m ~ EnvExpr n+       )+    => EnvExpr m+    -> m HostExpr+```+ `TypeOperators` and `MultiParamTypeClasses`  ```haskell@@ -529,6 +549,14 @@   type F a = b | b -> a ``` +Associated data families in classes++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/1050+class MyClass a where+  data AssociatedData a+```+ ### Class instance declarations  Without methods@@ -602,6 +630,15 @@     FooBar a ``` +Default associated type family keeps its default++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/897+class Foo a where+  type Bar a+  type instance Bar a = ()+```+ #### With overlapping pragmas  `OVERLAPPING`@@ -1208,21 +1245,22 @@        in y ``` -The indent after a top-level `where` has always 2 spaces.+The indent after a top-level `where` respects the indent size setting.  ```haskell 4 f = undefined-  where-    g = undefined+    where+        g = undefined ``` -The indent after a `where` inside a `case` depends on the indent space setting+The indent after a `where` inside a `case` respects the indent size setting  ```haskell 4 f =     case x of         x -> undefined-            where y = undefined+            where+                y = undefined ```  #### Pattern matchings@@ -1374,6 +1412,29 @@ f all@(x:xs) = all ``` +Empty data declarations with kind signatures and deriving clauses++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/1049+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++data Void :: Type++data Unit :: Type where+  MkUnit :: Unit+  deriving (Show)+```++Or patterns++```haskell since 9.12.1+{-# LANGUAGE OrPatterns #-}++isLeftOrRight :: Either a b -> Bool+isLeftOrRight (Left _; Right _) = True+```+ ### Infix declarations  infixl@@ -1727,13 +1788,39 @@ url :: r {url :: String} => r -> Integer ``` -`forall` type+#### Forall quantification +Invisible forall+ ```haskell f :: (forall a. Data a => a -> a) -> (forall a b. Data a => a -> b) g :: forall a b. a -> b ``` +Visible forall with single type variable++```haskell+idVis :: forall a -> a -> a+```++Visible forall with multiple type variables++```haskell+pairVis :: forall a -> forall b -> a -> b -> (a, b)+```++Visible forall with mixed visibility++```haskell+mixed :: forall a -> forall b. (a -> b) -> a -> b+```++Visible forall with kind annotation++```haskell+proxyVis :: forall (a :: Type) -> Proxy a+```+ An infix operator containing `#`  ```haskell@@ -1744,12 +1831,12 @@  ```haskell 4 foo = undefined-  where-    go :: Fooooooooooooooooooooooo-       -> Fooooooooooooooooooooooo-       -> Fooooooooooooooooooooooo-       -> Fooooooooooooooooooooooo-    go = undefined+    where+        go :: Fooooooooooooooooooooooo+           -> Fooooooooooooooooooooooo+           -> Fooooooooooooooooooooooo+           -> Fooooooooooooooooooooooo+        go = undefined ```  Types with many type applications@@ -1930,6 +2017,26 @@       , Looooooooooooooooooooooooooooooooooooooooooooong #) ``` +### Linear types++Linear function arrow (%1 ->)++```haskell+{-# LANGUAGE LinearTypes #-}++f :: a %1 -> b+```++Linear types in GADT constructors++```haskell+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}++data T where+  C :: a %1 -> T+```+ ### Type synonym declarations  Short@@ -2548,6 +2655,19 @@    in f ``` +With implicit parameters in a `where`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/1120+{-# LANGUAGE ImplicitParams #-}++foo :: Int -> Int+foo x+  | x > 0 = ?bar+  where+    ?bar = x + 1+```+ inside a `do`  ```haskell@@ -3132,6 +3252,17 @@ foo = $$bar ``` +Template Haskell function calls without arguments should not get '$' prepended++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/973+{-# LANGUAGE TemplateHaskell #-}++makeSem ''MyData++deriveJSON+```+ ## Comments  Only comments@@ -3469,11 +3600,12 @@                                       typeString                                       (map (snd $(presentVar)) xs))                                 ]-                              where getCh (CharPresentation "GHC.Types.Char" ch) =-                                      ch-                                    getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =-                                      ch-                                    getCh _ = ""+                              where+                                getCh (CharPresentation "GHC.Types.Char" ch) =+                                  ch+                                getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =+                                  ch+                                getCh _ = ""                             _ ->                               ListPresentation                                 typeString

elisp/hindent.el view

@@ -1,10 +1,10 @@-;;; hindent.el --- Indent haskell code using the "hindent" program+;;; hindent.el --- Indent haskell code using the "hindent" program -*- lexical-binding: t -*-  ;; Copyright (c) 2014 Chris Done. All rights reserved.  ;; Author: Chris Done <chrisdone@gmail.com>-;; URL: https://github.com/chrisdone/hindent-;; Package-Requires: ((cl-lib "0.5"))+;; URL: https://github.com/mihaimaruseac/hindent+;; Package-Requires: ((emacs "27.1"))  ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by@@ -31,7 +31,7 @@  ;;; Code: -(require 'cl-lib)+(eval-when-compile (require 'cl-lib))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization properties@@ -63,11 +63,13 @@ (defcustom hindent-extra-args nil   "Extra arguments to give to hindent"   :group 'hindent-  :type 'sexp-  :safe #'listp)+  :type '(choice+          (repeat string)+          (function :tag "Function with no arguments returning a list of strings")))  (defcustom hindent-reformat-buffer-on-save nil-  "Set to t to run `hindent-reformat-buffer' when a buffer in `hindent-mode' is saved."+  "Set to t to run `hindent-reformat-buffer' when a buffer in+`hindent-mode' is saved."   :group 'hindent   :type 'boolean   :safe #'booleanp)@@ -196,16 +198,6 @@                                           nil)                                     (hindent-extra-arguments)))))             (cond-             ((= ret 1)-              (let ((error-string-                     (with-current-buffer temp-                       (let ((string (progn (goto-char (point-min))-                                            (buffer-substring (line-beginning-position)-                                                              (line-end-position)))))-                         string))))-                (if (string= error-string "hindent: Parse error: EOF")-                    (message "language pragma")-                  (error error-string))))              ((= ret 0)               (let* ((last-decl (= end (point-max)))                      (new-str (with-current-buffer temp@@ -213,20 +205,24 @@                                   (goto-char (point-max))                                   (when (looking-back "\n" (1- (point)))                                     (delete-char -1)))-				(delete-trailing-whitespace)+                                (delete-trailing-whitespace)                                 (buffer-string))))                 (if (not (string= new-str orig-str))-		    (progn-		      (if (fboundp 'replace-region-contents)-			  (replace-region-contents-			   beg end (lambda () temp))-			(let ((line (line-number-at-pos))-			      (col (current-column)))-			  (delete-region beg-					 end)-			  (insert new-str)))-		      (message "Formatted."))-                  (message "Already formatted.")))))))))))+                    (progn+                      (replace-region-contents beg end (lambda () temp))+                      (message "Formatted."))+                  (message "Already formatted."))))+             (t+              (let ((error-string+                     (with-current-buffer temp+                       (let ((string (progn (goto-char (point-min))+                                            (buffer-substring (line-beginning-position)+                                                              (line-end-position)))))+                         string))))+                (if (string= error-string "hindent: Parse error: EOF")+                    (message "language pragma")+                  (error error-string))))+             )))))))  (defun hindent-decl-points ()   "Get the start and end position of the current declaration.@@ -253,35 +249,33 @@    (t     (save-excursion       (let ((start-             (or (cl-letf-                     (((symbol-function 'jump)-                       #'(lambda ()-                           (search-backward-regexp "^[^ \n]" nil t 1)-                           (cond-                            ((save-excursion (goto-char (line-beginning-position))-                                             (looking-at "|]"))-                             (jump))-                            (t (unless (or (looking-at "^-}$")-                                           (looking-at "^{-$"))-                                 (point)))))))+             (or (cl-labels+                     ((jump ()+                        (search-backward-regexp "^[^ \n]" nil t 1)+                        (cond+                         ((save-excursion (goto-char (line-beginning-position))+                                          (looking-at "|]"))+                          (jump))+                         (t (unless (or (looking-at "^-}$")+                                        (looking-at "^{-$"))+                              (point))))))                    (goto-char (line-end-position))                    (jump))                  0))             (end              (progn                (goto-char (1+ (point)))-               (or (cl-letf-                       (((symbol-function 'jump)-                         #'(lambda ()-                             (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)-                               (cond-                                ((save-excursion (goto-char (line-beginning-position))-                                                 (looking-at "|]"))-                                 (jump))-                                (t (forward-char -1)-                                   (search-backward-regexp "[^\n ]" nil t)-                                   (forward-char)-                                   (point)))))))+               (or (cl-labels+                       ((jump ()+                          (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)+                            (cond+                             ((save-excursion (goto-char (line-beginning-position))+                                              (looking-at "|]"))+                              (jump))+                             (t (forward-char -1)+                                (search-backward-regexp "[^\n ]" nil t)+                                (forward-char)+                                (point))))))                      (jump))                    (point-max)))))         (cons start end))))))@@ -308,7 +302,9 @@    (when hindent-style      (list "--style" hindent-style))    (when hindent-extra-args-     hindent-extra-args)))+     (if (functionp hindent-extra-args)+         (funcall hindent-extra-args)+       hindent-extra-args))))  (provide 'hindent)

hindent.cabal view

@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           hindent-version:        6.2.1+version:        6.3.0 synopsis:       Extensible Haskell pretty printer description:    Extensible Haskell pretty printer. Both a library and an executable.                 See the GitHub page for usage \/ explanation: <https://github.com/mihaimaruseac/hindent>@@ -37,18 +37,22 @@   other-modules:       HIndent.Applicative       HIndent.Ast+      HIndent.Ast.Cmd+      HIndent.Ast.Comment       HIndent.Ast.Context       HIndent.Ast.Declaration       HIndent.Ast.Declaration.Annotation       HIndent.Ast.Declaration.Annotation.Provenance       HIndent.Ast.Declaration.Annotation.Role       HIndent.Ast.Declaration.Bind+      HIndent.Ast.Declaration.Bind.GuardedRhs       HIndent.Ast.Declaration.Class       HIndent.Ast.Declaration.Class.FunctionalDependency       HIndent.Ast.Declaration.Class.NameAndTypeVariables       HIndent.Ast.Declaration.Collection       HIndent.Ast.Declaration.Data       HIndent.Ast.Declaration.Data.Body+      HIndent.Ast.Declaration.Data.Constructor.Field       HIndent.Ast.Declaration.Data.Deriving       HIndent.Ast.Declaration.Data.Deriving.Clause       HIndent.Ast.Declaration.Data.Deriving.Strategy@@ -71,9 +75,13 @@       HIndent.Ast.Declaration.Instance.Class.OverlapMode       HIndent.Ast.Declaration.Instance.Family.Data       HIndent.Ast.Declaration.Instance.Family.Type+      HIndent.Ast.Declaration.Instance.Family.Type.Associated+      HIndent.Ast.Declaration.Instance.Family.Type.Associated.Default+      HIndent.Ast.Declaration.PatternSynonym       HIndent.Ast.Declaration.Rule       HIndent.Ast.Declaration.Rule.Binder       HIndent.Ast.Declaration.Rule.Collection+      HIndent.Ast.Declaration.Rule.Name       HIndent.Ast.Declaration.Signature       HIndent.Ast.Declaration.Signature.BooleanFormula       HIndent.Ast.Declaration.Signature.Fixity@@ -88,26 +96,53 @@       HIndent.Ast.Declaration.Warning       HIndent.Ast.Declaration.Warning.Collection       HIndent.Ast.Declaration.Warning.Kind+      HIndent.Ast.Expression       HIndent.Ast.Expression.Bracket+      HIndent.Ast.Expression.FieldSelector+      HIndent.Ast.Expression.ListComprehension+      HIndent.Ast.Expression.OverloadedLabel+      HIndent.Ast.Expression.Pragmatic+      HIndent.Ast.Expression.RangeExpression+      HIndent.Ast.Expression.RecordConstructionField+      HIndent.Ast.Expression.RecordUpdateField       HIndent.Ast.Expression.Splice       HIndent.Ast.FileHeaderPragma       HIndent.Ast.FileHeaderPragma.Collection+      HIndent.Ast.Guard       HIndent.Ast.Import       HIndent.Ast.Import.Collection       HIndent.Ast.Import.Entry       HIndent.Ast.Import.Entry.Collection       HIndent.Ast.Import.ImportingOrHiding+      HIndent.Ast.LocalBinds+      HIndent.Ast.LocalBinds.ImplicitBinding+      HIndent.Ast.LocalBinds.ImplicitBindings+      HIndent.Ast.Match+      HIndent.Ast.MatchGroup       HIndent.Ast.Module       HIndent.Ast.Module.Declaration       HIndent.Ast.Module.Export.Collection       HIndent.Ast.Module.Export.Entry       HIndent.Ast.Module.Name       HIndent.Ast.Module.Warning+      HIndent.Ast.Name.ImportExport       HIndent.Ast.Name.Infix       HIndent.Ast.Name.Prefix+      HIndent.Ast.Name.RecordField       HIndent.Ast.NodeComments+      HIndent.Ast.Pattern+      HIndent.Ast.Pattern.RecordFields+      HIndent.Ast.Record.Field       HIndent.Ast.Role+      HIndent.Ast.Statement       HIndent.Ast.Type+      HIndent.Ast.Type.Bang+      HIndent.Ast.Type.Forall+      HIndent.Ast.Type.ImplicitParameterName+      HIndent.Ast.Type.Literal+      HIndent.Ast.Type.Multiplicity+      HIndent.Ast.Type.Strictness+      HIndent.Ast.Type.Unpackedness       HIndent.Ast.Type.Variable       HIndent.Ast.WithComments       HIndent.ByteString@@ -119,6 +154,7 @@       HIndent.Fixity       HIndent.GhcLibParserWrapper.GHC.Hs       HIndent.GhcLibParserWrapper.GHC.Hs.ImpExp+      HIndent.GhcLibParserWrapper.GHC.Parser.Annotation       HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings       HIndent.Language       HIndent.LanguageExtension@@ -137,7 +173,6 @@       HIndent.Pretty.Combinators.Lineup       HIndent.Pretty.Combinators.Op       HIndent.Pretty.Combinators.Outputable-      HIndent.Pretty.Combinators.RhsSeparator       HIndent.Pretty.Combinators.String       HIndent.Pretty.Combinators.Switch       HIndent.Pretty.Combinators.Wrap@@ -152,7 +187,7 @@       src   ghc-options: -Wall -O2 -threaded   build-depends:-      Cabal <3.12+      Cabal     , async >=2.2.5     , base >=4.7 && <5     , bytestring@@ -160,7 +195,7 @@     , directory     , exceptions     , filepath-    , ghc-lib-parser >=9.2 && <9.11+    , ghc-lib-parser >=9.2 && <9.13     , ghc-lib-parser-ex     , monad-loops     , mtl@@ -187,7 +222,7 @@       internal   ghc-options: -Wall -O2 -threaded   build-depends:-      Cabal <3.12+      Cabal     , async >=2.2.5     , base >=4.7 && <5     , bytestring@@ -196,7 +231,7 @@     , directory     , exceptions     , filepath-    , ghc-lib-parser >=9.2 && <9.11+    , ghc-lib-parser >=9.2 && <9.13     , ghc-lib-parser-ex     , monad-loops     , mtl@@ -222,7 +257,7 @@       app   ghc-options: -Wall -O2 -threaded   build-depends:-      Cabal <3.12+      Cabal     , async >=2.2.5     , base >=4.7 && <5     , bytestring@@ -230,7 +265,7 @@     , directory     , exceptions     , filepath-    , ghc-lib-parser >=9.2 && <9.11+    , ghc-lib-parser >=9.2 && <9.13     , ghc-lib-parser-ex     , hindent     , monad-loops@@ -258,7 +293,7 @@       tests   ghc-options: -Wall -O2 -threaded   build-depends:-      Cabal <3.12+      Cabal     , Diff     , async >=2.2.5     , base >=4.7 && <5@@ -267,7 +302,7 @@     , directory     , exceptions     , filepath-    , ghc-lib-parser >=9.2 && <9.11+    , ghc-lib-parser >=9.2 && <9.13     , ghc-lib-parser-ex     , hindent     , hindent-internal@@ -297,7 +332,7 @@       benchmarks   ghc-options: -Wall -O2 -threaded   build-depends:-      Cabal <3.12+      Cabal     , async >=2.2.5     , base >=4.7 && <5     , bytestring@@ -307,7 +342,7 @@     , directory     , exceptions     , filepath-    , ghc-lib-parser >=9.2 && <9.11+    , ghc-lib-parser >=9.2 && <9.13     , ghc-lib-parser-ex     , hindent     , hindent-internal

internal/HIndent/Internal/Test/Markdone.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -21,7 +20,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Char-import Data.Typeable import GHC.Generics  -- | A markdone token.@@ -45,7 +43,7 @@ data MarkdownError   = NoFenceEnd   | ExpectedSection-  deriving (Typeable, Show)+  deriving (Show)  instance Exception MarkdownError

+ src/HIndent/Ast/Cmd.hs view

@@ -0,0 +1,237 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Cmd+  ( Cmd+  , CmdDoBlock+  , mkCmd+  , mkCmdDoBlock+  , mkCmdFromHsCmdTop+  ) where++import Data.Maybe (fromMaybe)+import qualified GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import {-# SOURCE #-} HIndent.Ast.MatchGroup (MatchGroup, mkCmdMatchGroup)+import HIndent.Ast.Statement (CmdStatement, mkCmdStatement)+import HIndent.Ast.WithComments+  ( WithComments+  , flattenComments+  , fromGenLocated+  , prettyWith+  )+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..), emptyNodeComments)++data ArrowKind+  = Higher+  | First++data ArrowDirection+  = FunctionThenArgument+  | ArgumentThenFunction++data Cmd+  = ArrowApp+      { arrowKind :: ArrowKind+      , arrowDirection :: ArrowDirection+      , function :: WithComments Expression+      , argument :: WithComments Expression+      }+  | ArrowForm+      { function :: WithComments Expression+      , arguments :: [WithComments Cmd]+      }+  | CmdApp+      { cmd :: WithComments Cmd+      , argument :: WithComments Expression+      }+  | Lambda+      { matches :: MatchGroup+      }+  | LambdaCase+      { usesCases :: Bool+      , matches :: MatchGroup+      }+  | Case+      { scrutinee :: WithComments Expression+      , matches :: MatchGroup+      }+  | If+      { predicate :: WithComments Expression+      , thenBranch :: WithComments Cmd+      , elseBranch :: WithComments Cmd+      }+  | Let+      { localBinds :: WithComments LocalBinds+      , inCommand :: WithComments Cmd+      }+  | DoBlock+      { statements :: WithComments [WithComments CmdStatement]+      }+  | Parenthesized (WithComments Cmd)++instance CommentExtraction Cmd where+  nodeComments _ = emptyNodeComments++instance Pretty Cmd where+  pretty' ArrowApp {..} =+    case arrowDirection of+      FunctionThenArgument ->+        spaced [pretty function, string operator, pretty argument]+      ArgumentThenFunction ->+        spaced [pretty argument, string operator, pretty function]+    where+      operator =+        case (arrowKind, arrowDirection) of+          (Higher, FunctionThenArgument) -> "-<<"+          (Higher, ArgumentThenFunction) -> ">>-"+          (First, FunctionThenArgument) -> "-<"+          (First, ArgumentThenFunction) -> ">-"+  pretty' ArrowForm {..} =+    bananaBrackets $ spaced $ pretty function : fmap pretty arguments+  pretty' CmdApp {..} = spaced [pretty cmd, pretty argument]+  pretty' Lambda {..} = pretty matches+  pretty' LambdaCase {..} = do+    string+      $ if usesCases+          then "\\cases"+          else "\\case"+    newline+    indentedBlock $ pretty matches+  pretty' Case {..} = do+    spaced [string "case", pretty scrutinee, string "of"]+    newline+    indentedBlock $ pretty matches+  pretty' If {..} = do+    string "if "+    pretty predicate+    newline+    indentedBlock+      $ lined+          [ string "then " >> pretty thenBranch+          , string "else " >> pretty elseBranch+          ]+  pretty' Let {..} =+    lined+      [string "let " |=> pretty localBinds, string " in " |=> pretty inCommand]+  pretty' DoBlock {..} = do+    string "do"+    newline+    indentedBlock $ prettyWith statements $ lined . fmap pretty+  pretty' (Parenthesized cmd) = parens $ pretty cmd++mkCmd :: GHC.HsCmd GHC.GhcPs -> Cmd+mkCmd (GHC.HsCmdArrApp _ f arg appKind isFwd) =+  ArrowApp+    { arrowKind =+        case appKind of+          GHC.HsHigherOrderApp -> Higher+          GHC.HsFirstOrderApp -> First+    , arrowDirection =+        if isFwd+          then FunctionThenArgument+          else ArgumentThenFunction+    , function = mkExpression <$> fromGenLocated f+    , argument = mkExpression <$> fromGenLocated arg+    }+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkCmd (GHC.HsCmdArrForm _ f _ args) =+  ArrowForm+    { function = mkExpression <$> fromGenLocated f+    , arguments =+        fmap (flattenComments . fmap mkCmdFromHsCmdTop . fromGenLocated) args+    }+#else+mkCmd (GHC.HsCmdArrForm _ f _ _ args) =+  ArrowForm+    { function = mkExpression <$> fromGenLocated f+    , arguments =+        fmap (flattenComments . fmap mkCmdFromHsCmdTop . fromGenLocated) args+    }+#endif+mkCmd (GHC.HsCmdApp _ cmd arg) =+  CmdApp+    { cmd = mkCmd <$> fromGenLocated cmd+    , argument = mkExpression <$> fromGenLocated arg+    }+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLam _ GHC.LamSingle matches) =+  Lambda {matches = mkCmdMatchGroup matches}+mkCmd (GHC.HsCmdLam _ GHC.LamCase matches) =+  LambdaCase {usesCases = False, matches = mkCmdMatchGroup matches}+mkCmd (GHC.HsCmdLam _ GHC.LamCases matches) =+  LambdaCase {usesCases = True, matches = mkCmdMatchGroup matches}+#else+mkCmd (GHC.HsCmdLam _ matches) = Lambda {matches = mkCmdMatchGroup matches}+#endif+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdPar _ _ cmd _) = Parenthesized $ mkCmd <$> fromGenLocated cmd+#else+mkCmd (GHC.HsCmdPar _ cmd) = Parenthesized $ mkCmd <$> fromGenLocated cmd+#endif+mkCmd (GHC.HsCmdCase _ expr matches) =+  Case+    { scrutinee = mkExpression <$> fromGenLocated expr+    , matches = mkCmdMatchGroup matches+    }+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLamCase _ _ matches) =+  LambdaCase {usesCases = False, matches = mkCmdMatchGroup matches}+#elif !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLamCase _ matches) =+  LambdaCase {usesCases = False, matches = mkCmdMatchGroup matches}+#endif+mkCmd (GHC.HsCmdIf _ _ predicate thenCmd elseCmd) =+  If+    { predicate = mkExpression <$> fromGenLocated predicate+    , thenBranch = mkCmd <$> fromGenLocated thenCmd+    , elseBranch = mkCmd <$> fromGenLocated elseCmd+    }+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLet _ _ binds _ cmd) =+  Let+    { localBinds =+        fromMaybe+          (error "`ghc-lib-parser` never generates an empty `HsCmdLet` node.")+          $ mkLocalBinds binds+    , inCommand = mkCmd <$> fromGenLocated cmd+    }+#else+mkCmd (GHC.HsCmdLet _ binds cmd) =+  Let+    { localBinds =+        fromMaybe+          (error "`ghc-lib-parser` never generates an empty `HsCmdLet` node.")+          $ mkLocalBinds binds+    , inCommand = mkCmd <$> fromGenLocated cmd+    }+#endif+mkCmd (GHC.HsCmdDo _ stmts) =+  DoBlock+    { statements =+        fmap (fmap mkCmdStatement . fromGenLocated) <$> fromGenLocated stmts+    }+mkCmd _ = error "`ghc-lib-parser` never generates this AST node."++mkCmdFromHsCmdTop :: GHC.HsCmdTop GHC.GhcPs -> WithComments Cmd+mkCmdFromHsCmdTop (GHC.HsCmdTop _ cmd) = mkCmd <$> fromGenLocated cmd++newtype CmdDoBlock =+  CmdDoBlock Cmd++instance CommentExtraction CmdDoBlock where+  nodeComments _ = emptyNodeComments++instance Pretty CmdDoBlock where+  pretty' (CmdDoBlock DoBlock {statements = stmts}) =+    prettyWith stmts $ lined . fmap pretty+  pretty' (CmdDoBlock _) =+    error "mkCmdDoBlock must be used before pretty-printing CmdDoBlock"++mkCmdDoBlock :: Cmd -> Maybe CmdDoBlock+mkCmdDoBlock cmd+  | DoBlock {} <- cmd = Just (CmdDoBlock cmd)+  | otherwise = Nothing

+ src/HIndent/Ast/Cmd.hs-boot view

@@ -0,0 +1,10 @@+module HIndent.Ast.Cmd+  ( Cmd+  , mkCmd+  ) where++import qualified GHC.Hs as GHC++data Cmd++mkCmd :: GHC.HsCmd GHC.GhcPs -> Cmd

+ src/HIndent/Ast/Comment.hs view

@@ -0,0 +1,35 @@+module HIndent.Ast.Comment+  ( Comment+  , mkComment+  ) where++import qualified GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..))++data Comment+  = Line String+  | Block String+  deriving (Eq, Show)++instance CommentExtraction Comment where+  nodeComments _ = mempty++instance Pretty Comment where+  pretty' (Line c) = string c+  pretty' (Block c) =+    case lines c of+      [] -> pure ()+      [x] -> string x+      (x:xs) -> do+        string x+        newline+        -- 'indentedWithFixedLevel 0' is used because a 'BlockComment'+        -- contains indent spaces for all lines except the first one.+        indentedWithFixedLevel 0 $ lined $ fmap string xs++mkComment :: GHC.EpaCommentTok -> Comment+mkComment (GHC.EpaLineComment c) = Line c+mkComment (GHC.EpaBlockComment c) = Block c+mkComment _ = Line ""

src/HIndent/Ast/Declaration/Annotation.hs view

@@ -7,7 +7,9 @@   ) where  import HIndent.Ast.Declaration.Annotation.Provenance+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression) import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators@@ -15,7 +17,7 @@  data Annotation = Annotation   { provenance :: Provenance-  , expr :: GHC.LHsExpr GHC.GhcPs+  , expr :: WithComments Expression   }  instance CommentExtraction Annotation where@@ -27,9 +29,13 @@  mkAnnotation :: GHC.AnnDecl GHC.GhcPs -> Annotation #if MIN_VERSION_ghc_lib_parser(9, 6, 1)-mkAnnotation (GHC.HsAnnotation _ prov expr) =-  Annotation {provenance = mkProvenance prov, ..}+mkAnnotation (GHC.HsAnnotation _ prov expression) = Annotation {..}+  where+    provenance = mkProvenance prov+    expr = mkExpression <$> fromGenLocated expression #else-mkAnnotation (GHC.HsAnnotation _ _ prov expr) =-  Annotation {provenance = mkProvenance prov, ..}+mkAnnotation (GHC.HsAnnotation _ _ prov expression) = Annotation {..}+  where+    provenance = mkProvenance prov+    expr = mkExpression <$> fromGenLocated expression #endif

src/HIndent/Ast/Declaration/Bind.hs view

@@ -6,14 +6,14 @@   , mkBind   ) where -import HIndent.Ast.Name.Infix-import HIndent.Ast.Name.Prefix-import HIndent.Ast.NodeComments+import HIndent.Ast.Declaration.Bind.GuardedRhs+import HIndent.Ast.Declaration.PatternSynonym+import HIndent.Ast.MatchGroup (MatchGroup, mkExprMatchGroup)+import HIndent.Ast.Pattern+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  -- The difference between `Function` and `Pattern` is the same as the difference -- between `FunBind` and `PatBind` in GHC AST. See@@ -21,56 +21,29 @@ -- -- TODO: Merge them. data Bind-  = Function-      { fun_matches :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)-      }+  = Function MatchGroup   | 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+      { lhs :: WithComments Pattern+      , rhs :: WithComments GuardedRhs       }+  | PatternSynonym (WithComments PatternSynonym)  instance CommentExtraction Bind where-  nodeComments Function {} = NodeComments [] [] []-  nodeComments Pattern {} = NodeComments [] [] []-  nodeComments PatternSynonym {} = NodeComments [] [] []+  nodeComments Function {} = emptyNodeComments+  nodeComments Pattern {} = emptyNodeComments+  nodeComments PatternSynonym {} = emptyNodeComments  instance Pretty Bind where-  pretty' Function {..} = pretty fun_matches+  pretty' (Function matches) = pretty matches   pretty' Pattern {..} = pretty lhs >> pretty rhs-  pretty' PatternSynonym {..} = do-    string "pattern "-    case parameters of-      GHC.InfixCon l r ->-        spaced-          [ pretty $ fmap mkPrefixName l-          , pretty $ fmap mkInfixName name-          , pretty $ fmap mkPrefixName r-          ]-      GHC.PrefixCon _ [] -> pretty $ fmap mkPrefixName name-      _ -> spaced [pretty $ fmap mkPrefixName name, pretty parameters]-    spacePrefixed [pretty direction, pretty $ fmap PatInsidePatDecl definition]-    case direction of-      GHC.ExplicitBidirectional matches -> do-        newline-        indentedBlock $ string "where " |=> pretty matches-      _ -> pure ()+  pretty' (PatternSynonym ps) = pretty ps  mkBind :: GHC.HsBind GHC.GhcPs -> Bind-mkBind GHC.FunBind {..} = Function {..}+mkBind GHC.FunBind {..} = Function $ mkExprMatchGroup fun_matches 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+    lhs = mkPattern <$> fromGenLocated pat_lhs+    rhs = mkWithComments $ mkGuardedRhs pat_rhs+mkBind (GHC.PatSynBind _ psb) =+  PatternSynonym $ mkWithComments $ mkPatternSynonym psb mkBind _ = error "This AST node should not appear."

+ src/HIndent/Ast/Declaration/Bind/GuardedRhs.hs view

@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Bind.GuardedRhs+  ( GuardedRhs+  , mkGuardedRhs+  , mkCaseGuardedRhs+  , mkLambdaGuardedRhs+  , mkMultiWayIfGuardedRhs+  , mkCaseCmdGuardedRhs+  , mkLambdaCmdGuardedRhs+  ) where++import HIndent.Applicative (whenJust)+import HIndent.Ast.Guard+  ( Guard+  , mkCaseCmdGuard+  , mkCaseExprGuard+  , mkExprGuard+  , mkLambdaCmdGuard+  , mkLambdaExprGuard+  , mkMultiWayIfExprGuard+  )+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromGenLocated, prettyWith)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data GuardedRhs = GuardedRhs+  { guards :: [WithComments Guard]+  , localBinds :: Maybe (WithComments LocalBinds)+  }++instance CommentExtraction GuardedRhs where+  nodeComments _ = NodeComments [] [] []++instance Pretty GuardedRhs where+  pretty' GuardedRhs {..} = do+    mapM_ pretty guards+    whenJust localBinds $ \lbs ->+      indentedBlock+        $ newlinePrefixed+            [string "where", prettyWith lbs $ indentedBlock . pretty]++mkGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkCaseGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkCaseGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkCaseExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkLambdaGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkLambdaGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkLambdaExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkMultiWayIfGuardedRhs ::+     GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkMultiWayIfGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkMultiWayIfExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkCaseCmdGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> GuardedRhs+mkCaseCmdGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkCaseCmdGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkLambdaCmdGuardedRhs ::+     GHC.GRHSs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> GuardedRhs+mkLambdaCmdGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkLambdaCmdGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }

src/HIndent/Ast/Declaration/Class.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}  module HIndent.Ast.Declaration.Class@@ -7,7 +8,6 @@  import Control.Monad import Data.Maybe-import qualified GHC.Data.Bag as GHC import HIndent.Applicative import HIndent.Ast.Context import HIndent.Ast.Declaration.Class.FunctionalDependency@@ -19,7 +19,9 @@ import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments import HIndent.Pretty.SigBindFamily-+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified GHC.Data.Bag as GHC+#endif data ClassDeclaration = ClassDeclaration   { context :: Maybe (WithComments Context)   , nameAndTypeVariables :: NameAndTypeVariables@@ -55,6 +57,7 @@           $ newline >> indentedBlock (string "where")  mkClassDeclaration :: GHC.TyClDecl GHC.GhcPs -> Maybe ClassDeclaration+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) mkClassDeclaration x@GHC.ClassDecl {..}   | Just nameAndTypeVariables <- mkNameAndTypeVariables x =     Just ClassDeclaration {..}@@ -63,5 +66,22 @@     functionalDependencies =       fmap (fmap mkFunctionalDependency . fromGenLocated) tcdFDs     associatedThings =-      mkSortedLSigBindFamilyList tcdSigs (GHC.bagToList tcdMeths) tcdATs [] []+      mkSortedLSigBindFamilyList tcdSigs tcdMeths tcdATs [] tcdATDefs []+#else+mkClassDeclaration x@GHC.ClassDecl {..}+  | Just nameAndTypeVariables <- mkNameAndTypeVariables x =+    Just ClassDeclaration {..}+  where+    context = fmap (fmap mkContext . fromGenLocated) tcdCtxt+    functionalDependencies =+      fmap (fmap mkFunctionalDependency . fromGenLocated) tcdFDs+    associatedThings =+      mkSortedLSigBindFamilyList+        tcdSigs+        (GHC.bagToList tcdMeths)+        tcdATs+        []+        tcdATDefs+        []+#endif mkClassDeclaration _ = Nothing

src/HIndent/Ast/Declaration/Data/Body.hs view

@@ -9,7 +9,7 @@  import Control.Monad import Data.Maybe-import GHC.Hs (HsDataDefn(dd_derivs))+import GHC.Hs (HsDataDefn(dd_derivs, dd_kindSig)) import qualified GHC.Types.SrcLoc as GHC import HIndent.Applicative import HIndent.Ast.Declaration.Data.Deriving.Clause@@ -27,9 +27,11 @@   = GADT       { kind :: Maybe (WithComments Type)       , constructors :: [WithComments GADTConstructor]+      , derivings :: DerivingClause       }   | Haskell98-      { constructorsH98 :: [WithComments Haskell98Constructor]+      { kind :: Maybe (WithComments Type)+      , constructorsH98 :: [WithComments Haskell98Constructor]       , derivings :: DerivingClause       } @@ -41,8 +43,19 @@   pretty' GADT {..} = do     whenJust kind $ \x -> string " :: " >> pretty x     string " where"-    indentedBlock $ newlinePrefixed $ fmap pretty constructors+    case constructors of+      [] ->+        when (hasDerivings derivings) $ do+          newline+          indentedBlock $ pretty derivings+      _ ->+        indentedBlock $ do+          newlinePrefixed $ fmap pretty constructors+          when (hasDerivings derivings) $ do+            newline+            pretty derivings   pretty' Haskell98 {..} = do+    whenJust kind $ \x -> string " :: " >> pretty x     case constructorsH98 of       [] -> indentedBlock derivingsAfterNewline       [x]

+ src/HIndent/Ast/Declaration/Data/Constructor/Field.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Constructor.Field+  ( ConstructorField+  , mkConstructorField+  ) where++import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.NodeComments++newtype ConstructorField = ConstructorField+  { ty :: WithComments Type+  }++instance CommentExtraction ConstructorField where+  nodeComments ConstructorField {} = NodeComments [] [] []++instance Pretty ConstructorField where+  pretty' ConstructorField {..} = pretty ty++mkConstructorField ::+     GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs) -> ConstructorField+mkConstructorField (GHC.HsScaled _ bangTy) =+  ConstructorField {ty = mkType <$> fromGenLocated bangTy}

src/HIndent/Ast/Declaration/Data/Deriving.hs view

@@ -9,6 +9,7 @@ import HIndent.Applicative import HIndent.Ast.Declaration.Data.Deriving.Strategy import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType) import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty@@ -17,7 +18,7 @@  data Deriving = Deriving   { strategy :: Maybe (WithComments DerivingStrategy)-  , classes :: WithComments [GHC.LHsSigType GHC.GhcPs]+  , classes :: WithComments [WithComments Type]   }  instance CommentExtraction Deriving where@@ -41,7 +42,10 @@   where     strategy =       fmap (fmap mkDerivingStrategy . fromGenLocated) deriv_clause_strategy-    classes =-      case deriv_clause_tys of-        GHC.L ann (GHC.DctSingle _ ty) -> fromGenLocated (GHC.L ann [ty])-        GHC.L ann (GHC.DctMulti _ tys) -> fromGenLocated (GHC.L ann tys)+    classes = fromGenLocated $ fmap (const rawClasses) deriv_clause_tys+    rawClasses =+      case GHC.unLoc deriv_clause_tys of+        GHC.DctSingle _ ty ->+          [flattenComments $ mkTypeFromHsSigType <$> fromGenLocated ty]+        GHC.DctMulti _ tys ->+          flattenComments . fmap mkTypeFromHsSigType . fromGenLocated <$> tys

src/HIndent/Ast/Declaration/Data/Deriving/Strategy.hs view

@@ -5,6 +5,8 @@   ) where  import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType)+import HIndent.Ast.WithComments (WithComments, flattenComments, fromGenLocated) import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators@@ -14,7 +16,7 @@   = Stock   | Anyclass   | Newtype-  | Via (GHC.LHsSigType GHC.GhcPs)+  | Via (WithComments Type)  instance CommentExtraction DerivingStrategy where   nodeComments Stock {} = NodeComments [] [] []@@ -32,7 +34,8 @@ mkDerivingStrategy GHC.StockStrategy {} = Stock mkDerivingStrategy GHC.AnyclassStrategy {} = Anyclass mkDerivingStrategy GHC.NewtypeStrategy {} = Newtype-mkDerivingStrategy (GHC.ViaStrategy (GHC.XViaStrategyPs _ x)) = Via x+mkDerivingStrategy (GHC.ViaStrategy (GHC.XViaStrategyPs _ x)) =+  Via $ flattenComments $ mkTypeFromHsSigType <$> fromGenLocated x  isViaStrategy :: DerivingStrategy -> Bool isViaStrategy Via {} = True

src/HIndent/Ast/Declaration/Data/GADT/Constructor/Signature.hs view

@@ -19,30 +19,26 @@ import HIndent.Printer  data ConstructorSignature-  = ByArrows-      { parameters :: [WithComments Type]-      , result :: WithComments Type-      }+  = ByArrows (WithComments Type)   | Record       { fields :: WithComments [WithComments RecordField]       , result :: WithComments Type       }  instance CommentExtraction ConstructorSignature where-  nodeComments ByArrows {} = NodeComments [] [] []+  nodeComments (ByArrows _) = NodeComments [] [] []   nodeComments Record {} = NodeComments [] [] []  prettyHorizontally :: ConstructorSignature -> Printer ()-prettyHorizontally ByArrows {..} =-  inter (string " -> ") $ fmap pretty parameters ++ [pretty result]+prettyHorizontally (ByArrows signature) = pretty signature prettyHorizontally Record {..} =   inter     (string " -> ")     [prettyWith fields (vFields' . fmap pretty), pretty result]  prettyVertically :: ConstructorSignature -> Printer ()-prettyVertically ByArrows {..} =-  prefixedLined "-> " $ fmap pretty parameters ++ [pretty result]+prettyVertically (ByArrows signature) =+  pretty $ fmap mkVerticalFuncType signature prettyVertically Record {..} =   prefixedLined     "-> "@@ -51,20 +47,10 @@ mkConstructorSignature :: GHC.ConDecl GHC.GhcPs -> Maybe ConstructorSignature #if MIN_VERSION_ghc_lib_parser(9, 10, 1) mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT _ xs, ..} =-  Just-    $ ByArrows-        { parameters =-            fmap (fmap mkType . fromGenLocated . GHC.hsScaledThing) xs-        , result = mkType <$> fromGenLocated con_res_ty-        }+  Just $ ByArrows (buildFunctionType xs con_res_ty) #else mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT xs, ..} =-  Just-    $ ByArrows-        { parameters =-            fmap (fmap mkType . fromGenLocated . GHC.hsScaledThing) xs-        , result = mkType <$> fromGenLocated con_res_ty-        }+  Just $ ByArrows (buildFunctionType xs con_res_ty) #endif #if MIN_VERSION_ghc_lib_parser(9, 10, 1) mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT _ xs, ..} =@@ -95,3 +81,25 @@         } #endif mkConstructorSignature GHC.ConDeclH98 {} = Nothing++buildFunctionType ::+     [GHC.HsScaled GHC.GhcPs (GHC.LHsType GHC.GhcPs)]+  -> GHC.LHsType GHC.GhcPs+  -> WithComments Type+buildFunctionType scaledTypes resultTy =+  mkType <$> fromGenLocated (foldr mkFun resultTy scaledTypes)++mkFun ::+     GHC.HsScaled GHC.GhcPs (GHC.LHsType GHC.GhcPs)+  -> GHC.LHsType GHC.GhcPs+  -> GHC.LHsType GHC.GhcPs+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkFun (GHC.HsScaled mult paramTy) accTy =+  GHC.noLocA (GHC.HsFunTy GHC.noExtField mult paramTy accTy)+#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)+mkFun (GHC.HsScaled mult paramTy) accTy =+  GHC.noLocA (GHC.HsFunTy GHC.noAnn mult paramTy accTy)+#else+mkFun (GHC.HsScaled mult paramTy) accTy =+  GHC.noLocA (GHC.HsFunTy GHC.NoExtField mult paramTy accTy)+#endif

src/HIndent/Ast/Declaration/Data/Haskell98/Constructor/Body.hs view

@@ -6,6 +6,7 @@   , isRecord   ) where +import HIndent.Ast.Declaration.Data.Constructor.Field import HIndent.Ast.Declaration.Data.Record.Field import HIndent.Ast.Name.Infix import HIndent.Ast.Name.Prefix@@ -19,12 +20,12 @@ data Haskell98ConstructorBody   = Infix       { iName :: WithComments InfixName -- Using `name` in all constructors causes a type clash-      , left :: GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)-      , right :: GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)+      , left :: ConstructorField+      , right :: ConstructorField       }   | Prefix       { pName :: WithComments PrefixName-      , types :: [GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)]+      , types :: [ConstructorField]       }   | Record       { rName :: WithComments PrefixName@@ -49,15 +50,19 @@  mkHaskell98ConstructorBody ::      GHC.ConDecl GHC.GhcPs -> Maybe Haskell98ConstructorBody-mkHaskell98ConstructorBody GHC.ConDeclH98 { con_args = GHC.InfixCon left right+mkHaskell98ConstructorBody GHC.ConDeclH98 { con_args = GHC.InfixCon leftField rightField                                           , ..                                           } = Just Infix {..}   where     iName = fromGenLocated $ fmap mkInfixName con_name-mkHaskell98ConstructorBody GHC.ConDeclH98 {con_args = GHC.PrefixCon _ types, ..} =-  Just Prefix {..}+    left = mkConstructorField leftField+    right = mkConstructorField rightField+mkHaskell98ConstructorBody GHC.ConDeclH98 { con_args = GHC.PrefixCon _ rawTypes+                                          , ..+                                          } = Just Prefix {..}   where     pName = fromGenLocated $ fmap mkPrefixName con_name+    types = fmap mkConstructorField rawTypes mkHaskell98ConstructorBody GHC.ConDeclH98 {con_args = GHC.RecCon rs, ..} =   Just Record {..}   where

src/HIndent/Ast/Declaration/Data/Record/Field.hs view

@@ -5,15 +5,18 @@   , mkRecordField   ) where +import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc) import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Ast.Type+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 RecordField = RecordField-  { names :: [GHC.LFieldOcc GHC.GhcPs]-  , ty :: GHC.LBangType GHC.GhcPs+  { names :: [WithComments FieldName]+  , ty :: WithComments Type   }  instance CommentExtraction RecordField where@@ -26,5 +29,5 @@ mkRecordField :: GHC.ConDeclField GHC.GhcPs -> RecordField mkRecordField GHC.ConDeclField {..} = RecordField {..}   where-    names = cd_fld_names-    ty = cd_fld_type+    names = fmap mkFieldNameFromFieldOcc . fromGenLocated <$> cd_fld_names+    ty = mkType <$> fromGenLocated cd_fld_type

src/HIndent/Ast/Declaration/Default.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module HIndent.Ast.Declaration.Default   ( DefaultDeclaration   , mkDefaultDeclaration@@ -5,12 +7,14 @@  import qualified GHC.Hs as GHC import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments  newtype DefaultDeclaration =-  DefaultDeclaration [GHC.LHsType GHC.GhcPs]+  DefaultDeclaration [WithComments Type]  instance CommentExtraction DefaultDeclaration where   nodeComments DefaultDeclaration {} = NodeComments [] [] []@@ -20,4 +24,10 @@     spaced [string "default", hTuple $ fmap pretty xs]  mkDefaultDeclaration :: GHC.DefaultDecl GHC.GhcPs -> DefaultDeclaration-mkDefaultDeclaration (GHC.DefaultDecl _ xs) = DefaultDeclaration xs+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkDefaultDeclaration (GHC.DefaultDecl _ _ xs) =+  DefaultDeclaration $ fmap (fmap mkType . fromGenLocated) xs+#else+mkDefaultDeclaration (GHC.DefaultDecl _ xs) =+  DefaultDeclaration $ fmap (fmap mkType . fromGenLocated) xs+#endif

src/HIndent/Ast/Declaration/Family/Type/ResultSignature.hs view

@@ -4,6 +4,7 @@   ) where  import HIndent.Ast.NodeComments+import HIndent.Ast.Type import HIndent.Ast.Type.Variable import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC@@ -13,7 +14,7 @@  data ResultSignature   = NoSig-  | Kind (GHC.LHsKind GHC.GhcPs)+  | Kind (WithComments Type)   | TypeVariable (WithComments TypeVariable)  instance CommentExtraction ResultSignature where@@ -28,7 +29,7 @@  mkResultSignature :: GHC.FamilyResultSig GHC.GhcPs -> ResultSignature mkResultSignature (GHC.NoSig _) = NoSig-mkResultSignature (GHC.KindSig _ x) = Kind x+mkResultSignature (GHC.KindSig _ x) = Kind $ mkType <$> fromGenLocated x mkResultSignature (GHC.TyVarSig _ x) = TypeVariable var   where     var = mkTypeVariable <$> fromGenLocated x

src/HIndent/Ast/Declaration/Foreign.hs view

@@ -14,6 +14,7 @@ import HIndent.Ast.Declaration.Foreign.Safety import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType) import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty@@ -28,13 +29,13 @@       , safety :: Safety       , srcIdent :: Maybe String       , dstIdent :: WithComments PrefixName-      , signature :: GHC.LHsSigType GHC.GhcPs+      , signature :: WithComments Type       }   | ForeignExport       { convention :: CallingConvention       , srcIdent :: Maybe String       , dstIdent :: WithComments PrefixName-      , signature :: GHC.LHsSigType GHC.GhcPs+      , signature :: WithComments Type       }  instance CommentExtraction ForeignDeclaration where@@ -66,7 +67,8 @@         GHC.SourceText s -> Just $ GHC.unpackFS s         _ -> Nothing     dstIdent = fromGenLocated $ fmap mkPrefixName fd_name-    signature = fd_sig_ty+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ src) (GHC.L _ (GHC.CExportStatic _ _ conv)))                                        , ..                                        } = ForeignExport {..}@@ -77,7 +79,8 @@         GHC.SourceText s -> Just $ GHC.unpackFS s         _ -> Nothing     dstIdent = fromGenLocated $ fmap mkPrefixName fd_name-    signature = fd_sig_ty+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty #elif MIN_VERSION_ghc_lib_parser(9, 6, 0) mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ src) (GHC.L _ conv) (GHC.L _ sfty) _ _)                                        , ..@@ -90,7 +93,8 @@         GHC.SourceText s -> Just s         _ -> Nothing     dstIdent = fromGenLocated $ fmap mkPrefixName fd_name-    signature = fd_sig_ty+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ src) (GHC.L _ (GHC.CExportStatic _ _ conv)))                                        , ..                                        } = ForeignExport {..}@@ -101,7 +105,8 @@         GHC.SourceText s -> Just s         _ -> Nothing     dstIdent = fromGenLocated $ fmap mkPrefixName fd_name-    signature = fd_sig_ty+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty #else mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ conv) (GHC.L _ sfty) _ _ (GHC.L _ src))                                        , ..@@ -114,7 +119,8 @@         GHC.SourceText s -> Just s         _ -> Nothing     dstIdent = fromGenLocated $ fmap mkPrefixName fd_name-    signature = fd_sig_ty+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ (GHC.CExportStatic _ _ conv)) (GHC.L _ src))                                        , ..                                        } = ForeignExport {..}@@ -125,5 +131,6 @@         GHC.SourceText s -> Just s         _ -> Nothing     dstIdent = fromGenLocated $ fmap mkPrefixName fd_name-    signature = fd_sig_ty+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty #endif

src/HIndent/Ast/Declaration/Instance/Class.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}  module HIndent.Ast.Declaration.Instance.Class@@ -6,25 +7,26 @@   ) where  import Control.Monad-import qualified GHC.Data.Bag as GHC import HIndent.Applicative import HIndent.Ast.Declaration.Instance.Class.OverlapMode import HIndent.Ast.NodeComments+import HIndent.Ast.Type (InstDeclType, mkInstDeclType) 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.SigBindFamily-import HIndent.Pretty.Types-+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified GHC.Data.Bag as GHC+#endif data ClassInstance = ClassInstance   { overlapMode :: Maybe (WithComments OverlapMode)   , cid_sigs :: [GHC.LSig GHC.GhcPs]-  , cid_binds :: GHC.LHsBinds GHC.GhcPs+  , binds :: [GHC.LocatedA (GHC.HsBindLR GHC.GhcPs GHC.GhcPs)]   , cid_tyfam_insts :: [GHC.LTyFamInstDecl GHC.GhcPs]   , cid_datafam_insts :: [GHC.LDataFamInstDecl GHC.GhcPs]-  , cid_poly_ty :: GHC.LHsSigType GHC.GhcPs+  , cid_poly_ty :: WithComments InstDeclType   }  instance CommentExtraction ClassInstance where@@ -36,8 +38,7 @@       whenJust overlapMode $ \x -> do         pretty x         space-      pretty (fmap HsSigTypeInsideInstDecl cid_poly_ty)-        |=> unless (null sigsAndMethods) (string " where")+      pretty cid_poly_ty |=> unless (null sigsAndMethods) (string " where")     unless (null sigsAndMethods) $ do       newline       indentedBlock $ lined $ fmap pretty sigsAndMethods@@ -45,14 +46,32 @@       sigsAndMethods =         mkSortedLSigBindFamilyList           cid_sigs-          (GHC.bagToList cid_binds)+          binds           []           cid_tyfam_insts+          []           cid_datafam_insts  mkClassInstance :: GHC.InstDecl GHC.GhcPs -> Maybe ClassInstance+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) mkClassInstance GHC.ClsInstD {cid_inst = GHC.ClsInstDecl {..}} =-  Just $ ClassInstance {..}-  where-    overlapMode = fmap (fmap mkOverlapMode . fromGenLocated) cid_overlap_mode+  Just+    $ ClassInstance+        { cid_poly_ty =+            flattenComments $ mkInstDeclType <$> fromGenLocated cid_poly_ty+        , binds = cid_binds+        , overlapMode = fmap mkOverlapMode . fromGenLocated <$> cid_overlap_mode+        , ..+        }+#else+mkClassInstance GHC.ClsInstD {cid_inst = GHC.ClsInstDecl {..}} =+  Just+    $ ClassInstance+        { cid_poly_ty =+            flattenComments $ mkInstDeclType <$> fromGenLocated cid_poly_ty+        , binds = GHC.bagToList cid_binds+        , overlapMode = fmap mkOverlapMode . fromGenLocated <$> cid_overlap_mode+        , ..+        }+#endif mkClassInstance _ = Nothing

src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module HIndent.Ast.Declaration.Instance.Class.OverlapMode   ( OverlapMode   , mkOverlapMode@@ -34,3 +36,10 @@ mkOverlapMode GHC.Overlapping {} = Overlapping mkOverlapMode GHC.Overlaps {} = Overlaps mkOverlapMode GHC.Incoherent {} = Incoherent+#if MIN_VERSION_ghc_lib_parser(9, 8, 0)+-- From https://hackage-content.haskell.org/package/ghc-9.12.2/docs/GHC-Core-InstEnv.html#v:NonCanonical+-- > We don't have surface syntax for the distinction between Incoherent and NonCanonical instances; instead,+-- > the flag `-f{no-}specialise-incoherents` (on by default) controls whether INCOHERENT instances are+-- > regarded as Incoherent or NonCanonical.+mkOverlapMode GHC.NonCanonical {} = Incoherent+#endif

src/HIndent/Ast/Declaration/Instance/Family/Type.hs view

@@ -7,6 +7,7 @@  import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Type import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty@@ -16,13 +17,13 @@ data TypeFamilyInstance = TypeFamilyInstance   { name :: WithComments PrefixName   , types :: GHC.HsFamEqnPats GHC.GhcPs-  , bind :: GHC.LHsType GHC.GhcPs+  , bind :: WithComments Type   } #else data TypeFamilyInstance = TypeFamilyInstance   { name :: WithComments PrefixName   , types :: GHC.HsTyPats GHC.GhcPs-  , bind :: GHC.LHsType GHC.GhcPs+  , bind :: WithComments Type   } #endif instance CommentExtraction TypeFamilyInstance where@@ -40,5 +41,5 @@   where     name = fromGenLocated $ fmap mkPrefixName feqn_tycon     types = feqn_pats-    bind = feqn_rhs+    bind = mkType <$> fromGenLocated feqn_rhs mkTypeFamilyInstance _ = Nothing

+ src/HIndent/Ast/Declaration/Instance/Family/Type/Associated.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE RecordWildCards, CPP #-}++module HIndent.Ast.Declaration.Instance.Family.Type.Associated+  ( AssociatedType+  , mkAssociatedType+  ) 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++newtype AssociatedType =+  AssociatedType (GHC.FamEqn GHC.GhcPs (GHC.LocatedA (GHC.HsType GHC.GhcPs)))++instance CommentExtraction AssociatedType where+  nodeComments (AssociatedType _) = NodeComments [] [] []++instance Pretty AssociatedType where+  pretty' (AssociatedType equation) = string "type " >> pretty equation++mkAssociatedType :: GHC.TyFamInstDecl GHC.GhcPs -> AssociatedType+mkAssociatedType GHC.TyFamInstDecl {..} = AssociatedType tfid_eqn

+ src/HIndent/Ast/Declaration/Instance/Family/Type/Associated/Default.hs view

@@ -0,0 +1,27 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module HIndent.Ast.Declaration.Instance.Family.Type.Associated.Default+  ( AssociatedTypeDefault+  , mkAssociatedTypeDefault+  ) 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++newtype AssociatedTypeDefault =+  AssociatedTypeDefault+    (GHC.FamEqn GHC.GhcPs (GHC.LocatedA (GHC.HsType GHC.GhcPs)))++instance CommentExtraction AssociatedTypeDefault where+  nodeComments (AssociatedTypeDefault _) = NodeComments [] [] []++instance Pretty AssociatedTypeDefault where+  pretty' (AssociatedTypeDefault equation) =+    string "type instance " >> pretty equation++mkAssociatedTypeDefault :: GHC.TyFamInstDecl GHC.GhcPs -> AssociatedTypeDefault+mkAssociatedTypeDefault GHC.TyFamInstDecl {..} = AssociatedTypeDefault tfid_eqn

+ src/HIndent/Ast/Declaration/PatternSynonym.hs view

@@ -0,0 +1,97 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.PatternSynonym+  ( PatternSynonym+  , mkPatternSynonym+  ) where++import HIndent.Applicative+import HIndent.Ast.MatchGroup (MatchGroup, mkExprMatchGroup)+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc)+import HIndent.Ast.Pattern+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 Parameters+  = Prefix+      { args :: [WithComments PrefixName]+      }+  | Infix+      { leftArg :: WithComments PrefixName+      , rightArg :: WithComments PrefixName+      }+  | Record+      { fields :: [WithComments FieldName]+      }++data PatternSynonym = PatternSynonym+  { name :: GHC.LIdP GHC.GhcPs+  , parameters :: WithComments Parameters+  , isImplicitBidirectional :: Bool+  , explicitMatches :: Maybe MatchGroup+  , definition :: WithComments PatInsidePatDecl+  }++instance CommentExtraction Parameters where+  nodeComments Prefix {} = emptyNodeComments+  nodeComments Infix {} = emptyNodeComments+  nodeComments Record {} = emptyNodeComments++instance CommentExtraction PatternSynonym where+  nodeComments PatternSynonym {} = emptyNodeComments++instance Pretty Parameters where+  pretty' Prefix {..} = spaced $ fmap pretty args+  pretty' Infix {..} = spaced [pretty leftArg, pretty rightArg]+  pretty' Record {..} = hFields $ fmap pretty fields++instance Pretty PatternSynonym where+  pretty' PatternSynonym {..} = do+    string "pattern "+    case getNode parameters of+      Infix {..} ->+        spaced [pretty leftArg, pretty $ fmap mkInfixName name, pretty rightArg]+      Prefix {args = []} -> pretty $ fmap mkPrefixName name+      _ -> spaced [pretty $ fmap mkPrefixName name, pretty parameters]+    let arrow =+          if isImplicitBidirectional+            then "="+            else "<-"+    spacePrefixed [string arrow, pretty definition]+    whenJust explicitMatches $ \matches -> do+      newline+      indentedBlock $ string "where " |=> pretty matches++mkParameters :: GHC.HsPatSynDetails GHC.GhcPs -> Parameters+mkParameters (GHC.PrefixCon _ args) =+  Prefix {args = map (fromGenLocated . fmap mkPrefixName) args}+mkParameters (GHC.InfixCon l r) =+  Infix+    { leftArg = fromGenLocated $ fmap mkPrefixName l+    , rightArg = fromGenLocated $ fmap mkPrefixName r+    }+mkParameters (GHC.RecCon fields) =+  Record+    { fields =+        map+          (mkWithComments . mkFieldNameFromFieldOcc . GHC.recordPatSynField)+          fields+    }++mkPatternSynonym :: GHC.PatSynBind GHC.GhcPs GHC.GhcPs -> PatternSynonym+mkPatternSynonym GHC.PSB {..} = PatternSynonym {..}+  where+    name = psb_id+    parameters = mkWithComments $ mkParameters psb_args+    (isImplicitBidirectional, explicitMatches) =+      case psb_dir of+        GHC.Unidirectional -> (False, Nothing)+        GHC.ImplicitBidirectional -> (True, Nothing)+        GHC.ExplicitBidirectional matches ->+          (False, Just $ mkExprMatchGroup matches)+    definition = mkPatInsidePatDecl <$> fromGenLocated psb_def

src/HIndent/Ast/Declaration/Rule.hs view

@@ -6,9 +6,10 @@   , mkRuleDeclaration   ) where -import qualified GHC.Core as GHC-import qualified GHC.Data.FastString as GHC+import qualified GHC.Types.Basic as GHC import HIndent.Ast.Declaration.Rule.Binder+import HIndent.Ast.Declaration.Rule.Name+import HIndent.Ast.Expression (Expression, mkExpression) import HIndent.Ast.NodeComments import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC@@ -17,10 +18,10 @@ import HIndent.Pretty.NodeComments  data RuleDeclaration = RuleDeclaration-  { name :: WithComments GHC.RuleName+  { name :: WithComments RuleName   , binders :: [WithComments RuleBinder]-  , lhs :: WithComments (GHC.HsExpr GHC.GhcPs)-  , rhs :: WithComments (GHC.HsExpr GHC.GhcPs)+  , lhs :: WithComments Expression+  , rhs :: WithComments Expression   }  instance CommentExtraction RuleDeclaration where@@ -28,12 +29,7 @@  instance Pretty RuleDeclaration where   pretty' (RuleDeclaration {..}) =-    spaced-      [ prettyWith name (doubleQuotes . string . GHC.unpackFS)-      , prettyLhs-      , string "="-      , pretty rhs-      ]+    spaced [pretty name, prettyLhs, string "=", pretty rhs]     where       prettyLhs =         if null binders@@ -48,10 +44,10 @@ mkRuleDeclaration :: GHC.RuleDecl GHC.GhcPs -> RuleDeclaration mkRuleDeclaration rule@GHC.HsRule {..} = RuleDeclaration {..}   where-    name = getName rule+    name = mkRuleName <$> getName rule     binders = fmap (fmap mkRuleBinder . fromGenLocated) rd_tmvs-    lhs = fromGenLocated rd_lhs-    rhs = fromGenLocated rd_rhs+    lhs = mkExpression <$> fromGenLocated rd_lhs+    rhs = mkExpression <$> fromGenLocated rd_rhs  getName :: GHC.RuleDecl GHC.GhcPs -> WithComments GHC.RuleName #if MIN_VERSION_ghc_lib_parser(9, 6, 1)

+ src/HIndent/Ast/Declaration/Rule.hs-boot view

@@ -0,0 +1,15 @@+module HIndent.Ast.Declaration.Rule+  ( RuleDeclaration+  , mkRuleDeclaration+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import {-# SOURCE #-} HIndent.Pretty++data RuleDeclaration++instance CommentExtraction RuleDeclaration+instance Pretty RuleDeclaration++mkRuleDeclaration :: GHC.RuleDecl GHC.GhcPs -> RuleDeclaration

src/HIndent/Ast/Declaration/Rule/Binder.hs view

@@ -7,6 +7,7 @@  import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Type import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty@@ -15,7 +16,7 @@  data RuleBinder = RuleBinder   { name :: WithComments PrefixName-  , signature :: Maybe (WithComments (GHC.HsType GHC.GhcPs))+  , signature :: Maybe (WithComments Type)   }  instance CommentExtraction RuleBinder where@@ -33,5 +34,5 @@     name = fromGenLocated $ fmap mkPrefixName n mkRuleBinder (GHC.RuleBndrSig _ n GHC.HsPS {..}) = RuleBinder {..}   where-    signature = Just $ fromGenLocated hsps_body+    signature = Just $ fromGenLocated $ fmap mkType hsps_body     name = fromGenLocated $ fmap mkPrefixName n

src/HIndent/Ast/Declaration/Rule/Collection.hs view

@@ -5,7 +5,7 @@   , mkRuleCollection   ) where -import HIndent.Ast.Declaration.Rule+import {-# SOURCE #-} HIndent.Ast.Declaration.Rule import HIndent.Ast.NodeComments import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC

+ src/HIndent/Ast/Declaration/Rule/Name.hs view

@@ -0,0 +1,23 @@+module HIndent.Ast.Declaration.Rule.Name+  ( RuleName+  , mkRuleName+  ) where++import qualified GHC.Data.FastString as GHC+import qualified GHC.Types.Basic as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype RuleName =+  RuleName String+  deriving (Eq, Show)++instance CommentExtraction RuleName where+  nodeComments _ = emptyNodeComments++instance Pretty RuleName where+  pretty' (RuleName name) = doubleQuotes $ string name++mkRuleName :: GHC.RuleName -> RuleName+mkRuleName = RuleName . GHC.unpackFS

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

@@ -16,31 +16,31 @@ import HIndent.Ast.Name.Infix import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Type (DeclSigType, Type, mkDeclSigType, mkTypeFromHsSigType) 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 :: [WithComments PrefixName]-      , parameters :: GHC.LHsSigWcType GHC.GhcPs+      , parameters :: WithComments DeclSigType       }   | Pattern       { names :: [WithComments PrefixName]-      , signature :: GHC.LHsSigType GHC.GhcPs+      , signature :: WithComments Type       }   | DefaultClassMethod       { names :: [WithComments PrefixName]-      , signature :: GHC.LHsSigType GHC.GhcPs+      , methodSig :: WithComments DeclSigType       }   | ClassMethod       { names :: [WithComments PrefixName]-      , signature :: GHC.LHsSigType GHC.GhcPs+      , methodSig :: WithComments DeclSigType       }   | Fixity       { opNames :: [WithComments InfixName] -- Using `names` causes a type conflict.@@ -53,9 +53,9 @@       }   | Specialise       { name :: WithComments PrefixName-      , sigs :: [GHC.LHsSigType GHC.GhcPs]+      , sigs :: [WithComments Type]       }-  | SpecialiseInstance (GHC.LHsSigType GHC.GhcPs)+  | SpecialiseInstance (WithComments Type)   | Minimal (WithComments BooleanFormula)   | Scc (WithComments PrefixName)   | Complete (WithComments [WithComments PrefixName])@@ -81,20 +81,15 @@     where       horizontal = do         space-        pretty $ HsSigTypeInsideDeclSig <$> GHC.hswc_body parameters+        pretty parameters       vertical = do         headLen <- printerLength printFunName         indentSpaces <- getIndentSpaces         if headLen < indentSpaces-          then space-                 |=> pretty-                       (HsSigTypeInsideDeclSig <$> GHC.hswc_body parameters)+          then space |=> pretty parameters           else do             newline-            indentedBlock-              $ indentedWithSpace 3-              $ pretty-              $ HsSigTypeInsideDeclSig <$> GHC.hswc_body parameters+            indentedBlock $ indentedWithSpace 3 $ pretty parameters       printFunName = hCommaSep $ fmap pretty names   pretty' Pattern {..} =     spaced@@ -103,25 +98,25 @@       , string "::"       , pretty signature       ]-  pretty' DefaultClassMethod {..} =-    spaced-      [ string "default"-      , hCommaSep $ fmap pretty names-      , string "::"-      , printCommentsAnd signature pretty-      ]+  pretty' DefaultClassMethod {..} = do+    string "default "+    hCommaSep $ fmap pretty names+    string " ::"+    hor <-|> ver+    where+      hor = space >> pretty methodSig+      ver = do+        newline+        indentedBlock $ indentedWithSpace 3 $ pretty methodSig   pretty' ClassMethod {..} = do     hCommaSep $ fmap pretty names     string " ::"     hor <-|> ver     where-      hor =-        space >> printCommentsAnd signature (pretty . HsSigTypeInsideDeclSig)+      hor = space >> pretty methodSig       ver = do         newline-        indentedBlock-          $ indentedWithSpace 3-          $ printCommentsAnd signature (pretty . HsSigTypeInsideDeclSig)+        indentedBlock $ indentedWithSpace 3 $ pretty methodSig   pretty' Fixity {..} = spaced [pretty fixity, hCommaSep $ fmap pretty opNames]   pretty' Inline {..} = do     string "{-# "@@ -153,18 +148,24 @@       ]  mkSignature :: GHC.Sig GHC.GhcPs -> Signature-mkSignature (GHC.TypeSig _ ns parameters) = Type {..}+mkSignature (GHC.TypeSig _ ns GHC.HsWC { hswc_ext = GHC.NoExtField+                                       , GHC.hswc_body = params+                                       }) = Type {..}   where     names = fmap (fromGenLocated . fmap mkPrefixName) ns-mkSignature (GHC.PatSynSig _ ns signature) = Pattern {..}+    parameters = flattenComments $ mkDeclSigType <$> fromGenLocated params+mkSignature (GHC.PatSynSig _ ns s) = Pattern {..}   where     names = fmap (fromGenLocated . fmap mkPrefixName) ns-mkSignature (GHC.ClassOpSig _ True ns signature) = DefaultClassMethod {..}+    signature = flattenComments $ mkTypeFromHsSigType <$> fromGenLocated s+mkSignature (GHC.ClassOpSig _ True ns s) = DefaultClassMethod {..}   where     names = fmap (fromGenLocated . fmap mkPrefixName) ns-mkSignature (GHC.ClassOpSig _ False ns signature) = ClassMethod {..}+    methodSig = flattenComments $ mkDeclSigType <$> fromGenLocated s+mkSignature (GHC.ClassOpSig _ False ns s) = ClassMethod {..}   where     names = fmap (fromGenLocated . fmap mkPrefixName) ns+    methodSig = flattenComments $ mkDeclSigType <$> fromGenLocated s mkSignature (GHC.FixSig _ (GHC.FixitySig _ ops fy)) = Fixity {..}   where     fixity = mkFixity fy@@ -174,9 +175,10 @@     name = fromGenLocated $ fmap mkPrefixName n     spec = mkInlineSpec inl_inline     phase = mkInlinePhase inl_act-mkSignature (GHC.SpecSig _ n sigs _) = Specialise {..}+mkSignature (GHC.SpecSig _ n s _) = Specialise {..}   where     name = fromGenLocated $ fmap mkPrefixName n+    sigs = flattenComments . fmap mkTypeFromHsSigType . fromGenLocated <$> s #if MIN_VERSION_ghc_lib_parser(9, 10, 1) mkSignature (GHC.SCCFunSig _ n _) = Scc name   where@@ -207,7 +209,10 @@     $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) names #endif #if MIN_VERSION_ghc_lib_parser(9, 6, 0)-mkSignature (GHC.SpecInstSig _ sig) = SpecialiseInstance sig+mkSignature (GHC.SpecInstSig _ sig) =+  SpecialiseInstance+    $ flattenComments+    $ mkTypeFromHsSigType <$> fromGenLocated sig mkSignature (GHC.MinimalSig _ xs) =   Minimal $ mkBooleanFormula <$> fromGenLocated xs #else

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

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}  module HIndent.Ast.Declaration.Signature.Fixity@@ -24,5 +25,10 @@   pretty' Fixity {..} = spaced [pretty associativity, string $ show level]  mkFixity :: GHC.Fixity -> Fixity+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkFixity (GHC.Fixity level associativity) =+  Fixity level (mkAssociativity associativity)+#else mkFixity (GHC.Fixity _ level associativity) =   Fixity level (mkAssociativity associativity)+#endif

src/HIndent/Ast/Declaration/Signature/StandaloneKind.hs view

@@ -8,6 +8,7 @@ import qualified GHC.Hs as GHC import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType) import HIndent.Ast.WithComments import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators@@ -15,7 +16,7 @@  data StandaloneKind = StandaloneKind   { name :: WithComments PrefixName-  , kind :: GHC.LHsSigType GHC.GhcPs+  , kind :: WithComments Type   }  instance CommentExtraction StandaloneKind where@@ -26,6 +27,7 @@     spaced [string "type", pretty name, string "::", pretty kind]  mkStandaloneKind :: GHC.StandaloneKindSig GHC.GhcPs -> StandaloneKind-mkStandaloneKind (GHC.StandaloneKindSig _ n kind) = StandaloneKind {..}+mkStandaloneKind (GHC.StandaloneKindSig _ n k) = StandaloneKind {..}   where     name = fromGenLocated $ fmap mkPrefixName n+    kind = flattenComments $ mkTypeFromHsSigType <$> fromGenLocated k

src/HIndent/Ast/Declaration/Splice.hs view

@@ -5,19 +5,20 @@  import HIndent.Ast.Expression.Splice import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.NodeComments  newtype SpliceDeclaration =-  SpliceDeclaration (GHC.SpliceDecl GHC.GhcPs)+  SpliceDeclaration (WithComments Splice)  instance CommentExtraction SpliceDeclaration where   nodeComments SpliceDeclaration {} = NodeComments [] [] []  instance Pretty SpliceDeclaration where-  pretty' (SpliceDeclaration (GHC.SpliceDecl _ sp _)) =-    pretty $ fmap mkSplice sp+  pretty' (SpliceDeclaration splice) = pretty splice  mkSpliceDeclaration :: GHC.SpliceDecl GHC.GhcPs -> SpliceDeclaration-mkSpliceDeclaration = SpliceDeclaration+mkSpliceDeclaration (GHC.SpliceDecl _ sp _) =+  SpliceDeclaration $ mkSplice <$> fromGenLocated sp

src/HIndent/Ast/Declaration/StandAloneDeriving.hs view

@@ -8,6 +8,7 @@ import HIndent.Applicative import HIndent.Ast.Declaration.Data.Deriving.Strategy import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType) import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty@@ -16,7 +17,7 @@  data StandAloneDeriving = StandAloneDeriving   { strategy :: Maybe (WithComments DerivingStrategy)-  , className :: GHC.LHsSigType GHC.GhcPs+  , className :: WithComments Type   }  instance CommentExtraction StandAloneDeriving where@@ -42,4 +43,5 @@   StandAloneDeriving {..}   where     strategy = fmap (fmap mkDerivingStrategy . fromGenLocated) deriv_strategy-    className = hswc_body+    className =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated hswc_body

src/HIndent/Ast/Declaration/TypeSynonym/Lhs.hs view

@@ -44,8 +44,9 @@ mkTypeSynonymLhs GHC.SynDecl {tcdFixity = GHC.Infix, ..} =   case GHC.hsq_explicit tcdTyVars of     [l, r] -> Infix {..}-      where left = mkTypeVariable <$> fromGenLocated l-            iName = fromGenLocated $ fmap mkInfixName tcdLName-            right = mkTypeVariable <$> fromGenLocated r+      where+        left = mkTypeVariable <$> fromGenLocated l+        iName = fromGenLocated $ fmap mkInfixName tcdLName+        right = mkTypeVariable <$> fromGenLocated r     _ -> error "Unexpected number of type variables for infix type synonym." mkTypeSynonymLhs _ = error "Not a type synonym."

+ src/HIndent/Ast/Expression.hs view

@@ -0,0 +1,676 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module HIndent.Ast.Expression+  ( Expression+  , GuardExpression+  , mkExpression+  , mkGuardExpression+  ) where++import Control.Monad+import Control.Monad.RWS (gets)+import Data.List.NonEmpty (NonEmpty(..), (<|))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Monoid (First(..))+import qualified GHC.Hs as GHC+import qualified GHC.Types.Basic as GHC+import qualified GHC.Types.Fixity as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Ast.Cmd (Cmd, CmdDoBlock, mkCmdDoBlock, mkCmdFromHsCmdTop)+import HIndent.Ast.Expression.Bracket (Bracket, mkBracket)+import HIndent.Ast.Expression.FieldSelector (FieldSelector, mkFieldSelector)+import qualified HIndent.Ast.Expression.ListComprehension as LC+import HIndent.Ast.Expression.OverloadedLabel+  ( OverloadedLabel+  , mkOverloadedLabel+  )+import HIndent.Ast.Expression.Pragmatic (ExpressionPragma, mkExpressionPragma)+import HIndent.Ast.Expression.RangeExpression+  ( RangeExpression+  , mkRangeExpression+  )+import HIndent.Ast.Expression.RecordConstructionField+  ( RecordConstructionFields+  , mkRecordConstructionFields+  )+import HIndent.Ast.Expression.RecordUpdateField+  ( RecordUpdateFields+  , mkRecordUpdateFields+  )+import HIndent.Ast.Guard (Guard, mkMultiWayIfExprGuard)+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import HIndent.Ast.MatchGroup (MatchGroup, hasMatches, mkExprMatchGroup)+import HIndent.Ast.Module.Name (mkModuleName)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.Pattern+import HIndent.Ast.Statement (ExprStatement, mkExprStatement)+import HIndent.Ast.Type+import HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  )+import HIndent.Ast.WithComments+import HIndent.CabalFile ()+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Pretty.Types (DoOrMdo(..), QualifiedDo(..))+import HIndent.Printer+import qualified Language.Haskell.Syntax.Basic as HS+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import Data.Maybe+import HIndent.Ast.Expression.Splice (Splice, mkSplice, mkTypedSplice)+import HIndent.Fixity (fixities)+import qualified Language.Haskell.GhclibParserEx.GHC.Hs.Expr as GHC+#else+import qualified GHC.Types.Name.Reader as NameReader+import HIndent.Ast.Expression.Splice (Splice, mkSplice)+#endif+data Expression+  = Variable (WithComments PrefixName)+  | UnboundVariable PrefixName+  | OverloadedLabel OverloadedLabel+  | ImplicitParameter ImplicitParameterName+  | OverloadedLiteral (GHC.HsOverLit GHC.GhcPs)+  | Literal (GHC.HsLit GHC.GhcPs)+  | Lambda MatchGroup+  | LambdaCase+      { usesCases :: Bool+      , matches :: MatchGroup+      }+  | Application (NonEmpty (WithComments Expression))+  | TypeApplication+      { expression :: WithComments Expression+      , typeArg :: WithComments Type+      }+  | OperatorApplication+      { firstOperand :: WithComments Expression+      , operatorOperandPairs :: NonEmpty+          (WithComments InfixExpr, WithComments Expression)+      }+  | Negation (WithComments Expression)+  | Parenthesized (WithComments Expression)+  | LeftSection+      { left :: WithComments Expression+      , operator :: WithComments InfixExpr+      }+  | RightSection+      { operator :: WithComments InfixExpr+      , right :: WithComments Expression+      }+  | Tuple+      { arguments :: [WithComments (Maybe (WithComments Expression))]+      , isBoxed :: Bool+      }+  | Sum+      { position :: GHC.ConTag+      , arity :: HS.SumWidth+      , expression :: WithComments Expression+      }+  | CaseExpression+      { scrutinee :: WithComments Expression+      , matches :: MatchGroup+      }+  | IfExpression+      { predicate :: WithComments Expression+      , thenBranch :: WithComments Expression+      , elseBranch :: WithComments Expression+      }+  | MultiIf [WithComments Guard]+  | LetBinding+      { bindings :: WithComments LocalBinds+      , expression :: WithComments Expression+      }+  | DoBlock+      { qualifiedDo :: QualifiedDo+      , statements :: WithComments [WithComments ExprStatement]+      }+  | ListComprehension (WithComments LC.ListComprehension)+  | ListLiteral [WithComments Expression]+  | RecordConstruction+      { name :: WithComments PrefixName+      , fields :: RecordConstructionFields+      }+  | RecordUpdate RecordUpdateFields+  | FieldProjection+      { expression :: WithComments Expression+      , selector :: WithComments FieldSelector+      }+  | Projection (NonEmpty (WithComments FieldSelector))+  | TypeSignature+      { expression :: WithComments Expression+      , signature :: WithComments Type+      }+  | ArithmeticSequence RangeExpression+  | TypedQuotation (WithComments Expression)+  | UntypedQuotation Bracket+  | Splice Splice+  | ProcExpression+      { pat :: WithComments Pattern+      , cmd :: WithComments Cmd+      }+  | ProcDo+      { pat :: WithComments Pattern+      , block :: CmdDoBlock+      }+  | StaticExpression (WithComments Expression)+  | PragmaticExpression+      { pragma :: WithComments ExpressionPragma+      , expression :: WithComments Expression+      }++instance CommentExtraction Expression where+  nodeComments _ = NodeComments [] [] []++instance Pretty Expression where+  pretty' (Variable name) = pretty name+  pretty' (UnboundVariable name) = pretty name+  pretty' (OverloadedLabel label) = pretty label+  pretty' (ImplicitParameter name) = pretty name+  pretty' (OverloadedLiteral lit) = pretty lit+  pretty' (Literal lit) = pretty lit+  pretty' (Lambda matches) = pretty matches+  pretty' LambdaCase {..} = do+    string+      $ if usesCases+          then "\\cases"+          else "\\case"+    if not $ hasMatches matches+      then string " {}"+      else do+        newline+        indentedBlock $ pretty matches+  pretty' (Application (headExpr :| argList)) = horizontal <-|> vertical+    where+      horizontal = spaced $ pretty <$> headExpr : argList+      vertical = do+        col <- gets psColumn+        indentSpaces <- getIndentSpaces+        pretty headExpr+        col' <- gets psColumn+        let headLength =+              col'+                - col+                - if col == 0+                    then indentSpaces+                    else 0+            hangFirstArg = headLength + 1 <= indentSpaces+        if hangFirstArg+          then space+          else newline+        spaces' <- getIndentSpaces+        indentedWithSpace spaces' $ lined $ fmap pretty argList+  pretty' TypeApplication {..} = do+    pretty expression+    string " @"+    pretty typeArg+  pretty' OperatorApplication {..} = horizontal <-|> vertical+    where+      horizontal = do+        pretty firstOperand+        space+        spaced+          $ concatMap (\(op, r) -> [pretty op, pretty r]) operatorOperandPairs+      vertical = do+        pretty firstOperand+        prettyOpAndRhs $ NonEmpty.toList operatorOperandPairs+        where+          prettyOpAndRhs [] = pure ()+          prettyOpAndRhs [(o, r)]+            | shouldBeInline (getNode r) = space >> spaced [pretty o, pretty r]+          prettyOpAndRhs ((o, r):xs) = do+            newline+            indentedBlock $ (pretty o >> space) |=> pretty r+            prettyOpAndRhs xs+          shouldBeInline DoBlock {} = True+          shouldBeInline Lambda {} = True+          shouldBeInline LambdaCase {} = True+          shouldBeInline _ = False+  pretty' (Negation expr) = string "-" >> pretty expr+  pretty' (Parenthesized expr) = parens $ pretty expr+  pretty' LeftSection {..} = spaced [pretty left, pretty operator]+  pretty' RightSection {..} = (pretty operator >> space) |=> pretty right+  pretty' Tuple {..} = horizontal <-|> vertical+    where+      horizontal = parH $ prettyArg pretty <$> arguments+      vertical =+        parV+          $ prefixedLined ","+          $ prettyArg (\expr -> space |=> pretty expr) <$> arguments+      prettyArg f arg = prettyWith arg (maybe (pure ()) f)+      (parH, parV) =+        if isBoxed+          then (hTuple, parens)+          else (hUnboxedTuple, unboxedParens)+  pretty' Sum {..} = do+    string "(#"+    forM_ [1 .. arity] $ \idx -> do+      if idx == position+        then space >> pretty expression >> space+        else space+      when (idx < arity) $ string "|"+    string "#)"+  pretty' CaseExpression {..} = do+    string "case " |=> do+      pretty scrutinee+      string " of"+    if not $ hasMatches matches+      then string " {}"+      else do+        newline+        indentedBlock $ pretty matches+  pretty' IfExpression {..} = do+    string "if " |=> pretty predicate+    indentedBlock+      $ newlinePrefixed [branch "then " thenBranch, branch "else " elseBranch]+    where+      branch str exprWithComments =+        prettyWith exprWithComments $ \expr ->+          case expr of+            DoBlock {} -> do+              string str+              pretty expr+            _ -> string str |=> pretty expr+  pretty' (MultiIf multiIfClauses) =+    string "if " |=> lined (fmap pretty multiIfClauses)+  pretty' LetBinding {..} =+    lined+      [string "let " |=> pretty bindings, string " in " |=> pretty expression]+  pretty' DoBlock {..} = do+    pretty qualifiedDo+    newline+    indentedBlock $ prettyWith statements (lined . fmap pretty)+  pretty' (ListComprehension listComprehension) = pretty listComprehension+  pretty' (ListLiteral listItems) = horizontal <-|> vertical+    where+      horizontal = brackets $ hCommaSep $ fmap pretty listItems+      vertical = vList $ fmap pretty listItems+  pretty' RecordConstruction {..} = horizontal <-|> vertical+    where+      horizontal = spaced [pretty name, pretty fields]+      vertical = do+        pretty name+        (space >> pretty fields) <-|> (newline >> indentedBlock (pretty fields))+  pretty' (RecordUpdate fields) = pretty fields+  pretty' FieldProjection {..} = do+    pretty expression+    dot+    pretty selector+  pretty' (Projection projectionFields) =+    parens $ forM_ projectionFields prettyProjectionField+    where+      prettyProjectionField projectionField = do+        string "."+        pretty projectionField+  pretty' TypeSignature {..} =+    spaced [pretty expression, string "::", pretty signature]+  pretty' (ArithmeticSequence rangeExpression) = pretty rangeExpression+  pretty' (TypedQuotation expr) = typedBrackets $ pretty expr+  pretty' (UntypedQuotation bracket) = pretty bracket+  pretty' ProcExpression {..} = hor <-|> ver+    where+      hor = spaced [string "proc", pretty pat, string "->", pretty cmd]+      ver = do+        spaced [string "proc", pretty pat, string "->"]+        newline+        indentedBlock $ pretty cmd+  pretty' ProcDo {..} = do+    spaced [string "proc", pretty pat, string "-> do"]+    newline+    indentedBlock $ pretty block+  pretty' (StaticExpression expr) = spaced [string "static", pretty expr]+  pretty' PragmaticExpression {..} = spaced [pretty pragma, pretty expression]+  pretty' (Splice splice') = pretty splice'++mkExpression :: GHC.HsExpr GHC.GhcPs -> Expression+mkExpression (GHC.HsVar _ name) =+  Variable $ mkPrefixName <$> fromGenLocated name+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+mkExpression (GHC.HsUnboundVar _ name) = UnboundVariable $ mkPrefixName name+#else+mkExpression (GHC.HsUnboundVar _ name) =+  UnboundVariable $ mkPrefixName $ NameReader.mkRdrUnqual name+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExpression (GHC.HsOverLabel _ label) =+  OverloadedLabel $ mkOverloadedLabel label+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkExpression (GHC.HsOverLabel _ _ label) =+  OverloadedLabel $ mkOverloadedLabel label+#else+mkExpression (GHC.HsOverLabel _ label) =+  OverloadedLabel $ mkOverloadedLabel label+#endif+mkExpression (GHC.HsIPVar _ name) =+  ImplicitParameter $ mkImplicitParameterName name+mkExpression (GHC.HsOverLit _ lit) = OverloadedLiteral lit+mkExpression (GHC.HsLit _ lit) = Literal lit+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsEmbTy _ _) =+  error "`ghc-lib-parser` never generates this AST node."+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsLam _ GHC.LamSingle matches) =+  Lambda $ mkExprMatchGroup matches+mkExpression (GHC.HsLam _ GHC.LamCases matches) =+  LambdaCase {usesCases = True, matches = mkExprMatchGroup matches}+mkExpression (GHC.HsLam _ GHC.LamCase matches) =+  LambdaCase {usesCases = False, matches = mkExprMatchGroup matches}+#else+mkExpression (GHC.HsLam _ matches) = Lambda $ mkExprMatchGroup matches+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkExpression (GHC.HsLamCase _ GHC.LamCases matches) =+  LambdaCase {usesCases = True, matches = mkExprMatchGroup matches}+mkExpression (GHC.HsLamCase _ GHC.LamCase matches) =+  LambdaCase {usesCases = False, matches = mkExprMatchGroup matches}+#else+mkExpression (GHC.HsLamCase _ _ matches) =+  LambdaCase {usesCases = False, matches = mkExprMatchGroup matches}+#endif+#endif+mkExpression (GHC.HsApp _ function argument) =+  case getNode f of+    Application (h :| as) -> Application $ h :| push as+    _ -> Application $ f :| [a]+  where+    f = mkExpression <$> fromGenLocated function+    a = mkExpression <$> fromGenLocated argument+    push [] = [a]+    push (x:xs) = go x xs+      where+        go final [] = [addComments (getComments f) final, a]+        go current (y:ys) = current : go y ys+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsAppType _ fun typeArg) =+  TypeApplication+    { expression = mkExpression <$> fromGenLocated fun+    , typeArg = mkTypeFromLHsWcType typeArg+    }+#else+mkExpression (GHC.HsAppType _ fun _ typeArg) =+  TypeApplication+    { expression = mkExpression <$> fromGenLocated fun+    , typeArg = mkTypeFromLHsWcType typeArg+    }+#endif+mkExpression (GHC.OpApp _ lhs op rhs) = OperatorApplication {..}+  where+    (firstOperand, operatorOperandPairs) =+      case fixityDir operatorFixity of+        GHC.InfixL -> build leftChain+        GHC.InfixR -> build rightChain+        GHC.InfixN+          | GHC.L _ (GHC.OpApp _ _ o _) <- lhs+          , isSameAssoc o -> build leftChain+          | otherwise -> build rightChain+    operatorFixity = findFixity op+    build (x:xs) = (mkExpression <$> fromGenLocated x, f xs)+      where+        f [l, o] =+          NonEmpty.singleton+            ( InfixExpr . mkExpression <$> fromGenLocated l+            , mkExpression <$> fromGenLocated o)+        f (l:o:rs) =+          ( InfixExpr . mkExpression <$> fromGenLocated l+          , mkExpression <$> fromGenLocated o)+            <| f rs+        f _ = error "Malformed operator chain"+    build _ = error "Empty operator chain"+    findFixity o =+      fromMaybe GHC.defaultFixity $ lookup (GHC.varToStr o) fixities+    leftChain = reverse $ rhs : op : collect lhs+      where+        collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]+        collect (GHC.L _ (GHC.OpApp _ l o r))+          | isSameAssoc o = r : o : collect l+        collect x = [x]+    rightChain = lhs : op : collect rhs+      where+        collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]+        collect (GHC.L _ (GHC.OpApp _ l o r))+          | isSameAssoc o = l : o : collect r+        collect x = [x]+    isSameAssoc (findFixity -> fixity) =+      fixityLevel fixity == level && fixityDir fixity == dir+    level = fixityLevel operatorFixity+    dir = fixityDir operatorFixity+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+    fixityLevel (GHC.Fixity lvl _) = lvl+    +    fixityDir (GHC.Fixity _ direction) = direction+#else+    fixityLevel (GHC.Fixity _ lvl _) = lvl+    +    fixityDir (GHC.Fixity _ _ direction) = direction+#endif+mkExpression (GHC.NegApp _ expr _) =+  Negation $ mkExpression <$> fromGenLocated expr+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsPar _ expr) =+  Parenthesized $ mkExpression <$> fromGenLocated expr+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkExpression (GHC.HsPar _ _ expr _) =+  Parenthesized $ mkExpression <$> fromGenLocated expr+#else+mkExpression (GHC.HsPar _ expr) =+  Parenthesized $ mkExpression <$> fromGenLocated expr+#endif+mkExpression (GHC.SectionL _ l r) =+  LeftSection+    { left = mkExpression <$> fromGenLocated l+    , operator = InfixExpr . mkExpression <$> fromGenLocated r+    }+mkExpression (GHC.SectionR _ l r) =+  RightSection+    { operator = InfixExpr . mkExpression <$> fromGenLocated l+    , right = mkExpression <$> fromGenLocated r+    }+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.ExplicitTuple _ tupleArgs boxity) =+  Tuple+    { arguments = mkTupleArgument <$> tupleArgs+    , isBoxed =+        case boxity of+          GHC.Boxed -> True+          GHC.Unboxed -> False+    }+  where+    mkTupleArgument (GHC.Present _ expr) =+      mkWithComments $ Just $ mkExpression <$> fromGenLocated expr+    mkTupleArgument (GHC.Missing ann) = fromEpAnn ann Nothing+#else+mkExpression (GHC.ExplicitTuple _ tupleArgs boxity) =+  Tuple+    { arguments = mkTupleArgument <$> tupleArgs+    , isBoxed =+        case boxity of+          GHC.Boxed -> True+          GHC.Unboxed -> False+    }+  where+    mkTupleArgument (GHC.Present ann expr) =+      fromEpAnn ann $ Just $ mkExpression <$> fromGenLocated expr+    mkTupleArgument (GHC.Missing ann) = fromEpAnn ann Nothing+#endif+mkExpression (GHC.ExplicitSum _ position arity expr) =+  Sum {expression = mkExpression <$> fromGenLocated expr, ..}+mkExpression (GHC.HsCase _ scrut matches) =+  CaseExpression+    { scrutinee = mkExpression <$> fromGenLocated scrut+    , matches = mkExprMatchGroup matches+    }+mkExpression (GHC.HsIf _ predicateExpr thenExpr elseExpr) =+  IfExpression+    { predicate = mkExpression <$> fromGenLocated predicateExpr+    , thenBranch = mkExpression <$> fromGenLocated thenExpr+    , elseBranch = mkExpression <$> fromGenLocated elseExpr+    }+mkExpression (GHC.HsMultiIf _ clauses) =+  MultiIf (fmap (fmap mkMultiWayIfExprGuard . fromGenLocated) clauses)+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsLet _ localBinds body) =+  case mkLocalBinds localBinds of+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `HsLet` node with empty bindings."+    Just bindings ->+      LetBinding {expression = mkExpression <$> fromGenLocated body, ..}+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkExpression (GHC.HsLet _ _ localBinds _ body) =+  case mkLocalBinds localBinds of+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `HsLet` node with empty bindings."+    Just bindings ->+      LetBinding {expression = mkExpression <$> fromGenLocated body, ..}+#else+mkExpression (GHC.HsLet _ localBinds body) =+  case mkLocalBinds localBinds of+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `HsLet` node with empty bindings."+    Just bindings ->+      LetBinding {expression = mkExpression <$> fromGenLocated body, ..}+#endif+mkExpression (GHC.HsDo _ GHC.ListComp statements) =+  ListComprehension+    $ LC.mkListComprehension . fmap (fmap mkExprStatement . fromGenLocated)+        <$> fromGenLocated statements+mkExpression (GHC.HsDo _ GHC.MonadComp statements) =+  ListComprehension+    $ LC.mkListComprehension . fmap (fmap mkExprStatement . fromGenLocated)+        <$> fromGenLocated statements+mkExpression (GHC.HsDo _ (GHC.DoExpr moduleName) statements) =+  DoBlock+    { qualifiedDo = QualifiedDo (fmap mkModuleName moduleName) Do+    , statements =+        fmap (fmap mkExprStatement . fromGenLocated)+          <$> fromGenLocated statements+    }+mkExpression (GHC.HsDo _ (GHC.MDoExpr moduleName) statements) =+  DoBlock+    { qualifiedDo = QualifiedDo (fmap mkModuleName moduleName) Mdo+    , statements =+        fmap (fmap mkExprStatement . fromGenLocated)+          <$> fromGenLocated statements+    }+mkExpression (GHC.HsDo _ GHC.GhciStmtCtxt {} _) =+  error "`ghc-lib-parser` never generates this AST node."+mkExpression (GHC.ExplicitList _ items) =+  ListLiteral (fmap (fmap mkExpression . fromGenLocated) items)+mkExpression (GHC.RecordCon { GHC.rcon_con = conName+                            , GHC.rcon_flds = recordFields+                            }) =+  RecordConstruction+    { name = mkPrefixName <$> fromGenLocated conName+    , fields = mkRecordConstructionFields recordFields+    }+mkExpression (GHC.RecordUpd { GHC.rupd_expr = recordExpr+                            , GHC.rupd_flds = updates+                            }) =+  RecordUpdate+    $ mkRecordUpdateFields (mkExpression <$> fromGenLocated recordExpr) updates+mkExpression (GHC.HsGetField {GHC.gf_expr = fieldExpr, GHC.gf_field = selector}) =+  FieldProjection+    { expression = mkExpression <$> fromGenLocated fieldExpr+    , selector = fmap mkFieldSelector (fromGenLocated selector)+    }+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExpression (GHC.HsProjection {GHC.proj_flds = fields}) =+  Projection $ fmap (mkWithComments . mkFieldSelector) fields+#else+mkExpression (GHC.HsProjection {GHC.proj_flds = fields}) =+  Projection $ fmap (fmap mkFieldSelector . fromGenLocated) fields+#endif+mkExpression (GHC.ExprWithTySig _ signatureExpr ty) =+  TypeSignature+    { expression = mkExpression <$> fromGenLocated signatureExpr+    , signature =+        flattenComments+          $ mkTypeFromHsSigType <$> fromGenLocated (GHC.hswc_body ty)+    }+mkExpression (GHC.ArithSeq _ _ info) =+  ArithmeticSequence $ mkRangeExpression info+mkExpression (GHC.HsTypedBracket _ typedExpr) =+  TypedQuotation $ mkExpression <$> fromGenLocated typedExpr+mkExpression (GHC.HsUntypedBracket _ content) =+  UntypedQuotation $ mkBracket content+#if MIN_VERSION_ghc_lib_parser(9, 12, 2)+mkExpression GHC.HsForAll {} =+  error "`ghc-lib-parser` never generates this AST node."+mkExpression GHC.HsQual {} =+  error "`ghc-lib-parser` never generates this AST node."+mkExpression GHC.HsFunArr {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkExpression (GHC.HsTypedSplice _ expr) = Splice $ mkTypedSplice expr+mkExpression (GHC.HsUntypedSplice _ splice) = Splice $ mkSplice splice+#else+mkExpression (GHC.HsSpliceE _ splice) = Splice $ mkSplice splice+mkExpression (GHC.HsTypedSplice _ expr) = Splice $ mkSplice expr+mkExpression (GHC.HsUntypedSplice _ splice) = Splice $ mkSplice splice+#endif+mkExpression (GHC.HsProc _ pat command) =+  case getFirst $ foldMap (First . mkCmdDoBlock) cmd of+    Just block -> ProcDo {pat = mkPattern <$> fromGenLocated pat, block}+    Nothing -> ProcExpression {pat = mkPattern <$> fromGenLocated pat, cmd}+  where+    cmd = flattenComments $ mkCmdFromHsCmdTop <$> fromGenLocated command+mkExpression (GHC.HsStatic _ staticExpr) =+  StaticExpression $ mkExpression <$> fromGenLocated staticExpr+mkExpression (GHC.HsPragE _ pragma pragmaticExpr) =+  PragmaticExpression+    { expression = mkExpression <$> fromGenLocated pragmaticExpr+    , pragma = mkExpressionPragma pragma+    }+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExpression (GHC.HsRecSel _ _) =+  error "`ghc-lib-parser` never generates this AST node."+#endif+newtype InfixExpr =+  InfixExpr Expression++instance CommentExtraction InfixExpr where+  nodeComments _ = NodeComments [] [] []++instance Pretty InfixExpr where+  pretty' (InfixExpr (Variable name)) = pretty $ mkPrefixAsInfix <$> name+  pretty' (InfixExpr (UnboundVariable name)) = pretty $ mkPrefixAsInfix name+  pretty' (InfixExpr (Parenthesized inner)) = pretty $ fmap InfixExpr inner+  pretty' (InfixExpr x) = pretty x++data GuardExpression+  = GuardWithDo Expression+  | GuardWithAppAndDo Expression+  | GuardExpression Expression++instance CommentExtraction GuardExpression where+  nodeComments (GuardWithDo expr) = nodeComments expr+  nodeComments (GuardWithAppAndDo expr) = nodeComments expr+  nodeComments (GuardExpression expr) = nodeComments expr++instance Pretty GuardExpression where+  pretty' (GuardWithDo expr) = space >> pretty expr+  pretty' (GuardWithAppAndDo expr) = space >> pretty expr+  pretty' (GuardExpression expr) = horizontal <-|> vertical+    where+      horizontal = space >> pretty expr+      vertical = newline >> indentedBlock (pretty expr)++mkGuardExpression :: Expression -> GuardExpression+mkGuardExpression expr@DoBlock {} = GuardWithDo expr+mkGuardExpression expr+  | OperatorApplication {..} <- expr+  , DoBlock {} <- getNode firstOperand = GuardWithAppAndDo expr+  | otherwise = GuardExpression expr

+ src/HIndent/Ast/Expression.hs-boot view

@@ -0,0 +1,25 @@+module HIndent.Ast.Expression+  ( Expression+  , GuardExpression+  , mkExpression+  , mkGuardExpression+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty)+import HIndent.Pretty.NodeComments++data Expression++data GuardExpression++instance Pretty Expression++instance Pretty GuardExpression++instance CommentExtraction Expression++instance CommentExtraction GuardExpression++mkExpression :: GHC.HsExpr GHC.GhcPs -> Expression+mkGuardExpression :: Expression -> GuardExpression

src/HIndent/Ast/Expression/Bracket.hs view

@@ -6,8 +6,11 @@   ) where  import HIndent.Ast.Declaration+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression) import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Pattern+import HIndent.Ast.Type import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty@@ -15,16 +18,16 @@ import HIndent.Pretty.NodeComments  data Bracket-  = TypedExpression (GHC.LHsExpr GHC.GhcPs)-  | UntypedExpression (GHC.LHsExpr GHC.GhcPs)-  | Pattern (GHC.LPat GHC.GhcPs)+  = TypedExpression (WithComments Expression)+  | UntypedExpression (WithComments Expression)+  | Pattern (WithComments Pattern)   | Declaration [WithComments Declaration]-  | Type (GHC.LHsType GHC.GhcPs)+  | Type (WithComments Type)   | Variable Bool (WithComments PrefixName)  instance CommentExtraction Bracket where-  nodeComments TypedExpression {} = NodeComments [] [] []-  nodeComments UntypedExpression {} = NodeComments [] [] []+  nodeComments (TypedExpression expr) = nodeComments expr+  nodeComments (UntypedExpression expr) = nodeComments expr   nodeComments Pattern {} = NodeComments [] [] []   nodeComments Declaration {} = NodeComments [] [] []   nodeComments Type {} = NodeComments [] [] []@@ -44,13 +47,14 @@ #else mkBracket :: GHC.HsBracket GHC.GhcPs -> Bracket #endif-mkBracket (GHC.ExpBr _ x) = UntypedExpression x-mkBracket (GHC.PatBr _ x) = Pattern x+mkBracket (GHC.ExpBr _ x) =+  UntypedExpression $ mkExpression <$> fromGenLocated x+mkBracket (GHC.PatBr _ x) = Pattern $ mkPattern <$> fromGenLocated x mkBracket (GHC.DecBrL _ x) =   Declaration $ fmap (fmap mkDeclaration . fromGenLocated) x-mkBracket (GHC.TypBr _ x) = Type x+mkBracket (GHC.TypBr _ x) = Type $ mkType <$> fromGenLocated x mkBracket (GHC.VarBr _ b x) = Variable b $ fromGenLocated $ fmap mkPrefixName 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+mkBracket (GHC.TExpBr _ x) = TypedExpression $ mkExpression <$> fromGenLocated x #endif

+ src/HIndent/Ast/Expression/FieldSelector.hs view

@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.FieldSelector+  ( FieldSelector+  , mkFieldSelector+  ) where++import qualified GHC.Data.FastString as GHC+import qualified GHC.Hs as GHC+import HIndent.Ast.Name.Prefix (PrefixName, fromString)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.NodeComments (CommentExtraction(..))+import qualified Language.Haskell.Syntax.Basic as GHC++newtype FieldSelector = FieldSelector+  { name :: WithComments PrefixName+  }++instance CommentExtraction FieldSelector where+  nodeComments FieldSelector {} = NodeComments [] [] []++instance Pretty FieldSelector where+  pretty' FieldSelector {..} = pretty name++mkFieldSelector :: GHC.DotFieldOcc GHC.GhcPs -> FieldSelector+mkFieldSelector GHC.DotFieldOcc {..} =+  FieldSelector+    { name =+        fmap+          (fromString . GHC.unpackFS . GHC.field_label)+          (fromGenLocated dfoLabel)+    }

+ src/HIndent/Ast/Expression/ListComprehension.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.ListComprehension+  ( ListComprehension+  , mkListComprehension+  ) where++import Control.Monad (forM_)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import HIndent.Ast.Statement (ExprStatement)+import HIndent.Ast.WithComments (WithComments)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..), emptyNodeComments)++data ListComprehension = ListComprehension+  { leading :: WithComments ExprStatement+  , clauses :: NonEmpty (WithComments ExprStatement)+  }++instance CommentExtraction ListComprehension where+  nodeComments _ = emptyNodeComments++instance Pretty ListComprehension where+  pretty' ListComprehension {..} = horizontal <-|> vertical+    where+      horizontal =+        brackets+          $ spaced+              [ pretty leading+              , string "|"+              , hCommaSep $ pretty <$> NonEmpty.toList clauses+              ]+      vertical = do+        string "[ "+        pretty leading+        newline+        forM_ (clausePairs clauses) $ \(prefix, clause) -> do+          string prefix |=> pretty clause+          newline+        string "]"+      clausePairs (q :| qs) = ("| ", q) : fmap (", ", ) qs++mkListComprehension :: [WithComments ExprStatement] -> ListComprehension+mkListComprehension [] =+  error "List comprehension requires at least two statements."+mkListComprehension [_] =+  error "List comprehension requires at least two statements."+mkListComprehension (leading:second:rest) =+  ListComprehension {clauses = second :| rest, ..}

+ src/HIndent/Ast/Expression/OverloadedLabel.hs view

@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Expression.OverloadedLabel+  ( OverloadedLabel+  , mkOverloadedLabel+  ) where++import qualified GHC.Data.FastString as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype OverloadedLabel =+  OverloadedLabel String++instance CommentExtraction OverloadedLabel where+  nodeComments OverloadedLabel {} = emptyNodeComments++instance Pretty OverloadedLabel where+  pretty' (OverloadedLabel s) = string "#" >> string s++mkOverloadedLabel :: GHC.FastString -> OverloadedLabel+mkOverloadedLabel fs = OverloadedLabel $ GHC.unpackFS fs

+ src/HIndent/Ast/Expression/Pragmatic.hs view

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.Pragmatic+  ( ExpressionPragma+  , mkExpressionPragma+  ) where++import qualified GHC.Hs as GHC+import qualified GHC.Types.SourceText as GHC+import HIndent.Ast.NodeComments (NodeComments(..))+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+import HIndent.Ast.WithComments (WithComments, addComments, mkWithComments)+#else+import HIndent.Ast.WithComments (WithComments, fromEpAnn)+#endif+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators (spaced, string)+import HIndent.Pretty.NodeComments (CommentExtraction(..))++newtype ExpressionPragma = SccPragma+  { label :: GHC.StringLiteral+  }++instance CommentExtraction ExpressionPragma where+  nodeComments _ = NodeComments [] [] []++instance Pretty ExpressionPragma where+  pretty' SccPragma {..} = spaced [string "{-# SCC", pretty label, string "#-}"]++mkExpressionPragma :: GHC.HsPragE GHC.GhcPs -> WithComments ExpressionPragma+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpressionPragma (GHC.HsPragSCC (ann, _) literal) =+  addComments (nodeComments ann) $ mkWithComments SccPragma {label = literal}+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkExpressionPragma (GHC.HsPragSCC (ann, _) literal) =+  fromEpAnn ann SccPragma {label = literal}+#else+mkExpressionPragma (GHC.HsPragSCC ann _ literal) =+  fromEpAnn ann SccPragma {label = literal}+#endif

+ src/HIndent/Ast/Expression/RangeExpression.hs view

@@ -0,0 +1,64 @@+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.RangeExpression+  ( RangeExpression(..)+  , mkRangeExpression+  ) where++import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RangeExpression+  = From (WithComments Expression)+  | FromThen+      { from :: WithComments Expression+      , next :: WithComments Expression+      }+  | FromTo+      { from :: WithComments Expression+      , to :: WithComments Expression+      }+  | FromThenTo+      { from :: WithComments Expression+      , next :: WithComments Expression+      , to :: WithComments Expression+      }++instance CommentExtraction RangeExpression where+  nodeComments From {} = emptyNodeComments+  nodeComments FromThen {} = emptyNodeComments+  nodeComments FromTo {} = emptyNodeComments+  nodeComments FromThenTo {} = emptyNodeComments++instance Pretty RangeExpression where+  pretty' (From f) = brackets $ spaced [pretty f, string ".."]+  pretty' FromThen {..} =+    brackets $ spaced [pretty from >> comma >> pretty next, string ".."]+  pretty' FromTo {..} = brackets $ spaced [pretty from, string "..", pretty to]+  pretty' FromThenTo {..} =+    brackets+      $ spaced [pretty from >> comma >> pretty next, string "..", pretty to]++mkRangeExpression :: GHC.ArithSeqInfo GHC.GhcPs -> RangeExpression+mkRangeExpression (GHC.From f) = From $ mkExpression <$> fromGenLocated f+mkRangeExpression (GHC.FromThen f n) =+  FromThen+    { from = mkExpression <$> fromGenLocated f+    , next = mkExpression <$> fromGenLocated n+    }+mkRangeExpression (GHC.FromTo f t) =+  FromTo+    { from = mkExpression <$> fromGenLocated f+    , to = mkExpression <$> fromGenLocated t+    }+mkRangeExpression (GHC.FromThenTo f n t) =+  FromThenTo+    { from = mkExpression <$> fromGenLocated f+    , next = mkExpression <$> fromGenLocated n+    , to = mkExpression <$> fromGenLocated t+    }

+ src/HIndent/Ast/Expression/RecordConstructionField.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.RecordConstructionField+  ( RecordConstructionFields+  , mkRecordConstructionFields+  ) where++import Data.Maybe (isJust)+import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.Record.Field (ExprField, mkExprField)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RecordConstructionFields = RecordConstructionFields+  { fields :: [WithComments ExprField]+  , dotdot :: Bool+  }++instance CommentExtraction RecordConstructionFields where+  nodeComments _ = NodeComments [] [] []++instance Pretty RecordConstructionFields where+  pretty' RecordConstructionFields {..} =+    hvFields (fmap pretty fields ++ [string ".." | dotdot])++mkRecordConstructionFields ::+     GHC.HsRecordBinds GHC.GhcPs -> RecordConstructionFields+mkRecordConstructionFields GHC.HsRecFields {..} =+  RecordConstructionFields+    { fields = fmap (fmap mkExprField . fromGenLocated) rec_flds+    , dotdot = isJust rec_dotdot+    }

+ src/HIndent/Ast/Expression/RecordUpdateField.hs view

@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.RecordUpdateField+  ( RecordUpdateFields+  , mkRecordUpdateFields+  ) where++import qualified GHC.Hs as GHC+import HIndent.Applicative (whenJust)+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer (Printer)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+import HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromFieldLabelStrings+  , mkFieldNameFromFieldOcc+  )+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+import HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromAmbiguousFieldOcc+  , mkFieldNameFromFieldLabelStrings+  )+#else+import HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromFieldLabelStrings+  , mkFieldNameFromFieldOcc+  )+#endif+data RecordUpdateFields = RecordUpdateFields+  { expression :: WithComments Expression+  , fields :: [WithComments Field]+  }++instance CommentExtraction RecordUpdateFields where+  nodeComments _ = NodeComments [] [] []++instance Pretty RecordUpdateFields where+  pretty' RecordUpdateFields {..} = horizontal <-|> vertical+    where+      horizontal =+        spaced+          [ pretty expression+          , hFields $ fmap (`prettyWith` prettyFieldHorizontal) fields+          ]+      vertical = do+        pretty expression+        newline+        indentedBlock+          $ hFields (fmap (`prettyWith` prettyFieldHorizontal) fields)+              <-|> vFields (fmap (`prettyWith` prettyFieldVertical) fields)++mkRecordUpdateFields ::+     WithComments Expression+  -> GHC.LHsRecUpdFields GHC.GhcPs+  -> RecordUpdateFields+mkRecordUpdateFields expression updates =+  RecordUpdateFields {fields = collectFields updates, ..}++data Field = Field+  { fieldName :: WithComments FieldName+  , value :: Maybe (WithComments Expression)+  }++instance CommentExtraction Field where+  nodeComments _ = NodeComments [] [] []++prettyFieldHorizontal :: Field -> Printer ()+prettyFieldHorizontal Field {..} = do+  pretty fieldName+  whenJust value $ \val -> do+    string " = "+    pretty val++prettyFieldVertical :: Field -> Printer ()+prettyFieldVertical Field {..} = do+  pretty fieldName+  whenJust value $ \val -> do+    string " ="+    (space >> pretty val) <-|> (newline >> indentedBlock (pretty val))++collectFieldsWith ::+     CommentExtraction (GHC.Anno label)+  => (label -> FieldName)+  -> [GHC.LocatedA+        (GHC.HsFieldBind (GHC.XRec GHC.GhcPs label) (GHC.LHsExpr GHC.GhcPs))]+  -> [WithComments Field]+collectFieldsWith mkLabel =+  fmap (fmap (mkField (fmap mkLabel . fromGenLocated)) . fromGenLocated)++collectFields :: GHC.LHsRecUpdFields GHC.GhcPs -> [WithComments Field]+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+collectFields GHC.RegularRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromFieldOcc recUpdFields+collectFields GHC.OverloadedRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromFieldLabelStrings olRecUpdFields+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+collectFields GHC.RegularRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromAmbiguousFieldOcc recUpdFields+collectFields GHC.OverloadedRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromFieldLabelStrings olRecUpdFields+#else+collectFields = collectFieldsWith mkFieldNameFromFieldOcc . either id id+#endif+mkField ::+     (GHC.XRec GHC.GhcPs label -> WithComments FieldName)+  -> GHC.HsFieldBind (GHC.XRec GHC.GhcPs label) (GHC.LHsExpr GHC.GhcPs)+  -> Field+mkField wrapLabel GHC.HsFieldBind {..} =+  Field+    { fieldName = wrapLabel hfbLHS+    , value =+        if hfbPun+          then Nothing+          else Just $ mkExpression <$> fromGenLocated hfbRHS+    }

src/HIndent/Ast/Expression/Splice.hs view

@@ -3,11 +3,14 @@ module HIndent.Ast.Expression.Splice   ( Splice   , mkSplice+  , mkTypedSplice   ) where  import qualified GHC.Data.FastString as GHC+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression) import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments (WithComments, fromGenLocated) import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators@@ -16,15 +19,15 @@ 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)+  = Typed (WithComments Expression)+  | UntypedDollar (WithComments Expression)+  | UntypedBare (WithComments Expression)   | QuasiQuote PrefixName GHC.FastString  instance CommentExtraction Splice where-  nodeComments Typed {} = NodeComments [] [] []-  nodeComments UntypedDollar {} = NodeComments [] [] []-  nodeComments UntypedBare {} = NodeComments [] [] []+  nodeComments (Typed expr) = nodeComments expr+  nodeComments (UntypedDollar expr) = nodeComments expr+  nodeComments (UntypedBare expr) = nodeComments expr   nodeComments QuasiQuote {} = NodeComments [] [] []  instance Pretty Splice where@@ -46,13 +49,39 @@       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.HsUntypedSpliceExpr anns x)+  | hasDollarToken anns = UntypedDollar $ mkExpression <$> fromGenLocated x+  | otherwise = UntypedBare $ mkExpression <$> fromGenLocated x mkSplice (GHC.HsQuasiQuote _ l (GHC.L _ r)) = QuasiQuote (mkPrefixName 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.HsTypedSplice _ _ _ body) =+  Typed $ mkExpression <$> fromGenLocated body+mkSplice (GHC.HsUntypedSplice _ GHC.DollarSplice _ body) =+  UntypedDollar $ mkExpression <$> fromGenLocated body+mkSplice (GHC.HsUntypedSplice _ GHC.BareSplice _ body) =+  UntypedBare $ mkExpression <$> fromGenLocated body mkSplice (GHC.HsQuasiQuote _ _ l _ r) = QuasiQuote (mkPrefixName l) r mkSplice GHC.HsSpliced {} = error "This AST node should never appear." #endif++#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+hasDollarToken :: GHC.XUntypedSpliceExpr GHC.GhcPs -> Bool+hasDollarToken (GHC.EpTok _) = True+hasDollarToken GHC.NoEpTok = False+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+hasDollarToken :: GHC.XUntypedSpliceExpr GHC.GhcPs -> Bool+hasDollarToken anns = any isDollarAnn anns+  where+    isDollarAnn (GHC.AddEpAnn GHC.AnnDollar _) = True+    isDollarAnn _ = False+#else+hasDollarToken :: GHC.XUntypedSpliceExpr GHC.GhcPs -> Bool+hasDollarToken (GHC.EpAnn _ anns _) = any isDollarAnn anns+  where+    isDollarAnn (GHC.AddEpAnn GHC.AnnDollar _) = True+    isDollarAnn _ = False+hasDollarToken GHC.EpAnnNotUsed = False+#endif+mkTypedSplice :: GHC.LHsExpr GHC.GhcPs -> Splice+mkTypedSplice = Typed . fmap mkExpression . fromGenLocated

src/HIndent/Ast/FileHeaderPragma.hs view

@@ -5,7 +5,7 @@  import Data.Bifunctor import Data.Char-import Data.List+import Data.List (intercalate) import Data.List.Split import qualified GHC.Hs as GHC import HIndent.Ast.NodeComments

+ src/HIndent/Ast/Guard.hs view

@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module HIndent.Ast.Guard+  ( Guard+  , mkExprGuard+  , mkCaseExprGuard+  , mkLambdaExprGuard+  , mkMultiWayIfExprGuard+  , mkCaseCmdGuard+  , mkLambdaCmdGuard+  ) where++import Control.Monad (unless)+import HIndent.Ast.Cmd (Cmd, mkCmd)+import {-# SOURCE #-} HIndent.Ast.Expression+  ( GuardExpression+  , mkExpression+  , mkGuardExpression+  )+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data GuardContext+  = PlainGuard+  | CaseGuard+  | LambdaGuard+  | MultiWayIfGuard+  deriving (Eq)++data Guard+  = ExprGuard+      { guardContext :: GuardContext+      , conditions :: [GHC.GuardLStmt GHC.GhcPs]+      , expr :: WithComments GuardExpression+      }+  | CmdGuard+      { guardContext :: GuardContext+      , conditions :: [GHC.GuardLStmt GHC.GhcPs]+      , cmd :: WithComments Cmd+      }++instance CommentExtraction Guard where+  nodeComments _ = NodeComments [] [] []++instance Pretty Guard where+  pretty' ExprGuard {..}+    | null conditions = do+      space+      string (contextSeparator guardContext)+      pretty expr+    | otherwise = do+      unless (guardContext == MultiWayIfGuard) newline+      (if guardContext == MultiWayIfGuard+         then id+         else indentedBlock) $ do+        string "| " |=> vCommaSep (fmap pretty conditions)+        space+        string (contextSeparator guardContext)+        pretty expr+  pretty' CmdGuard {..}+    | null conditions = do+      space+      string (contextSeparator guardContext)+      let hor = space >> pretty cmd+          ver = newline >> indentedBlock (pretty cmd)+       in hor <-|> ver+    | otherwise = do+      unless (guardContext == MultiWayIfGuard) newline+      (if guardContext == MultiWayIfGuard+         then id+         else indentedBlock) $ do+        string "| " |=> vCommaSep (fmap pretty conditions)+        space+        string (contextSeparator guardContext)+        let hor = space >> pretty cmd+            ver = newline >> indentedBlock (pretty cmd)+         in hor <-|> ver++contextSeparator :: GuardContext -> String+contextSeparator PlainGuard = "="+contextSeparator CaseGuard = "->"+contextSeparator LambdaGuard = "->"+contextSeparator MultiWayIfGuard = "->"++mkExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = PlainGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkCaseExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkCaseExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = CaseGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkLambdaExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkLambdaExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = LambdaGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkMultiWayIfExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkMultiWayIfExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = MultiWayIfGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkCaseCmdGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Guard+mkCaseCmdGuard (GHC.GRHS _ conditions cmd) =+  CmdGuard {guardContext = CaseGuard, cmd = fmap mkCmd (fromGenLocated cmd), ..}++mkLambdaCmdGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Guard+mkLambdaCmdGuard (GHC.GRHS _ conditions cmd) =+  CmdGuard+    {guardContext = LambdaGuard, cmd = fmap mkCmd (fromGenLocated cmd), ..}

src/HIndent/Ast/Import.hs view

@@ -9,11 +9,12 @@  import Control.Monad import Data.Function-import Data.List+import Data.List (sortBy) import qualified GHC.Types.SourceText as GHC import qualified GHC.Unit as GHC import HIndent.Applicative import HIndent.Ast.Import.Entry.Collection+import HIndent.Ast.Module.Name (ModuleName, mkModuleName) import HIndent.Ast.NodeComments import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC@@ -27,16 +28,12 @@   | Post   deriving (Eq) -data Qualification = Qualification-  { qualifiedAs :: Maybe (WithComments GHC.ModuleName)-  , position :: QualificationPosition-  } deriving (Eq)- data Import = Import-  { moduleName :: WithComments GHC.ModuleName+  { moduleName :: WithComments ModuleName   , isSafe :: Bool   , isBoot :: Bool-  , qualification :: Maybe Qualification+  , qualifiedAs :: Maybe (WithComments ModuleName)+  , qualification :: Maybe QualificationPosition   , packageName :: Maybe GHC.StringLiteral   , importEntries :: Maybe (WithComments ImportEntryCollection)   }@@ -49,37 +46,27 @@     string "import "     when isBoot $ string "{-# SOURCE #-} "     when isSafe $ string "safe "-    when (fmap position qualification == Just Pre) $ string "qualified "+    when (qualification == Just Pre) $ string "qualified "     whenJust packageName $ \name -> pretty name >> space     pretty moduleName-    when (fmap position qualification == Just Post) $ string " qualified"-    case qualification of-      Just Qualification {qualifiedAs = Just name} ->-        string " as " >> pretty name+    when (qualification == Just Post) $ string " qualified"+    case qualifiedAs of+      Just name -> string " as " >> pretty name       _ -> pure ()     whenJust importEntries pretty  mkImport :: GHC.ImportDecl GHC.GhcPs -> Import mkImport decl@GHC.ImportDecl {..} = Import {..}   where-    moduleName = fromGenLocated ideclName+    moduleName = mkModuleName <$> fromGenLocated ideclName     isSafe = ideclSafe     isBoot = ideclSource == GHC.IsBoot     qualification =-      case (ideclQualified, ideclAs, ideclQualified) of-        (GHC.NotQualified, _, _) -> Nothing-        (_, Nothing, GHC.QualifiedPre) ->-          Just Qualification {qualifiedAs = Nothing, position = Pre}-        (_, Nothing, GHC.QualifiedPost) ->-          Just Qualification {qualifiedAs = Nothing, position = Post}-        (_, Just name, GHC.QualifiedPre) ->-          Just-            Qualification-              {qualifiedAs = Just $ fromGenLocated name, position = Pre}-        (_, Just name, GHC.QualifiedPost) ->-          Just-            Qualification-              {qualifiedAs = Just $ fromGenLocated name, position = Post}+      case ideclQualified of+        GHC.NotQualified -> Nothing+        GHC.QualifiedPre -> Just Pre+        GHC.QualifiedPost -> Just Post+    qualifiedAs = fmap mkModuleName . fromGenLocated <$> ideclAs     packageName = GHC.getPackageName decl     importEntries = mkImportEntryCollection decl @@ -88,8 +75,7 @@  -- | This function sorts import declarations by their module names. sortByModuleName :: [WithComments Import] -> [WithComments Import]-sortByModuleName =-  sortBy (compare `on` showOutputable . getNode . moduleName . getNode)+sortByModuleName = sortBy (compare `on` getNode . moduleName . getNode)  -- | This function sorts explicit imports in the given import declaration -- by their names.

src/HIndent/Ast/Import/Collection.hs view

@@ -9,7 +9,7 @@  import Control.Monad.RWS import Data.Function-import Data.List+import Data.List (sortBy) import qualified GHC.Hs as GHC import GHC.Stack import qualified GHC.Types.SrcLoc as GHC

src/HIndent/Ast/Import/Entry.hs view

@@ -7,32 +7,24 @@   , sortVariantsAndExplicitImports   ) where -import Data.Char import Data.Function-import Data.List+import Data.List (sortBy) import qualified GHC.Hs as GHC+import HIndent.Ast.Name.ImportExport import HIndent.Ast.NodeComments import HIndent.Ast.WithComments import HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)-data ImportEntry-  = SingleIdentifier (GHC.LIEWrappedName GHC.GhcPs)-  | WithSpecificConstructors-      { name :: GHC.LIEWrappedName GHC.GhcPs-      , constructors :: [GHC.LIEWrappedName GHC.GhcPs]-      }-  | WithAllConstructors (GHC.LIEWrappedName GHC.GhcPs)-#else+ data ImportEntry-  = SingleIdentifier (GHC.LIEWrappedName (GHC.IdP GHC.GhcPs))+  = SingleIdentifier (WithComments ImportExportName)   | WithSpecificConstructors-      { name :: GHC.LIEWrappedName (GHC.IdP GHC.GhcPs)-      , constructors :: [GHC.LIEWrappedName (GHC.IdP GHC.GhcPs)]+      { name :: WithComments ImportExportName+      , constructors :: [WithComments ImportExportName]       }-  | WithAllConstructors (GHC.LIEWrappedName (GHC.IdP GHC.GhcPs))-#endif+  | WithAllConstructors (WithComments ImportExportName)+ instance CommentExtraction ImportEntry where   nodeComments _ = NodeComments [] [] [] @@ -44,17 +36,31 @@  mkImportEntry :: GHC.IE GHC.GhcPs -> ImportEntry #if MIN_VERSION_ghc_lib_parser(9, 10, 1)-mkImportEntry (GHC.IEVar _ name _) = SingleIdentifier name-mkImportEntry (GHC.IEThingAbs _ name _) = SingleIdentifier name-mkImportEntry (GHC.IEThingAll _ name _) = WithAllConstructors name+mkImportEntry (GHC.IEVar _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAbs _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAll _ name _) =+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name mkImportEntry (GHC.IEThingWith _ name _ constructors _) =-  WithSpecificConstructors {..}+  WithSpecificConstructors+    { name = mkImportExportName <$> fromGenLocated name+    , constructors =+        fmap (fmap mkImportExportName . fromGenLocated) constructors+    } #else-mkImportEntry (GHC.IEVar _ name) = SingleIdentifier name-mkImportEntry (GHC.IEThingAbs _ name) = SingleIdentifier name-mkImportEntry (GHC.IEThingAll _ name) = WithAllConstructors name+mkImportEntry (GHC.IEVar _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAbs _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAll _ name) =+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name mkImportEntry (GHC.IEThingWith _ name _ constructors) =-  WithSpecificConstructors {..}+  WithSpecificConstructors+    { name = mkImportExportName <$> fromGenLocated name+    , constructors =+        fmap (fmap mkImportExportName . fromGenLocated) constructors+    } #endif mkImportEntry _ = undefined @@ -69,7 +75,7 @@   where     f WithSpecificConstructors {..} =       WithSpecificConstructors-        {constructors = sortBy (compare `on` showOutputable) constructors, ..}+        {constructors = sortBy (compare `on` getNode) constructors, ..}     f x = x  -- | This function sorts the given explicit imports by their names.@@ -78,68 +84,11 @@  -- | This function compares two import declarations by their module names. compareImportEntities :: ImportEntry -> ImportEntry -> Ordering-compareImportEntities = compareIdentifier `on` showOutputable . getModuleName+compareImportEntities = compare `on` getNode . getModuleName+ -- | This function returns a 'Just' value with the module name extracted -- from the import declaration. Otherwise, it returns a 'Nothing'.-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)-getModuleName :: ImportEntry -> GHC.LIEWrappedName GHC.GhcPs-#else-getModuleName :: ImportEntry -> GHC.LIEWrappedName (GHC.IdP GHC.GhcPs)-#endif+getModuleName :: ImportEntry -> WithComments ImportExportName getModuleName (SingleIdentifier wrapped) = wrapped getModuleName (WithAllConstructors wrapped) = wrapped getModuleName (WithSpecificConstructors wrapped _) = wrapped---- | This function compares two identifiers in order of capitals, symbols,--- and lowers.-compareIdentifier :: String -> String -> Ordering-compareIdentifier as@(a:_) bs@(b:_) =-  case compareChar a b of-    EQ -> compareSameIdentifierType as bs-    x -> x-compareIdentifier _ _ = error "Either identifier is an empty string."---- | Almost similar to 'compare' but ignores parentheses for symbol--- identifiers as they are enclosed by parentheses.-compareSameIdentifierType :: String -> String -> Ordering-compareSameIdentifierType "" "" = EQ-compareSameIdentifierType "" _ = LT-compareSameIdentifierType _ "" = GT-compareSameIdentifierType ('(':as) bs = compareSameIdentifierType as bs-compareSameIdentifierType (')':as) bs = compareSameIdentifierType as bs-compareSameIdentifierType as ('(':bs) = compareSameIdentifierType as bs-compareSameIdentifierType as (')':bs) = compareSameIdentifierType as bs-compareSameIdentifierType (a:as) (b:bs) =-  case compare a b of-    EQ -> compareSameIdentifierType as bs-    x -> x---- | This function compares two characters by their types (capital, symbol,--- and lower). If both are the same type, then it compares them by the--- usual ordering.-compareChar :: Char -> Char -> Ordering-compareChar a b =-  case compare at bt of-    EQ -> compare a b-    x -> x-  where-    at = charToLetterType a-    bt = charToLetterType b---- | This function returns a 'LetterType' based on the given character.-charToLetterType :: Char -> LetterType-charToLetterType c-  | isLower c = Lower-  | isUpper c = Capital-  | otherwise = Symbol---- | The letter type of a 'Char'.------ The order of constructors is important. HIndent sorts explicit imports--- from ones starting from a capital letter (e.g., data constructors),--- symbol identifiers, and functions.-data LetterType-  = Capital-  | Symbol-  | Lower-  deriving (Eq, Ord)

+ src/HIndent/Ast/LocalBinds.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.LocalBinds+  ( LocalBinds+  , mkLocalBinds+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified GHC.Data.Bag as GHC+#endif+import HIndent.Ast.LocalBinds.ImplicitBindings+  ( ImplicitBindings+  , mkImplicitBindings+  )+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromEpAnn, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import qualified HIndent.Pretty.SigBindFamily as SBF++data LocalBinds+  = Value+      { sigBindFamilies :: [WithComments SBF.SigBindFamily]+      }+  | ImplicitParameters+      { implicitBindings :: ImplicitBindings+      }++instance CommentExtraction LocalBinds where+  nodeComments Value {} = NodeComments [] [] []+  nodeComments ImplicitParameters {} = NodeComments [] [] []++instance Pretty LocalBinds where+  pretty' Value {sigBindFamilies = families} = lined $ fmap pretty families+  pretty' (ImplicitParameters {implicitBindings = binds}) = pretty binds++mkLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Maybe (WithComments LocalBinds)+mkLocalBinds (GHC.HsValBinds ann binds) =+  Just $ fromEpAnn ann $ Value {sigBindFamilies = mkSigBindFamilies binds}+mkLocalBinds (GHC.HsIPBinds ann binds) =+  Just+    $ fromEpAnn ann+    $ ImplicitParameters {implicitBindings = mkImplicitBindings binds}+mkLocalBinds GHC.EmptyLocalBinds {} = Nothing++mkSigBindFamilies ::+     GHC.HsValBindsLR GHC.GhcPs GHC.GhcPs -> [WithComments SBF.SigBindFamily]+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkSigBindFamilies (GHC.ValBinds _ binds sigs) =+  fmap fromGenLocated $ SBF.mkSortedLSigBindFamilyList sigs binds [] [] [] []+#else+mkSigBindFamilies (GHC.ValBinds _ bindBag sigs) =+  fromGenLocated+    <$> SBF.mkSortedLSigBindFamilyList sigs (GHC.bagToList bindBag) [] [] [] []+#endif+mkSigBindFamilies GHC.XValBindsLR {} =+  error "`ghc-lib-parser` never generates this AST node."

+ src/HIndent/Ast/LocalBinds/ImplicitBinding.hs view

@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.LocalBinds.ImplicitBinding+  ( ImplicitBinding+  , mkImplicitBinding+  ) where++import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  )+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ImplicitBinding = ImplicitBinding+  { name :: WithComments ImplicitParameterName+  , expression :: WithComments Expression+  }++instance CommentExtraction ImplicitBinding where+  nodeComments _ = NodeComments [] [] []++instance Pretty ImplicitBinding where+  pretty' ImplicitBinding {..} =+    spaced [pretty name, string "=", pretty expression]++mkImplicitBinding :: GHC.IPBind GHC.GhcPs -> ImplicitBinding+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkImplicitBinding (GHC.IPBind _ lhs rhs) =+  ImplicitBinding+    { name = mkImplicitParameterName <$> fromGenLocated lhs+    , expression = mkExpression <$> fromGenLocated rhs+    }+#else+mkImplicitBinding (GHC.IPBind _ (Left lhs) rhs) =+  ImplicitBinding+    { name = mkImplicitParameterName <$> fromGenLocated lhs+    , expression = mkExpression <$> fromGenLocated rhs+    }+mkImplicitBinding (GHC.IPBind _ (Right _) _) =+  error "`ghc-lib-parser` never generates this AST node."+#endif

+ src/HIndent/Ast/LocalBinds/ImplicitBindings.hs view

@@ -0,0 +1,30 @@+module HIndent.Ast.LocalBinds.ImplicitBindings+  ( ImplicitBindings+  , mkImplicitBindings+  ) where++import HIndent.Ast.LocalBinds.ImplicitBinding+  ( ImplicitBinding+  , mkImplicitBinding+  )+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype ImplicitBindings = ImplicitBindings+  { bindings :: [WithComments ImplicitBinding]+  }++instance CommentExtraction ImplicitBindings where+  nodeComments _ = NodeComments [] [] []++instance Pretty ImplicitBindings where+  pretty' (ImplicitBindings xs) = lined $ fmap pretty xs++mkImplicitBindings :: GHC.HsIPBinds GHC.GhcPs -> ImplicitBindings+mkImplicitBindings (GHC.IPBinds _ xs) =+  ImplicitBindings+    {bindings = fmap (fmap mkImplicitBinding . fromGenLocated) xs}

+ src/HIndent/Ast/Match.hs view

@@ -0,0 +1,317 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Match+  ( Match+  , mkExprMatch+  , mkCmdMatch+  ) where++import Control.Monad (unless, when)+import qualified GHC.Hs as GHC+import qualified GHC.Types.Fixity as Fixity+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+import qualified GHC.Types.Name.Reader as GHC+#endif+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative (whenJust)+import HIndent.Ast.Declaration.Bind.GuardedRhs+  ( GuardedRhs+  , mkCaseCmdGuardedRhs+  , mkCaseGuardedRhs+  , mkGuardedRhs+  , mkLambdaCmdGuardedRhs+  , mkLambdaGuardedRhs+  )+import HIndent.Ast.Name.Infix (InfixName, mkInfixName)+import HIndent.Ast.Name.Prefix (PrefixName, mkPrefixName)+import HIndent.Ast.NodeComments+import HIndent.Ast.Pattern (Pattern, mkPattern)+import HIndent.Ast.Type.Strictness (Strictness, mkStrictness)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+import HIndent.Ast.WithComments (WithComments, fromGenLocated, prettyWith)+#else+import HIndent.Ast.WithComments+  ( WithComments+  , fromGenLocated+  , mkWithComments+  , prettyWith+  )+#endif+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..))++data InfixOperands = InfixOperands+  { left :: WithComments Pattern+  , operator :: WithComments InfixName+  , right :: WithComments Pattern+  , rest :: [WithComments Pattern]+  }++instance CommentExtraction InfixOperands where+  nodeComments _ = NodeComments [] [] []++instance Pretty InfixOperands where+  pretty' InfixOperands {..} =+    spaced $ pretty left : pretty operator : pretty right : fmap pretty rest++data Match+  = Lambda+      { needsSpaceAfterLambda :: Bool+      , patterns :: WithComments [WithComments Pattern]+      , rhs :: GuardedRhs+      }+  | Case+      { patterns :: WithComments [WithComments Pattern]+      , rhs :: GuardedRhs+      }+  | FunctionPrefix+      { strictness :: Maybe Strictness+      , name :: WithComments PrefixName+      , patterns :: WithComments [WithComments Pattern]+      , rhs :: GuardedRhs+      }+  | FunctionInfix+      { operands :: WithComments InfixOperands+      , rhs :: GuardedRhs+      }++instance CommentExtraction Match where+  nodeComments _ = NodeComments [] [] []++instance Pretty Match where+  pretty' Lambda {..} = do+    string "\\"+    when needsSpaceAfterLambda space+    prettyWith patterns $ spaced . fmap pretty+    pretty rhs+  pretty' Case {..} = do+    prettyWith patterns $ spaced . fmap pretty+    pretty rhs+  pretty' FunctionPrefix {..} = do+    whenJust strictness pretty+    pretty name+    prettyWith patterns $ \pats ->+      unless (null pats) $ spacePrefixed $ fmap pretty pats+    pretty rhs+  pretty' FunctionInfix {..} = do+    pretty operands+    pretty rhs+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace $ GHC.unLoc m_pats+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkLambdaGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt _, ..} =+  Case+    { rhs = mkCaseGuardedRhs m_grhss+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { rhs = mkCaseGuardedRhs m_grhss+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns =+      fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkLambdaGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCase, ..} =+  Case+    { rhs = mkCaseGuardedRhs m_grhss+    , patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCases, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = patterns+    , rhs = mkLambdaGuardedRhs m_grhss+    }+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamCaseAlt {}, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#else+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkLambdaGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#endif++#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace (GHC.unLoc m_pats)+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt _, ..} =+  Case+    { patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCase, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCases, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamCaseAlt {}, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#else+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { rhs = mkCaseCmdGuardedRhs m_grhss+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkFunctionMatch ::+     GHC.HsMatchContext (GHC.GenLocated GHC.SrcSpanAnnN GHC.RdrName)+  -> WithComments [WithComments Pattern]+  -> GuardedRhs+  -> Match+#else+mkFunctionMatch ::+     GHC.HsMatchContext GHC.GhcPs+  -> WithComments [WithComments Pattern]+  -> GuardedRhs+  -> Match+#endif+mkFunctionMatch GHC.FunRhs {mc_fixity = Fixity.Prefix, ..} patterns rhs =+  FunctionPrefix+    { strictness = mkStrictness mc_strictness+    , name = mkPrefixName <$> fromGenLocated mc_fun+    , ..+    }+mkFunctionMatch GHC.FunRhs {mc_fixity = Fixity.Infix, ..} pats rhs =+  FunctionInfix {..}+  where+    operands =+      flip fmap pats $ \case+        left:right:rest ->+          InfixOperands {operator = mkInfixName <$> fromGenLocated mc_fun, ..}+        _ -> error "FunctionInfix match must have at least two patterns."+mkFunctionMatch _ _ _ = error "`ghc-lib-parser` never generates this AST node."++lambdaNeedsSpace :: [GHC.LPat GHC.GhcPs] -> Bool+lambdaNeedsSpace (pat:_) =+  case GHC.unLoc pat of+    GHC.LazyPat {} -> True+    GHC.BangPat {} -> True+    _ -> False+lambdaNeedsSpace _ = False

+ src/HIndent/Ast/MatchGroup.hs view

@@ -0,0 +1,46 @@+module HIndent.Ast.MatchGroup+  ( MatchGroup+  , mkExprMatchGroup+  , mkCmdMatchGroup+  , hasMatches+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.Match (Match, mkCmdMatch, mkExprMatch)+import HIndent.Ast.WithComments+  ( WithComments+  , fromGenLocated+  , getComments+  , getNode+  , prettyWith+  )+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators (lined)+import HIndent.Pretty.NodeComments (CommentExtraction(..))++newtype MatchGroup =+  MatchGroup (WithComments [WithComments Match])++instance CommentExtraction MatchGroup where+  nodeComments (MatchGroup alts) = getComments alts++instance Pretty MatchGroup where+  pretty' (MatchGroup alts) = prettyWith alts (lined . fmap pretty)++mkExprMatchGroup ::+     GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> MatchGroup+mkExprMatchGroup =+  MatchGroup+    . fmap (fmap (fmap mkExprMatch . fromGenLocated))+    . fromGenLocated+    . GHC.mg_alts++mkCmdMatchGroup :: GHC.MatchGroup GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> MatchGroup+mkCmdMatchGroup =+  MatchGroup+    . fmap (fmap (fmap mkCmdMatch . fromGenLocated))+    . fromGenLocated+    . GHC.mg_alts++hasMatches :: MatchGroup -> Bool+hasMatches (MatchGroup alts) = not $ null $ getNode alts

+ src/HIndent/Ast/MatchGroup.hs-boot view

@@ -0,0 +1,17 @@+module HIndent.Ast.MatchGroup+  ( MatchGroup+  , mkCmdMatchGroup+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty)+import HIndent.Pretty.NodeComments++data MatchGroup++instance Pretty MatchGroup++instance CommentExtraction MatchGroup++mkCmdMatchGroup ::+     GHC.MatchGroup GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> MatchGroup

src/HIndent/Ast/Module/Declaration.hs view

@@ -27,7 +27,9 @@  instance Pretty ModuleDeclaration where   pretty' ModuleDeclaration {..} = do-    pretty name+    prettyWith name $ \n -> do+      string "module "+      pretty n     whenJust warning $ \x -> do       space       pretty x@@ -41,6 +43,7 @@   case GHC.hsmodName m of     Nothing -> Nothing     Just name' -> Just ModuleDeclaration {..}-      where name = mkModuleName <$> fromGenLocated name'-            warning = mkModuleWarning m-            exports = mkExportCollection m+      where+        name = mkModuleName <$> fromGenLocated name'+        warning = mkModuleWarning m+        exports = mkExportCollection m

src/HIndent/Ast/Module/Export/Entry.hs view

@@ -6,30 +6,23 @@   ) where  import GHC.Stack-import qualified GHC.Unit as GHC+import HIndent.Ast.Module.Name+import HIndent.Ast.Name.ImportExport import HIndent.Ast.NodeComments import HIndent.Ast.WithComments import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)-data ExportEntry-  = SingleIdentifier (WithComments (GHC.IEWrappedName GHC.GhcPs))-  | WithSpecificConstructors-      (WithComments (GHC.IEWrappedName GHC.GhcPs))-      [WithComments (GHC.IEWrappedName GHC.GhcPs)]-  | WithAllConstructors (WithComments (GHC.IEWrappedName GHC.GhcPs))-  | ByModule (WithComments GHC.ModuleName)-#else+ data ExportEntry-  = SingleIdentifier (WithComments (GHC.IEWrappedName (GHC.IdP GHC.GhcPs)))+  = SingleIdentifier (WithComments ImportExportName)   | WithSpecificConstructors-      (WithComments (GHC.IEWrappedName (GHC.IdP GHC.GhcPs)))-      [WithComments (GHC.IEWrappedName (GHC.IdP GHC.GhcPs))]-  | WithAllConstructors (WithComments (GHC.IEWrappedName (GHC.IdP GHC.GhcPs)))-  | ByModule (WithComments GHC.ModuleName)-#endif+      (WithComments ImportExportName)+      [WithComments ImportExportName]+  | WithAllConstructors (WithComments ImportExportName)+  | ByModule (WithComments ModuleName)+ instance CommentExtraction ExportEntry where   nodeComments SingleIdentifier {} = NodeComments [] [] []   nodeComments WithSpecificConstructors {} = NodeComments [] [] []@@ -44,25 +37,28 @@  mkExportEntry :: GHC.IE GHC.GhcPs -> ExportEntry #if MIN_VERSION_ghc_lib_parser(9, 10, 1)-mkExportEntry (GHC.IEVar _ name _) = SingleIdentifier $ fromGenLocated name-mkExportEntry (GHC.IEThingAbs _ name _) = SingleIdentifier $ fromGenLocated name+mkExportEntry (GHC.IEVar _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingAbs _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name mkExportEntry (GHC.IEThingAll _ name _) =-  WithAllConstructors $ fromGenLocated name+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name mkExportEntry (GHC.IEThingWith _ name _ constructors _) =-  WithSpecificConstructors-    (fromGenLocated name)-    (fmap fromGenLocated constructors)+  WithSpecificConstructors (mkImportExportName <$> fromGenLocated name)+    $ fmap mkImportExportName . fromGenLocated <$> constructors #else-mkExportEntry (GHC.IEVar _ name) = SingleIdentifier $ fromGenLocated name-mkExportEntry (GHC.IEThingAbs _ name) = SingleIdentifier $ fromGenLocated name+mkExportEntry (GHC.IEVar _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingAbs _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name mkExportEntry (GHC.IEThingAll _ name) =-  WithAllConstructors $ fromGenLocated name+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name mkExportEntry (GHC.IEThingWith _ name _ constructors) =-  WithSpecificConstructors-    (fromGenLocated name)-    (fmap fromGenLocated constructors)+  WithSpecificConstructors (mkImportExportName <$> fromGenLocated name)+    $ fmap mkImportExportName . fromGenLocated <$> constructors #endif-mkExportEntry (GHC.IEModuleContents _ name) = ByModule $ fromGenLocated name+mkExportEntry (GHC.IEModuleContents _ name) =+  ByModule $ mkModuleName <$> fromGenLocated name mkExportEntry GHC.IEGroup {} = neverAppears mkExportEntry GHC.IEDoc {} = neverAppears mkExportEntry GHC.IEDocNamed {} = neverAppears

src/HIndent/Ast/Module/Name.hs view

@@ -5,18 +5,19 @@  import qualified GHC.Unit as GHC import HIndent.Ast.NodeComments-import HIndent.Pretty+import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments  newtype ModuleName =   ModuleName String+  deriving (Eq, Ord)  instance CommentExtraction ModuleName where   nodeComments _ = NodeComments [] [] []  instance Pretty ModuleName where-  pretty' (ModuleName x) = string "module " >> string x+  pretty' (ModuleName x) = string x  mkModuleName :: GHC.ModuleName -> ModuleName mkModuleName = ModuleName . GHC.moduleNameString

+ src/HIndent/Ast/Module/Name.hs-boot view

@@ -0,0 +1,5 @@+module HIndent.Ast.Module.Name+  ( ModuleName+  ) where++data ModuleName

src/HIndent/Ast/Module/Warning.hs view

@@ -7,7 +7,6 @@   ) where  import qualified GHC.Types.SourceText as GHC-import qualified GHC.Types.SrcLoc as GHC import HIndent.Ast.Declaration.Warning.Kind import HIndent.Ast.NodeComments import HIndent.Ast.WithComments@@ -16,6 +15,9 @@ import HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments+#if !MIN_VERSION_ghc_lib_parser(9, 10, 0)+import qualified GHC.Types.SrcLoc as GHC+#endif #if MIN_VERSION_ghc_lib_parser(9, 10, 1) data ModuleWarning = ModuleWarning   { messages :: [GHC.LocatedE

+ src/HIndent/Ast/Name/ImportExport.hs view

@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Name.ImportExport+  ( ImportExportName+  , mkImportExportName+  ) where++import qualified Data.ByteString.Builder as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char (isLower, isUpper)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import HIndent.Config+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer++data ImportExportName+  = Regular (WithComments PrefixName)+  | Pattern (WithComments PrefixName)+  | Type (WithComments PrefixName)++instance CommentExtraction ImportExportName where+  nodeComments Regular {} = NodeComments [] [] []+  nodeComments Pattern {} = NodeComments [] [] []+  nodeComments Type {} = NodeComments [] [] []++instance Pretty ImportExportName where+  pretty' (Regular name) = pretty name+  pretty' (Pattern name) = spaced [string "pattern", pretty name]+  pretty' (Type name) = string "type " >> pretty name++instance Eq ImportExportName where+  a == b = compare a b == EQ++instance Ord ImportExportName where+  compare a b = compareIdentifier (getNameString a) (getNameString b)++getNameString :: ImportExportName -> String+getNameString n =+  L.unpack $ S.toLazyByteString $ runPrinterStyle defaultConfig $ pretty' n++compareIdentifier :: String -> String -> Ordering+compareIdentifier as@(a:_) bs@(b:_) =+  case compareChar a b of+    EQ -> compareSameIdentifierType as bs+    x -> x+compareIdentifier "" "" = EQ+compareIdentifier "" _ = LT+compareIdentifier _ "" = GT++compareSameIdentifierType :: String -> String -> Ordering+compareSameIdentifierType "" "" = EQ+compareSameIdentifierType "" _ = LT+compareSameIdentifierType _ "" = GT+compareSameIdentifierType ('(':as) bs = compareSameIdentifierType as bs+compareSameIdentifierType (')':as) bs = compareSameIdentifierType as bs+compareSameIdentifierType as ('(':bs) = compareSameIdentifierType as bs+compareSameIdentifierType as (')':bs) = compareSameIdentifierType as bs+compareSameIdentifierType (a:as) (b:bs) =+  case compare a b of+    EQ -> compareSameIdentifierType as bs+    x -> x++compareChar :: Char -> Char -> Ordering+compareChar a b =+  case compare (charToLetterType a) (charToLetterType b) of+    EQ -> compare a b+    x -> x++charToLetterType :: Char -> LetterType+charToLetterType c+  | isLower c = Lower+  | isUpper c = Capital+  | otherwise = Symbol++data LetterType+  = Capital+  | Symbol+  | Lower+  deriving (Eq, Ord)+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkImportExportName :: GHC.IEWrappedName GHC.GhcPs -> ImportExportName+mkImportExportName (GHC.IEName _ name) =+  Regular $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEPattern _ name) =+  Pattern $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEType _ name) =+  Type $ fromGenLocated $ fmap mkPrefixName name+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkImportExportName GHC.IEDefault {} =+  error "IEDefault is not generated by parser"+#endif+#else+mkImportExportName :: GHC.IEWrappedName GHC.RdrName -> ImportExportName+mkImportExportName (GHC.IEName name) =+  Regular $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEPattern _ name) =+  Pattern $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEType _ name) =+  Type $ fromGenLocated $ fmap mkPrefixName name+#endif

src/HIndent/Ast/Name/Infix.hs view

@@ -3,20 +3,24 @@ module HIndent.Ast.Name.Infix   ( InfixName   , mkInfixName+  , getInfixName+  , unlessSpecialOp   ) where +import Control.Monad import Data.Maybe import qualified GHC.Types.Name as GHC import qualified GHC.Types.Name.Reader as GHC-import qualified GHC.Unit.Module as GHC+import HIndent.Ast.Module.Name import HIndent.Ast.NodeComments import {-# SOURCE #-} HIndent.Pretty-import HIndent.Pretty.Combinators+import HIndent.Pretty.Combinators hiding (unlessSpecialOp) import HIndent.Pretty.NodeComments+import HIndent.Printer  data InfixName = InfixName-  { name :: GHC.OccName-  , moduleName :: Maybe GHC.ModuleName+  { name :: String+  , moduleName :: Maybe ModuleName   , backtick :: Bool   } @@ -25,7 +29,7 @@  instance Pretty InfixName where   pretty' InfixName {..} =-    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ pretty name]+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ string name]     where       wrap =         if backtick@@ -33,13 +37,26 @@           else id  mkInfixName :: GHC.RdrName -> InfixName-mkInfixName (GHC.Unqual name) = InfixName name Nothing (backticksNeeded name)+mkInfixName (GHC.Unqual name) =+  InfixName (showOutputable name) Nothing (backticksNeeded name) mkInfixName (GHC.Qual modName name) =-  InfixName name (Just modName) (backticksNeeded name)+  InfixName+    (showOutputable name)+    (Just $ mkModuleName modName)+    (backticksNeeded name) mkInfixName (GHC.Orig {}) =   error "This AST node should not appear in the parser output." mkInfixName (GHC.Exact name) =-  InfixName (GHC.occName name) Nothing (backticksNeeded $ GHC.occName name)+  InfixName+    (showOutputable $ GHC.occName name)+    Nothing+    (backticksNeeded $ GHC.occName name)++getInfixName :: InfixName -> String+getInfixName = name++unlessSpecialOp :: InfixName -> Printer () -> Printer ()+unlessSpecialOp InfixName {..} = unless $ name `elem` ["()", "[]", "->", ":"]  backticksNeeded :: GHC.OccName -> Bool backticksNeeded = not . GHC.isSymOcc

src/HIndent/Ast/Name/Prefix.hs view

@@ -3,20 +3,26 @@ module HIndent.Ast.Name.Prefix   ( PrefixName   , mkPrefixName+  , fromString+  , PrefixAsInfix+  , mkPrefixAsInfix+  , prefixAsInfixFixity   ) where  import Data.Maybe+import qualified GHC.Types.Fixity as Fixity import qualified GHC.Types.Name as GHC import qualified GHC.Types.Name.Reader as GHC-import qualified GHC.Unit.Module as GHC+import HIndent.Ast.Module.Name import HIndent.Ast.NodeComments+import HIndent.Fixity (fixities) import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments  data PrefixName = PrefixName   { name :: String-  , moduleName :: Maybe GHC.ModuleName+  , moduleName :: Maybe ModuleName   , parentheses :: Bool   } @@ -36,11 +42,39 @@ mkPrefixName (GHC.Unqual name) =   PrefixName (showOutputable name) Nothing (parensNeeded name) mkPrefixName (GHC.Qual modName name) =-  PrefixName (showOutputable name) (Just modName) (parensNeeded name)+  PrefixName+    (showOutputable name)+    (Just $ mkModuleName modName)+    (parensNeeded name) mkPrefixName (GHC.Orig {}) =   error "This AST node should not appear in the parser output." mkPrefixName (GHC.Exact name) =   PrefixName (showOutputable name) Nothing (parensNeeded $ GHC.occName name)++fromString :: String -> PrefixName+fromString name = PrefixName name Nothing False++newtype PrefixAsInfix =+  PrefixAsInfix PrefixName++instance CommentExtraction PrefixAsInfix where+  nodeComments (PrefixAsInfix prefix) = nodeComments prefix++instance Pretty PrefixAsInfix where+  pretty' (PrefixAsInfix PrefixName {..}) =+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ string name]+    where+      wrap =+        if parentheses+          then id+          else backticks++mkPrefixAsInfix :: PrefixName -> PrefixAsInfix+mkPrefixAsInfix = PrefixAsInfix++prefixAsInfixFixity :: PrefixAsInfix -> Fixity.Fixity+prefixAsInfixFixity (PrefixAsInfix PrefixName {..}) =+  fromMaybe Fixity.defaultFixity $ lookup name fixities  parensNeeded :: GHC.OccName -> Bool parensNeeded = GHC.isSymOcc

+ src/HIndent/Ast/Name/RecordField.hs view

@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromFieldOcc+  , mkFieldNameFromAmbiguousFieldOcc+  , mkFieldNameFromFieldLabelStrings+  , mkFieldNameFromLabels+  ) where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified GHC.Data.FastString as GHC+import qualified GHC.Hs as GHC+import HIndent.Ast.Name.Prefix (PrefixName, fromString, mkPrefixName)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, flattenComments, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators (hDotSep)+import HIndent.Pretty.NodeComments+import qualified Language.Haskell.Syntax.Basic as GHC++newtype FieldName =+  FieldName (NonEmpty (WithComments PrefixName))++mkFieldNameFromLabels :: NonEmpty (WithComments PrefixName) -> FieldName+mkFieldNameFromLabels = FieldName++instance CommentExtraction FieldName where+  nodeComments FieldName {} = NodeComments [] [] []++instance Pretty FieldName where+  pretty' (FieldName labels) = hDotSep $ pretty <$> NonEmpty.toList labels++mkFieldNameFromFieldOcc :: GHC.FieldOcc GHC.GhcPs -> FieldName+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkFieldNameFromFieldOcc GHC.FieldOcc {..} =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated foLabel+#else+mkFieldNameFromFieldOcc GHC.FieldOcc {..} =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated rdrNameFieldOcc+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkFieldNameFromAmbiguousFieldOcc :: GHC.FieldOcc GHC.GhcPs -> FieldName+mkFieldNameFromAmbiguousFieldOcc = mkFieldNameFromFieldOcc+#else+mkFieldNameFromAmbiguousFieldOcc :: GHC.AmbiguousFieldOcc GHC.GhcPs -> FieldName+mkFieldNameFromAmbiguousFieldOcc (GHC.Unambiguous GHC.NoExtField name) =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated name+mkFieldNameFromAmbiguousFieldOcc (GHC.Ambiguous GHC.NoExtField name) =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated name+#endif+mkFieldNameFromFieldLabelStrings :: GHC.FieldLabelStrings GHC.GhcPs -> FieldName+mkFieldNameFromFieldLabelStrings (GHC.FieldLabelStrings labels) =+  maybe (error "FieldLabelStrings: expected non-empty label path") FieldName+    $ NonEmpty.nonEmpty+    $ fmap toSegment labels+  where+    toSegment =+      flattenComments+        . fmap+            (fmap (fromString . GHC.unpackFS . GHC.field_label)+               . fromGenLocated+               . GHC.dfoLabel)+        . fromGenLocated

src/HIndent/Ast/NodeComments.hs view

@@ -34,6 +34,7 @@ fromEpAnn = fromEpAnn' . filterOutEofAndPragmasFromAnn  fromEpAnn' :: GHC.EpAnn a -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) fromEpAnn' GHC.EpAnn {..} = NodeComments {..}   where     commentsBefore = GHC.priorComments comments@@ -42,10 +43,22 @@     commentsAfter =       filter (not . isCommentOnSameLine) $ GHC.getFollowingComments comments     isCommentOnSameLine (GHC.L comAnn _) =+      GHC.srcSpanEndLine (GHC.epaLocationRealSrcSpan entry)+        == GHC.srcSpanStartLine (GHC.epaLocationRealSrcSpan comAnn)+#else+fromEpAnn' GHC.EpAnn {..} = NodeComments {..}+  where+    commentsBefore = GHC.priorComments comments+    commentsOnSameLine =+      filter isCommentOnSameLine $ GHC.getFollowingComments comments+    commentsAfter =+      filter (not . isCommentOnSameLine) $ GHC.getFollowingComments comments+    isCommentOnSameLine (GHC.L comAnn _) =       GHC.srcSpanEndLine (GHC.anchor entry)         == GHC.srcSpanStartLine (GHC.anchor comAnn) #if !MIN_VERSION_ghc_lib_parser(9, 10, 1) fromEpAnn' GHC.EpAnnNotUsed = NodeComments [] [] []+#endif #endif filterOutEofAndPragmasFromAnn :: GHC.EpAnn ann -> GHC.EpAnn ann filterOutEofAndPragmasFromAnn GHC.EpAnn {..} =

+ src/HIndent/Ast/Pattern.hs view

@@ -0,0 +1,212 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Pattern+  ( Pattern+  , PatInsidePatDecl+  , mkPattern+  , mkPatInsidePatDecl+  ) where++import Control.Monad+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import qualified GHC.Types.Basic as GHC+import qualified GHC.Types.SrcLoc as GHC+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.Expression.Splice+import HIndent.Ast.Name.Infix hiding (unlessSpecialOp)+import qualified HIndent.Ast.Name.Infix as InfixName+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Pattern.RecordFields+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..))++data Pattern+  = WildCard+  | Variable (WithComments PrefixName)+  | Lazy (WithComments Pattern)+  | As+      { name :: WithComments PrefixName+      , pat :: WithComments Pattern+      }+  | Parenthesized (WithComments Pattern)+  | Bang (WithComments Pattern)+  | List [WithComments Pattern]+  | Tuple+      { boxed :: Bool+      , patterns :: [WithComments Pattern]+      }+  | Sum+      { pat :: WithComments Pattern+      , position :: Int+      , arity :: Int+      }+  | PrefixConstructor+      { name :: WithComments PrefixName+      , patterns :: [WithComments Pattern]+      }+  | InfixConstructor+      { left :: WithComments Pattern+      , operator :: WithComments InfixName+      , right :: WithComments Pattern+      }+  | RecordConstructor+      { name :: WithComments PrefixName+      , fields :: RecordFieldsPat+      }+  | View+      { expression :: WithComments Expression+      , pat :: WithComments Pattern+      }+  | Splice (WithComments Splice)+  | Literal (GHC.HsLit GHC.GhcPs)+  | Overloaded (GHC.HsOverLit GHC.GhcPs)+  | NPlusK+      { n :: WithComments PrefixName+      , k :: GHC.HsOverLit GHC.GhcPs+      }+  | Signature+      { pat :: WithComments Pattern+      , sig :: WithComments Type+      }+  | Or (NonEmpty (WithComments Pattern))++instance CommentExtraction Pattern where+  nodeComments _ = NodeComments [] [] []++instance Pretty Pattern where+  pretty' WildCard = string "_"+  pretty' (Variable name) = pretty name+  pretty' (Lazy pat) = string "~" >> pretty pat+  pretty' As {..} = pretty name >> string "@" >> pretty pat+  pretty' (Parenthesized pat) = parens $ pretty pat+  pretty' (Bang pat) = string "!" >> pretty pat+  pretty' (List pats) = hList $ pretty <$> pats+  pretty' Tuple {boxed = True, ..} = hTuple $ pretty <$> patterns+  pretty' Tuple {boxed = False, ..} = hUnboxedTuple $ pretty <$> patterns+  pretty' Sum {..} = do+    string "(#"+    forM_ [1 .. arity] $ \idx -> do+      if idx == position+        then string " " >> pretty pat >> string " "+        else string " "+      when (idx < arity) $ string "|"+    string "#)"+  pretty' PrefixConstructor {..} = do+    pretty name+    spacePrefixed $ pretty <$> patterns+  pretty' InfixConstructor {..} = do+    pretty left+    InfixName.unlessSpecialOp (getNode operator) space+    pretty operator+    InfixName.unlessSpecialOp (getNode operator) space+    pretty right+  pretty' RecordConstructor {..} = (pretty name >> space) |=> pretty fields+  pretty' View {..} = spaced [pretty expression, string "->", pretty pat]+  pretty' (Splice splice) = pretty splice+  pretty' (Literal lit) = pretty lit+  pretty' (Overloaded lit) = pretty lit+  pretty' NPlusK {..} = pretty n >> string "+" >> pretty k+  pretty' Signature {..} = spaced [pretty pat, string "::", pretty sig]+  pretty' (Or pats) = inter (string "; ") $ pretty <$> NE.toList pats++mkPattern :: GHC.Pat GHC.GhcPs -> Pattern+mkPattern GHC.WildPat {} = WildCard+mkPattern (GHC.VarPat _ x) = Variable $ mkPrefixName <$> fromGenLocated x+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkPattern GHC.EmbTyPat {} = notGeneratedByParser+mkPattern GHC.InvisPat {} = notGeneratedByParser+#endif+mkPattern (GHC.LazyPat _ x) = Lazy $ mkPattern <$> fromGenLocated x+#if MIN_VERSION_ghc_lib_parser(9, 6, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkPattern (GHC.AsPat _ a _ b) =+  As+    { name = mkPrefixName <$> fromGenLocated a+    , pat = mkPattern <$> fromGenLocated b+    }+#else+mkPattern (GHC.AsPat _ a b) =+  As+    { name = mkPrefixName <$> fromGenLocated a+    , pat = mkPattern <$> fromGenLocated b+    }+#endif+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkPattern (GHC.ParPat _ _ inner _) =+  Parenthesized $ mkPattern <$> fromGenLocated inner+#else+mkPattern (GHC.ParPat _ inner) =+  Parenthesized $ mkPattern <$> fromGenLocated inner+#endif+mkPattern (GHC.BangPat _ x) = Bang $ mkPattern <$> fromGenLocated x+mkPattern (GHC.ListPat _ xs) = List $ fmap (fmap mkPattern . fromGenLocated) xs+mkPattern (GHC.TuplePat _ pats GHC.Boxed) =+  Tuple {boxed = True, patterns = fmap (fmap mkPattern . fromGenLocated) pats}+mkPattern (GHC.TuplePat _ pats GHC.Unboxed) =+  Tuple {boxed = False, patterns = fmap (fmap mkPattern . fromGenLocated) pats}+mkPattern (GHC.SumPat _ x position numElem) =+  Sum+    {pat = mkPattern <$> fromGenLocated x, position = position, arity = numElem}+mkPattern GHC.ConPat {..} =+  case pat_args of+    GHC.PrefixCon _ as ->+      PrefixConstructor+        { name = mkPrefixName <$> fromGenLocated pat_con+        , patterns = fmap (fmap mkPattern . fromGenLocated) as+        }+    GHC.RecCon rec ->+      RecordConstructor+        { name = mkPrefixName <$> fromGenLocated pat_con+        , fields = mkRecordFieldsPat rec+        }+    GHC.InfixCon a b ->+      InfixConstructor+        { left = mkPattern <$> fromGenLocated a+        , operator = mkInfixName <$> fromGenLocated pat_con+        , right = mkPattern <$> fromGenLocated b+        }+mkPattern (GHC.ViewPat _ l r) =+  View+    { expression = mkExpression <$> fromGenLocated l+    , pat = mkPattern <$> fromGenLocated r+    }+mkPattern (GHC.SplicePat _ x) = Splice $ mkWithComments $ mkSplice x+mkPattern (GHC.LitPat _ x) = Literal x+mkPattern (GHC.NPat _ x _ _) = Overloaded $ GHC.unLoc x+mkPattern (GHC.NPlusKPat _ n k _ _ _) =+  NPlusK {n = mkPrefixName <$> fromGenLocated n, k = GHC.unLoc k}+mkPattern (GHC.SigPat _ l r) =+  Signature+    { pat = mkPattern <$> fromGenLocated l+    , sig =+        flattenComments+          $ fmap mkType+              <$> fromEpAnn (GHC.hsps_ext r) (fromGenLocated $ GHC.hsps_body r)+    }+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkPattern (GHC.OrPat _ pats) = Or $ fmap (fmap mkPattern . fromGenLocated) pats+#endif+newtype PatInsidePatDecl =+  PatInsidePatDecl Pattern++instance CommentExtraction PatInsidePatDecl where+  nodeComments (PatInsidePatDecl p) = nodeComments p++instance Pretty PatInsidePatDecl where+  pretty' (PatInsidePatDecl InfixConstructor {..}) =+    spaced [pretty left, pretty operator, pretty right]+  pretty' (PatInsidePatDecl p) = pretty p++mkPatInsidePatDecl :: GHC.Pat GHC.GhcPs -> PatInsidePatDecl+mkPatInsidePatDecl = PatInsidePatDecl . mkPattern+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+notGeneratedByParser :: a+notGeneratedByParser = error "This AST node is not generated by the parser."+#endif

+ src/HIndent/Ast/Pattern.hs-boot view

@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleInstances #-}++module HIndent.Ast.Pattern+  ( Pattern+  , mkPattern+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import {-# SOURCE #-} HIndent.Pretty++data Pattern++instance CommentExtraction Pattern+instance Pretty Pattern++mkPattern :: GHC.Pat GHC.GhcPs -> Pattern

+ src/HIndent/Ast/Pattern/RecordFields.hs view

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Pattern.RecordFields+  ( RecordFieldsPat+  , mkRecordFieldsPat+  ) where++import Data.Maybe (isJust)+import HIndent.Ast.NodeComments+import HIndent.Ast.Record.Field (PatField, mkPatField)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RecordFieldsPat = RecordFieldsPat+  { fields :: [WithComments PatField]+  , dotdot :: Bool+  }++instance CommentExtraction RecordFieldsPat where+  nodeComments RecordFieldsPat {} = NodeComments [] [] []++instance Pretty RecordFieldsPat where+  pretty' (RecordFieldsPat fs dd) =+    case fieldPrinters of+      [] -> string "{}"+      [x] -> braces x+      xs -> hvFields xs+    where+      fieldPrinters = fmap pretty fs ++ [string ".." | dd]++mkRecordFieldsPat ::+     GHC.HsRecFields GHC.GhcPs (GHC.LPat GHC.GhcPs) -> RecordFieldsPat+mkRecordFieldsPat GHC.HsRecFields {..} =+  RecordFieldsPat+    { fields = fmap (fmap mkPatField . fromGenLocated) rec_flds+    , dotdot = isJust rec_dotdot+    }

+ src/HIndent/Ast/Record/Field.hs view

@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Record.Field+  ( ExprField+  , PatField+  , mkExprField+  , mkPatField+  ) where++import HIndent.Applicative (whenJust)+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc)+import HIndent.Ast.NodeComments (NodeComments(..))+import {-# SOURCE #-} HIndent.Ast.Pattern (Pattern, mkPattern)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+  ( (<-|>)+  , indentedBlock+  , newline+  , space+  , string+  )+import HIndent.Pretty.NodeComments (CommentExtraction(..))++type ExprField = Field Expression++type PatField = Field Pattern++data Field rhs = Field+  { name :: WithComments FieldName+  , value :: Maybe (WithComments rhs)+  }++instance CommentExtraction (Field rhs) where+  nodeComments Field {} = NodeComments [] [] []++instance Pretty ExprField where+  pretty' Field {..} = do+    pretty name+    whenJust value $ \val -> do+      string " ="+      (space >> pretty val) <-|> (newline >> indentedBlock (pretty val))++instance Pretty PatField where+  pretty' Field {..} = do+    pretty name+    whenJust value $ \val -> do+      string " = "+      pretty val+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkExprField ::+     GHC.HsFieldBind (GHC.LFieldOcc GHC.GhcPs) (GHC.LHsExpr GHC.GhcPs)+  -> ExprField+mkExprField GHC.HsFieldBind {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hfbLHS+    , value =+        if hfbPun+          then Nothing+          else Just (mkExpression <$> fromGenLocated hfbRHS)+    }+#else+mkExprField ::+     GHC.HsRecField' (GHC.FieldOcc GHC.GhcPs) (GHC.LHsExpr GHC.GhcPs)+  -> ExprField+mkExprField GHC.HsRecField {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hsRecFieldLbl+    , value =+        if hsRecPun+          then Nothing+          else Just (mkExpression <$> fromGenLocated hsRecFieldArg)+    }+#endif++#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkPatField ::+     GHC.HsFieldBind (GHC.LFieldOcc GHC.GhcPs) (GHC.LPat GHC.GhcPs) -> PatField+mkPatField GHC.HsFieldBind {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hfbLHS+    , value =+        if hfbPun+          then Nothing+          else Just (mkPattern <$> fromGenLocated hfbRHS)+    }+#else+mkPatField ::+     GHC.HsRecField' (GHC.FieldOcc GHC.GhcPs) (GHC.LPat GHC.GhcPs) -> PatField+mkPatField GHC.HsRecField {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hsRecFieldLbl+    , value =+        if hsRecPun+          then Nothing+          else Just (mkPattern <$> fromGenLocated hsRecFieldArg)+    }+#endif

+ src/HIndent/Ast/Statement.hs view

@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Statement+  ( ExprStatement+  , CmdStatement+  , mkExprStatement+  , mkCmdStatement+  ) where++import qualified GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Ast.Cmd (Cmd, mkCmd)+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import HIndent.Ast.Pattern (Pattern, mkPattern)+import HIndent.Ast.WithComments (WithComments, fromGenLocated, prettyWith)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..), emptyNodeComments)++type ExprStatement = Statement Expression++type CmdStatement = Statement Cmd++data Statement a+  = Expression (WithComments a)+  | Binding+      { lhsPattern :: WithComments Pattern+      , rhs :: WithComments a+      }+  | LetBinding (WithComments LocalBinds)+  | Parallel [[WithComments (Statement a)]]+  | Transform+      { steps :: [WithComments (Statement a)]+      , using :: WithComments a+      }+  | Recursive+      { block :: WithComments [WithComments (Statement a)]+      }++instance CommentExtraction (Statement a) where+  nodeComments _ = emptyNodeComments++instance Pretty a => Pretty (Statement a) where+  pretty' (Expression expr) = pretty expr+  pretty' Binding {..} = do+    pretty lhsPattern+    string " <-"+    hor <-|> ver+    where+      hor = space >> pretty rhs+      ver = newline >> indentedBlock (pretty rhs)+  pretty' (LetBinding binds) = string "let " |=> pretty binds+  pretty' (Parallel blocks)+    | any ((> 1) . length) blocks =+      vBarSep $ fmap (vCommaSep . fmap pretty) blocks+    | otherwise = hvBarSep $ fmap (hvCommaSep . fmap pretty) blocks+  pretty' Transform {..} =+    vCommaSep $ fmap pretty steps ++ [string "then " >> pretty using]+  pretty' Recursive {..} =+    string "rec " |=> prettyWith block (lined . fmap pretty)++mkExprStatement ::+     GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> ExprStatement+mkExprStatement (GHC.LastStmt _ expr _ _) =+  Expression $ mkExpression <$> fromGenLocated expr+mkExprStatement (GHC.BindStmt _ pat expr) =+  Binding+    { lhsPattern = mkPattern <$> fromGenLocated pat+    , rhs = mkExpression <$> fromGenLocated expr+    }+mkExprStatement (GHC.BodyStmt _ body _ _) =+  Expression $ mkExpression <$> fromGenLocated body+mkExprStatement (GHC.LetStmt _ binds) =+  case mkLocalBinds binds of+    Just localBinds -> LetBinding localBinds+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `LetStmt` without bindings in the parsed AST."+mkExprStatement (GHC.ParStmt _ blocks _ _) =+  Parallel+    $ fmap+        (\(GHC.ParStmtBlock _ stmts _ _) ->+           fmap (fmap mkExprStatement . fromGenLocated) stmts)+        blocks+mkExprStatement GHC.TransStmt {..} =+  Transform+    { steps = fmap (fmap mkExprStatement . fromGenLocated) trS_stmts+    , using = mkExpression <$> fromGenLocated trS_using+    }+mkExprStatement GHC.RecStmt {..} =+  Recursive+    { block =+        fmap+          (fmap (fmap mkExprStatement . fromGenLocated))+          (fromGenLocated recS_stmts)+    }+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExprStatement GHC.ApplicativeStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif+mkExprStatement GHC.XStmtLR {} =+  error "`ghc-lib-parser` never generates this AST node."++mkCmdStatement ::+     GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> CmdStatement+mkCmdStatement (GHC.LastStmt _ cmd _ _) =+  Expression $ mkCmd <$> fromGenLocated cmd+mkCmdStatement (GHC.BindStmt _ pat cmd) =+  Binding+    { lhsPattern = mkPattern <$> fromGenLocated pat+    , rhs = mkCmd <$> fromGenLocated cmd+    }+mkCmdStatement (GHC.BodyStmt _ cmd _ _) =+  Expression $ mkCmd <$> fromGenLocated cmd+mkCmdStatement (GHC.LetStmt _ binds) =+  case mkLocalBinds binds of+    Just localBinds -> LetBinding localBinds+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `LetStmt` without bindings in the parsed AST."+mkCmdStatement GHC.ParStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+mkCmdStatement GHC.TransStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+mkCmdStatement GHC.RecStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkCmdStatement GHC.ApplicativeStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif+mkCmdStatement GHC.XStmtLR {} =+  error "`ghc-lib-parser` never generates this AST node."

src/HIndent/Ast/Type.hs view

@@ -1,21 +1,400 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoFieldSelectors #-}+ module HIndent.Ast.Type   ( Type+  , VerticalFuncType+  , DeclSigType+  , InstDeclType   , mkType+  , mkTypeFromHsSigType+  , mkTypeFromLHsWcType+  , mkVerticalFuncType+  , mkDeclSigType+  , mkInstDeclType   ) where +import Control.Monad.RWS (gets)+import HIndent.Ast.Declaration.Data.Record.Field+import HIndent.Ast.Expression.Splice+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Bang+import HIndent.Ast.Type.Forall+  ( Forall+  , mkForallFromOuter+  , mkForallFromTelescope+  )+import HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  )+import HIndent.Ast.Type.Literal+import HIndent.Ast.Type.Multiplicity+import HIndent.Ast.WithComments+import HIndent.Config import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments+import HIndent.Pretty.Types+import HIndent.Printer -newtype Type =-  Type (GHC.HsType GHC.GhcPs)+data Type+  = UniversalType+      { telescope :: WithComments Forall+      , body :: WithComments Type+      }+  | ConstrainedType+      { context :: WithComments Context+      , body :: WithComments Type+      }+  | Variable+      { isPromoted :: Bool+      , name :: WithComments PrefixName+      }+  | Application+      { function :: WithComments Type+      , argument :: WithComments Type+      }+  | KindApplication+      { base :: WithComments Type+      , kind :: WithComments Type+      }+  | Function+      { multiplicity :: Multiplicity+      , from :: WithComments Type+      , to :: WithComments Type+      }+  | List+      { elementType :: WithComments Type+      }+  | Tuple+      { isUnboxed :: Bool+      , elements :: [WithComments Type]+      }+  | Sum+      { elements :: [WithComments Type]+      }+  | InfixType+      { left :: WithComments Type+      , operator :: WithComments InfixName+      , right :: WithComments Type+      }+  | Parenthesized+      { inner :: WithComments Type+      }+  | ImplicitParameter+      { ipName :: WithComments ImplicitParameterName+      , paramType :: WithComments Type+      }+  | Star+  | KindSig+      { annotated :: WithComments Type+      , kind :: WithComments Type+      }+  | Splice+      { splice :: Splice+      }+  | StrictType+      { bang :: Bang+      , baseType :: WithComments Type+      }+  | RecordType+      { fields :: [WithComments RecordField]+      }+  | PromotedList+      { elements :: [WithComments Type]+      }+  | PromotedTuple+      { elements :: [WithComments Type]+      }+  | Literal+      { literal :: Literal+      }+  | Wildcard  instance CommentExtraction Type where-  nodeComments (Type _) = NodeComments [] [] []+  nodeComments (UniversalType {}) = NodeComments [] [] []+  nodeComments (ConstrainedType {}) = NodeComments [] [] []+  nodeComments (Variable {}) = NodeComments [] [] []+  nodeComments (Application {}) = NodeComments [] [] []+  nodeComments (KindApplication {}) = NodeComments [] [] []+  nodeComments (Function {}) = NodeComments [] [] []+  nodeComments (List (getNode -> List {})) = NodeComments [] [] []+  nodeComments (List x) = nodeComments x+  nodeComments (Tuple _ xs) = mconcat $ nodeComments <$> xs+  nodeComments (Sum xs) = mconcat $ nodeComments <$> xs+  nodeComments (InfixType {}) = NodeComments [] [] []+  nodeComments (Parenthesized (getNode -> Parenthesized {})) =+    NodeComments [] [] []+  nodeComments (Parenthesized x) = nodeComments x+  nodeComments (ImplicitParameter {}) = NodeComments [] [] []+  nodeComments Star = NodeComments [] [] []+  nodeComments (KindSig {}) = NodeComments [] [] []+  nodeComments (Splice {}) = NodeComments [] [] []+  nodeComments (StrictType {}) = NodeComments [] [] []+  nodeComments (RecordType xs) = mconcat $ nodeComments <$> xs+  nodeComments (PromotedList xs) = mconcat $ nodeComments <$> xs+  nodeComments (PromotedTuple xs) = mconcat $ nodeComments <$> xs+  nodeComments (Literal {}) = NodeComments [] [] []+  nodeComments Wildcard = NodeComments [] [] []  instance Pretty Type where-  pretty' (Type x) = pretty x+  pretty' UniversalType {..} = (pretty telescope >> space) |=> pretty body+  pretty' ConstrainedType {..} = hor <-|> ver+    where+      hor = spaced [pretty context, string "=>", pretty body]+      ver = do+        pretty context+        lined [string " =>", indentedBlock $ pretty body]+  pretty' Variable {isPromoted = False, ..} = pretty name+  pretty' Variable {isPromoted = True, ..} = string "'" >> pretty name+  pretty' Application {..} = hor <-|> ver+    where+      hor = spaced [pretty function, pretty argument]+      ver = verticalApp function argument+      verticalApp left right = do+        case getNode left of+          Application {function = l', argument = r'} ->+            verticalApp l' r' >> newline >> indentedBlock (pretty right)+          _ -> pretty left >> newline >> indentedBlock (pretty right)+  pretty' KindApplication {..} = pretty base >> string " @" >> pretty kind+  pretty' Function {..} =+    (pretty from+       >> if isUnrestricted multiplicity+            then string " -> "+            else space >> pretty multiplicity >> string " -> ")+      |=> pretty to+  pretty' List {..} = brackets $ pretty elementType+  pretty' Tuple {isUnboxed = True, elements = []} = string "(# #)"+  pretty' Tuple {isUnboxed = False, elements = []} = string "()"+  pretty' Tuple {isUnboxed = True, ..} = hvUnboxedTuple' $ fmap pretty elements+  pretty' Tuple {isUnboxed = False, ..} = hvTuple' $ fmap pretty elements+  pretty' Sum {..} = hvUnboxedSum' $ fmap pretty elements+  pretty' InfixType {..} = do+    lineBreak <- gets (configLineBreaks . psConfig)+    if getInfixName (getNode operator) `elem` lineBreak+      then do+        pretty left+        newline+        pretty operator+        space+        pretty right+      else spaced [pretty left, pretty operator, pretty right]+  pretty' Parenthesized {..} = parens $ pretty inner+  pretty' ImplicitParameter {..} =+    spaced [pretty ipName, string "::", pretty paramType]+  pretty' Star = string "*"+  pretty' KindSig {..} = spaced [pretty annotated, string "::", pretty kind]+  pretty' Splice {..} = pretty splice+  pretty' StrictType {..} = pretty bang >> pretty baseType+  pretty' RecordType {..} = hvFields $ fmap pretty fields+  pretty' PromotedList {elements = []} = string "'[]"+  pretty' PromotedList {..} = hvPromotedList $ fmap pretty elements+  pretty' PromotedTuple {..} = hPromotedTuple $ fmap pretty elements+  pretty' Literal {..} = pretty literal+  pretty' Wildcard = string "_"  mkType :: GHC.HsType GHC.GhcPs -> Type-mkType = Type+mkType (GHC.HsForAllTy _ tele body) =+  UniversalType+    { telescope = mkForallFromTelescope tele+    , body = mkType <$> fromGenLocated body+    }+mkType GHC.HsQualTy {..} =+  ConstrainedType+    { context = mkWithComments $ Context hst_ctxt+    , body = mkType <$> fromGenLocated hst_body+    }+mkType (GHC.HsTyVar _ GHC.IsPromoted x) =+  Variable {isPromoted = True, name = mkPrefixName <$> fromGenLocated x}+mkType (GHC.HsTyVar _ GHC.NotPromoted x) =+  Variable {isPromoted = False, name = mkPrefixName <$> fromGenLocated x}+mkType (GHC.HsAppTy _ l r) =+  Application+    { function = mkType <$> fromGenLocated l+    , argument = mkType <$> fromGenLocated r+    }+#if MIN_VERSION_ghc_lib_parser(9, 8, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkType (GHC.HsAppKindTy _ l _ r) =+  KindApplication+    {base = mkType <$> fromGenLocated l, kind = mkType <$> fromGenLocated r}+#else+mkType (GHC.HsAppKindTy _ l r) =+  KindApplication+    {base = mkType <$> fromGenLocated l, kind = mkType <$> fromGenLocated r}+#endif+mkType (GHC.HsFunTy _ arr a b) =+  Function+    { multiplicity = mkMultiplicity arr+    , from = mkType <$> fromGenLocated a+    , to = mkType <$> fromGenLocated b+    }+mkType (GHC.HsListTy _ xs) = List {elementType = mkType <$> fromGenLocated xs}+mkType (GHC.HsTupleTy _ sort xs) =+  Tuple+    { isUnboxed =+        case sort of+          GHC.HsUnboxedTuple -> True+          _ -> False+    , elements = fmap (fmap mkType . fromGenLocated) xs+    }+mkType (GHC.HsSumTy _ xs) =+  Sum {elements = fmap (fmap mkType . fromGenLocated) xs}+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkType (GHC.HsOpTy _ _ l op r) =+  InfixType+    { left = mkType <$> fromGenLocated l+    , operator = mkInfixName <$> fromGenLocated op+    , right = mkType <$> fromGenLocated r+    }+#else+mkType (GHC.HsOpTy _ l op r) =+  InfixType+    { left = mkType <$> fromGenLocated l+    , operator = mkInfixName <$> fromGenLocated op+    , right = mkType <$> fromGenLocated r+    }+#endif+mkType (GHC.HsParTy _ inside) =+  Parenthesized {inner = mkType <$> fromGenLocated inside}+mkType (GHC.HsIParamTy _ x ty) =+  ImplicitParameter+    { ipName = mkImplicitParameterName <$> fromGenLocated x+    , paramType = mkType <$> fromGenLocated ty+    }+mkType GHC.HsStarTy {} = Star+mkType (GHC.HsKindSig _ t k) =+  KindSig+    { annotated = mkType <$> fromGenLocated t+    , kind = mkType <$> fromGenLocated k+    }+mkType (GHC.HsSpliceTy _ sp) = Splice {splice = mkSplice sp}+mkType GHC.HsDocTy {} = error "HsDocTy not supported"+mkType (GHC.HsBangTy _ pack x) =+  StrictType {bang = mkBang pack, baseType = mkType <$> fromGenLocated x}+mkType (GHC.HsRecTy _ xs) =+  RecordType {fields = fmap (fromGenLocated . fmap mkRecordField) xs}+mkType (GHC.HsExplicitListTy _ _ xs) =+  PromotedList {elements = fmap (fmap mkType . fromGenLocated) xs}+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkType (GHC.HsExplicitTupleTy _ _ xs) =+  PromotedTuple {elements = fmap (fmap mkType . fromGenLocated) xs}+#else+mkType (GHC.HsExplicitTupleTy _ xs) =+  PromotedTuple {elements = fmap (fmap mkType . fromGenLocated) xs}+#endif+mkType (GHC.HsTyLit _ x) = Literal {literal = mkLiteral x}+mkType GHC.HsWildCardTy {} = Wildcard+mkType GHC.XHsType {} = error "XHsType not generated by parser"++mkTypeFromHsSigType :: GHC.HsSigType GHC.GhcPs -> WithComments Type+mkTypeFromHsSigType GHC.HsSig {..} =+  case mkForallFromOuter sig_bndrs of+    Just telescope ->+      mkWithComments+        $ UniversalType+            {telescope = telescope, body = mkType <$> fromGenLocated sig_body}+    Nothing -> mkType <$> fromGenLocated sig_body++mkTypeFromLHsWcType ::+     GHC.LHsWcType (GHC.NoGhcTc GHC.GhcPs) -> WithComments Type+mkTypeFromLHsWcType GHC.HsWC {..} = mkType <$> fromGenLocated hswc_body++newtype VerticalFuncType =+  VerticalFuncType Type++instance CommentExtraction VerticalFuncType where+  nodeComments (VerticalFuncType t) = nodeComments t++instance Pretty VerticalFuncType where+  pretty' (VerticalFuncType Function {..}) = do+    pretty $ fmap mkVerticalFuncType from+    newline+    if isUnrestricted multiplicity+      then prefixed "-> " $ pretty $ fmap mkVerticalFuncType to+      else do+        pretty multiplicity+        string " -> "+        pretty $ fmap mkVerticalFuncType to+  pretty' (VerticalFuncType t) = pretty t++mkVerticalFuncType :: Type -> VerticalFuncType+mkVerticalFuncType = VerticalFuncType++newtype DeclSigType =+  DeclSigType Type++instance CommentExtraction DeclSigType where+  nodeComments (DeclSigType t) = nodeComments t++instance Pretty DeclSigType where+  pretty' (DeclSigType UniversalType {..}) = do+    pretty telescope+    case getNode body of+      ConstrainedType ctxt b ->+        let hor = space >> pretty ctxt+            ver = newline >> pretty ctxt+         in do+              hor <-|> ver+              newline+              prefixed "=> " $ pretty $ fmap mkVerticalFuncType b+      _ ->+        let hor = space >> pretty (DeclSigType <$> body)+            ver = newline >> pretty (DeclSigType <$> body)+         in hor <-|> ver+  pretty' (DeclSigType ConstrainedType {..}) = hor <-|> ver+    where+      hor = spaced [pretty context, string "=>", pretty body]+      ver = do+        pretty context+        newline+        prefixed "=> " $ pretty $ fmap mkVerticalFuncType body+  pretty' (DeclSigType Function {..}) = hor <-|> ver+    where+      hor = do+        pretty from+        if isUnrestricted multiplicity+          then string " -> "+          else space >> pretty multiplicity >> string " -> "+        pretty to+      ver = do+        pretty $ fmap mkVerticalFuncType from+        newline+        if isUnrestricted multiplicity+          then prefixed "-> " $ pretty $ mkVerticalFuncType <$> to+          else do+            pretty multiplicity+            string " -> "+            pretty $ mkVerticalFuncType <$> to+  pretty' (DeclSigType t) = pretty t++mkDeclSigType :: GHC.HsSigType GHC.GhcPs -> WithComments DeclSigType+mkDeclSigType hsSigType = DeclSigType <$> mkTypeFromHsSigType hsSigType++newtype InstDeclType =+  InstDeclType Type++instance CommentExtraction InstDeclType where+  nodeComments (InstDeclType t) = nodeComments t++instance Pretty InstDeclType where+  pretty' (InstDeclType UniversalType {..}) = do+    pretty telescope+    space+    pretty $ InstDeclType <$> body+  pretty' (InstDeclType ConstrainedType {..}) = hor <-|> ver+    where+      hor = spaced [pretty context, string "=>", pretty body]+      ver = do+        pretty context >> string " =>"+        newline+        indentedWithFixedLevel 9 $ pretty body+  pretty' (InstDeclType t) = pretty t++mkInstDeclType :: GHC.HsSigType GHC.GhcPs -> WithComments InstDeclType+mkInstDeclType hsSigType = InstDeclType <$> mkTypeFromHsSigType hsSigType

+ src/HIndent/Ast/Type.hs-boot view

@@ -0,0 +1,12 @@+module HIndent.Ast.Type where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import {-# SOURCE #-} HIndent.Pretty++data Type++instance CommentExtraction Type+instance Pretty Type++mkType :: GHC.HsType GHC.GhcPs -> Type

+ src/HIndent/Ast/Type/Bang.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Bang+  ( Bang+  , mkBang+  ) where++import Control.Monad+import Data.Maybe+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Strictness+import HIndent.Ast.Type.Unpackedness+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Bang =+  Bang (Maybe Unpackedness) (Maybe Strictness)++instance CommentExtraction Bang where+  nodeComments _ = NodeComments [] [] []++instance Pretty Bang where+  pretty' (Bang unpack strictness) = do+    maybe (pure ()) pretty' unpack+    unless (isNothing unpack) space+    maybe (pure ()) pretty' strictness+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkBang :: GHC.HsBang -> Bang+mkBang (GHC.HsBang unpack strictness) =+  Bang (mkUnpackedness unpack) (mkStrictness strictness)+#else+mkBang :: GHC.HsSrcBang -> Bang+mkBang (GHC.HsSrcBang _ unpack strictness) =+  Bang (mkUnpackedness unpack) (mkStrictness strictness)+#endif

+ src/HIndent/Ast/Type/Forall.hs view

@@ -0,0 +1,51 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Type.Forall+  ( Forall+  , mkForallFromTelescope+  , mkForallFromOuter+  ) where++import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Type.Variable+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 Forall+  = Visible [WithComments TypeVariable] -- forall a b c ->+  | Invisible [WithComments TypeVariable] -- forall a b c.++instance CommentExtraction Forall where+  nodeComments _ = NodeComments [] [] []++instance Pretty Forall where+  pretty' (Visible vars) = do+    string "forall "+    spaced $ fmap pretty vars+    string " ->"+  pretty' (Invisible vars) = do+    string "forall "+    spaced $ fmap pretty vars+    dot++mkForallFromTelescope :: GHC.HsForAllTelescope GHC.GhcPs -> WithComments Forall+mkForallFromTelescope GHC.HsForAllVis {..} =+  fromEpAnn hsf_xvis+    $ Visible+    $ fmap (fmap mkTypeVariable . fromGenLocated) hsf_vis_bndrs+mkForallFromTelescope GHC.HsForAllInvis {..} =+  fromEpAnn hsf_xinvis+    $ Invisible+    $ fmap (fmap mkTypeVariable . fromGenLocated) hsf_invis_bndrs++mkForallFromOuter ::+     GHC.HsOuterTyVarBndrs flag GHC.GhcPs -> Maybe (WithComments Forall)+mkForallFromOuter (GHC.HsOuterExplicit ann xs) =+  Just+    $ fromEpAnn ann+    $ Invisible+    $ fmap (fmap mkTypeVariable . fromGenLocated) xs+mkForallFromOuter GHC.HsOuterImplicit {} = Nothing

+ src/HIndent/Ast/Type/ImplicitParameterName.hs view

@@ -0,0 +1,23 @@+module HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  ) where++import qualified GHC.Data.FastString as GHC+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype ImplicitParameterName =+  ImplicitParameterName String++instance CommentExtraction ImplicitParameterName where+  nodeComments ImplicitParameterName {} = emptyNodeComments++instance Pretty ImplicitParameterName where+  pretty' (ImplicitParameterName s) = string "?" >> string s++mkImplicitParameterName :: GHC.HsIPName -> ImplicitParameterName+mkImplicitParameterName (GHC.HsIPName fs) =+  ImplicitParameterName $ GHC.unpackFS fs

+ src/HIndent/Ast/Type/Literal.hs view

@@ -0,0 +1,30 @@+module HIndent.Ast.Type.Literal+  ( Literal+  , mkLiteral+  ) where++import qualified GHC.Data.FastString 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+import Text.Show.Unicode++data Literal+  = Numeric Integer+  | String String+  | Character Char++instance CommentExtraction Literal where+  nodeComments _ = NodeComments [] [] []++instance Pretty Literal where+  pretty' (Numeric n) = string $ show n+  pretty' (String s) = string $ ushow s+  pretty' (Character c) = string $ ushow c++mkLiteral :: GHC.HsTyLit GHC.GhcPs -> Literal+mkLiteral (GHC.HsNumTy _ n) = Numeric n+mkLiteral (GHC.HsStrTy _ s) = String (GHC.unpackFS s)+mkLiteral (GHC.HsCharTy _ c) = Character c

+ src/HIndent/Ast/Type/Multiplicity.hs view

@@ -0,0 +1,44 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Multiplicity+  ( Multiplicity+  , mkMultiplicity+  , isUnrestricted+  ) where++import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Ast.Type+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 Multiplicity+  = MkUnrestricted+  | MkLinear+  | MkExplicit (WithComments Type)++instance CommentExtraction Multiplicity where+  nodeComments MkUnrestricted = NodeComments [] [] []+  nodeComments MkLinear = NodeComments [] [] []+  nodeComments (MkExplicit mult) = nodeComments mult++instance Pretty Multiplicity where+  pretty' MkUnrestricted = pure ()+  pretty' MkLinear = string "%1"+  pretty' (MkExplicit mult) = string "%" >> pretty mult++mkMultiplicity :: GHC.HsArrow GHC.GhcPs -> Multiplicity+mkMultiplicity (GHC.HsUnrestrictedArrow _) = MkUnrestricted+mkMultiplicity (GHC.HsLinearArrow _) = MkLinear+#if MIN_VERSION_ghc_lib_parser(9, 10, 0)+mkMultiplicity (GHC.HsExplicitMult _ mult) =+  MkExplicit (mkType <$> fromGenLocated mult)+#else+mkMultiplicity (GHC.HsExplicitMult _ mult _) =+  MkExplicit (mkType <$> fromGenLocated mult)+#endif+isUnrestricted :: Multiplicity -> Bool+isUnrestricted MkUnrestricted = True+isUnrestricted _ = False

+ src/HIndent/Ast/Type/Strictness.hs view

@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Strictness+  ( Strictness+  , mkStrictness+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Strictness+  = Lazy+  | Strict+  deriving (Eq)++instance CommentExtraction Strictness where+  nodeComments _ = NodeComments [] [] []++instance Pretty Strictness where+  pretty' Lazy = string "~"+  pretty' Strict = string "!"++mkStrictness :: GHC.SrcStrictness -> Maybe Strictness+mkStrictness GHC.SrcLazy = Just Lazy+mkStrictness GHC.SrcStrict = Just Strict+mkStrictness GHC.NoSrcStrict = Nothing

+ src/HIndent/Ast/Type/Unpackedness.hs view

@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Unpackedness+  ( Unpackedness+  , mkUnpackedness+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Unpackedness+  = Unpack+  | NoUnpack+  deriving (Eq)++instance CommentExtraction Unpackedness where+  nodeComments _ = NodeComments [] [] []++instance Pretty Unpackedness where+  pretty' Unpack = string "{-# UNPACK #-}"+  pretty' NoUnpack = string "{-# NOUNPACK #-}"++mkUnpackedness :: GHC.SrcUnpackedness -> Maybe Unpackedness+mkUnpackedness GHC.SrcUnpack = Just Unpack+mkUnpackedness GHC.SrcNoUnpack = Just NoUnpack+mkUnpackedness GHC.NoSrcUnpack = Nothing

src/HIndent/Ast/Type/Variable.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}  module HIndent.Ast.Type.Variable@@ -8,12 +9,14 @@ import qualified GHC.Hs as GHC import HIndent.Ast.Name.Prefix import HIndent.Ast.NodeComments-import HIndent.Ast.Type+import {-# SOURCE #-} HIndent.Ast.Type import HIndent.Ast.WithComments import {-# SOURCE #-} HIndent.Pretty import HIndent.Pretty.Combinators import HIndent.Pretty.NodeComments-+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified HIndent.Ast.Name.Prefix as Prefix+#endif data TypeVariable = TypeVariable   { name :: WithComments PrefixName   , kind :: Maybe (WithComments Type)@@ -28,6 +31,18 @@   pretty' TypeVariable {kind = Nothing, ..} = pretty name  mkTypeVariable :: GHC.HsTyVarBndr a GHC.GhcPs -> TypeVariable+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkTypeVariable GHC.HsTvb {..} = TypeVariable {..}+  where+    name =+      case tvb_var of+        GHC.HsBndrVar _ n -> fromGenLocated $ fmap mkPrefixName n+        GHC.HsBndrWildCard _ -> mkWithComments (Prefix.fromString "_")+    kind =+      case tvb_kind of+        GHC.HsBndrKind _ k -> Just $ mkType <$> fromGenLocated k+        GHC.HsBndrNoKind _ -> Nothing+#else mkTypeVariable (GHC.UserTyVar _ _ n) = TypeVariable {..}   where     name = fromGenLocated $ fmap mkPrefixName n@@ -36,3 +51,4 @@   where     name = fromGenLocated $ fmap mkPrefixName n     kind = Just $ mkType <$> fromGenLocated k+#endif

src/HIndent/Ast/WithComments.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}@@ -9,6 +10,9 @@   , fromEpAnn   , mkWithComments   , getNode+  , getComments+  , addComments+  , flattenComments   ) where  import Control.Monad@@ -47,28 +51,54 @@  -- | Prints comments that are before the given AST node. printCommentsBefore :: NodeComments -> Printer ()+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) printCommentsBefore p =   forM_ (commentsBefore p) $ \(GHC.L loc c) -> do+    let col =+          fromIntegral+            $ GHC.srcSpanStartCol (GHC.epaLocationRealSrcSpan loc) - 1+    indentedWithFixedLevel col $ pretty c+    newline+#else+printCommentsBefore p =+  forM_ (commentsBefore p) $ \(GHC.L loc c) -> do     let col = fromIntegral $ GHC.srcSpanStartCol (GHC.anchor loc) - 1     indentedWithFixedLevel col $ pretty c     newline-+#endif -- | Prints comments that are on the same line as the given AST node. printCommentOnSameLine :: NodeComments -> Printer ()+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) printCommentOnSameLine (commentsOnSameLine -> (c:cs)) = do   col <- gets psColumn   if col == 0     then indentedWithFixedLevel+           (fromIntegral+              $ GHC.srcSpanStartCol+              $ GHC.epaLocationRealSrcSpan+              $ GHC.getLoc c)+           $ spaced+           $ fmap pretty+           $ c : cs+    else spacePrefixed $ fmap pretty $ c : cs+  eolCommentsArePrinted+#else+printCommentOnSameLine (commentsOnSameLine -> (c:cs)) = do+  col <- gets psColumn+  if col == 0+    then indentedWithFixedLevel            (fromIntegral $ GHC.srcSpanStartCol $ GHC.anchor $ GHC.getLoc c)            $ spaced            $ fmap pretty            $ c : cs     else spacePrefixed $ fmap pretty $ c : cs   eolCommentsArePrinted+#endif printCommentOnSameLine _ = return ()  -- | Prints comments that are after the given AST node. printCommentsAfter :: NodeComments -> Printer ()+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) printCommentsAfter p =   case commentsAfter p of     [] -> return ()@@ -76,10 +106,23 @@       isThereCommentsOnSameLine <- gets psEolComment       unless isThereCommentsOnSameLine newline       forM_ xs $ \(GHC.L loc c) -> do+        let col =+              fromIntegral+                $ GHC.srcSpanStartCol (GHC.epaLocationRealSrcSpan loc) - 1+        indentedWithFixedLevel col $ pretty c+        eolCommentsArePrinted+#else+printCommentsAfter p =+  case commentsAfter p of+    [] -> return ()+    xs -> do+      isThereCommentsOnSameLine <- gets psEolComment+      unless isThereCommentsOnSameLine newline+      forM_ xs $ \(GHC.L loc c) -> do         let col = fromIntegral $ GHC.srcSpanStartCol (GHC.anchor loc) - 1         indentedWithFixedLevel col $ pretty c         eolCommentsArePrinted-+#endif fromGenLocated :: (CommentExtraction l) => GHC.GenLocated l a -> WithComments a fromGenLocated (GHC.L l a) = WithComments (nodeComments l) a @@ -91,3 +134,14 @@  getNode :: WithComments a -> a getNode = node++getComments :: WithComments a -> NodeComments+getComments = comments++flattenComments :: WithComments (WithComments a) -> WithComments a+flattenComments (WithComments outerComments (WithComments innerComments node)) =+  WithComments (outerComments <> innerComments) node++addComments :: NodeComments -> WithComments a -> WithComments a+addComments extra (WithComments current node) =+  WithComments (extra <> current) node

src/HIndent/ByteString.hs view

@@ -12,7 +12,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8-import Data.List hiding (stripPrefix)+import Data.List (intersperse) import Data.Maybe  -- | Returns the prefix that all the given `ByteString`s except for the ones composed of `\n`s have.

src/HIndent/CabalFile.hs view

@@ -6,12 +6,15 @@  import Control.Monad import qualified Data.ByteString as BS-import Data.List+import Data.List (isSuffixOf) import Data.Maybe import Data.Traversable import Distribution.ModuleName import Distribution.PackageDescription import Distribution.PackageDescription.Configuration+#if MIN_VERSION_Cabal(3, 14, 0)+import Distribution.Utils.Path (interpretSymbolicPathCWD)+#endif #if MIN_VERSION_Cabal(3, 6, 0) import Distribution.Utils.Path (getSymbolicPath) #endif@@ -62,10 +65,40 @@ #endif -- | Extract `Stanza`s from a package packageStanzas :: PackageDescription -> [Stanza]+#if MIN_VERSION_Cabal(3, 14, 0) packageStanzas pd =   let libStanza :: Library -> Stanza       libStanza lib = mkStanza (libBuildInfo lib) (exposedModules lib) []       exeStanza :: Executable -> Stanza+      exeStanza exe =+        mkStanza (buildInfo exe) [] [interpretSymbolicPathCWD $ modulePath exe]+      testStanza :: TestSuite -> Stanza+      testStanza ts =+        mkStanza+          (testBuildInfo ts)+          (case testInterface ts of+             TestSuiteLibV09 _ mname -> [mname]+             _ -> [])+          (case testInterface ts of+             TestSuiteExeV10 _ path -> [interpretSymbolicPathCWD path]+             _ -> [])+      benchStanza :: Benchmark -> Stanza+      benchStanza bn =+        mkStanza (benchmarkBuildInfo bn) []+          $ case benchmarkInterface bn of+              BenchmarkExeV10 _ path -> [interpretSymbolicPathCWD path]+              _ -> []+   in mconcat+        [ maybeToList $ libStanza <$> library pd+        , exeStanza <$> executables pd+        , testStanza <$> testSuites pd+        , benchStanza <$> benchmarks pd+        ]+#else+packageStanzas pd =+  let libStanza :: Library -> Stanza+      libStanza lib = mkStanza (libBuildInfo lib) (exposedModules lib) []+      exeStanza :: Executable -> Stanza       exeStanza exe = mkStanza (buildInfo exe) [] [modulePath exe]       testStanza :: TestSuite -> Stanza       testStanza ts =@@ -89,7 +122,7 @@         , testStanza <$> testSuites pd         , benchStanza <$> benchmarks pd         ]-+#endif -- | Find cabal files that are "above" the source path findCabalFiles :: FilePath -> FilePath -> IO (Maybe ([FilePath], FilePath)) findCabalFiles dir rel = do

src/HIndent/Config.hs view

@@ -53,7 +53,7 @@       convertExt x =         case strToExt x of           Just x' -> pure x'-          Nothing -> error $ "Unknow extension: " ++ show x+          Nothing -> error $ "Unknown extension: " ++ show x   parseJSON _ = fail "Expected Object for Config value"  -- | Default style configuration.

+ src/HIndent/GhcLibParserWrapper/GHC/Parser/Annotation.hs view

@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}++module HIndent.GhcLibParserWrapper.GHC.Parser.Annotation+  ( module GHC.Parser.Annotation+  , epaLocationToRealSrcSpan+  ) where++import GHC.Parser.Annotation+import GHC.Types.SrcLoc+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+epaLocationToRealSrcSpan :: EpaLocation' a -> RealSrcSpan+epaLocationToRealSrcSpan = epaLocationRealSrcSpan+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+epaLocationToRealSrcSpan :: EpaLocation' a -> RealSrcSpan+epaLocationToRealSrcSpan = anchor+#else+epaLocationToRealSrcSpan :: Anchor -> RealSrcSpan+epaLocationToRealSrcSpan = anchor+#endif

src/HIndent/Language.hs view

@@ -17,7 +17,16 @@ convertLanguage :: HasCallStack => Cabal.Language -> GLP.Language convertLanguage Cabal.Haskell98 = GLP.Haskell98 convertLanguage Cabal.Haskell2010 = GLP.Haskell2010-#if MIN_VERSION_Cabal(3,6,0)+#if MIN_VERSION_Cabal(3, 6, 0) convertLanguage Cabal.GHC2021 = GLP.GHC2021+#endif+#if MIN_VERSION_Cabal(3, 12, 0)+#if MIN_VERSION_ghc_lib_parser(9, 10, 0)+convertLanguage Cabal.GHC2024 = GLP.GHC2024+#else+convertLanguage Cabal.GHC2024 =+  error+    "GHC2024 language is not supported. Hindent was built with GHC < 9.10. Please rebuild Hindent with GHC 9.10 or later."+#endif #endif convertLanguage (Cabal.UnknownLanguage s) = error $ "Unknown language: " ++ s

src/HIndent/LanguageExtension.hs view

@@ -11,7 +11,7 @@   ) where  import Data.Char-import Data.List+import Data.List (delete) import Data.List.Split import Data.Maybe import qualified GHC.Driver.Session as GLP

src/HIndent/ModulePreprocessing.hs view

@@ -12,7 +12,7 @@   ) where  import Data.Function-import Data.List+import Data.List (sortBy) import GHC.Hs import GHC.Types.SrcLoc import Generics.SYB hiding (GT, typeOf, typeRep)@@ -22,6 +22,7 @@ import Language.Haskell.GhclibParserEx.Fixity #if MIN_VERSION_ghc_lib_parser(9, 10, 1) import qualified GHC.Data.Strict as Strict+import HIndent.GhcLibParserWrapper.GHC.Parser.Annotation #else import Control.Applicative import Data.Maybe@@ -57,13 +58,33 @@ -- | This function modifies the range of `HsDo` with `ListComp` so that it -- includes the whole list comprehension. ----- This function is necessary for `ghc-lib-parser>=9.10.1` because `HsDo`+-- This function is necessary for `ghc-lib-parser>=9.10.1<9.12.1` because `HsDo` -- no longer includes brackets of list comprehensions in its range. resetListCompRange :: HsModule' -> HsModule'-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) resetListCompRange = everywhere (mkT resetListCompRange')   where     resetListCompRange' :: HsExpr GhcPs -> HsExpr GhcPs+    resetListCompRange' (HsDo al@AnnList {al_brackets = ListSquare (EpTok (EpaSpan (RealSrcSpan open _))) (EpTok (EpaSpan (RealSrcSpan close _)))} ListComp (L EpAnn {..} xs)) =+      HsDo+        al+        ListComp+        (L EpAnn+             { entry =+                 EpaSpan+                   $ RealSrcSpan+                       (mkRealSrcSpan+                          (realSrcSpanStart open)+                          (realSrcSpanEnd close))+                       Strict.Nothing+             , ..+             }+           xs)+    resetListCompRange' x = x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+resetListCompRange = everywhere (mkT resetListCompRange')+  where+    resetListCompRange' :: HsExpr GhcPs -> HsExpr GhcPs     resetListCompRange' (HsDo al@AnnList { al_open = Just (AddEpAnn _ (EpaSpan (RealSrcSpan open _)))                                          , al_close = Just (AddEpAnn _ (EpaSpan (RealSrcSpan close _)))                                          } ListComp (L EpAnn {..} xs)) =@@ -278,15 +299,20 @@ #if MIN_VERSION_ghc_lib_parser(9, 10, 1) resetLGRHSEndPosition (L locAnn (GRHS ext@EpAnn {..} stmt body)) =   let lastPosition =-        maximum $ realSrcSpanEnd . anchor <$> listify collectAnchor body-      newSpan = mkRealSrcSpan (realSrcSpanStart $ anchor entry) lastPosition+        maximum+          $ realSrcSpanEnd . epaLocationToRealSrcSpan+              <$> listify collectEpaLocation' body+      newSpan =+        mkRealSrcSpan+          (realSrcSpanStart $ epaLocationToRealSrcSpan entry)+          lastPosition       newLocAnn = locAnn {entry = realSpanAsAnchor newSpan}       newAnn = ext {entry = realSpanAsAnchor newSpan}    in L newLocAnn (GRHS newAnn stmt body)   where-    collectAnchor :: Anchor -> Bool-    collectAnchor (EpaSpan RealSrcSpan {}) = True-    collectAnchor _ = False+    collectEpaLocation' :: EpaLocation -> Bool+    collectEpaLocation' (EpaSpan RealSrcSpan {}) = True+    collectEpaLocation' _ = False #elif MIN_VERSION_ghc_lib_parser(9, 4, 1) resetLGRHSEndPosition (L (SrcSpanAnn locAnn@EpAnn {} sp) (GRHS ext@EpAnn {..} stmt body)) =   let lastPosition =

src/HIndent/ModulePreprocessing/CommentRelocation.hs view

@@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}  -- | Comment relocation for pretty-printing comments correctly. --@@ -43,18 +44,23 @@ import Control.Monad.State import Data.Foldable import Data.Function-import Data.List-import Data.Traversable-import GHC.Data.Bag+import Data.List (partition, sortBy) import GHC.Types.SrcLoc import Generics.SYB hiding (GT, typeOf, typeRep) import HIndent.GhcLibParserWrapper.GHC.Hs+import HIndent.GhcLibParserWrapper.GHC.Parser.Annotation import HIndent.Pragma import HIndent.Pretty.SigBindFamily import Type.Reflection #if MIN_VERSION_GLASGOW_HASKELL(9, 6, 0, 0) import Control.Monad #endif+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import GHC.Data.Bag+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import Data.Maybe+#endif -- | A wrapper type used in everywhereMEpAnnsBackwards' to collect all -- 'EpAnn's to apply a function with them in order their positions. data Wrapper =@@ -86,7 +92,7 @@       cs <- get       assert (null cs) (pure x) -- | This function locates pragmas to the module's EPA.-#if MIN_VERSION_ghc_lib_parser(9,6,1)+#if MIN_VERSION_ghc_lib_parser(9, 6, 1) relocatePragmas :: HsModule GhcPs -> WithComments (HsModule GhcPs) relocatePragmas m@HsModule {hsmodExt = xmod@XModulePs {hsmodAnn = epa@EpAnn {}}} = do   newAnn <- insertComments (isPragma . ac_tok . unLoc) insertPriorComments epa@@ -97,7 +103,9 @@   newAnn <- insertComments (isPragma . ac_tok . unLoc) insertPriorComments epa   return m {hsmodAnn = newAnn} #endif+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1) relocatePragmas m = pure m+#endif -- | This function locates comments that are located before pragmas to the -- module's EPA. #if MIN_VERSION_ghc_lib_parser(9, 10, 1)@@ -109,7 +117,11 @@   | otherwise = pure m   where     startPosOfPragmas =-      let loc = getLoc $ head $ priorComments $ comments ann+      let loc =+            maybe (error "No prior comments") getLoc+              $ listToMaybe+              $ priorComments+              $ comments ann        in case loc of             EpaSpan (RealSrcSpan sp _) -> sp             _ -> undefined@@ -121,7 +133,11 @@     pure m {hsmodExt = xmod {hsmodAnn = newAnn}}   | otherwise = pure m   where-    startPosOfPragmas = anchor $ getLoc $ head $ priorComments $ comments ann+    startPosOfPragmas =+      maybe (error "No prior comments.") (anchor . getLoc)+        $ listToMaybe+        $ priorComments+        $ comments ann #else relocateCommentsBeforePragmas :: HsModule -> WithComments HsModule relocateCommentsBeforePragmas m@HsModule {hsmodAnn = ann}@@ -132,7 +148,7 @@   where     startPosOfPragmas = anchor $ getLoc $ head $ priorComments $ comments ann #endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) -- | This function locates comments that are located before each element of -- an export list. relocateCommentsInExportList :: HsModule' -> WithComments HsModule'@@ -192,10 +208,196 @@   where     elemGetter :: LHsDecl GhcPs -> [LSigBindFamily]     elemGetter (L _ (TyClD _ ClassDecl {..})) =+      mkSortedLSigBindFamilyList tcdSigs tcdMeths tcdATs [] tcdATDefs []+    elemGetter _ = []+    elemSetter xs (L sp (TyClD ext ClassDecl {..})) = L sp (TyClD ext newDecl)+      where+        newDecl =+          ClassDecl+            { tcdSigs = sigs+            , tcdMeths = binds+            , tcdATs = typeFamilies+            , tcdATDefs = tyFamDeflts+            , ..+            }+        (sigs, binds, typeFamilies, _, tyFamDeflts, _) =+          destructLSigBindFamilyList xs+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan classAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart classAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each statement in a do expression.+relocateCommentsInDoExpr :: HsModule' -> WithComments HsModule'+relocateCommentsInDoExpr =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [ExprLStmt GhcPs]+    elemGetter (L _ (HsDo _ DoExpr {} (L _ xs))) = xs+    elemGetter (L _ (HsDo _ MDoExpr {} (L _ xs))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsDo ext flavor@DoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter xs (L sp (HsDo ext flavor@MDoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan doAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart doAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | This function locates comments located before top-level declarations.+relocateCommentsBeforeTopLevelDecls :: HsModule' -> WithComments HsModule'+relocateCommentsBeforeTopLevelDecls = everywhereM (applyM f)+  where+    f epa@EpAnn {..}+      | EpaSpan (RealSrcSpan anc _) <- entry =+        insertCommentsByPos (isBefore anc) insertPriorComments epa+      | otherwise = pure epa+    isBefore anc comAnc =+      srcSpanStartCol anc == 1+        && srcSpanStartCol comAnc == 1+        && srcSpanStartLine comAnc < srcSpanStartLine anc++-- | This function scans the given AST from bottom to top and locates+-- comments that are on the same line as the node.  Comments are stored in+-- the 'followingComments' of 'EpaCommentsBalanced'.+relocateCommentsSameLine :: HsModule' -> WithComments HsModule'+relocateCommentsSameLine = everywhereMEpAnnsBackwards f+  where+    f epa@EpAnn {..}+      | EpaSpan (RealSrcSpan anc _) <- entry =+        insertCommentsByPos (isOnSameLine anc) insertFollowingComments epa+      | otherwise = pure epa+    isOnSameLine anc comAnc =+      srcSpanStartLine comAnc == srcSpanStartLine anc+        && srcSpanStartLine comAnc == srcSpanEndLine anc++-- | This function locates comments above the top-level declarations in+-- a 'where' clause in the topmost declaration.+relocateCommentsTopLevelWhereClause :: HsModule' -> WithComments HsModule'+relocateCommentsTopLevelWhereClause m@HsModule {..} = do+  hsmodDecls' <- mapM relocateCommentsDeclWhereClause hsmodDecls+  pure m {hsmodDecls = hsmodDecls'}+  where+    relocateCommentsDeclWhereClause (L l (ValD ext fb@(FunBind {fun_matches = MG {..}}))) = do+      mg_alts' <- mapM (mapM relocateCommentsMatch) mg_alts+      pure $ L l (ValD ext fb {fun_matches = MG {mg_alts = mg_alts', ..}})+    relocateCommentsDeclWhereClause x = pure x+    relocateCommentsMatch (L l match@Match {m_grhss = gs@GRHSs {grhssLocalBinds = (HsValBinds ext (ValBinds ext' binds sigs))}}) = do+      (binds', sigs') <- relocateCommentsBindsSigs binds sigs+      let localBinds = HsValBinds ext (ValBinds ext' binds' sigs')+      pure $ L l match {m_grhss = gs {grhssLocalBinds = localBinds}}+    relocateCommentsMatch x = pure x+    relocateCommentsBindsSigs ::+         LHsBindsLR GhcPs GhcPs+      -> [LSig GhcPs]+      -> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])+    relocateCommentsBindsSigs binds sigs = do+      bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs+      pure (filterLBind bindsSigs', filterLSig bindsSigs')+      where+        bindsSigs = mkSortedLSigBindFamilyList sigs binds [] [] [] []+    addCommentsBeforeEpAnn (L epa@EpAnn { entry = EpaSpan (RealSrcSpan anc _)+                                        , ..+                                        } x) = do+      cs <- get+      let (notAbove, above) =+            partitionAboveNotAbove (sortCommentsByLocation cs) anc+          epa' = epa {comments = insertPriorComments comments above}+      put notAbove+      pure $ L epa' x+    addCommentsBeforeEpAnn x = pure x+    partitionAboveNotAbove cs sp =+      fst+        $ foldr'+            (\c@(L l _) ((ls, rs), lastSpan) ->+               case l of+                 EpaSpan (RealSrcSpan anc _) ->+                   if anc `isAbove` lastSpan+                     then ((ls, c : rs), anc)+                     else ((c : ls, rs), lastSpan)+                 _ -> undefined)+            (([], []), sp)+            cs+    isAbove comAnc anc =+      srcSpanStartCol comAnc == srcSpanStartCol anc+        && srcSpanEndLine comAnc + 1 == srcSpanStartLine anc+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- | This function locates comments that are located before each element of+-- an export list.+relocateCommentsInExportList :: HsModule' -> WithComments HsModule'+relocateCommentsInExportList =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: HsModule' -> [LIE GhcPs]+    elemGetter HsModule {hsmodExports = Just (L _ xs)} = xs+    elemGetter _ = []+    elemSetter xs HsModule {hsmodExports = Just (L sp _), ..} =+      HsModule {hsmodExports = Just (L sp xs), ..}+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond HsModule {hsmodExports = Just (L EpAnn {entry = EpaSpan (RealSrcSpan listAnc _)} _)} (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnc _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnc+        && realSrcSpanStart listAnc < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each case branch.+relocateCommentsInCase :: HsModule' -> WithComments HsModule'+relocateCommentsInCase =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]+    elemGetter (L _ (HsCase _ _ (MG {mg_alts = L _ xs}))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsCase ext expr (MG {mg_alts = L sp' _, ..}))) =+      L sp (HsCase ext expr (MG {mg_alts = L sp' xs, ..}))+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan caseAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan branchAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine branchAnchor+        && realSrcSpanStart caseAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each class element.+relocateCommentsInClass :: HsModule' -> WithComments HsModule'+relocateCommentsInClass =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsDecl GhcPs -> [LSigBindFamily]+    elemGetter (L _ (TyClD _ ClassDecl {..})) =       mkSortedLSigBindFamilyList         tcdSigs         (bagToList tcdMeths)         tcdATs+        []         tcdATDefs         []     elemGetter _ = []@@ -206,10 +408,10 @@             { tcdSigs = sigs             , tcdMeths = listToBag binds             , tcdATs = typeFamilies-            , tcdATDefs = tyFamInsts+            , tcdATDefs = tyFamDeflts             , ..             }-        (sigs, binds, typeFamilies, tyFamInsts, _) =+        (sigs, binds, typeFamilies, _, tyFamDeflts, _) =           destructLSigBindFamilyList xs     elemSetter _ x = x     annGetter (L ann _) = ann@@ -296,7 +498,8 @@       bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs       pure (listToBag $ filterLBind bindsSigs', filterLSig bindsSigs')       where-        bindsSigs = mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] []+        bindsSigs =+          mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] [] []     addCommentsBeforeEpAnn (L epa@EpAnn {..} x)       | EpaSpan (RealSrcSpan anc _) <- entry = do         cs <- get@@ -306,7 +509,6 @@         put notAbove         pure $ L epa' x       | otherwise = undefined-    addCommentsBeforeEpAnn x = pure x     partitionAboveNotAbove cs sp =       fst         $ foldr'@@ -386,6 +588,7 @@         tcdSigs         (bagToList tcdMeths)         tcdATs+        []         tcdATDefs         []     elemGetter _ = []@@ -396,10 +599,10 @@             { tcdSigs = sigs             , tcdMeths = listToBag binds             , tcdATs = typeFamilies-            , tcdATDefs = tyFamInsts+            , tcdATDefs = tyFamDeflts             , ..             }-        (sigs, binds, typeFamilies, tyFamInsts, _) =+        (sigs, binds, typeFamilies, _, tyFamDeflts, _) =           destructLSigBindFamilyList xs     elemSetter _ x = x     annGetter (L SrcSpanAnn {..} _) = ann@@ -487,7 +690,8 @@       bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs       pure (listToBag $ filterLBind bindsSigs', filterLSig bindsSigs')       where-        bindsSigs = mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] []+        bindsSigs =+          mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] [] []     addCommentsBeforeEpAnn (L (SrcSpanAnn epa@EpAnn {..} sp) x) = do       cs <- get       let (notAbove, above) =@@ -516,13 +720,19 @@ relocateCommentsAfter = everywhereMEpAnnsBackwards f   where     f epa@EpAnn {..} =-      insertCommentsByPos (isAfter $ anchor entry) insertFollowingComments epa+      insertCommentsByPos+        (isAfter $ epaLocationToRealSrcSpan entry)+        insertFollowingComments+        epa     isAfter anc comAnc = srcSpanEndLine anc <= srcSpanStartLine comAnc #else relocateCommentsAfter = everywhereMEpAnnsBackwards f   where     f epa@EpAnn {..} =-      insertCommentsByPos (isAfter $ anchor entry) insertFollowingComments epa+      insertCommentsByPos+        (isAfter $ epaLocationToRealSrcSpan entry)+        insertFollowingComments+        epa     f EpAnnNotUsed = pure EpAnnNotUsed     isAfter anc comAnc = srcSpanEndLine anc <= srcSpanStartLine comAnc #endif@@ -536,6 +746,7 @@   -> (a -> b -> RealSrcSpan -> Bool) -- ^ The function to decide whether to locate comments   -> HsModule'   -> WithComments HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1) relocateCommentsBeforeEachElement elemGetter elemSetter annGetter annSetter cond =   everywhereM (mkM f)   where@@ -544,13 +755,29 @@       newElems <- mapM insertCommentsBeforeElement (elemGetter x)       pure $ elemSetter newElems x       where+        insertCommentsBeforeElement element = do+          newEpa <-+            insertCommentsByPos+              (cond x element)+              insertPriorComments+              (annGetter element)+          pure $ annSetter newEpa element+#else+relocateCommentsBeforeEachElement elemGetter elemSetter annGetter annSetter cond =+  everywhereM (mkM f)+  where+    f :: a -> WithComments a+    f x = do+      newElems <- mapM insertCommentsBeforeElement (elemGetter x)+      pure $ elemSetter newElems x+      where         insertCommentsBeforeElement element           | elemAnn@EpAnn {} <- annGetter element = do             newEpa <-               insertCommentsByPos (cond x element) insertPriorComments elemAnn             pure $ annSetter newEpa element           | otherwise = pure element-+#endif -- | This function applies the given function to all 'EpAnn's. applyM ::      forall a. Typeable a@@ -568,7 +795,8 @@   -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)   -> EpAnn a   -> WithComments (EpAnn a)-insertCommentsByPos cond = insertComments (cond . anchor . getLoc)+insertCommentsByPos cond =+  insertComments (cond . epaLocationToRealSrcSpan . getLoc)  -- | This function drains comments that satisfy the given predicate and -- inserts them to the given node using the given inserter.@@ -667,13 +895,15 @@           -- This guard arm checks if 'a' is 'EpAnn b' ('b' can be any type).           | App g g' <- typeRep @a           , Just HRefl <- eqTypeRep g (typeRep @EpAnn) = do-            i <- gets head-            modify tail-            case lookup i anns of-              Just (Wrapper y)-                | App _ h <- typeOf y-                , Just HRefl <- eqTypeRep g' h -> pure y-              _ -> error "Unmatches"+            get >>= \case+              [] -> error "No comments."+              (i:is) -> do+                put is+                case lookup i anns of+                  Just (Wrapper y)+                    | App _ h <- typeOf y+                    , Just HRefl <- eqTypeRep g' h -> pure y+                  _ -> error "Unmatches"           | otherwise = pure x  -- | This function moves comments in `fun_id` of `FunBind` to@@ -698,14 +928,12 @@           fmap             (\(L l' x) ->                case x of-                 Match {m_ctxt = FunRhs {mc_fun = L EpAnn {..} fun, ..}, ..} ->+                 Match {m_ctxt = FunRhs {mc_fun = L funann@EpAnn {} fun, ..}} ->                    L                      l'-                     Match+                     x                        { m_ctxt =-                           FunRhs-                             {mc_fun = L EpAnn {comments = from, ..} fun, ..}-                       , ..+                           FunRhs {mc_fun = L funann {comments = from} fun, ..}                        }                  x'' -> L l' x'')             alts@@ -715,7 +943,7 @@ #endif -- | This function sorts comments by its location. sortCommentsByLocation :: [LEpaComment] -> [LEpaComment]-sortCommentsByLocation = sortBy (compare `on` anchor . getLoc)+sortCommentsByLocation = sortBy (compare `on` epaLocationToRealSrcSpan . getLoc)  -- | This function compares given EPAs by their end positions. compareEpaByEndPosition :: EpAnn a -> EpAnn b -> Ordering

src/HIndent/Path/Find.hs view

@@ -8,7 +8,7 @@  import Control.Monad.Catch import Control.Monad.IO.Class-import Data.List+import Data.List (find) import Path import Path.IO hiding (findFiles)

src/HIndent/Pragma.hs view

@@ -11,7 +11,7 @@ import Data.Bifunctor import Data.Char import Data.Generics-import Data.List+import Data.List (intercalate) import Data.List.Split import Data.Maybe import GHC.Hs

src/HIndent/Pretty.hs view

@@ -2,1880 +2,444 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}---- | Pretty printing.------ Some instances define top-level functions to handle CPP.------ Some value constructors never appear in an AST. GHC has three stages for--- using an AST: parsing, renaming, and type checking, and GHC uses these--- constructors only in remaining and type checking.-module HIndent.Pretty-  ( Pretty(..)-  , pretty-  , printCommentsAnd-  ) where--import Control.Monad-import Control.Monad.RWS-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NE-import Data.Maybe-import Data.Void-import qualified GHC.Data.Bag as GHC-import qualified GHC.Data.FastString as GHC-import qualified GHC.Hs as GHC-import GHC.Stack-import qualified GHC.Types.Basic as GHC-import qualified GHC.Types.Fixity as GHC-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.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.Name.Infix-import HIndent.Ast.Name.Prefix-import HIndent.Ast.NodeComments-import HIndent.Ast.Type.Variable-import HIndent.Ast.WithComments-import HIndent.Config-import HIndent.Fixity-import HIndent.Pretty.Combinators-import HIndent.Pretty.NodeComments-import qualified HIndent.Pretty.SigBindFamily as SBF-import HIndent.Pretty.Types-import HIndent.Printer-import qualified Language.Haskell.GhclibParserEx.GHC.Hs.Expr as GHC-import Text.Show.Unicode-#if MIN_VERSION_ghc_lib_parser(9,6,1)-import qualified GHC.Core.DataCon as GHC-#endif-#if !MIN_VERSION_ghc_lib_parser(9,6,1)-import qualified GHC.Unit as GHC-#endif--- | This function pretty-prints the given AST node with comments.-pretty :: Pretty a => a -> Printer ()-pretty p = do-  printCommentsBefore p-  pretty' p-  printCommentOnSameLine p-  printCommentsAfter p---- | Prints comments included in the location information and then the--- AST node body.-printCommentsAnd ::-     (CommentExtraction l)-  => GHC.GenLocated l e-  -> (e -> Printer ())-  -> Printer ()-printCommentsAnd (GHC.L l e) f = do-  printCommentsBefore l-  f e-  printCommentOnSameLine l-  printCommentsAfter l---- | Prints comments that are before the given AST node.-printCommentsBefore :: CommentExtraction a => a -> Printer ()-printCommentsBefore p =-  forM_ (commentsBefore $ nodeComments p) $ \(GHC.L loc c) -> do-    let col = fromIntegral $ GHC.srcSpanStartCol (getAnc loc) - 1-    indentedWithFixedLevel col $ pretty c-    newline---- | Prints comments that are on the same line as the given AST node.-printCommentOnSameLine :: CommentExtraction a => a -> Printer ()-printCommentOnSameLine (commentsOnSameLine . nodeComments -> (c:cs)) = do-  col <- gets psColumn-  if col == 0-    then indentedWithFixedLevel-           (fromIntegral $ GHC.srcSpanStartCol $ getAnc $ GHC.getLoc c)-           $ spaced-           $ fmap pretty-           $ c : cs-    else spacePrefixed $ fmap pretty $ c : cs-  eolCommentsArePrinted-printCommentOnSameLine _ = return ()---- | Prints comments that are after the given AST node.-printCommentsAfter :: CommentExtraction a => a -> Printer ()-printCommentsAfter p =-  case commentsAfter $ nodeComments p of-    [] -> return ()-    xs -> do-      isThereCommentsOnSameLine <- gets psEolComment-      unless isThereCommentsOnSameLine newline-      forM_ xs $ \(GHC.L loc c) -> do-        let col = fromIntegral $ GHC.srcSpanStartCol (getAnc loc) - 1-        indentedWithFixedLevel col $ pretty c-        eolCommentsArePrinted---- | Pretty print including comments.------ 'FastString' does not implement this class because it may contain @\n@s--- and each type that may contain a 'FastString' value needs their own--- handlings.-class CommentExtraction a =>-      Pretty a-  where-  pretty' :: a -> Printer ()---- Do nothing if there are no pragmas, module headers, imports, or--- declarations. Otherwise, extra blank lines will be inserted if only--- comments are present in the source code. See--- https://github.com/mihaimaruseac/hindent/issues/586#issuecomment-1374992624.-instance (CommentExtraction l, Pretty e) => Pretty (GHC.GenLocated l e) where-  pretty' (GHC.L _ e) = pretty e--instance Pretty-           (GHC.MatchGroup-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' GHC.MG {..} = printCommentsAnd mg_alts (lined . fmap pretty)--instance Pretty-           (GHC.MatchGroup-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsCmd GHC.GhcPs))) where-  pretty' GHC.MG {..} = printCommentsAnd mg_alts (lined . fmap pretty)--instance Pretty (GHC.HsExpr GHC.GhcPs) where-  pretty' = prettyHsExpr--prettyHsExpr :: GHC.HsExpr GHC.GhcPs -> Printer ()-prettyHsExpr (GHC.HsVar _ bind) = pretty $ fmap mkPrefixName bind-#if MIN_VERSION_ghc_lib_parser(9, 6, 0)-prettyHsExpr (GHC.HsUnboundVar _ x) = pretty $ mkPrefixName x-#else-prettyHsExpr (GHC.HsUnboundVar _ x) = pretty x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)-prettyHsExpr (GHC.HsOverLabel _ _ l) = string "#" >> string (GHC.unpackFS l)-#else-prettyHsExpr (GHC.HsOverLabel _ l) = string "#" >> string (GHC.unpackFS l)-#endif-prettyHsExpr (GHC.HsIPVar _ var) = string "?" >> pretty var-prettyHsExpr (GHC.HsOverLit _ x) = pretty x-prettyHsExpr (GHC.HsLit _ l) = pretty l-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsExpr (GHC.HsLam _ GHC.LamSingle body) = pretty body-prettyHsExpr (GHC.HsLam _ GHC.LamCase body) = pretty $ LambdaCase body Case-prettyHsExpr (GHC.HsLam _ GHC.LamCases body) = pretty $ LambdaCase body Cases-#else-prettyHsExpr (GHC.HsLam _ body) = pretty body-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)--- No `HsLamCase` since 9.10.1.-#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)-prettyHsExpr (GHC.HsLamCase _ GHC.LamCase matches) =-  pretty $ LambdaCase matches Case-prettyHsExpr (GHC.HsLamCase _ GHC.LamCases matches) =-  pretty $ LambdaCase matches Cases-#else-prettyHsExpr (GHC.HsLamCase _ matches) = pretty $ LambdaCase matches Case-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsExpr (GHC.HsApp _ l r) = horizontal <-|> vertical-  where-    horizontal = spaced [pretty l, pretty r]-    vertical = do-      let (f, args) =-            case flatten l ++ [r] of-              [] -> error "Invalid function application."-              (f':args') -> (f', args')-      col <- gets psColumn-      spaces <- getIndentSpaces-      pretty f-      col' <- gets psColumn-      let diff =-            col'-              - col-              - if col == 0-                  then spaces-                  else 0-      if diff + 1 <= spaces-        then space-        else newline-      spaces' <- getIndentSpaces-      indentedWithSpace spaces' $ lined $ fmap pretty args-    flatten :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]-    flatten (GHC.L (GHC.EpAnn _ _ cs) (GHC.HsApp _ l' r')) =-      flatten l' ++ [insertComments cs r']-    flatten x = [x]-    insertComments ::-         GHC.EpAnnComments -> GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs-    insertComments cs (GHC.L s@GHC.EpAnn {comments = cs'} r') =-      GHC.L (s {GHC.comments = cs <> cs'}) r'-    insertComments _ x = x-#else-prettyHsExpr (GHC.HsApp _ l r) = horizontal <-|> vertical-  where-    horizontal = spaced [pretty l, pretty r]-    vertical = do-      let (f, args) =-            case flatten l ++ [r] of-              [] -> error "Invalid function application."-              (f':args') -> (f', args')-      col <- gets psColumn-      spaces <- getIndentSpaces-      pretty f-      col' <- gets psColumn-      let diff =-            col'-              - col-              - if col == 0-                  then spaces-                  else 0-      if diff + 1 <= spaces-        then space-        else newline-      spaces' <- getIndentSpaces-      indentedWithSpace spaces' $ lined $ fmap pretty args-    flatten :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]-    flatten (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn _ _ cs) _) (GHC.HsApp _ l' r')) =-      flatten l' ++ [insertComments cs r']-    flatten x = [x]-    insertComments ::-         GHC.EpAnnComments -> GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs-    insertComments cs (GHC.L s@GHC.SrcSpanAnn {GHC.ann = e@GHC.EpAnn {comments = cs'}} r') =-      GHC.L (s {GHC.ann = e {GHC.comments = cs <> cs'}}) r'-    insertComments _ x = x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 6, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsExpr (GHC.HsAppType _ l _ r) = do-  pretty l-  string " @"-  pretty r-#else-prettyHsExpr (GHC.HsAppType _ l r) = do-  pretty l-  string " @"-  pretty r-#endif-prettyHsExpr (GHC.OpApp _ l o r) = pretty (InfixApp l o r)-prettyHsExpr (GHC.NegApp _ x _) = string "-" >> pretty x-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsExpr (GHC.HsPar _ _ expr _) = parens $ pretty expr-#else-prettyHsExpr (GHC.HsPar _ expr) = parens $ pretty expr-#endif-prettyHsExpr (GHC.SectionL _ l o) = spaced [pretty l, pretty (InfixExpr o)]-prettyHsExpr (GHC.SectionR _ o r) = (pretty (InfixExpr o) >> space) |=> pretty r-prettyHsExpr (GHC.ExplicitTuple _ full boxity) = horizontal <-|> vertical-  where-    horizontal = parH $ fmap pretty full-    vertical =-      parV-        $ prefixedLined ","-        $ fmap (\e -> unless (isMissing e) (space |=> pretty e)) full-    isMissing GHC.Missing {} = True-    isMissing _ = False-    parH =-      case boxity of-        GHC.Boxed -> hTuple-        GHC.Unboxed -> hUnboxedTuple-    parV =-      case boxity of-        GHC.Boxed -> parens-        GHC.Unboxed -> unboxedParens-prettyHsExpr (GHC.ExplicitSum _ position numElem expr) = do-  string "(#"-  forM_ [1 .. numElem] $ \idx -> do-    if idx == position-      then string " " >> pretty expr >> string " "-      else string " "-    when (idx < numElem) $ string "|"-  string "#)"-prettyHsExpr (GHC.HsCase _ cond arms) = do-  string "case " |=> do-    pretty cond-    string " of"-  if null $ GHC.unLoc $ GHC.mg_alts arms-    then string " {}"-    else do-      newline-      indentedBlock $ pretty arms-prettyHsExpr (GHC.HsIf _ cond t f) = do-  string "if " |=> pretty cond-  indentedBlock $ newlinePrefixed [branch "then " t, branch "else " f]-  where-    branch :: String -> GHC.LHsExpr GHC.GhcPs -> Printer ()-    branch str e =-      case e of-        (GHC.L _ (GHC.HsDo _ (GHC.DoExpr m) xs)) -> doStmt (QualifiedDo m Do) xs-        (GHC.L _ (GHC.HsDo _ (GHC.MDoExpr m) xs)) ->-          doStmt (QualifiedDo m Mdo) xs-        _ -> string str |=> pretty e-      where-        doStmt qDo stmts = do-          string str-          pretty qDo-          newline-          indentedBlock $ printCommentsAnd stmts (lined . fmap pretty)-prettyHsExpr (GHC.HsMultiIf _ guards) =-  string "if "-    |=> lined (fmap (pretty . fmap (GRHSExpr GRHSExprMultiWayIf)) guards)-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsExpr (GHC.HsLet _ _ binds _ exprs) = pretty $ LetIn binds exprs-#else-prettyHsExpr (GHC.HsLet _ binds exprs) = pretty $ LetIn binds exprs-#endif-prettyHsExpr (GHC.HsDo _ GHC.ListComp {} (GHC.L _ [])) =-  error "Not enough arguments are passed to pretty-print a list comprehension."-prettyHsExpr (GHC.HsDo _ GHC.ListComp {} (GHC.L _ [_])) =-  error "Not enough arguments are passed to pretty-print a list comprehension."-prettyHsExpr (GHC.HsDo _ GHC.ListComp {} (GHC.L l (lhs:rhs:rhss))) =-  pretty $ GHC.L l $ ListComprehension lhs (rhs :| rhss)--- While the name contains 'Monad', 'MonadComp' is for list comprehensions.-prettyHsExpr (GHC.HsDo _ GHC.MonadComp {} (GHC.L _ [])) =-  error "Not enough arguments are passed to pretty-print a list comprehension."-prettyHsExpr (GHC.HsDo _ GHC.MonadComp {} (GHC.L _ [_])) =-  error "Not enough arguments are passed to pretty-print a list comprehension."-prettyHsExpr (GHC.HsDo _ GHC.MonadComp {} (GHC.L l (lhs:rhs:rhss))) =-  pretty $ GHC.L l $ ListComprehension lhs (rhs :| rhss)-prettyHsExpr (GHC.HsDo _ (GHC.DoExpr m) (GHC.L l xs)) =-  pretty $ GHC.L l $ DoExpression xs (QualifiedDo m Do)-prettyHsExpr (GHC.HsDo _ (GHC.MDoExpr m) (GHC.L l xs)) =-  pretty $ GHC.L l $ DoExpression xs (QualifiedDo m Mdo)-prettyHsExpr (GHC.HsDo _ GHC.GhciStmtCtxt {} _) =-  error "We're not using GHCi, are we?"-prettyHsExpr (GHC.ExplicitList _ xs) = horizontal <-|> vertical-  where-    horizontal = brackets $ hCommaSep $ fmap pretty xs-    vertical = vList $ fmap pretty xs-prettyHsExpr (GHC.RecordCon _ name fields) = horizontal <-|> vertical-  where-    horizontal = spaced [pretty $ fmap mkPrefixName name, pretty fields]-    vertical = do-      pretty $ fmap mkPrefixName name-      (space >> pretty fields) <-|> (newline >> indentedBlock (pretty fields))-#if MIN_VERSION_ghc_lib_parser(9,8,1)-prettyHsExpr (GHC.RecordUpd _ name fields) = hor <-|> ver-  where-    hor = spaced [pretty name, printHorFields fields]-    ver = do-      pretty name-      newline-      indentedBlock $ printHorFields fields <-|> printVerFields fields-    printHorFields GHC.RegularRecUpdFields {..} =-      hFields $ fmap (`printCommentsAnd` horField) recUpdFields-    printHorFields GHC.OverloadedRecUpdFields {..} =-      hFields $ fmap (`printCommentsAnd` horField) olRecUpdFields-    printVerFields GHC.RegularRecUpdFields {..} =-      vFields $ fmap printField recUpdFields-    printVerFields GHC.OverloadedRecUpdFields {..} =-      vFields $ fmap printField olRecUpdFields-    printField x = printCommentsAnd x $ (<-|>) <$> horField <*> verField-    horField GHC.HsFieldBind {..} = do-      pretty hfbLHS-      string " = "-      pretty hfbRHS-    verField GHC.HsFieldBind {..} = do-      pretty hfbLHS-      string " ="-      newline-      indentedBlock $ pretty hfbRHS-#elif MIN_VERSION_ghc_lib_parser(9,4,1)-prettyHsExpr (GHC.RecordUpd _ name fields) = hor <-|> ver-  where-    hor = spaced [pretty name, either printHorFields printHorFields fields]-    ver = do-      pretty name-      newline-      indentedBlock-        $ either printHorFields printHorFields fields-            <-|> either printVerFields printVerFields fields-    printHorFields ::-         (Pretty a, Pretty b, CommentExtraction l)-      => [GHC.GenLocated l (GHC.HsFieldBind a b)]-      -> Printer ()-    printHorFields = hFields . fmap (`printCommentsAnd` horField)-    printVerFields ::-         (Pretty a, Pretty b, CommentExtraction l)-      => [GHC.GenLocated l (GHC.HsFieldBind a b)]-      -> Printer ()-    printVerFields = vFields . fmap printField-    printField x = printCommentsAnd x $ (<-|>) <$> horField <*> verField-    horField GHC.HsFieldBind {..} = do-      pretty hfbLHS-      string " = "-      pretty hfbRHS-    verField GHC.HsFieldBind {..} = do-      pretty hfbLHS-      string " ="-      newline-      indentedBlock $ pretty hfbRHS-#else-prettyHsExpr (GHC.RecordUpd _ name fields) = hor <-|> ver-  where-    hor = spaced [pretty name, either printHorFields printHorFields fields]-    ver = do-      pretty name-      newline-      indentedBlock-        $ either printHorFields printHorFields fields-            <-|> either printVerFields printVerFields fields-    printHorFields ::-         (Pretty a, Pretty b, CommentExtraction l)-      => [GHC.GenLocated l (GHC.HsRecField' a b)]-      -> Printer ()-    printHorFields = hFields . fmap (`printCommentsAnd` horField)-    printVerFields ::-         (Pretty a, Pretty b, CommentExtraction l)-      => [GHC.GenLocated l (GHC.HsRecField' a b)]-      -> Printer ()-    printVerFields = vFields . fmap printField-    printField x = printCommentsAnd x $ (<-|>) <$> horField <*> verField-    horField GHC.HsRecField {..} = do-      pretty hsRecFieldLbl-      string " = "-      pretty hsRecFieldArg-    verField GHC.HsRecField {..} = do-      pretty hsRecFieldLbl-      string " ="-      newline-      indentedBlock $ pretty hsRecFieldArg-#endif-prettyHsExpr (GHC.HsGetField _ e f) = do-  pretty e-  dot-  pretty f-prettyHsExpr GHC.HsProjection {..} =-  parens-    $ forM_ proj_flds-    $ \x -> do-        string "."-        pretty x-prettyHsExpr (GHC.ExprWithTySig _ e sig) = do-  pretty e-  string " :: "-  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 $ 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"]-  newline-  indentedBlock-    $ printCommentsAnd x (const (printCommentsAnd xs (lined . fmap pretty)))-prettyHsExpr (GHC.HsProc _ pat body) = hor <-|> ver-  where-    hor = spaced [string "proc", pretty pat, string "->", pretty body]-    ver = do-      spaced [string "proc", pretty pat, string "->"]-      newline-      indentedBlock (pretty body)-prettyHsExpr (GHC.HsStatic _ x) = spaced [string "static", pretty x]-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 $ mkBracket inner-#else-prettyHsExpr GHC.HsConLikeOut {} = notGeneratedByParser-prettyHsExpr GHC.HsRecFld {} = notGeneratedByParser-prettyHsExpr (GHC.HsDo _ GHC.ArrowExpr {} _) = notGeneratedByParser-prettyHsExpr (GHC.HsDo _ GHC.PatGuard {} _) = notGeneratedByParser-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 $ mkBracket inner-prettyHsExpr GHC.HsRnBracketOut {} = notGeneratedByParser-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 $ mkSplice x-#endif-instance Pretty LambdaCase where-  pretty' (LambdaCase matches caseOrCases) = do-    case caseOrCases of-      Case -> string "\\case"-      Cases -> string "\\cases"-    if null $ GHC.unLoc $ GHC.mg_alts matches-      then string " {}"-      else do-        newline-        indentedBlock $ pretty matches--instance Pretty (GHC.HsSigType GHC.GhcPs) where-  pretty' = pretty' . HsSigType' HsTypeForNormalDecl HsTypeNoDir--instance Pretty HsSigType' where-  pretty' (HsSigTypeInsideDeclSig GHC.HsSig {..}) =-    case sig_bndrs of-      GHC.HsOuterExplicit _ xs -> do-        string "forall "-        spaced $ fmap (pretty . fmap mkTypeVariable . fromGenLocated) xs-        dot-        case GHC.unLoc sig_body of-          GHC.HsQualTy {..} ->-            printCommentsAnd sig_body $ \_ ->-              let hor = do-                    space-                    pretty $ HorizontalContext hst_ctxt-                  ver = do-                    newline-                    pretty $ VerticalContext hst_ctxt-               in do-                    hor <-|> ver-                    newline-                    prefixed "=> "-                      $ prefixedLined "-> "-                      $ pretty <$> flatten hst_body-          _ ->-            let hor = space >> pretty (fmap HsTypeInsideDeclSig sig_body)-                ver =-                  newline >> prefixedLined "-> " (pretty <$> flatten sig_body)-             in hor <-|> ver-      _ -> pretty $ fmap HsTypeInsideDeclSig sig_body-    where-      flatten :: GHC.LHsType GHC.GhcPs -> [GHC.LHsType GHC.GhcPs]-      flatten (GHC.L _ (GHC.HsFunTy _ _ l r)) = flatten l ++ flatten r-      flatten x = [x]-  pretty' (HsSigTypeInsideVerticalFuncSig GHC.HsSig {..}) =-    case sig_bndrs of-      GHC.HsOuterExplicit _ xs -> do-        string "forall "-        spaced $ fmap (pretty . fmap mkTypeVariable . fromGenLocated) xs-        dot-        printCommentsAnd sig_body $ \case-          GHC.HsQualTy {..} -> do-            (space >> pretty (HorizontalContext hst_ctxt))-              <-|> (newline >> pretty (VerticalContext hst_ctxt))-            newline-            prefixed "=> " $ pretty hst_body-          x -> pretty $ HsTypeInsideDeclSig x-      _ -> pretty $ fmap HsTypeInsideDeclSig sig_body-  pretty' (HsSigType' for dir GHC.HsSig {..}) = do-    case sig_bndrs of-      GHC.HsOuterExplicit _ xs -> do-        string "forall "-        spaced $ fmap (pretty . fmap mkTypeVariable . fromGenLocated) xs-        dot-        space-      _ -> return ()-    pretty $ HsType' for dir <$> sig_body--instance Pretty-           (GHC.Match-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' = prettyMatchExpr--prettyMatchExpr :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Printer ()-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyMatchExpr GHC.Match {m_ctxt = GHC.LamAlt GHC.LamSingle, ..} = do-  string "\\"-  case m_pats of-    p:_ ->-      case GHC.unLoc p of-        GHC.LazyPat {} -> space-        GHC.BangPat {} -> space-        _ -> return ()-    _ -> return ()-  spaced $ fmap pretty m_pats-  pretty $ GRHSsExpr GRHSExprLambda m_grhss-prettyMatchExpr GHC.Match {m_ctxt = GHC.LamAlt GHC.LamCase, ..} = do-  spaced $ fmap pretty m_pats-  pretty $ GRHSsExpr GRHSExprCase m_grhss-prettyMatchExpr GHC.Match {m_ctxt = GHC.LamAlt GHC.LamCases, ..} = do-  spaced $ fmap pretty m_pats-  pretty $ GRHSsExpr GRHSExprCase m_grhss-#else-prettyMatchExpr GHC.Match {m_ctxt = GHC.LambdaExpr, ..} = do-  string "\\"-  case m_pats of-    p:_ ->-      case GHC.unLoc p of-        GHC.LazyPat {} -> space-        GHC.BangPat {} -> space-        _ -> return ()-    _ -> return ()-  spaced $ fmap pretty m_pats-  pretty $ GRHSsExpr GRHSExprLambda m_grhss-#endif-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyMatchExpr GHC.Match {m_ctxt = GHC.LamCaseAlt {}, ..} = do-  spaced $ fmap pretty m_pats-  pretty $ GRHSsExpr GRHSExprCase m_grhss-#endif-prettyMatchExpr GHC.Match {m_ctxt = GHC.CaseAlt, ..} = do-  mapM_ pretty m_pats-  pretty $ GRHSsExpr GRHSExprCase m_grhss-prettyMatchExpr GHC.Match {..} =-  case GHC.mc_fixity m_ctxt of-    GHC.Prefix -> do-      pretty m_ctxt-      spacePrefixed $ fmap pretty m_pats-      pretty m_grhss-    GHC.Infix -> do-      case (m_pats, m_ctxt) of-        (l:r:xs, GHC.FunRhs {..}) -> do-          spaced-            $ [pretty l, pretty $ fmap mkInfixName mc_fun, pretty r]-                ++ fmap pretty xs-          pretty m_grhss-        _ -> error "Not enough parameters are passed."--instance Pretty-           (GHC.Match-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsCmd GHC.GhcPs))) where-  pretty' = prettyMatchProc--prettyMatchProc :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Printer ()-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyMatchProc GHC.Match {m_ctxt = GHC.LamAlt GHC.LamSingle, ..} = do-  string "\\"-  case m_pats of-    p:_ ->-      case GHC.unLoc p of-        GHC.LazyPat {} -> space-        GHC.BangPat {} -> space-        _ -> return ()-    _ -> return ()-  spaced $ fmap pretty m_pats ++ [pretty m_grhss]-prettyMatchProc GHC.Match {m_ctxt = GHC.LamAlt GHC.LamCase, ..} = do-  spaced [mapM_ pretty m_pats, pretty m_grhss]-prettyMatchProc GHC.Match {m_ctxt = GHC.LamAlt GHC.LamCases, ..} = do-  spaced [mapM_ pretty m_pats, pretty m_grhss]-#else-prettyMatchProc GHC.Match {m_ctxt = GHC.LambdaExpr, ..} = do-  string "\\"-  case m_pats of-    p:_ ->-      case GHC.unLoc p of-        GHC.LazyPat {} -> space-        GHC.BangPat {} -> space-        _ -> return ()-    _ -> return ()-  spaced $ fmap pretty m_pats ++ [pretty m_grhss]-#endif-prettyMatchProc GHC.Match {m_ctxt = GHC.CaseAlt, ..} =-  spaced [mapM_ pretty m_pats, pretty m_grhss]-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyMatchProc GHC.Match {m_ctxt = GHC.LamCaseAlt {}, ..} = do-  spaced [mapM_ pretty m_pats, pretty m_grhss]-#endif-prettyMatchProc _ = notGeneratedByParser--instance Pretty-           (GHC.StmtLR-              GHC.GhcPs-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' (GHC.LastStmt _ x _ _) = pretty x-  pretty' (GHC.BindStmt _ pat body) = do-    pretty pat-    string " <-"-    hor <-|> ver-    where-      hor = space >> pretty body-      ver = newline >> indentedBlock (pretty body)-  pretty' GHC.ApplicativeStmt {} = notGeneratedByParser-  pretty' (GHC.BodyStmt _ (GHC.L loc (GHC.OpApp _ l o r)) _ _) =-    pretty (GHC.L loc (InfixApp l o r))-  pretty' (GHC.BodyStmt _ body _ _) = pretty body-  pretty' (GHC.LetStmt _ l) = string "let " |=> pretty l-  pretty' (GHC.ParStmt _ xs _ _) = hvBarSep $ fmap pretty xs-  pretty' GHC.TransStmt {..} =-    vCommaSep $ fmap pretty trS_stmts ++ [string "then " >> pretty trS_using]-  pretty' GHC.RecStmt {..} =-    string "rec " |=> printCommentsAnd recS_stmts (lined . fmap pretty)--instance Pretty-           (GHC.StmtLR-              GHC.GhcPs-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsCmd GHC.GhcPs))) where-  pretty' (GHC.LastStmt _ x _ _) = pretty x-  pretty' (GHC.BindStmt _ pat body) = hor <-|> ver-    where-      hor = spaced [pretty pat, string "<-", pretty body]-      ver = do-        pretty pat-        string " <-"-        newline-        indentedBlock $ pretty body-  pretty' GHC.ApplicativeStmt {} = notGeneratedByParser-  pretty' (GHC.BodyStmt _ body _ _) = pretty body-  pretty' (GHC.LetStmt _ l) = string "let " |=> pretty l-  pretty' (GHC.ParStmt _ xs _ _) = hvBarSep $ fmap pretty xs-  pretty' GHC.TransStmt {..} =-    vCommaSep $ fmap pretty trS_stmts ++ [string "then " >> pretty trS_using]-  pretty' GHC.RecStmt {..} =-    string "rec " |=> printCommentsAnd recS_stmts (lined . fmap pretty)--instance Pretty StmtLRInsideVerticalList where-  pretty' (StmtLRInsideVerticalList (GHC.ParStmt _ xs _ _)) =-    vBarSep $ fmap (pretty . ParStmtBlockInsideVerticalList) xs-  pretty' (StmtLRInsideVerticalList x) = pretty x---- | For pattern matching.-instance Pretty-           (GHC.HsRecFields-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.Pat GHC.GhcPs))) where-  pretty' GHC.HsRecFields {..} = horizontal <-|> vertical-    where-      horizontal =-        case rec_dotdot of-          Just _ -> braces $ string ".."-          Nothing -> hFields $ fmap pretty rec_flds-      vertical = vFields $ fmap pretty rec_flds---- | For record updates-instance Pretty-           (GHC.HsRecFields-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' GHC.HsRecFields {..} = hvFields fieldPrinters-    where-      fieldPrinters =-        fmap pretty rec_flds-          ++ maybeToList (fmap (const (string "..")) rec_dotdot)--instance Pretty (GHC.HsType GHC.GhcPs) where-  pretty' = pretty' . HsType' HsTypeForNormalDecl HsTypeNoDir--instance Pretty HsType' where-  pretty' (HsTypeInsideVerticalFuncSig (GHC.HsFunTy _ _ a b)) = do-    pretty $ HsTypeInsideVerticalFuncSig <$> a-    newline-    prefixed "-> " $ pretty $ HsTypeInsideVerticalFuncSig <$> b-  pretty' (HsTypeInsideDeclSig GHC.HsQualTy {..}) = hor <-|> ver-    where-      hor = spaced [pretty $ Context hst_ctxt, string "=>", pretty hst_body]-      ver = do-        pretty $ Context hst_ctxt-        newline-        prefixed "=> " $ pretty $ fmap HsTypeInsideVerticalFuncSig hst_body-  pretty' (HsTypeInsideDeclSig (GHC.HsFunTy _ _ a b)) = hor <-|> ver-    where-      hor = spaced [pretty a, string "->", pretty b]-      ver = do-        pretty $ fmap HsTypeInsideVerticalFuncSig a-        newline-        prefixed "-> " $ pretty $ fmap HsTypeInsideVerticalFuncSig b-  pretty' (HsTypeInsideInstDecl GHC.HsQualTy {..}) = hor <-|> ver-    where-      hor = spaced [pretty (Context hst_ctxt), string "=>", pretty hst_body]-      ver = do-        pretty (Context hst_ctxt)-        string " =>"-        newline-        pretty hst_body-  pretty' (HsTypeWithVerticalAppTy (GHC.HsAppTy _ l r)) = do-    pretty $ fmap HsTypeWithVerticalAppTy l-    newline-    indentedBlock $ pretty $ fmap HsTypeWithVerticalAppTy r-  pretty' (HsType' _ _ x) = prettyHsType x--prettyHsType :: GHC.HsType GHC.GhcPs -> Printer ()-prettyHsType (GHC.HsForAllTy _ tele body) =-  (pretty tele >> space) |=> pretty body-prettyHsType GHC.HsQualTy {..} = hor <-|> ver-  where-    hor = spaced [pretty $ Context hst_ctxt, string "=>", pretty hst_body]-    ver = do-      pretty $ Context hst_ctxt-      lined [string " =>", indentedBlock $ pretty hst_body]-prettyHsType (GHC.HsTyVar _ GHC.NotPromoted x) = pretty $ fmap mkPrefixName x-prettyHsType (GHC.HsTyVar _ GHC.IsPromoted x) =-  string "'" >> pretty (fmap mkPrefixName x)-prettyHsType x@(GHC.HsAppTy _ l r) = hor <-|> ver-  where-    hor = spaced $ fmap pretty [l, r]-    ver = pretty $ HsTypeWithVerticalAppTy x-#if MIN_VERSION_ghc_lib_parser(9, 8, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsType (GHC.HsAppKindTy _ l _ r) = pretty l >> string " @" >> pretty r-#else-prettyHsType (GHC.HsAppKindTy _ l r) = pretty l >> string " @" >> pretty r-#endif-prettyHsType (GHC.HsFunTy _ _ a b) = (pretty a >> string " -> ") |=> pretty b-prettyHsType (GHC.HsListTy _ xs) = brackets $ pretty xs-prettyHsType (GHC.HsTupleTy _ GHC.HsUnboxedTuple []) = string "(# #)"-prettyHsType (GHC.HsTupleTy _ GHC.HsBoxedOrConstraintTuple []) = string "()"-prettyHsType (GHC.HsTupleTy _ GHC.HsUnboxedTuple xs) =-  hvUnboxedTuple' $ fmap pretty xs-prettyHsType (GHC.HsTupleTy _ GHC.HsBoxedOrConstraintTuple xs) =-  hvTuple' $ fmap pretty xs-prettyHsType (GHC.HsSumTy _ xs) = hvUnboxedSum' $ fmap pretty xs--- For `HsOpTy`, we do not need a single quote for the infix operator. An--- explicit promotion is necessary if there is a data constructor and--- a type with the same name. However, infix data constructors never--- share their names with types because types cannot contain symbols.--- Thus there is no ambiguity.-#if MIN_VERSION_ghc_lib_parser(9,4,1)-prettyHsType (GHC.HsOpTy _ _ l op r) = do-  lineBreak <- gets (configLineBreaks . psConfig)-  if showOutputable op `elem` lineBreak-    then do-      pretty l-      newline-      pretty $ fmap mkInfixName op-      space-      pretty r-    else spaced [pretty l, pretty $ fmap mkInfixName op, pretty r]-#else-prettyHsType (GHC.HsOpTy _ l op r) = do-  lineBreak <- gets (configLineBreaks . psConfig)-  if showOutputable op `elem` lineBreak-    then do-      pretty l-      newline-      pretty $ fmap mkInfixName op-      space-      pretty r-    else spaced [pretty l, pretty $ fmap mkInfixName op, pretty r]-#endif-prettyHsType (GHC.HsParTy _ inside) = parens $ pretty inside-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 $ mkSplice sp-prettyHsType GHC.HsDocTy {} = docNode-prettyHsType (GHC.HsBangTy _ pack x) = pretty pack >> pretty x-prettyHsType (GHC.HsRecTy _ xs) =-  hvFields $ fmap (pretty . fmap mkRecordField . fromGenLocated) xs-prettyHsType (GHC.HsExplicitListTy _ _ xs) =-  case xs of-    [] -> string "'[]"-    _ -> hvPromotedList $ fmap pretty xs-prettyHsType (GHC.HsExplicitTupleTy _ xs) = hPromotedTuple $ fmap pretty xs-prettyHsType (GHC.HsTyLit _ x) = pretty x-prettyHsType GHC.HsWildCardTy {} = string "_"-prettyHsType GHC.XHsType {} = notGeneratedByParser--instance Pretty-           (GHC.GRHSs-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' = pretty' . GRHSsExpr GRHSExprNormal--instance Pretty GRHSsExpr where-  pretty' (GRHSsExpr {grhssExpr = GHC.GRHSs {..}, ..}) = do-    mapM_ (pretty . fmap (GRHSExpr grhssExprType)) grhssGRHSs-    case (grhssLocalBinds, grhssExprType) of-      (GHC.HsValBinds {}, GRHSExprCase) ->-        indentedBlock $ do-          newline-          string "where " |=> pretty grhssLocalBinds-      (GHC.HsValBinds epa lr, _) ->-        indentedWithSpace 2-          $ newlinePrefixed-              [ string "where"-              , printCommentsAnd (GHC.L epa lr) (indentedWithSpace 2 . pretty)-              ]-      _ -> return ()--instance Pretty-           (GHC.GRHSs-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsCmd GHC.GhcPs))) where-  pretty' GHC.GRHSs {..} = do-    mapM_ (pretty . fmap GRHSProc) grhssGRHSs-    case grhssLocalBinds of-      (GHC.HsValBinds epa lr) ->-        indentedWithSpace 2-          $ newlinePrefixed-              [ string "where"-              , printCommentsAnd (GHC.L epa lr) (indentedWithSpace 2 . pretty)-              ]-      _ -> return ()-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-instance Pretty-           (GHC.HsMatchContext (GHC.GenLocated GHC.SrcSpanAnnN GHC.RdrName)) where-  pretty' = prettyHsMatchContext--prettyHsMatchContext ::-     GHC.HsMatchContext (GHC.GenLocated GHC.SrcSpanAnnN GHC.RdrName)-  -> Printer ()-prettyHsMatchContext GHC.FunRhs {..} =-  pretty mc_strictness >> pretty (fmap mkPrefixName mc_fun)-prettyHsMatchContext GHC.CaseAlt = return ()-prettyHsMatchContext GHC.IfAlt {} = notGeneratedByParser-prettyHsMatchContext GHC.ArrowMatchCtxt {} = notGeneratedByParser-prettyHsMatchContext GHC.PatBindRhs {} = notGeneratedByParser-prettyHsMatchContext GHC.PatBindGuards {} = notGeneratedByParser-prettyHsMatchContext GHC.RecUpd {} = notGeneratedByParser-prettyHsMatchContext GHC.StmtCtxt {} = notGeneratedByParser-prettyHsMatchContext GHC.ThPatSplice {} = notGeneratedByParser-prettyHsMatchContext GHC.ThPatQuote {} = notGeneratedByParser-prettyHsMatchContext GHC.PatSyn {} = notGeneratedByParser-#else-instance Pretty (GHC.HsMatchContext GHC.GhcPs) where-  pretty' = prettyHsMatchContext--prettyHsMatchContext :: GHC.HsMatchContext GHC.GhcPs -> Printer ()-prettyHsMatchContext GHC.FunRhs {..} =-  pretty mc_strictness >> pretty (fmap mkPrefixName mc_fun)-prettyHsMatchContext GHC.LambdaExpr = return ()-prettyHsMatchContext GHC.CaseAlt = return ()-prettyHsMatchContext GHC.IfAlt {} = notGeneratedByParser-prettyHsMatchContext GHC.ArrowMatchCtxt {} = notGeneratedByParser-prettyHsMatchContext GHC.PatBindRhs {} = notGeneratedByParser-prettyHsMatchContext GHC.PatBindGuards {} = notGeneratedByParser-prettyHsMatchContext GHC.RecUpd {} = notGeneratedByParser-prettyHsMatchContext GHC.StmtCtxt {} = notGeneratedByParser-prettyHsMatchContext GHC.ThPatSplice {} = notGeneratedByParser-prettyHsMatchContext GHC.ThPatQuote {} = notGeneratedByParser-prettyHsMatchContext GHC.PatSyn {} = notGeneratedByParser-#if MIN_VERSION_ghc_lib_parser(9, 4, 1)-prettyHsMatchContext GHC.LamCaseAlt {} = notUsedInParsedStage-#endif-#endif-instance Pretty (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where-  pretty' (GHC.ParStmtBlock _ xs _ _) = hvCommaSep $ fmap pretty xs--instance Pretty ParStmtBlockInsideVerticalList where-  pretty' (ParStmtBlockInsideVerticalList (GHC.ParStmtBlock _ xs _ _)) =-    vCommaSep $ fmap pretty xs--instance Pretty-           (GHC.GRHS-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' = pretty' . GRHSExpr GRHSExprNormal--instance Pretty GRHSExpr where-  pretty' (GRHSExpr {grhsExpr = (GHC.GRHS _ [] body), ..}) = do-    space-    rhsSeparator grhsExprType-    case GHC.unLoc body of-      GHC.HsDo _ (GHC.DoExpr m) stmts ->-        printCommentsAnd body (const (doExpr (QualifiedDo m Do) stmts))-      GHC.HsDo _ (GHC.MDoExpr m) stmts ->-        printCommentsAnd body (const (doExpr (QualifiedDo m Mdo) stmts))-      GHC.OpApp _ (GHC.L _ (GHC.HsDo _ GHC.DoExpr {} _)) _ _ ->-        space >> pretty body-      GHC.OpApp _ (GHC.L _ (GHC.HsDo _ GHC.MDoExpr {} _)) _ _ ->-        space >> pretty body-      _ ->-        let hor = space >> pretty body-            ver = newline >> indentedBlock (pretty body)-         in hor <-|> ver-    where-      doExpr qDo stmts = do-        space-        pretty qDo-        newline-        indentedBlock $ printCommentsAnd stmts (lined . fmap pretty)-  pretty' (GRHSExpr {grhsExpr = (GHC.GRHS _ guards body), ..}) = do-    unless (grhsExprType == GRHSExprMultiWayIf) newline-    (if grhsExprType == GRHSExprMultiWayIf-       then id-       else indentedBlock) $ do-      string "| " |=> vCommaSep (fmap pretty guards)-      space-      rhsSeparator grhsExprType-      printCommentsAnd body $ \case-        GHC.HsDo _ (GHC.DoExpr m) stmts -> doExpr (QualifiedDo m Do) stmts-        GHC.HsDo _ (GHC.MDoExpr m) stmts -> doExpr (QualifiedDo m Mdo) stmts-        x ->-          let hor = space >> pretty x-              ver = newline >> indentedBlock (pretty x)-           in hor <-|> ver-    where-      doExpr qDo stmts = do-        space-        pretty qDo-        newline-        indentedBlock (printCommentsAnd stmts (lined . fmap pretty))--instance Pretty GRHSProc where-  pretty' (GRHSProc (GHC.GRHS _ guards body)) =-    if null guards-      then bodyPrinter-      else do-        newline-        indentedBlock $ do-          string "| " |=> vCommaSep (fmap pretty guards)-          space-          bodyPrinter-    where-      bodyPrinter = do-        string "->"-        printCommentsAnd body $ \case-          GHC.HsCmdDo _ stmts ->-            let hor = space >> printCommentsAnd stmts (lined . fmap pretty)-                ver = do-                  newline-                  indentedBlock $ printCommentsAnd stmts (lined . fmap pretty)-             in hor <-|> ver-          x ->-            let hor = space >> pretty x-                ver = newline >> indentedBlock (pretty x)-             in hor <-|> ver--instance Pretty GHC.EpaCommentTok where-  pretty' (GHC.EpaLineComment c) = string c-  pretty' (GHC.EpaBlockComment c) =-    case lines c of-      [] -> pure ()-      [x] -> string x-      (x:xs) -> do-        string x-        newline-        -- 'indentedWithFixedLevel 0' is used because an 'EpaBlockComment'-        -- contains indent spaces for all lines except the first one.-        indentedWithFixedLevel 0 $ lined $ fmap string xs-  pretty' _ = docNode--instance Pretty (GHC.Pat GHC.GhcPs) where-  pretty' = prettyPat--instance Pretty PatInsidePatDecl where-  pretty' (PatInsidePatDecl (GHC.ConPat {pat_args = (GHC.InfixCon l r), ..})) =-    spaced [pretty l, pretty $ fmap mkInfixName pat_con, pretty r]-  pretty' (PatInsidePatDecl x) = pretty x--prettyPat :: GHC.Pat GHC.GhcPs -> Printer ()-prettyPat GHC.WildPat {} = string "_"-prettyPat (GHC.VarPat _ x) = pretty $ fmap mkPrefixName x-prettyPat (GHC.LazyPat _ x) = string "~" >> pretty x-#if MIN_VERSION_ghc_lib_parser(9, 6, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyPat (GHC.AsPat _ a _ b) =-  pretty (fmap mkPrefixName a) >> string "@" >> pretty b-#else-prettyPat (GHC.AsPat _ a b) =-  pretty (fmap mkPrefixName a) >> string "@" >> pretty b-#endif-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyPat (GHC.ParPat _ _ inner _) = parens $ pretty inner-#else-prettyPat (GHC.ParPat _ inner) = parens $ pretty inner-#endif-prettyPat (GHC.BangPat _ x) = string "!" >> pretty x-prettyPat (GHC.ListPat _ xs) = hList $ fmap pretty xs-prettyPat (GHC.TuplePat _ pats GHC.Boxed) = hTuple $ fmap pretty pats-prettyPat (GHC.TuplePat _ pats GHC.Unboxed) = hUnboxedTuple $ fmap pretty pats-prettyPat (GHC.SumPat _ x position numElem) = do-  string "(#"-  forM_ [1 .. numElem] $ \idx -> do-    if idx == position-      then string " " >> pretty x >> string " "-      else string " "-    when (idx < numElem) $ string "|"-  string "#)"-prettyPat GHC.ConPat {..} =-  case pat_args of-    GHC.PrefixCon _ as -> do-      pretty $ fmap mkPrefixName pat_con-      spacePrefixed $ fmap pretty as-    GHC.RecCon rec ->-      (pretty (fmap mkPrefixName pat_con) >> space) |=> pretty (RecConPat rec)-    GHC.InfixCon a b -> do-      pretty a-      unlessSpecialOp (GHC.unLoc pat_con) space-      pretty $ fmap mkInfixName pat_con-      unlessSpecialOp (GHC.unLoc pat_con) space-      pretty b-prettyPat (GHC.ViewPat _ l r) = spaced [pretty l, string "->", pretty r]-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 (fmap mkPrefixName n) >> string "+" >> pretty k-prettyPat (GHC.SigPat _ l r) = spaced [pretty l, string "::", pretty r]--instance Pretty RecConPat where-  pretty' (RecConPat GHC.HsRecFields {..}) =-    case fieldPrinters of-      [] -> string "{}"-      [x] -> braces x-      xs -> hvFields xs-    where-      fieldPrinters =-        fmap (pretty . fmap RecConField) rec_flds-          ++ maybeToList (fmap (const (string "..")) rec_dotdot)--instance Pretty SBF.SigBindFamily where-  pretty' (SBF.Sig x) = pretty $ mkSignature x-  pretty' (SBF.Bind x) = pretty $ mkBind x-  pretty' (SBF.TypeFamily x)-    | Just fam <- mkTypeFamily x = pretty fam-    | otherwise = error "Unreachable"-  pretty' (SBF.TyFamInst x) = pretty x-  pretty' (SBF.DataFamInst x) = pretty $ DataFamInstDeclInsideClassInst x--instance Pretty GHC.EpaComment where-  pretty' GHC.EpaComment {..} = pretty ac_tok--instance Pretty (GHC.HsLocalBindsLR GHC.GhcPs GHC.GhcPs) where-  pretty' (GHC.HsValBinds _ lr) = pretty lr-  pretty' (GHC.HsIPBinds _ x) = pretty x-  pretty' GHC.EmptyLocalBinds {} =-    error-      "This branch indicates that the bind is empty, but since calling this code means that let or where has already been output, it cannot be handled here. It should be handled higher up in the AST."--instance Pretty (GHC.HsValBindsLR GHC.GhcPs GHC.GhcPs) where-  pretty' (GHC.ValBinds _ methods sigs) = lined $ fmap pretty sigsAndMethods-    where-      sigsAndMethods =-        SBF.mkSortedLSigBindFamilyList sigs (GHC.bagToList methods) [] [] []-  pretty' GHC.XValBindsLR {} = notUsedInParsedStage--instance Pretty (GHC.HsTupArg GHC.GhcPs) where-  pretty' (GHC.Present _ e) = pretty e-  pretty' GHC.Missing {} = pure () -- This appears in a tuple section.-#if MIN_VERSION_ghc_lib_parser(9,4,1)-instance Pretty RecConField where-  pretty' (RecConField GHC.HsFieldBind {..}) = do-    pretty hfbLHS-    unless hfbPun $ do-      string " = "-      pretty hfbRHS-#else--- | For pattern matching against a record.-instance Pretty-           (GHC.HsRecField'-              (GHC.FieldOcc GHC.GhcPs)-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.Pat GHC.GhcPs))) where-  pretty' GHC.HsRecField {..} =-    (pretty hsRecFieldLbl >> string " = ") |=> pretty hsRecFieldArg---- | For record updates.-instance Pretty-           (GHC.HsRecField'-              (GHC.FieldOcc GHC.GhcPs)-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' GHC.HsRecField {..} = do-    pretty hsRecFieldLbl-    unless hsRecPun $ do-      string " ="-      horizontal <-|> vertical-    where-      horizontal = space >> pretty hsRecFieldArg-      vertical = newline >> indentedBlock (pretty hsRecFieldArg)-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)--- | For pattern matchings against records.-instance Pretty-           (GHC.HsFieldBind-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.FieldOcc GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.Pat GHC.GhcPs))) where-  pretty' GHC.HsFieldBind {..} =-    (pretty hfbLHS >> string " = ") |=> pretty hfbRHS---- | For record updates.-instance Pretty-           (GHC.HsFieldBind-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.FieldOcc GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' GHC.HsFieldBind {..} = do-    pretty hfbLHS-    unless hfbPun $ do-      string " ="-      horizontal <-|> vertical-    where-      horizontal = space >> pretty hfbRHS-      vertical = newline >> indentedBlock (pretty hfbRHS)-#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)--- | For pattern matchings against records.-instance Pretty-           (GHC.HsFieldBind-              (GHC.GenLocated (GHC.SrcAnn GHC.NoEpAnns) (GHC.FieldOcc GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.Pat GHC.GhcPs))) where-  pretty' GHC.HsFieldBind {..} =-    (pretty hfbLHS >> string " = ") |=> pretty hfbRHS---- | For record updates.-instance Pretty-           (GHC.HsFieldBind-              (GHC.GenLocated (GHC.SrcAnn GHC.NoEpAnns) (GHC.FieldOcc GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where-  pretty' GHC.HsFieldBind {..} = do-    pretty hfbLHS-    unless hfbPun $ do-      string " ="-      horizontal <-|> vertical-    where-      horizontal = space >> pretty hfbRHS-      vertical = newline >> indentedBlock (pretty hfbRHS)-#else-instance Pretty RecConField where-  pretty' (RecConField GHC.HsRecField {..}) = do-    pretty hsRecFieldLbl-    unless hsRecPun $ do-      string " = "-      pretty hsRecFieldArg-#endif-#if MIN_VERSION_ghc_lib_parser(9,4,1)-instance Pretty (GHC.FieldOcc GHC.GhcPs) where-  pretty' GHC.FieldOcc {..} = pretty $ fmap mkPrefixName foLabel-#else-instance Pretty (GHC.FieldOcc GHC.GhcPs) where-  pretty' GHC.FieldOcc {..} = pretty $ fmap mkPrefixName rdrNameFieldOcc-#endif-instance Pretty a => Pretty (GHC.HsScaled GHC.GhcPs a) where-  pretty' (GHC.HsScaled _ x) = pretty x--instance Pretty InfixExpr where-  pretty' (InfixExpr (GHC.L _ (GHC.HsVar _ bind))) =-    pretty $ fmap mkInfixName bind-  pretty' (InfixExpr x) = pretty' x-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-instance Pretty InfixApp where-  pretty' InfixApp {..} = horizontal <-|> vertical-    where-      horizontal = spaced [pretty lhs, pretty (InfixExpr op), pretty rhs]-      vertical =-        case findFixity op of-          GHC.Fixity _ _ GHC.InfixL -> leftAssoc-          GHC.Fixity _ _ GHC.InfixR -> rightAssoc-          GHC.Fixity _ _ GHC.InfixN -> noAssoc-      leftAssoc = prettyOps allOperantsAndOperatorsLeftAssoc-      rightAssoc = prettyOps allOperantsAndOperatorsRightAssoc-      noAssoc-        | GHC.L _ (GHC.OpApp _ _ o _) <- lhs-        , isSameAssoc o = leftAssoc-        | otherwise = rightAssoc-      prettyOps [l, o, GHC.L _ (GHC.HsDo _ (GHC.DoExpr m) xs)] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty $ QualifiedDo m Do]-        newline-        indentedBlock $ printCommentsAnd xs (lined . fmap pretty)-      prettyOps [l, o, GHC.L _ (GHC.HsDo _ (GHC.MDoExpr m) xs)] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty $ QualifiedDo m Mdo]-        newline-        indentedBlock $ printCommentsAnd xs (lined . fmap pretty)-      prettyOps [l, o, r@(GHC.L _ GHC.HsLam {})] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty r]-      prettyOps (l:xs) = do-        pretty l-        newline-        indentedBlock $ f xs-        where-          f (o:r:rems) = do-            (pretty (InfixExpr o) >> space) |=> pretty r-            unless (null rems) $ do-              newline-              f rems-          f _ =-            error-              "The number of the sum of operants and operators should be odd."-      prettyOps _ = error "Too short list."-      findFixity o =-        fromMaybe GHC.defaultFixity $ lookup (GHC.varToStr o) fixities-      allOperantsAndOperatorsLeftAssoc = reverse $ rhs : op : collect lhs-        where-          collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]-          collect (GHC.L _ (GHC.OpApp _ l o r))-            | isSameAssoc o = r : o : collect l-          collect x = [x]-      allOperantsAndOperatorsRightAssoc = lhs : op : collect rhs-        where-          collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]-          collect (GHC.L _ (GHC.OpApp _ l o r))-            | isSameAssoc o = l : o : collect r-          collect x = [x]-      isSameAssoc (findFixity -> GHC.Fixity _ lv d) = lv == level && d == dir-      GHC.Fixity _ level dir = findFixity op-#else-instance Pretty InfixApp where-  pretty' InfixApp {..} = horizontal <-|> vertical-    where-      horizontal = spaced [pretty lhs, pretty (InfixExpr op), pretty rhs]-      vertical =-        case findFixity op of-          GHC.Fixity _ _ GHC.InfixL -> leftAssoc-          GHC.Fixity _ _ GHC.InfixR -> rightAssoc-          GHC.Fixity _ _ GHC.InfixN -> noAssoc-      leftAssoc = prettyOps allOperantsAndOperatorsLeftAssoc-      rightAssoc = prettyOps allOperantsAndOperatorsRightAssoc-      noAssoc-        | GHC.L _ (GHC.OpApp _ _ o _) <- lhs-        , isSameAssoc o = leftAssoc-        | otherwise = rightAssoc-      prettyOps [l, o, GHC.L _ (GHC.HsDo _ (GHC.DoExpr m) xs)] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty $ QualifiedDo m Do]-        newline-        indentedBlock $ printCommentsAnd xs (lined . fmap pretty)-      prettyOps [l, o, GHC.L _ (GHC.HsDo _ (GHC.MDoExpr m) xs)] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty $ QualifiedDo m Mdo]-        newline-        indentedBlock $ printCommentsAnd xs (lined . fmap pretty)-      prettyOps [l, o, r@(GHC.L _ GHC.HsLam {})] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty r]-      prettyOps [l, o, r@(GHC.L _ GHC.HsLamCase {})] = do-        spaced [pretty l, pretty $ InfixExpr o, pretty r]-      prettyOps (l:xs) = do-        pretty l-        newline-        indentedBlock $ f xs-        where-          f (o:r:rems) = do-            (pretty (InfixExpr o) >> space) |=> pretty r-            unless (null rems) $ do-              newline-              f rems-          f _ =-            error-              "The number of the sum of operants and operators should be odd."-      prettyOps _ = error "Too short list."-      findFixity o =-        fromMaybe GHC.defaultFixity $ lookup (GHC.varToStr o) fixities-      allOperantsAndOperatorsLeftAssoc = reverse $ rhs : op : collect lhs-        where-          collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]-          collect (GHC.L _ (GHC.OpApp _ l o r))-            | isSameAssoc o = r : o : collect l-          collect x = [x]-      allOperantsAndOperatorsRightAssoc = lhs : op : collect rhs-        where-          collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]-          collect (GHC.L _ (GHC.OpApp _ l o r))-            | isSameAssoc o = l : o : collect r-          collect x = [x]-      isSameAssoc (findFixity -> GHC.Fixity _ lv d) = lv == level && d == dir-      GHC.Fixity _ level dir = findFixity op-#endif-instance Pretty (GHC.FieldLabelStrings GHC.GhcPs) where-  pretty' (GHC.FieldLabelStrings xs) = hDotSep $ fmap pretty xs--instance Pretty (GHC.AmbiguousFieldOcc GHC.GhcPs) where-  pretty' (GHC.Unambiguous _ name) = pretty $ fmap mkPrefixName name-  pretty' (GHC.Ambiguous _ name) = pretty $ fmap mkPrefixName name--instance Pretty (GHC.DerivClauseTys GHC.GhcPs) where-  pretty' (GHC.DctSingle _ ty) = parens $ pretty ty-  pretty' (GHC.DctMulti _ ts) = hvTuple $ fmap pretty ts-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-instance Pretty GHC.StringLiteral where-  pretty' GHC.StringLiteral {sl_st = GHC.SourceText s} = string $ GHC.unpackFS s-  pretty' GHC.StringLiteral {..} = string $ GHC.unpackFS sl_fs-#else-instance Pretty GHC.StringLiteral where-  pretty' = output-#endif-instance Pretty (GHC.ArithSeqInfo GHC.GhcPs) where-  pretty' (GHC.From from) = brackets $ spaced [pretty from, string ".."]-  pretty' (GHC.FromThen from next) =-    brackets $ spaced [pretty from >> comma >> pretty next, string ".."]-  pretty' (GHC.FromTo from to) =-    brackets $ spaced [pretty from, string "..", pretty to]-  pretty' (GHC.FromThenTo from next to) =-    brackets-      $ spaced [pretty from >> comma >> pretty next, string "..", pretty to]--instance Pretty (GHC.HsForAllTelescope GHC.GhcPs) where-  pretty' GHC.HsForAllVis {..} = do-    string "forall "-    spaced $ fmap (pretty . fmap mkTypeVariable . fromGenLocated) hsf_vis_bndrs-    dot-  pretty' GHC.HsForAllInvis {..} = do-    string "forall "-    spaced-      $ fmap (pretty . fmap mkTypeVariable . fromGenLocated) hsf_invis_bndrs-    dot--instance Pretty Context where-  pretty' (Context xs) =-    pretty (HorizontalContext xs) <-|> pretty (VerticalContext xs)-#if MIN_VERSION_ghc_lib_parser(9,4,1)-instance Pretty HorizontalContext where-  pretty' (HorizontalContext xs) =-    constraintsParens $ printCommentsAnd xs (hCommaSep . fmap pretty)-    where-      constraintsParens =-        case xs of-          (GHC.L _ []) -> parens-          (GHC.L _ [_]) -> id-          _ -> parens--instance Pretty VerticalContext where-  pretty' (VerticalContext full@(GHC.L _ [])) =-    printCommentsAnd full (const $ string "()")-  pretty' (VerticalContext full@(GHC.L _ [x])) =-    printCommentsAnd full (const $ pretty x)-  pretty' (VerticalContext xs) = printCommentsAnd xs (vTuple . fmap pretty)-#else-instance Pretty HorizontalContext where-  pretty' (HorizontalContext xs) =-    constraintsParens $ mapM_ (`printCommentsAnd` (hCommaSep . fmap pretty)) xs-    where-      constraintsParens =-        case xs of-          Nothing -> id-          Just (GHC.L _ []) -> parens-          Just (GHC.L _ [_]) -> id-          Just _ -> parens--instance Pretty VerticalContext where-  pretty' (VerticalContext Nothing) = pure ()-  pretty' (VerticalContext (Just (GHC.L _ []))) = string "()"-  pretty' (VerticalContext (Just full@(GHC.L _ [x]))) =-    printCommentsAnd full (const $ pretty x)-  pretty' (VerticalContext (Just xs)) =-    printCommentsAnd xs (vTuple . fmap pretty)-#endif--- Wrap a value of this type with 'ModulenameWithPrefix' to print it with--- the "module " prefix.-instance Pretty GHC.ModuleName where-  pretty' = output--instance Pretty ModuleNameWithPrefix where-  pretty' (ModuleNameWithPrefix name) = spaced [string "module", pretty name]-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-instance Pretty (GHC.IE GHC.GhcPs) where-  pretty' (GHC.IEVar _ name _) = pretty name-  pretty' (GHC.IEThingAbs _ name _) = pretty name-  pretty' (GHC.IEThingAll _ name _) = do-    pretty name-    string "(..)"-  -- FIXME: Currently, pretty-printing a 'IEThingWith' uses-  -- 'ghc-lib-parser''s pretty-printer. However, we should avoid it because-  -- 'ghc-lib-parser' may suddenly change how it prints, resulting in-  -- unexpected test failures.-  pretty' x@GHC.IEThingWith {} =-    case lines $ showOutputable x of-      [] -> pure ()-      [x'] -> string x'-      x':xs' -> do-        string x'-        indentedWithFixedLevel 0 $ newlinePrefixed $ string <$> xs'-  pretty' (GHC.IEModuleContents _ name) =-    pretty $ fmap ModuleNameWithPrefix name-  pretty' GHC.IEGroup {} = docNode-  pretty' GHC.IEDoc {} = docNode-  pretty' GHC.IEDocNamed {} = docNode-#else-instance Pretty (GHC.IE GHC.GhcPs) where-  pretty' (GHC.IEVar _ name) = pretty name-  pretty' (GHC.IEThingAbs _ name) = pretty name-  pretty' (GHC.IEThingAll _ name) = do-    pretty name-    string "(..)"-  -- FIXME: Currently, pretty-printing a 'IEThingWith' uses-  -- 'ghc-lib-parser''s pretty-printer. However, we should avoid it because-  -- 'ghc-lib-parser' may suddenly change how it prints, resulting in-  -- unexpected test failures.-  pretty' x@GHC.IEThingWith {} =-    case lines $ showOutputable x of-      [] -> pure ()-      [x'] -> string x'-      x':xs' -> do-        string x'-        indentedWithFixedLevel 0 $ newlinePrefixed $ string <$> xs'-  pretty' (GHC.IEModuleContents _ name) =-    pretty $ fmap ModuleNameWithPrefix name-  pretty' GHC.IEGroup {} = docNode-  pretty' GHC.IEDoc {} = docNode-  pretty' GHC.IEDocNamed {} = docNode-#endif-instance Pretty-           (GHC.FamEqn-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where-  pretty' GHC.FamEqn {..} = do-    pretty $ fmap mkPrefixName feqn_tycon-    spacePrefixed $ fmap pretty feqn_pats-    string " = "-    pretty feqn_rhs---- | Pretty-print a data instance.-instance Pretty (GHC.FamEqn GHC.GhcPs (GHC.HsDataDefn GHC.GhcPs)) where-  pretty' = pretty' . FamEqnTopLevel-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)-instance Pretty FamEqn' where-  pretty' FamEqn' {famEqn = GHC.FamEqn {..}, ..} = do-    spaced-      $ string prefix-          : pretty (fmap mkPrefixName feqn_tycon)-          : fmap pretty feqn_pats-    pretty (mkDataBody feqn_rhs)-    where-      prefix =-        case (famEqnFor, GHC.dd_cons feqn_rhs) of-          (DataFamInstDeclForTopLevel, GHC.NewTypeCon {}) -> "newtype instance"-          (DataFamInstDeclForTopLevel, GHC.DataTypeCons {}) -> "data instance"-          (DataFamInstDeclForInsideClassInst, GHC.NewTypeCon {}) -> "newtype"-          (DataFamInstDeclForInsideClassInst, GHC.DataTypeCons {}) -> "data"-#else-instance Pretty FamEqn' where-  pretty' FamEqn' {famEqn = GHC.FamEqn {..}, ..} = do-    spaced-      $ string prefix-          : pretty (fmap mkPrefixName feqn_tycon)-          : fmap pretty feqn_pats-    pretty (mkDataBody feqn_rhs)-    where-      prefix =-        case (famEqnFor, GHC.dd_ND feqn_rhs) of-          (DataFamInstDeclForTopLevel, GHC.NewType) -> "newtype instance"-          (DataFamInstDeclForTopLevel, GHC.DataType) -> "data instance"-          (DataFamInstDeclForInsideClassInst, GHC.NewType) -> "newtype"-          (DataFamInstDeclForInsideClassInst, GHC.DataType) -> "data"-#endif--- | HsArg (LHsType GhcPs) (LHsType GhcPs)-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-instance Pretty-           (GHC.HsArg-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where-  pretty' (GHC.HsValArg _ x) = pretty x-  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty x-  pretty' GHC.HsArgPar {} = notUsedInParsedStage-#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)-instance Pretty-           (GHC.HsArg-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where-  pretty' (GHC.HsValArg x) = pretty x-  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty x-  pretty' GHC.HsArgPar {} = notUsedInParsedStage-#else-instance Pretty-           (GHC.HsArg-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where-  pretty' (GHC.HsValArg x) = pretty x-  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty x-  pretty' GHC.HsArgPar {} = notUsedInParsedStage-#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--#if MIN_VERSION_ghc_lib_parser(9,6,1)--- | 'Pretty' for 'LIEWrappedName (IdP GhcPs)'-instance Pretty (GHC.IEWrappedName GHC.GhcPs) where-  pretty' (GHC.IEName _ name) = pretty $ fmap mkPrefixName name-  pretty' (GHC.IEPattern _ name) =-    spaced [string "pattern", pretty $ fmap mkPrefixName name]-  pretty' (GHC.IEType _ name) =-    string "type " >> pretty (fmap mkPrefixName name)-#else--- | 'Pretty' for 'LIEWrappedName (IdP GhcPs)'-instance Pretty (GHC.IEWrappedName GHC.RdrName) where-  pretty' (GHC.IEName name) = pretty $ fmap mkPrefixName name-  pretty' (GHC.IEPattern _ name) =-    spaced [string "pattern", pretty $ fmap mkPrefixName name]-  pretty' (GHC.IEType _ name) =-    string "type " >> pretty (fmap mkPrefixName name)-#endif-#if MIN_VERSION_ghc_lib_parser(9,6,1)-instance Pretty (GHC.DotFieldOcc GHC.GhcPs) where-  pretty' GHC.DotFieldOcc {..} = printCommentsAnd dfoLabel pretty-#elif MIN_VERSION_ghc_lib_parser(9,4,1)-instance Pretty (GHC.DotFieldOcc GHC.GhcPs) where-  pretty' GHC.DotFieldOcc {..} =-    printCommentsAnd dfoLabel (string . GHC.unpackFS)-#else-instance Pretty (GHC.HsFieldLabel GHC.GhcPs) where-  pretty' GHC.HsFieldLabel {..} =-    printCommentsAnd hflLabel (string . GHC.unpackFS)-#endif-instance Pretty GHC.OccName where-  pretty' = output---- | 'Pretty' for 'LHsWcType'-instance Pretty-           (GHC.HsWildCardBndrs-              GHC.GhcPs-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where-  pretty' GHC.HsWC {..} = pretty hswc_body--instance Pretty (GHC.TyFamInstDecl GHC.GhcPs) where-  pretty' GHC.TyFamInstDecl {..} = string "type " >> pretty tfid_eqn--instance Pretty TopLevelTyFamInstDecl where-  pretty' (TopLevelTyFamInstDecl GHC.TyFamInstDecl {..}) =-    string "type instance " >> pretty tfid_eqn--instance Pretty (GHC.DataFamInstDecl GHC.GhcPs) where-  pretty' = pretty' . DataFamInstDeclTopLevel--instance Pretty DataFamInstDecl' where-  pretty' DataFamInstDecl' {dataFamInstDecl = GHC.DataFamInstDecl {..}, ..} =-    pretty $ FamEqn' dataFamInstDeclFor dfid_eqn---- | 'Pretty' for 'HsPatSynDetails'.-instance Pretty-           (GHC.HsConDetails-              Void-              (GHC.GenLocated GHC.SrcSpanAnnN GHC.RdrName)-              [GHC.RecordPatSynField GHC.GhcPs]) where-  pretty' (GHC.PrefixCon _ xs) = spaced $ fmap (pretty . fmap mkPrefixName) xs-  pretty' (GHC.RecCon rec) = hFields $ fmap pretty rec-  pretty' GHC.InfixCon {} =-    error-      "Cannot handle here because `InfixCon` does not have the information of the constructor."--instance Pretty (GHC.HsPatSynDir GHC.GhcPs) where-  pretty' GHC.Unidirectional = string "<-"-  pretty' GHC.ImplicitBidirectional = string "="-  pretty' GHC.ExplicitBidirectional {} = string "<-"--instance Pretty (GHC.HsOverLit GHC.GhcPs) where-  pretty' GHC.OverLit {..} = pretty ol_val--instance Pretty GHC.OverLitVal where-  pretty' (GHC.HsIntegral x) = pretty x-  pretty' (GHC.HsFractional x) = pretty x-  pretty' (GHC.HsIsString _ x) = string $ GHC.unpackFS x-#if MIN_VERSION_ghc_lib_parser(9,8,1)-instance Pretty GHC.IntegralLit where-  pretty' GHC.IL {il_text = GHC.SourceText s} = output s-  pretty' GHC.IL {..} = string $ show il_value-#else-instance Pretty GHC.IntegralLit where-  pretty' GHC.IL {il_text = GHC.SourceText s} = string s-  pretty' GHC.IL {..} = string $ show il_value-#endif-instance Pretty GHC.FractionalLit where-  pretty' = output--instance Pretty (GHC.HsLit GHC.GhcPs) where-  pretty' x@(GHC.HsChar _ _) = output x-  pretty' x@GHC.HsCharPrim {} = output x-  pretty' GHC.HsInt {} = notUsedInParsedStage-  pretty' (GHC.HsIntPrim _ x) = string $ show x ++ "#"-  pretty' GHC.HsWordPrim {} = notUsedInParsedStage-  pretty' GHC.HsInt64Prim {} = notUsedInParsedStage-  pretty' GHC.HsWord64Prim {} = notUsedInParsedStage-  pretty' GHC.HsInteger {} = notUsedInParsedStage-  pretty' GHC.HsRat {} = notUsedInParsedStage-  pretty' (GHC.HsFloatPrim _ x) = pretty x >> string "#"-  pretty' GHC.HsDoublePrim {} = notUsedInParsedStage-  pretty' x =-    case x of-      GHC.HsString {} -> prettyString-      GHC.HsStringPrim {} -> prettyString-    where-      prettyString =-        case lines $ showOutputable x of-          [] -> pure ()-          [l] -> string l-          (s:ss) ->-            string "" |=> do-              string s-              newline-              indentedWithSpace (-1)-                $ lined-                $ fmap (string . dropWhile (/= '\\')) ss-#if MIN_VERSION_ghc_lib_parser(9,6,1)-instance Pretty (GHC.HsPragE GHC.GhcPs) where-  pretty' (GHC.HsPragSCC _ x) =-    spaced [string "{-# SCC", pretty x, string "#-}"]-#else-instance Pretty (GHC.HsPragE GHC.GhcPs) where-  pretty' (GHC.HsPragSCC _ _ x) =-    spaced [string "{-# SCC", pretty x, string "#-}"]-#endif-instance Pretty GHC.HsIPName where-  pretty' (GHC.HsIPName x) = string $ GHC.unpackFS x-#if MIN_VERSION_ghc_lib_parser(9,6,1)-instance Pretty (GHC.HsTyLit GHC.GhcPs) where-  pretty' (GHC.HsNumTy _ x) = string $ show x-  pretty' (GHC.HsStrTy _ x) = string $ ushow x-  pretty' (GHC.HsCharTy _ x) = string $ show x-#else-instance Pretty GHC.HsTyLit where-  pretty' (GHC.HsNumTy _ x) = string $ show x-  pretty' (GHC.HsStrTy _ x) = string $ ushow x-  pretty' (GHC.HsCharTy _ x) = string $ show x-#endif-instance Pretty (GHC.HsPatSigType GHC.GhcPs) where-  pretty' GHC.HsPS {..} = pretty hsps_body--instance Pretty (GHC.HsIPBinds GHC.GhcPs) where-  pretty' (GHC.IPBinds _ xs) = lined $ fmap pretty xs--instance Pretty (GHC.IPBind GHC.GhcPs) where-  pretty' = prettyIPBind--prettyIPBind :: GHC.IPBind GHC.GhcPs -> Printer ()-#if MIN_VERSION_ghc_lib_parser(9,4,1)-prettyIPBind (GHC.IPBind _ l r) =-  spaced [string "?" >> pretty l, string "=", pretty r]-#else-prettyIPBind (GHC.IPBind _ (Right _) _) = notUsedInParsedStage-prettyIPBind (GHC.IPBind _ (Left l) r) =-  spaced [string "?" >> pretty l, string "=", pretty r]-#endif-instance Pretty (GHC.RecordPatSynField GHC.GhcPs) where-  pretty' GHC.RecordPatSynField {..} = pretty recordPatSynField--instance Pretty (GHC.HsCmdTop GHC.GhcPs) where-  pretty' (GHC.HsCmdTop _ cmd) = pretty cmd--instance Pretty (GHC.HsCmd GHC.GhcPs) where-  pretty' = prettyHsCmd--prettyHsCmd :: GHC.HsCmd GHC.GhcPs -> Printer ()-prettyHsCmd (GHC.HsCmdArrApp _ f arg GHC.HsHigherOrderApp True) =-  spaced [pretty f, string "-<<", pretty arg]-prettyHsCmd (GHC.HsCmdArrApp _ f arg GHC.HsHigherOrderApp False) =-  spaced [pretty arg, string ">>-", pretty f]-prettyHsCmd (GHC.HsCmdArrApp _ f arg GHC.HsFirstOrderApp True) =-  spaced [pretty f, string "-<", pretty arg]-prettyHsCmd (GHC.HsCmdArrApp _ f arg GHC.HsFirstOrderApp False) =-  spaced [pretty arg, string ">-", pretty f]-prettyHsCmd (GHC.HsCmdArrForm _ f _ _ args) =-  bananaBrackets $ spaced $ pretty f : fmap pretty args-prettyHsCmd (GHC.HsCmdApp _ f arg) = spaced [pretty f, pretty arg]-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsCmd (GHC.HsCmdLam _ GHC.LamSingle x) = pretty x-prettyHsCmd (GHC.HsCmdLam _ GHC.LamCase arms) = do-  string "\\case"-  newline-  indentedBlock $ pretty arms-prettyHsCmd (GHC.HsCmdLam _ GHC.LamCases arms) = do-  string "\\cases"-  newline-  indentedBlock $ pretty arms-#else-prettyHsCmd (GHC.HsCmdLam _ x) = pretty x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsCmd (GHC.HsCmdPar _ _ x _) = parens $ pretty x-#else-prettyHsCmd (GHC.HsCmdPar _ x) = parens $ pretty x-#endif-prettyHsCmd (GHC.HsCmdCase _ cond arms) = do-  spaced [string "case", pretty cond, string "of"]-  newline-  indentedBlock $ pretty arms-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)--- No `HsCmdLamCase` since 9.10.1-#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)-prettyHsCmd (GHC.HsCmdLamCase _ _ arms) = do-  string "\\case"-  newline-  indentedBlock $ pretty arms-#else-prettyHsCmd (GHC.HsCmdLamCase _ arms) = do-  string "\\case"-  newline-  indentedBlock $ pretty arms-#endif-prettyHsCmd (GHC.HsCmdIf _ _ cond t f) = do-  string "if "-  pretty cond-  newline-  indentedBlock $ lined [string "then " >> pretty t, string "else " >> pretty f]-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-prettyHsCmd (GHC.HsCmdLet _ _ binds _ expr) =-  lined [string "let " |=> pretty binds, string " in " |=> pretty expr]-#else-prettyHsCmd (GHC.HsCmdLet _ binds expr) =-  lined [string "let " |=> pretty binds, string " in " |=> pretty expr]-#endif-prettyHsCmd (GHC.HsCmdDo _ stmts) = do-  string "do"-  newline-  indentedBlock $ printCommentsAnd stmts (lined . fmap pretty)--instance Pretty ListComprehension where-  pretty' ListComprehension {..} = horizontal <-|> vertical-    where-      horizontal =-        brackets-          $ spaced-              [ pretty listCompLhs-              , string "|"-              , hCommaSep $ NE.toList $ NE.map pretty listCompRhs-              ]-      vertical = do-        string "[ "-        pretty $ fmap StmtLRInsideVerticalList listCompLhs-        newline-        forM_ (stmtsAndPrefixes listCompRhs) $ \(p, x) -> do-          string p |=> pretty (fmap StmtLRInsideVerticalList x)-          newline-        string "]"-      stmtsAndPrefixes (s :| ss) = ("| ", s) : fmap (", ", ) ss--instance Pretty DoExpression where-  pretty' DoExpression {..} = do-    pretty qualifiedDo-    newline-    indentedBlock $ lined $ fmap pretty doStmts--instance Pretty DoOrMdo where-  pretty' Do = string "do"-  pretty' Mdo = string "mdo"--instance Pretty QualifiedDo where-  pretty' (QualifiedDo (Just m) d) = do-    pretty m-    string "."-    pretty d-  pretty' (QualifiedDo Nothing d) = pretty d--instance Pretty LetIn where-  pretty' LetIn {..} =-    lined [string "let " |=> pretty letBinds, string " in " |=> pretty inExpr]--instance Pretty GHC.HsSrcBang where-  pretty' (GHC.HsSrcBang _ unpack strictness) = do-    pretty unpack-    unless (unpack == GHC.NoSrcUnpack) space-    pretty strictness--instance Pretty GHC.SrcUnpackedness where-  pretty' GHC.SrcUnpack = string "{-# UNPACK #-}"-  pretty' GHC.SrcNoUnpack = string "{-# NOUNPACK #-}"-  pretty' GHC.NoSrcUnpack = pure ()--instance Pretty GHC.SrcStrictness where-  pretty' GHC.SrcLazy = string "~"-  pretty' GHC.SrcStrict = string "!"-  pretty' GHC.NoSrcStrict = pure ()-#if MIN_VERSION_ghc_lib_parser(9,6,1)-instance Pretty GHC.FieldLabelString where-  pretty' = output-#endif--- | Marks an AST node as never appearing in an AST.------ Some AST node types are only defined in `ghc-lib-parser` and not--- generated by it.-notGeneratedByParser :: HasCallStack => a-notGeneratedByParser = error "`ghc-lib-parser` never generates this AST node."---- | Marks an AST node as related to Haddock comments.------ The parser parses haddock comments as normal ones, meaning AST nodes--- related to haddock never appear in an AST.-docNode :: HasCallStack => a-docNode =-  error-    "This AST node is related to Haddocks, but haddock comments are treated as normal ones, and this node should never appear in an AST."---- | Marks an AST node as never appearing in the AST.------ Some AST node types are only used in the renaming or type-checking phase.-notUsedInParsedStage :: HasCallStack => a-notUsedInParsedStage =-  error-    "This AST should never appears in an AST. It only appears in the renaming or type checked stages."-#if !MIN_VERSION_ghc_lib_parser(9,4,1)--- | Marks an AST node as it is used only for Haskell Program Coverage.-forHpc :: HasCallStack => a-forHpc = error "This AST type is for the use of Haskell Program Coverage."-#endif--#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-getAnc (GHC.EpaSpan (GHC.RealSrcSpan x _)) = x-getAnc _ = undefined-#else+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Pretty printing.+--+-- Some instances define top-level functions to handle CPP.+--+-- Some value constructors never appear in an AST. GHC has three stages for+-- using an AST: parsing, renaming, and type checking, and GHC uses these+-- constructors only in remaining and type checking.+module HIndent.Pretty+  ( Pretty(..)+  , pretty+  , printCommentsAnd+  ) where++import Control.Monad+import Control.Monad.RWS+import qualified GHC.Data.FastString as GHC+import qualified GHC.Hs as GHC+import GHC.Stack+import qualified GHC.Types.SourceText as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative (whenJust)+import HIndent.Ast.Comment (mkComment)+import HIndent.Ast.Declaration.Bind+import HIndent.Ast.Declaration.Data.Body+import HIndent.Ast.Declaration.Family.Data+import HIndent.Ast.Declaration.Family.Type+import HIndent.Ast.Declaration.Instance.Family.Type.Associated+  ( mkAssociatedType+  )+import HIndent.Ast.Declaration.Instance.Family.Type.Associated.Default+  ( mkAssociatedTypeDefault+  )+import HIndent.Ast.Declaration.Signature+import HIndent.Ast.Expression (mkExpression)+import HIndent.Ast.LocalBinds (mkLocalBinds)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Pattern+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import qualified HIndent.Pretty.SigBindFamily as SBF+import HIndent.Pretty.Types+import HIndent.Printer+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import qualified GHC.Core.DataCon as GHC+#else+import qualified GHC.Unit as GHC+#endif+-- | This function pretty-prints the given AST node with comments.+pretty :: Pretty a => a -> Printer ()+pretty p = do+  printCommentsBefore p+  pretty' p+  printCommentOnSameLine p+  printCommentsAfter p++-- | Prints comments included in the location information and then the+-- AST node body.+printCommentsAnd ::+     (CommentExtraction l)+  => GHC.GenLocated l e+  -> (e -> Printer ())+  -> Printer ()+printCommentsAnd (GHC.L l e) f = do+  printCommentsBefore l+  f e+  printCommentOnSameLine l+  printCommentsAfter l++-- | Prints comments that are before the given AST node.+printCommentsBefore :: CommentExtraction a => a -> Printer ()+printCommentsBefore p =+  forM_ (commentsBefore $ nodeComments p) $ \(GHC.L loc c) -> do+    let col = fromIntegral $ GHC.srcSpanStartCol (getAnc loc) - 1+    indentedWithFixedLevel col $ pretty c+    newline++-- | Prints comments that are on the same line as the given AST node.+printCommentOnSameLine :: CommentExtraction a => a -> Printer ()+printCommentOnSameLine (commentsOnSameLine . nodeComments -> (c:cs)) = do+  col <- gets psColumn+  if col == 0+    then indentedWithFixedLevel+           (fromIntegral $ GHC.srcSpanStartCol $ getAnc $ GHC.getLoc c)+           $ spaced+           $ fmap pretty+           $ c : cs+    else spacePrefixed $ fmap pretty $ c : cs+  eolCommentsArePrinted+printCommentOnSameLine _ = return ()++-- | Prints comments that are after the given AST node.+printCommentsAfter :: CommentExtraction a => a -> Printer ()+printCommentsAfter p =+  case commentsAfter $ nodeComments p of+    [] -> return ()+    xs -> do+      isThereCommentsOnSameLine <- gets psEolComment+      unless isThereCommentsOnSameLine newline+      forM_ xs $ \(GHC.L loc c) -> do+        let col = fromIntegral $ GHC.srcSpanStartCol (getAnc loc) - 1+        indentedWithFixedLevel col $ pretty c+        eolCommentsArePrinted++-- | Pretty print including comments.+--+-- 'FastString' does not implement this class because it may contain @\n@s+-- and each type that may contain a 'FastString' value needs their own+-- handlings.+class CommentExtraction a =>+      Pretty a+  where+  pretty' :: a -> Printer ()++-- Do nothing if there are no pragmas, module headers, imports, or+-- declarations. Otherwise, extra blank lines will be inserted if only+-- comments are present in the source code. See+-- https://github.com/mihaimaruseac/hindent/issues/586#issuecomment-1374992624.+instance (CommentExtraction l, Pretty e) => Pretty (GHC.GenLocated l e) where+  pretty' (GHC.L _ e) = pretty e++instance Pretty+           (GHC.StmtLR+              GHC.GhcPs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where+  pretty' = prettyStmtLRExpr++prettyStmtLRExpr ::+     GHC.StmtLR+       GHC.GhcPs+       GHC.GhcPs+       (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))+  -> Printer ()+prettyStmtLRExpr (GHC.LastStmt _ x _ _) =+  pretty $ mkExpression <$> fromGenLocated x+prettyStmtLRExpr (GHC.BindStmt _ pat body) = do+  pretty $ mkPattern <$> fromGenLocated pat+  string " <-"+  hor <-|> ver+  where+    hor = do+      space+      pretty $ mkExpression <$> fromGenLocated body+    ver = do+      newline+      indentedBlock $ pretty $ mkExpression <$> fromGenLocated body+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+prettyStmtLRExpr GHC.ApplicativeStmt {} = notGeneratedByParser+#endif+prettyStmtLRExpr (GHC.BodyStmt _ body _ _) =+  pretty $ mkExpression <$> fromGenLocated body+prettyStmtLRExpr (GHC.LetStmt _ l) =+  whenJust (mkLocalBinds l) $ \binds -> string "let " |=> pretty binds+prettyStmtLRExpr (GHC.ParStmt _ xs _ _) = hvBarSep $ fmap pretty xs+prettyStmtLRExpr GHC.TransStmt {..} =+  vCommaSep+    $ fmap pretty trS_stmts+        ++ [ string "then "+               >> pretty (mkExpression <$> fromGenLocated trS_using)+           ]+prettyStmtLRExpr GHC.RecStmt {..} =+  string "rec " |=> printCommentsAnd recS_stmts (lined . fmap pretty)++instance Pretty (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where+  pretty' (GHC.ParStmtBlock _ xs _ _) = hvCommaSep $ fmap pretty xs++instance Pretty SBF.SigBindFamily where+  pretty' (SBF.Sig x) = pretty $ mkSignature x+  pretty' (SBF.Bind x) = pretty $ mkBind x+  pretty' (SBF.Family x)+    | Just fam <- mkTypeFamily x = pretty fam+    | Just fam <- mkDataFamily x = pretty fam+    | otherwise = error "Unreachable"+  pretty' (SBF.TyFamInst x) = pretty $ mkAssociatedType x+  pretty' (SBF.TyFamDeflt x) = pretty $ mkAssociatedTypeDefault x+  pretty' (SBF.DataFamInst x) = pretty $ DataFamInstDeclInsideClassInst x++instance Pretty GHC.EpaComment where+  pretty' GHC.EpaComment {..} = pretty $ mkComment ac_tok++instance Pretty+           (GHC.HsScaled+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsScaled _ ty) = pretty $ fmap mkType ty+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+instance Pretty GHC.StringLiteral where+  pretty' GHC.StringLiteral {sl_st = GHC.SourceText s} = string $ GHC.unpackFS s+  pretty' GHC.StringLiteral {..} = string $ GHC.unpackFS sl_fs+#else+instance Pretty GHC.StringLiteral where+  pretty' = output+#endif+instance Pretty Context where+  pretty' (Context xs) =+    pretty (HorizontalContext xs) <-|> pretty (VerticalContext xs)+#if MIN_VERSION_ghc_lib_parser(9,4,1)+instance Pretty HorizontalContext where+  pretty' (HorizontalContext xs) =+    constraintsParens+      $ printCommentsAnd xs (hCommaSep . fmap (pretty . fmap mkType))+    where+      constraintsParens =+        case xs of+          (GHC.L _ []) -> parens+          (GHC.L _ [_]) -> id+          _ -> parens++instance Pretty VerticalContext where+  pretty' (VerticalContext full@(GHC.L _ [])) =+    printCommentsAnd full (const $ string "()")+  pretty' (VerticalContext full@(GHC.L _ [x])) =+    printCommentsAnd full (const $ pretty $ mkType <$> x)+  pretty' (VerticalContext xs) =+    printCommentsAnd xs (vTuple . fmap (pretty . fmap mkType))+#else+instance Pretty HorizontalContext where+  pretty' (HorizontalContext xs) =+    constraintsParens $ mapM_ (`printCommentsAnd` (hCommaSep . fmap pretty)) xs+    where+      constraintsParens =+        case xs of+          Nothing -> id+          Just (GHC.L _ []) -> parens+          Just (GHC.L _ [_]) -> id+          Just _ -> parens++instance Pretty VerticalContext where+  pretty' (VerticalContext Nothing) = pure ()+  pretty' (VerticalContext (Just (GHC.L _ []))) = string "()"+  pretty' (VerticalContext (Just full@(GHC.L _ [x]))) =+    printCommentsAnd full (const $ pretty x)+  pretty' (VerticalContext (Just xs)) =+    printCommentsAnd xs (vTuple . fmap pretty)+#endif+instance Pretty+           (GHC.FamEqn+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' GHC.FamEqn {..} = do+    pretty $ fmap mkPrefixName feqn_tycon+    spacePrefixed $ fmap pretty feqn_pats+    string " = "+    pretty $ mkType <$> feqn_rhs++-- | Pretty-print a data instance.+instance Pretty (GHC.FamEqn GHC.GhcPs (GHC.HsDataDefn GHC.GhcPs)) where+  pretty' = pretty' . FamEqnTopLevel+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+instance Pretty FamEqn' where+  pretty' FamEqn' {famEqn = GHC.FamEqn {..}, ..} = do+    spaced+      $ string prefix+          : pretty (fmap mkPrefixName feqn_tycon)+          : fmap pretty feqn_pats+    pretty (mkDataBody feqn_rhs)+    where+      prefix =+        case (famEqnFor, GHC.dd_cons feqn_rhs) of+          (DataFamInstDeclForTopLevel, GHC.NewTypeCon {}) -> "newtype instance"+          (DataFamInstDeclForTopLevel, GHC.DataTypeCons {}) -> "data instance"+          (DataFamInstDeclForInsideClassInst, GHC.NewTypeCon {}) -> "newtype"+          (DataFamInstDeclForInsideClassInst, GHC.DataTypeCons {}) -> "data"+#else+instance Pretty FamEqn' where+  pretty' FamEqn' {famEqn = GHC.FamEqn {..}, ..} = do+    spaced+      $ string prefix+          : pretty (fmap mkPrefixName feqn_tycon)+          : fmap pretty feqn_pats+    pretty (mkDataBody feqn_rhs)+    where+      prefix =+        case (famEqnFor, GHC.dd_ND feqn_rhs) of+          (DataFamInstDeclForTopLevel, GHC.NewType) -> "newtype instance"+          (DataFamInstDeclForTopLevel, GHC.DataType) -> "data instance"+          (DataFamInstDeclForInsideClassInst, GHC.NewType) -> "newtype"+          (DataFamInstDeclForInsideClassInst, GHC.DataType) -> "data"+#endif+-- | HsArg (LHsType GhcPs) (LHsType GhcPs)+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+instance Pretty+           (GHC.HsArg+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsValArg _ x) = pretty $ mkType <$> x+  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty (mkType <$> x)+  pretty' GHC.HsArgPar {} = notUsedInParsedStage+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+instance Pretty+           (GHC.HsArg+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsValArg x) = pretty $ mkType <$> x+  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty (mkType <$> x)+  pretty' GHC.HsArgPar {} = notUsedInParsedStage+#else+instance Pretty+           (GHC.HsArg+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsValArg x) = pretty $ mkType <$> x+  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty (mkType <$> x)+  pretty' GHC.HsArgPar {} = notUsedInParsedStage+#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+-- | 'Pretty' for 'LHsWcType'+instance Pretty+           (GHC.HsWildCardBndrs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' GHC.HsWC {..} = pretty $ mkType <$> hswc_body++instance Pretty TopLevelTyFamInstDecl where+  pretty' (TopLevelTyFamInstDecl GHC.TyFamInstDecl {..}) =+    string "instance " >> pretty tfid_eqn++instance Pretty (GHC.DataFamInstDecl GHC.GhcPs) where+  pretty' = pretty' . DataFamInstDeclTopLevel++instance Pretty DataFamInstDecl' where+  pretty' DataFamInstDecl' {dataFamInstDecl = GHC.DataFamInstDecl {..}, ..} =+    pretty $ FamEqn' dataFamInstDeclFor dfid_eqn++instance Pretty (GHC.HsOverLit GHC.GhcPs) where+  pretty' GHC.OverLit {..} = pretty ol_val++instance Pretty GHC.OverLitVal where+  pretty' (GHC.HsIntegral x) = pretty x+  pretty' (GHC.HsFractional x) = pretty x+  pretty' (GHC.HsIsString _ x) = string $ GHC.unpackFS x+#if MIN_VERSION_ghc_lib_parser(9,8,1)+instance Pretty GHC.IntegralLit where+  pretty' GHC.IL {il_text = GHC.SourceText s} = output s+  pretty' GHC.IL {..} = string $ show il_value+#else+instance Pretty GHC.IntegralLit where+  pretty' GHC.IL {il_text = GHC.SourceText s} = string s+  pretty' GHC.IL {..} = string $ show il_value+#endif+instance Pretty GHC.FractionalLit where+  pretty' = output++instance Pretty (GHC.HsLit GHC.GhcPs) where+  pretty' = prettyHsLit++prettyHsLit :: GHC.HsLit GHC.GhcPs -> Printer ()+prettyHsLit x@(GHC.HsChar _ _) = output x+prettyHsLit x@GHC.HsCharPrim {} = output x+prettyHsLit GHC.HsInt {} = notUsedInParsedStage+prettyHsLit (GHC.HsIntPrim _ x) = string $ show x ++ "#"+prettyHsLit GHC.HsWordPrim {} = notUsedInParsedStage+prettyHsLit GHC.HsInt64Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord64Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsInteger {} = notUsedInParsedStage+prettyHsLit GHC.HsRat {} = notUsedInParsedStage+prettyHsLit (GHC.HsFloatPrim _ x) = pretty x >> string "#"+prettyHsLit GHC.HsDoublePrim {} = notUsedInParsedStage+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)+prettyHsLit GHC.HsInt8Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsInt16Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsInt32Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord8Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord16Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord32Prim {} = notUsedInParsedStage+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+prettyHsLit GHC.HsMultilineString {} = notGeneratedByParser+#endif+prettyHsLit x =+  case x of+    GHC.HsString {} -> prettyString+    GHC.HsStringPrim {} -> prettyString+  where+    prettyString =+      case lines $ showOutputable x of+        [] -> pure ()+        [l] -> string l+        (s:ss) ->+          string "" |=> do+            string s+            newline+            indentedWithSpace (-1)+              $ lined+              $ fmap (string . dropWhile (/= '\\')) ss++instance Pretty DoOrMdo where+  pretty' Do = string "do"+  pretty' Mdo = string "mdo"++instance Pretty QualifiedDo where+  pretty' (QualifiedDo (Just m) d) = do+    pretty m+    string "."+    pretty d+  pretty' (QualifiedDo Nothing d) = pretty d+#if MIN_VERSION_ghc_lib_parser(9,6,1)+instance Pretty GHC.FieldLabelString where+  pretty' = output+#endif+-- | Marks an AST node as never appearing in an AST.+--+-- Some AST node types are only defined in `ghc-lib-parser` and not+-- generated by it.+notGeneratedByParser :: HasCallStack => a+notGeneratedByParser = error "`ghc-lib-parser` never generates this AST node."++-- | Marks an AST node as never appearing in the AST.+--+-- Some AST node types are only used in the renaming or type-checking phase.+notUsedInParsedStage :: HasCallStack => a+notUsedInParsedStage =+  error+    "This AST should never appears in an AST. It only appears in the renaming or type checked stages."+#if !MIN_VERSION_ghc_lib_parser(9,4,1)+-- | Marks an AST node as it is used only for Haskell Program Coverage.+forHpc :: HasCallStack => a+forHpc = error "This AST type is for the use of Haskell Program Coverage."+#endif++#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+getAnc :: GHC.EpaLocation' a -> GHC.RealSrcSpan+getAnc (GHC.EpaSpan (GHC.RealSrcSpan x _)) = x+getAnc _ = undefined+#else+getAnc :: GHC.Anchor -> GHC.RealSrcSpan getAnc = GHC.anchor #endif

src/HIndent/Pretty.hs-boot view

@@ -7,14 +7,9 @@   , printCommentsAnd   ) where -import Data.Void-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 qualified GHC.Unit as GHC import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC-import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHc import HIndent.Pretty.NodeComments import HIndent.Pretty.SigBindFamily import HIndent.Pretty.Types@@ -35,8 +30,6 @@  instance Pretty GHC.EpaComment -instance Pretty (GHC.HsType GHC.GhcPs)- instance Pretty            (GHC.FamEqn               GHC.GhcPs@@ -44,39 +37,14 @@  instance Pretty SigBindFamily -instance Pretty HsSigType'--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.StringLiteral -instance Pretty (GHC.HsSigType GHC.GhcPs)- instance Pretty Context -instance Pretty (GHC.DerivClauseTys GHC.GhcPs)--instance Pretty a => Pretty (GHC.HsScaled GHC.GhcPs a)+instance Pretty+           (GHC.HsScaled+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) #if MIN_VERSION_ghc_lib_parser(9, 8, 1) instance Pretty            (GHC.HsArg@@ -86,13 +54,22 @@ #else instance Pretty            (GHC.HsArg-              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHc.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))               (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) #endif-instance Pretty (GHC.HsExpr GHC.GhcPs)+instance Pretty (GHC.HsLit GHC.GhcPs) -instance Pretty (GHC.FieldOcc GHC.GhcPs)+instance Pretty (GHC.HsOverLit GHC.GhcPs) -instance Pretty GHC.OccName+instance Pretty QualifiedDo -instance Pretty GHC.ModuleName+instance Pretty+           (GHC.StmtLR+              GHC.GhcPs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs)))++instance Pretty+           (GHC.HsWildCardBndrs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))

src/HIndent/Pretty/Combinators.hs view

@@ -6,7 +6,6 @@   , module HIndent.Pretty.Combinators.Lineup   , module HIndent.Pretty.Combinators.Op   , module HIndent.Pretty.Combinators.Outputable-  , module HIndent.Pretty.Combinators.RhsSeparator   , module HIndent.Pretty.Combinators.String   , module HIndent.Pretty.Combinators.Switch   , module HIndent.Pretty.Combinators.Wrap@@ -18,7 +17,6 @@ import HIndent.Pretty.Combinators.Lineup import HIndent.Pretty.Combinators.Op import HIndent.Pretty.Combinators.Outputable-import HIndent.Pretty.Combinators.RhsSeparator import HIndent.Pretty.Combinators.String import HIndent.Pretty.Combinators.Switch import HIndent.Pretty.Combinators.Wrap

src/HIndent/Pretty/Combinators/Lineup.hs view

@@ -42,7 +42,8 @@   ) where  import Control.Monad-import Data.List+import Data.Foldable (toList)+import Data.List (intersperse) import HIndent.Pretty.Combinators.Indent import HIndent.Pretty.Combinators.String import HIndent.Pretty.Combinators.Switch@@ -50,15 +51,15 @@ import HIndent.Printer  -- | Applies 'hTuple' if the result fits in a line or 'vTuple' otherwise.-hvTuple :: [Printer ()] -> Printer ()+hvTuple :: Foldable f => f (Printer ()) -> Printer () hvTuple = (<-|>) <$> hTuple <*> vTuple  -- | Applies 'hTuple'' if the result fits in a line or 'vTuple'' otherwise.-hvTuple' :: [Printer ()] -> Printer ()+hvTuple' :: Foldable f => f (Printer ()) -> Printer () hvTuple' = (<-|>) <$> hTuple <*> vTuple'  -- | Runs printers to construct a tuple in a line.-hTuple :: [Printer ()] -> Printer ()+hTuple :: Foldable f => f (Printer ()) -> Printer () hTuple = parens . hCommaSep  -- | Runs printers to construct a tuple in a line, but inserts newlines if@@ -67,35 +68,35 @@ -- The difference between this function and 'vTuple' is that the number of elements -- in a row in this function is not limited to 1 while the number of elements in -- a row in 'vTuple' is limited to 1.-hFillingTuple :: [Printer ()] -> Printer ()+hFillingTuple :: Foldable f => f (Printer ()) -> Printer () hFillingTuple = parens . inter (comma >> (space <-|> newline))  -- | Runs printers to construct a tuple where elements are aligned -- vertically.-vTuple :: [Printer ()] -> Printer ()+vTuple :: Foldable f => f (Printer ()) -> Printer () vTuple = vCommaSepWrapped ("(", ")")  -- | Similar to 'vTuple', but the closing parenthesis is in the last -- element.-vTuple' :: [Printer ()] -> Printer ()+vTuple' :: Foldable f => f (Printer ()) -> Printer () vTuple' = vCommaSepWrapped' ("(", ")")  -- | Runs printers to construct a promoted tuple in a line.-hPromotedTuple :: [Printer ()] -> Printer ()+hPromotedTuple :: Foldable f => f (Printer ()) -> Printer () hPromotedTuple = promotedTupleParens . hCommaSep  -- | Runs printers to construct an unboxed tuple. The elements are aligned -- either in a line or vertically.-hvUnboxedTuple' :: [Printer ()] -> Printer ()+hvUnboxedTuple' :: Foldable f => f (Printer ()) -> Printer () hvUnboxedTuple' = (<-|>) <$> hUnboxedTuple <*> vUnboxedTuple'  -- | Runs printers to construct an unboxed tuple in a line.-hUnboxedTuple :: [Printer ()] -> Printer ()+hUnboxedTuple :: Foldable f => f (Printer ()) -> Printer () hUnboxedTuple = unboxedParens . hCommaSep  -- | Runs printers to construct an unboxed tuple where the elements are -- aligned vertically.-vUnboxedTuple' :: [Printer ()] -> Printer ()+vUnboxedTuple' :: Foldable f => f (Printer ()) -> Printer () vUnboxedTuple' = vCommaSepWrapped' ("(#", " #)")  -- | Runs printers to construct an unboxed sum. The elements are aligned@@ -103,11 +104,11 @@ -- -- The enclosing parenthesis will be printed on the same line as the last -- element.-hvUnboxedSum' :: [Printer ()] -> Printer ()+hvUnboxedSum' :: Foldable f => f (Printer ()) -> Printer () hvUnboxedSum' = (<-|>) <$> hUnboxedSum <*> vUnboxedSum'  -- | Runs printers to construct an unboxed sum in a line.-hUnboxedSum :: [Printer ()] -> Printer ()+hUnboxedSum :: Foldable f => f (Printer ()) -> Printer () hUnboxedSum = unboxedParens . hBarSep  -- | Runs printers to construct an unboxed sum where the elements are@@ -115,123 +116,128 @@ -- -- The enclosing parenthesis will be printed on the same line as the last -- element.-vUnboxedSum' :: [Printer ()] -> Printer ()+vUnboxedSum' :: Foldable f => f (Printer ()) -> Printer () vUnboxedSum' = vWrappedLineup' '|' ("(#", " #)")  -- | Applies 'hFields' if the result fits in a line or 'vFields' otherwise.-hvFields :: [Printer ()] -> Printer ()+hvFields :: Foldable f => f (Printer ()) -> Printer () hvFields = (<-|>) <$> hFields <*> vFields  -- | Runs printers to construct a record in a line.-hFields :: [Printer ()] -> Printer ()+hFields :: Foldable f => f (Printer ()) -> Printer () hFields = braces . hCommaSep  -- | Runs printers to construct a record where elements are aligned -- vertically.-vFields :: [Printer ()] -> Printer ()+vFields :: Foldable f => f (Printer ()) -> Printer () vFields = vCommaSepWrapped ("{", "}")  -- | Similar to 'vFields', but the closing brace is in the same line as the -- last element.-vFields' :: [Printer ()] -> Printer ()+vFields' :: Foldable f => f (Printer ()) -> Printer () vFields' = vCommaSepWrapped' ("{", "}")  -- | Runs printers to construct a list in a line.-hList :: [Printer ()] -> Printer ()+hList :: Foldable f => f (Printer ()) -> Printer () hList = brackets . hCommaSep  -- | Runs printers to construct a list where elements are aligned -- vertically.-vList :: [Printer ()] -> Printer ()+vList :: Foldable f => f (Printer ()) -> Printer () vList = vCommaSepWrapped ("[", "]")  -- | Runs printers to construct a promoted list where elements are aligned -- in a line or vertically.-hvPromotedList :: [Printer ()] -> Printer ()+hvPromotedList :: Foldable f => f (Printer ()) -> Printer () hvPromotedList = (<-|>) <$> hPromotedList <*> vPromotedList  -- | Runs printers to construct a promoted list in a line.-hPromotedList :: [Printer ()] -> Printer ()+hPromotedList :: Foldable f => f (Printer ()) -> Printer () hPromotedList = promotedListBrackets . hCommaSep  -- | Runs printers to construct a promoted list where elements are aligned -- vertically.-vPromotedList :: [Printer ()] -> Printer ()+vPromotedList :: Foldable f => f (Printer ()) -> Printer () vPromotedList = vCommaSepWrapped ("'[", " ]")  -- | Runs printers in a line with a space as the separator.-spaced :: [Printer ()] -> Printer ()+spaced :: Foldable f => f (Printer ()) -> Printer () spaced = inter space  -- | Runs printers line by line.-lined :: [Printer ()] -> Printer ()+lined :: Foldable f => f (Printer ()) -> Printer () lined = inter newline  -- | Runs printers with a blank line as the separator.-blanklined :: [Printer ()] -> Printer ()+blanklined :: Foldable f => f (Printer ()) -> Printer () blanklined = inter blankline  -- | Applies 'hBarSep' if the result fits in a line or 'vBarSep' otherwise.-hvBarSep :: [Printer ()] -> Printer ()+hvBarSep :: Foldable f => f (Printer ()) -> Printer () hvBarSep = (<-|>) <$> hBarSep <*> vBarSep  -- | Runs printers in a line with a bar as the separator.-hBarSep :: [Printer ()] -> Printer ()+hBarSep :: Foldable f => f (Printer ()) -> Printer () hBarSep = inter (string " | ")  -- | Runs printers where each line except the first one has @| @ as -- a prefix.-vBarSep :: [Printer ()] -> Printer ()+vBarSep :: Foldable f => f (Printer ()) -> Printer () vBarSep = prefixedLined "| "  -- | Applies 'hCommaSep' if the result fits in a line or 'vCommaSep' -- otherwise.-hvCommaSep :: [Printer ()] -> Printer ()+hvCommaSep :: Foldable f => f (Printer ()) -> Printer () hvCommaSep = (<-|>) <$> hCommaSep <*> vCommaSep  -- | Runs printers in a line with a comma as the separator.-hCommaSep :: [Printer ()] -> Printer ()+hCommaSep :: Foldable f => f (Printer ()) -> Printer () hCommaSep = inter (string ", ")  -- | Runs printers with each line except the first one has @, @ as -- a prefix.-vCommaSep :: [Printer ()] -> Printer ()+vCommaSep :: Foldable f => f (Printer ()) -> Printer () vCommaSep = prefixedLined ", "  -- | Prints elements separated by comma  in vertical with the given prefix -- and suffix.-vCommaSepWrapped :: (String, String) -> [Printer ()] -> Printer ()+vCommaSepWrapped ::+     Foldable f => (String, String) -> f (Printer ()) -> Printer () vCommaSepWrapped = vWrappedLineup ','  -- | Similar to 'vCommaSepWrapped' but the suffix is in the same line as the last -- element.-vCommaSepWrapped' :: (String, String) -> [Printer ()] -> Printer ()+vCommaSepWrapped' ::+     Foldable f => (String, String) -> f (Printer ()) -> Printer () vCommaSepWrapped' = vWrappedLineup' ','  -- | Runs printers with a dot as the separator.-hDotSep :: [Printer ()] -> Printer ()+hDotSep :: Foldable f => f (Printer ()) -> Printer () hDotSep = inter (string ".")  -- | Prints each element after a space like.-spacePrefixed :: [Printer ()] -> Printer ()+spacePrefixed :: Foldable f => f (Printer ()) -> Printer () spacePrefixed = mapM_ (space >>)  -- | Prints each element after a new line.-newlinePrefixed :: [Printer ()] -> Printer ()+newlinePrefixed :: Foldable f => f (Printer ()) -> Printer () newlinePrefixed = mapM_ (newline >>)  -- | Runs printers with a prefix. The prefix is printed before the indent.-prefixedLined :: String -> [Printer ()] -> Printer ()-prefixedLined _ [] = return ()-prefixedLined pref (x:xs) = do-  x-  forM_ xs $ \p -> do-    newline-    prefixed pref p+prefixedLined :: Foldable f => String -> f (Printer ()) -> Printer ()+prefixedLined pref printers =+  case toList printers of+    [] -> return ()+    x:xs -> do+      x+      forM_ xs $ \p -> do+        newline+        prefixed pref p  -- | Prints elements in vertical with the given prefix, suffix, and -- separator.-vWrappedLineup :: Char -> (String, String) -> [Printer ()] -> Printer ()+vWrappedLineup ::+     Foldable f => Char -> (String, String) -> f (Printer ()) -> Printer () vWrappedLineup sep (prefix, suffix) ps =   string prefix     >> space |=> do@@ -241,16 +247,18 @@  -- | Similar to 'vWrappedLineup' but the suffix is in the same line as the -- last element.-vWrappedLineup' :: Char -> (String, String) -> [Printer ()] -> Printer ()-vWrappedLineup' _ (prefix, suffix) [x] =-  spaced [string prefix, x, string suffix]-vWrappedLineup' sep (prefix, suffix) ps =-  string prefix-    >> space |=> do-         prefixedLined [sep, ' '] ps-         string suffix+vWrappedLineup' ::+     Foldable f => Char -> (String, String) -> f (Printer ()) -> Printer ()+vWrappedLineup' sep (prefix, suffix) printers =+  case toList printers of+    [x] -> spaced [string prefix, x, string suffix]+    ps ->+      string prefix+        >> space |=> do+             prefixedLined [sep, ' '] ps+             string suffix  -- Inserts the first printer between each element of the list passed as the -- second argument and runs them.-inter :: Printer () -> [Printer ()] -> Printer ()-inter separator = sequence_ . intersperse separator+inter :: Foldable f => Printer () -> f (Printer ()) -> Printer ()+inter separator = sequence_ . intersperse separator . toList

− src/HIndent/Pretty/Combinators/RhsSeparator.hs

@@ -1,16 +0,0 @@--- | Separator-related things (e.g., '=' and '->').-module HIndent.Pretty.Combinators.RhsSeparator-  ( rhsSeparator-  ) where--import HIndent.Pretty.Combinators.String-import HIndent.Pretty.Types-import HIndent.Printer---- | Returns a separator between a LHS and a RHS according to the type of--- the RHS.-rhsSeparator :: GRHSExprType -> Printer ()-rhsSeparator GRHSExprNormal = string "="-rhsSeparator GRHSExprCase = string "->"-rhsSeparator GRHSExprMultiWayIf = string "->"-rhsSeparator GRHSExprLambda = string "->"

src/HIndent/Pretty/NodeComments.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} --- | Comment handling around an AST node module HIndent.Pretty.NodeComments   ( CommentExtraction(..)   , emptyNodeComments@@ -10,14 +9,11 @@  import Data.Maybe import Data.Void-import GHC.Core.Coercion import GHC.Data.BooleanFormula import GHC.Hs-import GHC.Stack import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.ForeignCall-import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc@@ -29,6 +25,9 @@ #else import GHC.Unit #endif+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)+import GHC.Stack+#endif -- | An interface to extract comments from an AST node. class CommentExtraction a where   nodeComments :: a -> NodeComments@@ -39,9 +38,6 @@ instance CommentExtraction (MatchGroup GhcPs a) where   nodeComments MG {} = emptyNodeComments -instance CommentExtraction LambdaCase where-  nodeComments (LambdaCase x _) = nodeComments x- instance CommentExtraction DoOrMdo where   nodeComments = const emptyNodeComments @@ -51,12 +47,6 @@ instance CommentExtraction (HsSigType GhcPs) where   nodeComments HsSig {} = emptyNodeComments -instance CommentExtraction HsSigType' where-  nodeComments (HsSigType' _ _ HsSig {}) = emptyNodeComments--instance CommentExtraction StmtLRInsideVerticalList where-  nodeComments (StmtLRInsideVerticalList x) = nodeComments x- -- | For pattern matching. instance CommentExtraction            (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))) where@@ -67,9 +57,6 @@            (HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where   nodeComments HsRecFields {} = emptyNodeComments -instance CommentExtraction HsType' where-  nodeComments HsType' {..} = nodeComments hsType- instance CommentExtraction (GRHSs GhcPs a) where   nodeComments GRHSs {..} = NodeComments {..}     where@@ -77,47 +64,27 @@       commentsOnSameLine = []       commentsAfter = getFollowingComments grhssExt -instance CommentExtraction GRHSsExpr where-  nodeComments (GRHSsExpr {..}) = nodeComments grhssExpr- instance CommentExtraction (ParStmtBlock GhcPs GhcPs) where   nodeComments ParStmtBlock {} = emptyNodeComments -instance CommentExtraction ParStmtBlockInsideVerticalList where-  nodeComments (ParStmtBlockInsideVerticalList x) = nodeComments x- instance CommentExtraction RdrName where   nodeComments Unqual {} = emptyNodeComments   nodeComments Qual {} = emptyNodeComments   nodeComments Orig {} = emptyNodeComments   nodeComments Exact {} = emptyNodeComments -instance CommentExtraction (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where-  nodeComments = nodeComments . GRHSExpr GRHSExprNormal--instance CommentExtraction GRHSExpr where-  nodeComments (GRHSExpr {grhsExpr = (GRHS x _ _)}) = nodeComments x--instance CommentExtraction GRHSProc where-  nodeComments (GRHSProc (GRHS x _ _)) = nodeComments x- instance CommentExtraction EpaCommentTok where   nodeComments = const emptyNodeComments  instance CommentExtraction (SpliceDecl GhcPs) where   nodeComments SpliceDecl {} = emptyNodeComments -instance CommentExtraction PatInsidePatDecl where-  nodeComments (PatInsidePatDecl x) = nodeComments x--instance CommentExtraction RecConPat where-  nodeComments (RecConPat x) = nodeComments x- instance CommentExtraction SigBindFamily where   nodeComments (Sig x) = nodeComments x   nodeComments (Bind x) = nodeComments x-  nodeComments (TypeFamily x) = nodeComments x+  nodeComments (Family x) = nodeComments x   nodeComments (TyFamInst x) = nodeComments x+  nodeComments (TyFamDeflt x) = nodeComments x   nodeComments (DataFamInst x) = nodeComments x  instance CommentExtraction EpaComment where@@ -127,18 +94,6 @@   nodeComments RealSrcSpan {} = emptyNodeComments   nodeComments UnhelpfulSpan {} = emptyNodeComments -instance CommentExtraction (HsLocalBindsLR GhcPs GhcPs) where-  nodeComments (HsValBinds x _) = nodeComments x-  nodeComments (HsIPBinds x _) = nodeComments x-  nodeComments EmptyLocalBinds {} = emptyNodeComments--instance CommentExtraction (HsValBindsLR GhcPs GhcPs) where-  nodeComments ValBinds {} = emptyNodeComments-  nodeComments XValBindsLR {} = notUsedInParsedStage--instance CommentExtraction (FieldOcc GhcPs) where-  nodeComments FieldOcc {} = emptyNodeComments- -- HsConDeclH98Details instance CommentExtraction            (HsConDetails@@ -154,39 +109,15 @@ instance CommentExtraction (HsScaled GhcPs a) where   nodeComments HsScaled {} = emptyNodeComments -instance CommentExtraction InfixExpr where-  nodeComments (InfixExpr x) = nodeComments x--instance CommentExtraction InfixApp where-  nodeComments InfixApp {} = emptyNodeComments- instance CommentExtraction (BooleanFormula a) where   nodeComments Var {} = emptyNodeComments   nodeComments And {} = emptyNodeComments   nodeComments Or {} = emptyNodeComments   nodeComments Parens {} = emptyNodeComments -instance CommentExtraction (FieldLabelStrings GhcPs) where-  nodeComments FieldLabelStrings {} = emptyNodeComments--instance CommentExtraction (AmbiguousFieldOcc GhcPs) where-  nodeComments Unambiguous {} = emptyNodeComments-  nodeComments Ambiguous {} = emptyNodeComments- instance CommentExtraction (ImportDecl GhcPs) where   nodeComments ImportDecl {..} = nodeComments ideclExt -instance CommentExtraction (DerivClauseTys GhcPs) where-  nodeComments DctSingle {} = emptyNodeComments-  nodeComments DctMulti {} = emptyNodeComments--instance CommentExtraction OverlapMode where-  nodeComments NoOverlap {} = emptyNodeComments-  nodeComments Overlappable {} = emptyNodeComments-  nodeComments Overlapping {} = emptyNodeComments-  nodeComments Overlaps {} = emptyNodeComments-  nodeComments Incoherent {} = emptyNodeComments- instance CommentExtraction StringLiteral where   nodeComments StringLiteral {} = emptyNodeComments @@ -195,22 +126,6 @@   nodeComments KindSig {} = emptyNodeComments   nodeComments TyVarSig {} = emptyNodeComments -instance CommentExtraction (ArithSeqInfo GhcPs) where-  nodeComments From {} = emptyNodeComments-  nodeComments FromThen {} = emptyNodeComments-  nodeComments FromTo {} = emptyNodeComments-  nodeComments FromThenTo {} = emptyNodeComments--instance CommentExtraction (HsForAllTelescope GhcPs) where-  nodeComments HsForAllVis {..} = nodeComments hsf_xvis-  nodeComments HsForAllInvis {..} = nodeComments hsf_xinvis--instance CommentExtraction InfixOp where-  nodeComments (InfixOp x) = nodeComments x--instance CommentExtraction PrefixOp where-  nodeComments (PrefixOp x) = nodeComments x- instance CommentExtraction Context where   nodeComments Context {} = emptyNodeComments @@ -220,25 +135,9 @@ instance CommentExtraction VerticalContext where   nodeComments VerticalContext {} = emptyNodeComments --- Wrap a value of this type with 'ModulenameWithPrefix' to print it with--- the "module " prefix.-instance CommentExtraction ModuleName where-  nodeComments = const emptyNodeComments--instance CommentExtraction ModuleNameWithPrefix where-  nodeComments ModuleNameWithPrefix {} = emptyNodeComments- instance CommentExtraction FamEqn' where   nodeComments FamEqn' {..} = nodeComments famEqn -instance CommentExtraction (IEWrappedName a) where-  nodeComments IEName {} = emptyNodeComments-  nodeComments IEPattern {} = emptyNodeComments-  nodeComments IEType {} = emptyNodeComments--instance CommentExtraction OccName where-  nodeComments = const emptyNodeComments- -- | 'Pretty' for 'LHsSigWcType GhcPs'. instance CommentExtraction            (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))) where@@ -252,16 +151,6 @@ instance CommentExtraction CExportSpec where   nodeComments CExportStatic {} = emptyNodeComments -instance CommentExtraction Safety where-  nodeComments PlaySafe = emptyNodeComments-  nodeComments PlayInterruptible = emptyNodeComments-  nodeComments PlayRisky = emptyNodeComments--instance CommentExtraction Role where-  nodeComments Nominal = emptyNodeComments-  nodeComments Representational = emptyNodeComments-  nodeComments Phantom = emptyNodeComments- instance CommentExtraction TopLevelTyFamInstDecl where   nodeComments (TopLevelTyFamInstDecl x) = nodeComments x @@ -271,35 +160,15 @@ instance CommentExtraction DataFamInstDecl' where   nodeComments DataFamInstDecl' {..} = nodeComments dataFamInstDecl --- | 'Pretty' for 'HsPatSynDetails'.-instance CommentExtraction-           (HsConDetails-              Void-              (GenLocated SrcSpanAnnN RdrName)-              [RecordPatSynField GhcPs]) where-  nodeComments PrefixCon {} = emptyNodeComments-  nodeComments RecCon {} = emptyNodeComments-  nodeComments InfixCon {} = emptyNodeComments- instance CommentExtraction (FixitySig GhcPs) where   nodeComments FixitySig {} = emptyNodeComments  instance CommentExtraction Fixity where   nodeComments Fixity {} = emptyNodeComments -instance CommentExtraction FixityDirection where-  nodeComments InfixL {} = emptyNodeComments-  nodeComments InfixR {} = emptyNodeComments-  nodeComments InfixN {} = emptyNodeComments- instance CommentExtraction InlinePragma where   nodeComments InlinePragma {} = emptyNodeComments -instance CommentExtraction (HsPatSynDir GhcPs) where-  nodeComments Unidirectional = emptyNodeComments-  nodeComments ImplicitBidirectional = emptyNodeComments-  nodeComments ExplicitBidirectional {} = emptyNodeComments- instance CommentExtraction (HsOverLit GhcPs) where   nodeComments OverLit {} = emptyNodeComments @@ -328,116 +197,196 @@   nodeComments HsRat {} = emptyNodeComments   nodeComments HsFloatPrim {} = emptyNodeComments   nodeComments HsDoublePrim {} = emptyNodeComments--instance CommentExtraction HsIPName where-  nodeComments HsIPName {} = emptyNodeComments--instance CommentExtraction (HsPatSigType GhcPs) where-  nodeComments HsPS {..} = nodeComments hsps_ext--instance CommentExtraction (HsIPBinds GhcPs) where-  nodeComments IPBinds {} = emptyNodeComments--instance CommentExtraction (RecordPatSynField GhcPs) where-  nodeComments RecordPatSynField {} = emptyNodeComments--instance CommentExtraction (HsCmdTop GhcPs) where-  nodeComments HsCmdTop {} = emptyNodeComments--instance CommentExtraction ListComprehension where-  nodeComments ListComprehension {} = emptyNodeComments--instance CommentExtraction DoExpression where-  nodeComments DoExpression {} = emptyNodeComments--instance CommentExtraction LetIn where-  nodeComments LetIn {} = emptyNodeComments--instance CommentExtraction CCallConv where-  nodeComments = const emptyNodeComments--instance CommentExtraction HsSrcBang where-  nodeComments HsSrcBang {} = emptyNodeComments--instance CommentExtraction SrcUnpackedness where-  nodeComments SrcUnpack = emptyNodeComments-  nodeComments SrcNoUnpack = emptyNodeComments-  nodeComments NoSrcUnpack = emptyNodeComments--instance CommentExtraction SrcStrictness where-  nodeComments SrcLazy = emptyNodeComments-  nodeComments SrcStrict = emptyNodeComments-  nodeComments NoSrcStrict = emptyNodeComments-+#if MIN_VERSION_ghc_lib_parser(9, 8, 0)+  nodeComments HsInt8Prim {} = emptyNodeComments+  nodeComments HsInt16Prim {} = emptyNodeComments+  nodeComments HsInt32Prim {} = emptyNodeComments+  nodeComments HsWord8Prim {} = emptyNodeComments+  nodeComments HsWord16Prim {} = emptyNodeComments+  nodeComments HsWord32Prim {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+  nodeComments HsMultilineString {} = emptyNodeComments+#endif instance CommentExtraction (HsOuterSigTyVarBndrs GhcPs) where   nodeComments HsOuterImplicit {} = emptyNodeComments   nodeComments HsOuterExplicit {..} = nodeComments hso_xexplicit-+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1) instance CommentExtraction AddEpAnn where   nodeComments (AddEpAnn _ x) = nodeComments x-+#endif instance CommentExtraction EpaLocation where-  nodeComments EpaSpan {} = emptyNodeComments-  nodeComments (EpaDelta _ x) = mconcat $ fmap nodeComments x+  nodeComments = nodeCommentsEpaLocation +nodeCommentsEpaLocation :: EpaLocation -> NodeComments+nodeCommentsEpaLocation EpaSpan {} = emptyNodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpaLocation (EpaDelta _ _ x) = mconcat $ fmap nodeComments x+#else+nodeCommentsEpaLocation (EpaDelta _ x) = mconcat $ fmap nodeComments x+#endif instance CommentExtraction AnnPragma where-  nodeComments AnnPragma {..} =-    mconcat $ fmap nodeComments $ apr_open : apr_close : apr_rest+  nodeComments = nodeCommentsAnnPragma +nodeCommentsAnnPragma :: AnnPragma -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnPragma AnnPragma {..} =+  mconcat+    [ nodeComments apr_open+    , nodeComments apr_close+    , nodeComments $ fst apr_squares+    , nodeComments $ snd apr_squares+    , nodeComments apr_loc1+    , nodeComments apr_loc2+    , nodeComments apr_type+    , nodeComments apr_module+    ]+#else+nodeCommentsAnnPragma AnnPragma {..} =+  mconcat $ fmap nodeComments $ apr_open : apr_close : apr_rest+#endif instance CommentExtraction HsRuleAnn where-  nodeComments HsRuleAnn {..} =-    mconcat $ f ra_tyanns : f ra_tmanns : fmap nodeComments ra_rest-    where-      f (Just (x, y)) = mconcat $ fmap nodeComments [x, y]-      f Nothing = emptyNodeComments+  nodeComments = nodeCommentsHsRuleAnn +nodeCommentsHsRuleAnn :: HsRuleAnn -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsRuleAnn HsRuleAnn {..} =+  mconcat+    [ maybe+        emptyNodeComments+        (\(a, b) -> mconcat [nodeComments a, nodeComments b])+        ra_tyanns+    , maybe+        emptyNodeComments+        (\(a, b) -> mconcat [nodeComments a, nodeComments b])+        ra_tmanns+    , nodeComments ra_equal+    , nodeComments ra_rest+    ]+#else+nodeCommentsHsRuleAnn HsRuleAnn {..} =+  mconcat $ f ra_tyanns : f ra_tmanns : fmap nodeComments ra_rest+  where+    f (Just (x, y)) = mconcat $ fmap nodeComments [x, y]+    f Nothing = emptyNodeComments+#endif instance CommentExtraction AnnFieldLabel where   nodeComments AnnFieldLabel {afDot = Just x} = nodeComments x   nodeComments AnnFieldLabel {afDot = Nothing} = emptyNodeComments  instance CommentExtraction EpAnnSumPat where-  nodeComments EpAnnSumPat {..} =-    mconcat-      $ fmap nodeComments sumPatParens-          <> fmap nodeComments sumPatVbarsBefore-          <> fmap nodeComments sumPatVbarsAfter+  nodeComments = nodeCommentsEpAnnSumPat +nodeCommentsEpAnnSumPat :: EpAnnSumPat -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpAnnSumPat EpAnnSumPat {..} =+  mconcat+    [ nodeComments $ fst sumPatParens+    , nodeComments $ snd sumPatParens+    , mconcat $ fmap nodeComments sumPatVbarsBefore+    , mconcat $ fmap nodeComments sumPatVbarsAfter+    ]+#else+nodeCommentsEpAnnSumPat EpAnnSumPat {..} =+  mconcat+    [ mconcat $ fmap nodeComments sumPatParens+    , mconcat $ fmap nodeComments sumPatVbarsBefore+    , mconcat $ fmap nodeComments sumPatVbarsAfter+    ]+#endif instance CommentExtraction AnnProjection where-  nodeComments AnnProjection {..} =-    mconcat $ fmap nodeComments [apOpen, apClose]+  nodeComments = nodeCommentsAnnProjection +nodeCommentsAnnProjection :: AnnProjection -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnProjection AnnProjection {..} =+  mconcat [nodeComments apOpen, nodeComments apClose]+#else+nodeCommentsAnnProjection AnnProjection {..} =+  mconcat $ fmap nodeComments [apOpen, apClose]+#endif instance CommentExtraction AnnsIf where-  nodeComments AnnsIf {..} =-    mconcat-      $ fmap nodeComments-      $ aiIf-          : aiThen-          : aiElse-          : (maybeToList aiThenSemi <> maybeToList aiElseSemi)+  nodeComments = nodeCommentsAnnsIf +nodeCommentsAnnsIf :: AnnsIf -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnsIf AnnsIf {..} =+  mconcat+    [ nodeComments aiIf+    , nodeComments aiThen+    , nodeComments aiElse+    , maybe emptyNodeComments nodeComments aiThenSemi+    , maybe emptyNodeComments nodeComments aiElseSemi+    ]+#else+nodeCommentsAnnsIf AnnsIf {..} =+  mconcat+    $ fmap nodeComments+    $ aiIf+        : aiThen+        : aiElse+        : (maybeToList aiThenSemi <> maybeToList aiElseSemi)+#endif instance CommentExtraction EpAnnHsCase where-  nodeComments EpAnnHsCase {..} =-    mconcat-      $ nodeComments hsCaseAnnCase-          : nodeComments hsCaseAnnOf-          : fmap nodeComments hsCaseAnnsRest+  nodeComments = nodeCommentsEpAnnHsCase +nodeCommentsEpAnnHsCase :: EpAnnHsCase -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpAnnHsCase EpAnnHsCase {..} =+  mconcat [nodeComments hsCaseAnnCase, nodeComments hsCaseAnnOf]+#else+nodeCommentsEpAnnHsCase EpAnnHsCase {..} =+  mconcat+    $ nodeComments hsCaseAnnCase+        : nodeComments hsCaseAnnOf+        : fmap nodeComments hsCaseAnnsRest+#endif instance CommentExtraction AnnExplicitSum where-  nodeComments AnnExplicitSum {..} =-    mconcat-      $ fmap nodeComments-      $ aesOpen : aesBarsBefore <> aesBarsAfter <> [aesClose]+  nodeComments = nodeCommentsAnnExplicitSum +nodeCommentsAnnExplicitSum :: AnnExplicitSum -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnExplicitSum AnnExplicitSum {..} =+  mconcat+    [ nodeComments aesOpen+    , mconcat $ fmap nodeComments aesBarsBefore+    , mconcat $ fmap nodeComments aesBarsAfter+    , nodeComments aesClose+    ]+#else+nodeCommentsAnnExplicitSum AnnExplicitSum {..} =+  mconcat+    $ fmap nodeComments+    $ aesOpen : aesBarsBefore <> aesBarsAfter <> [aesClose]+#endif instance CommentExtraction EpAnnUnboundVar where-  nodeComments EpAnnUnboundVar {..} =-    mconcat-      $ fmap-          nodeComments-          [fst hsUnboundBackquotes, snd hsUnboundBackquotes, hsUnboundHole]+  nodeComments = nodeCommentsEpAnnUnboundVar +nodeCommentsEpAnnUnboundVar :: EpAnnUnboundVar -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpAnnUnboundVar EpAnnUnboundVar {hsUnboundBackquotes = (a, b), ..} =+  mconcat [nodeComments a, nodeComments b, nodeComments hsUnboundHole]+#else+nodeCommentsEpAnnUnboundVar EpAnnUnboundVar {..} =+  mconcat+    $ fmap+        nodeComments+        [fst hsUnboundBackquotes, snd hsUnboundBackquotes, hsUnboundHole]+#endif instance CommentExtraction AnnSig where-  nodeComments AnnSig {..} = mconcat $ fmap nodeComments $ asDcolon : asRest+  nodeComments = nodeCommentsAnnSig +nodeCommentsAnnSig :: AnnSig -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnSig AnnSig {..} =+  mconcat+    [ nodeComments asDcolon+    , maybe emptyNodeComments nodeComments asPattern+    , maybe emptyNodeComments nodeComments asDefault+    ]+#else+nodeCommentsAnnSig AnnSig {..} = mconcat $ fmap nodeComments $ asDcolon : asRest+#endif instance CommentExtraction (HsBind GhcPs) where   nodeComments = nodeCommentsHsBind @@ -461,7 +410,22 @@ nodeCommentsSig (TypeSig x _ _) = nodeComments x nodeCommentsSig (PatSynSig x _ _) = nodeComments x nodeCommentsSig (ClassOpSig x _ _ _) = nodeComments x-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsSig (FixSig ((a, b), _) _) =+  mconcat [nodeComments a, maybe emptyNodeComments nodeComments b]+nodeCommentsSig (InlineSig (a, b, c) _ _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsSig (SpecSig x _ _ _) = nodeComments x+nodeCommentsSig (SpecInstSig ((a, b, c), _) _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsSig (MinimalSig ((a, b), _) _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsSig (SCCFunSig ((a, b), _) _ _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsSig (CompleteMatchSig ((a, b, c), _) _ _) =+  mconcat+    [nodeComments a, maybe emptyNodeComments nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsSig (FixSig x _) = mconcat $ fmap nodeComments x nodeCommentsSig (InlineSig x _ _) = mconcat $ fmap nodeComments x nodeCommentsSig (SpecSig x _ _ _) = mconcat $ fmap nodeComments x@@ -502,10 +466,19 @@ nodeCommentsHsExpr HsProjection {..} = nodeComments proj_ext nodeCommentsHsExpr HsPragE {} = emptyNodeComments #if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr (HsTypedBracket (a, b) _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsHsExpr HsUntypedBracket {} = emptyNodeComments+#else nodeCommentsHsExpr (HsTypedBracket x _) = mconcat $ fmap nodeComments x nodeCommentsHsExpr (HsUntypedBracket x _) = mconcat $ fmap nodeComments x+#endif nodeCommentsHsExpr HsLet {} = emptyNodeComments nodeCommentsHsExpr HsPar {} = emptyNodeComments+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr HsRecSel {} = emptyNodeComments+#endif #elif MIN_VERSION_ghc_lib_parser(9, 4, 1) nodeCommentsHsExpr HsRecSel {} = emptyNodeComments nodeCommentsHsExpr (HsTypedBracket x _) = nodeComments x@@ -526,7 +499,11 @@ nodeCommentsHsExpr HsRecFld {} = emptyNodeComments #endif #if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr (HsTypedSplice x _) = nodeComments x+#else nodeCommentsHsExpr (HsTypedSplice x _) = mconcat $ fmap nodeComments x+#endif nodeCommentsHsExpr HsUntypedSplice {} = emptyNodeComments nodeCommentsHsExpr HsOverLabel {} = emptyNodeComments #elif MIN_VERSION_ghc_lib_parser(9, 6, 1)@@ -538,24 +515,48 @@ nodeCommentsHsExpr (HsOverLabel x _) = nodeComments x #endif #if MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsHsExpr HsGetField {} = emptyNodeComments+nodeCommentsHsExpr SectionR {} = emptyNodeComments+nodeCommentsHsExpr SectionL {} = emptyNodeComments+nodeCommentsHsExpr HsApp {} = emptyNodeComments+nodeCommentsHsExpr HsLit {} = emptyNodeComments+nodeCommentsHsExpr HsOverLit {} = emptyNodeComments+nodeCommentsHsExpr HsIPVar {} = emptyNodeComments+nodeCommentsHsExpr (HsUnboundVar x _) = fromMaybe mempty $ fmap nodeComments x+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr (HsStatic x _) = nodeComments x+nodeCommentsHsExpr (HsProc (a, b) _ _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsHsExpr (ArithSeq x _ _) = nodeComments x+nodeCommentsHsExpr (ExprWithTySig x _ _) = nodeComments x+nodeCommentsHsExpr RecordUpd {rupd_ext = (s, d)} =+  mconcat+    [ maybe emptyNodeComments nodeComments s+    , maybe emptyNodeComments nodeComments d+    ]+nodeCommentsHsExpr RecordCon {rcon_ext = (s, d)} =+  mconcat+    [ maybe emptyNodeComments nodeComments s+    , maybe emptyNodeComments nodeComments d+    ]+nodeCommentsHsExpr (HsMultiIf (a, b, c) _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsHsExpr (ExplicitTuple (a, b) _ _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsHsExpr (NegApp x _ _) = nodeComments x+nodeCommentsHsExpr OpApp {} = emptyNodeComments+#else nodeCommentsHsExpr (HsStatic x _) = mconcat $ fmap nodeComments x nodeCommentsHsExpr (HsProc x _ _) = mconcat $ fmap nodeComments x nodeCommentsHsExpr (ArithSeq x _ _) = mconcat $ fmap nodeComments x nodeCommentsHsExpr (ExprWithTySig x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsExpr HsGetField {} = emptyNodeComments nodeCommentsHsExpr RecordUpd {..} = mconcat $ fmap nodeComments rupd_ext nodeCommentsHsExpr RecordCon {..} = mconcat $ fmap nodeComments rcon_ext nodeCommentsHsExpr (HsMultiIf x _) = mconcat $ fmap nodeComments x nodeCommentsHsExpr (ExplicitTuple x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsExpr SectionR {} = emptyNodeComments-nodeCommentsHsExpr SectionL {} = emptyNodeComments nodeCommentsHsExpr (NegApp x _ _) = mconcat $ fmap nodeComments x nodeCommentsHsExpr (OpApp x _ _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsExpr HsApp {} = emptyNodeComments-nodeCommentsHsExpr HsLit {} = emptyNodeComments-nodeCommentsHsExpr HsOverLit {} = emptyNodeComments-nodeCommentsHsExpr HsIPVar {} = emptyNodeComments-nodeCommentsHsExpr (HsUnboundVar x _) = fromMaybe mempty $ fmap nodeComments x+#endif #else nodeCommentsHsExpr (HsStatic x _) = nodeComments x nodeCommentsHsExpr (HsProc x _ _) = nodeComments x@@ -576,11 +577,21 @@ nodeCommentsHsExpr (HsIPVar x _) = nodeComments x nodeCommentsHsExpr (HsUnboundVar x _) = nodeComments x #endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 2)+nodeCommentsHsExpr HsEmbTy {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 2)+nodeCommentsHsExpr HsForAll {} = emptyNodeComments+nodeCommentsHsExpr HsQual {} = emptyNodeComments+nodeCommentsHsExpr HsFunArr {} = emptyNodeComments+#endif instance CommentExtraction (Match GhcPs a) where   nodeComments = nodeCommentsMatch  nodeCommentsMatch :: Match GhcPs a -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsMatch Match {} = emptyNodeComments+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsMatch Match {..} = mconcat $ fmap nodeComments m_ext #else nodeCommentsMatch Match {..} = nodeComments m_ext@@ -590,168 +601,50 @@  nodeCommentsStmtLR :: StmtLR GhcPs GhcPs a -> NodeComments nodeCommentsStmtLR LastStmt {} = emptyNodeComments-nodeCommentsStmtLR ApplicativeStmt {} = emptyNodeComments nodeCommentsStmtLR BodyStmt {} = emptyNodeComments nodeCommentsStmtLR ParStmt {} = emptyNodeComments nodeCommentsStmtLR RecStmt {..} = nodeComments recS_ext-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsStmtLR (BindStmt x _ _) = mconcat $ fmap nodeComments x-nodeCommentsStmtLR (LetStmt x _) = mconcat $ fmap nodeComments x-nodeCommentsStmtLR TransStmt {..} = mconcat $ fmap nodeComments trS_ext-#else+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsStmtLR (BindStmt x _ _) = nodeComments x nodeCommentsStmtLR (LetStmt x _) = nodeComments x nodeCommentsStmtLR TransStmt {..} = nodeComments trS_ext-#endif-instance CommentExtraction (HsType GhcPs) where-  nodeComments = nodeCommentsHsType--nodeCommentsHsType :: HsType GhcPs -> NodeComments-nodeCommentsHsType HsForAllTy {} = emptyNodeComments-nodeCommentsHsType HsQualTy {} = emptyNodeComments-nodeCommentsHsType HsAppTy {} = emptyNodeComments-nodeCommentsHsType HsAppKindTy {} = emptyNodeComments-nodeCommentsHsType (HsListTy x _) = nodeComments x-nodeCommentsHsType (HsTupleTy x _ _) = nodeComments x-nodeCommentsHsType (HsSumTy x _) = nodeComments x-nodeCommentsHsType HsOpTy {} = emptyNodeComments-nodeCommentsHsType (HsParTy x _) = nodeComments x-nodeCommentsHsType HsStarTy {} = emptyNodeComments-nodeCommentsHsType HsSpliceTy {} = emptyNodeComments-nodeCommentsHsType (HsRecTy x _) = nodeComments x-nodeCommentsHsType HsTyLit {} = emptyNodeComments-nodeCommentsHsType HsWildCardTy {} = emptyNodeComments-nodeCommentsHsType XHsType {} = emptyNodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsHsType (HsTyVar x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsType HsFunTy {} = emptyNodeComments-nodeCommentsHsType (HsIParamTy x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsType (HsKindSig x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsType (HsDocTy x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsType (HsBangTy x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsType (HsExplicitListTy x _ _) = mconcat $ fmap nodeComments x-nodeCommentsHsType (HsExplicitTupleTy x _) = mconcat $ fmap nodeComments x #else-nodeCommentsHsType (HsTyVar x _ _) = nodeComments x-nodeCommentsHsType (HsFunTy x _ _ _) = nodeComments x-nodeCommentsHsType (HsIParamTy x _ _) = nodeComments x-nodeCommentsHsType (HsKindSig x _ _) = nodeComments x-nodeCommentsHsType (HsDocTy x _ _) = nodeComments x-nodeCommentsHsType (HsBangTy x _ _) = nodeComments x-nodeCommentsHsType (HsExplicitListTy x _ _) = nodeComments x-nodeCommentsHsType (HsExplicitTupleTy x _) = nodeComments x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-instance CommentExtraction (HsMatchContext (GenLocated SrcSpanAnnN RdrName)) where-  nodeComments = nodeCommentsMatchContext-#else-instance CommentExtraction (HsMatchContext GhcPs) where-  nodeComments = nodeCommentsMatchContext-#endif--#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsMatchContext ::-     HsMatchContext (GenLocated SrcSpanAnnN RdrName) -> NodeComments-#else-nodeCommentsMatchContext :: HsMatchContext GhcPs -> NodeComments-#endif-nodeCommentsMatchContext FunRhs {} = emptyNodeComments-nodeCommentsMatchContext CaseAlt {} = emptyNodeComments-nodeCommentsMatchContext IfAlt {} = emptyNodeComments-nodeCommentsMatchContext ArrowMatchCtxt {} = emptyNodeComments-nodeCommentsMatchContext PatBindRhs {} = emptyNodeComments-nodeCommentsMatchContext PatBindGuards {} = emptyNodeComments-nodeCommentsMatchContext RecUpd {} = emptyNodeComments-nodeCommentsMatchContext StmtCtxt {} = emptyNodeComments-nodeCommentsMatchContext ThPatSplice {} = emptyNodeComments-nodeCommentsMatchContext ThPatQuote {} = emptyNodeComments-nodeCommentsMatchContext PatSyn {} = emptyNodeComments-#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsMatchContext LambdaExpr {} = emptyNodeComments-#endif-#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsMatchContext LamCaseAlt {} = emptyNodeComments-#endif-instance CommentExtraction (Pat GhcPs) where-  nodeComments = nodeCommentsPat--nodeCommentsPat :: Pat GhcPs -> NodeComments-nodeCommentsPat WildPat {} = emptyNodeComments-nodeCommentsPat VarPat {} = emptyNodeComments-nodeCommentsPat (ListPat x _) = nodeComments x-nodeCommentsPat (SumPat x _ _ _) = nodeComments x-nodeCommentsPat SplicePat {} = emptyNodeComments-nodeCommentsPat LitPat {} = emptyNodeComments-nodeCommentsPat (NPlusKPat x _ _ _ _ _) = nodeComments x-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsPat ParPat {} = emptyNodeComments-#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)-nodeCommentsPat (ParPat x _ _ _) = nodeComments x-#else-nodeCommentsPat (ParPat x _) = nodeComments x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsPat AsPat {} = emptyNodeComments-#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)-nodeCommentsPat (AsPat x _ _ _) = nodeComments x-#else-nodeCommentsPat (AsPat x _ _) = nodeComments x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsPat (LazyPat x _) = mconcat $ fmap nodeComments x-nodeCommentsPat (BangPat x _) = mconcat $ fmap nodeComments x-nodeCommentsPat (TuplePat x _ _) = mconcat $ fmap nodeComments x-nodeCommentsPat ConPat {..} = mconcat $ fmap nodeComments pat_con_ext-nodeCommentsPat (ViewPat x _ _) = mconcat $ fmap nodeComments x-nodeCommentsPat (NPat x _ _ _) = mconcat $ fmap nodeComments x-nodeCommentsPat (SigPat x _ _) = mconcat $ fmap nodeComments x-#else-nodeCommentsPat (LazyPat x _) = nodeComments x-nodeCommentsPat (BangPat x _) = nodeComments x-nodeCommentsPat (TuplePat x _ _) = nodeComments x-nodeCommentsPat ConPat {..} = nodeComments pat_con_ext-nodeCommentsPat (ViewPat x _ _) = nodeComments x-nodeCommentsPat (NPat x _ _ _) = nodeComments x-nodeCommentsPat (SigPat x _ _) = nodeComments x+nodeCommentsStmtLR (BindStmt x _ _) = mconcat $ fmap nodeComments x+nodeCommentsStmtLR (LetStmt x _) = mconcat $ fmap nodeComments x+nodeCommentsStmtLR TransStmt {..} = mconcat $ fmap nodeComments trS_ext #endif-instance CommentExtraction (HsTupArg GhcPs) where-  nodeComments = nodeCommentsHsTupArg--nodeCommentsHsTupArg :: HsTupArg GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsHsTupArg Present {} = emptyNodeComments-#else-nodeCommentsHsTupArg (Present x _) = nodeComments x+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsStmtLR ApplicativeStmt {} = emptyNodeComments #endif-nodeCommentsHsTupArg (Missing x) = nodeComments x- instance CommentExtraction (ConDeclField GhcPs) where   nodeComments = nodeCommentsConDeclField  nodeCommentsConDeclField :: ConDeclField GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsConDeclField ConDeclField {..} = nodeComments cd_fld_ext+#else nodeCommentsConDeclField ConDeclField {..} =   mconcat $ fmap nodeComments cd_fld_ext-#else-nodeCommentsConDeclField ConDeclField {..} = nodeComments cd_fld_ext #endif instance CommentExtraction (HsDerivingClause GhcPs) where   nodeComments = nodeCommentsHsDerivingClause  nodeCommentsHsDerivingClause :: HsDerivingClause GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsHsDerivingClause HsDerivingClause {..} =-  mconcat $ fmap nodeComments deriv_clause_ext+  nodeComments deriv_clause_ext #else nodeCommentsHsDerivingClause HsDerivingClause {..} =-  nodeComments deriv_clause_ext+  mconcat $ fmap nodeComments deriv_clause_ext #endif -- | This instance is for type family declarations inside a class declaration. instance CommentExtraction (FamilyDecl GhcPs) where   nodeComments = nodeCommentsFamilyDecl  nodeCommentsFamilyDecl :: FamilyDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsFamilyDecl FamilyDecl {..} = nodeComments fdExt+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsFamilyDecl FamilyDecl {..} = mconcat $ fmap nodeComments fdExt #else nodeCommentsFamilyDecl FamilyDecl {..} = nodeComments fdExt@@ -760,43 +653,27 @@   nodeComments = nodeCommentsHsTyVarBndr  nodeCommentsHsTyVarBndr :: HsTyVarBndr a GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsTyVarBndr HsTvb {..} = nodeComments tvb_ext+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsHsTyVarBndr (UserTyVar x _ _) = mconcat $ fmap nodeComments x nodeCommentsHsTyVarBndr (KindedTyVar x _ _ _) = mconcat $ fmap nodeComments x #else nodeCommentsHsTyVarBndr (UserTyVar x _ _) = nodeComments x nodeCommentsHsTyVarBndr (KindedTyVar x _ _ _) = nodeComments x #endif-instance CommentExtraction (IE GhcPs) where-  nodeComments = nodeCommentsIE--nodeCommentsIE :: IE GhcPs -> NodeComments-nodeCommentsIE IEVar {} = emptyNodeComments-nodeCommentsIE IEGroup {} = emptyNodeComments-nodeCommentsIE IEDoc {} = emptyNodeComments-nodeCommentsIE IEDocNamed {} = emptyNodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsIE (IEThingAbs _ x _) = nodeComments x-nodeCommentsIE (IEThingAll _ x _) = nodeComments x-nodeCommentsIE (IEThingWith _ x _ _ _) = nodeComments x-nodeCommentsIE (IEModuleContents (x, y) _) =-  mconcat $ maybeToList (fmap nodeComments x) <> fmap nodeComments y-#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)-nodeCommentsIE (IEThingAbs (_, x) _) = nodeComments x-nodeCommentsIE (IEThingAll (_, x) _) = nodeComments x-nodeCommentsIE (IEThingWith (_, x) _ _ _) = nodeComments x-nodeCommentsIE (IEModuleContents (_, x) _) = nodeComments x-#else-nodeCommentsIE (IEThingAbs x _) = nodeComments x-nodeCommentsIE (IEThingAll x _) = nodeComments x-nodeCommentsIE (IEThingWith x _ _ _) = nodeComments x-nodeCommentsIE (IEModuleContents x _) = nodeComments x-#endif instance CommentExtraction (FamEqn GhcPs a) where   nodeComments = nodeCommentsFamEqn  nodeCommentsFamEqn :: FamEqn GhcPs a -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsFamEqn FamEqn {feqn_ext = (as, bs, c)} =+  mconcat+    [ mconcat $ fmap nodeComments as+    , mconcat $ fmap nodeComments bs+    , nodeComments c+    ]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsFamEqn FamEqn {..} = mconcat $ fmap nodeComments feqn_ext #else nodeCommentsFamEqn FamEqn {..} = nodeComments feqn_ext@@ -805,7 +682,10 @@   nodeComments = nodeCommentsWarnDecls  nodeCommentsWarnDecls :: WarnDecls GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsWarnDecls Warnings {wd_ext = ((a, b), _)} =+  mconcat [nodeComments a, nodeComments b]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsWarnDecls Warnings {..} = mconcat $ fmap nodeComments $ fst wd_ext #elif MIN_VERSION_ghc_lib_parser(9, 6, 1) nodeCommentsWarnDecls Warnings {..} = nodeComments $ fst wd_ext@@ -816,7 +696,10 @@   nodeComments = nodeCommentsWarnDecl  nodeCommentsWarnDecl :: WarnDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsWarnDecl (Warning (a, (b, c)) _ _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsWarnDecl (Warning (_, x) _ _) = mconcat $ fmap nodeComments x #else nodeCommentsWarnDecl (Warning x _ _) = nodeComments x@@ -825,7 +708,10 @@   nodeComments = nodeCommentsRuleDecls  nodeCommentsRuleDecls :: RuleDecls GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsRuleDecls HsRules {rds_ext = ((a, b), _)} =+  mconcat [nodeComments a, nodeComments b]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsRuleDecls HsRules {..} = mconcat $ fmap nodeComments $ fst rds_ext #elif MIN_VERSION_ghc_lib_parser(9, 6, 1) nodeCommentsRuleDecls HsRules {..} = nodeComments $ fst rds_ext@@ -845,7 +731,11 @@   nodeComments = nodeCommentsDerivDecl  nodeCommentsDerivDecl :: DerivDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsDerivDecl DerivDecl {deriv_ext = (a, (b, c))} =+  mconcat+    [maybe emptyNodeComments nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsDerivDecl DerivDecl {deriv_ext = (x, xs)} =   mconcat $ maybeToList (fmap nodeComments x) <> fmap nodeComments xs #else@@ -855,8 +745,11 @@   nodeComments = nodeCommentsStandaloneKindSig  nodeCommentsStandaloneKindSig :: StandaloneKindSig GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) nodeCommentsStandaloneKindSig (StandaloneKindSig x _ _) =+  mconcat [nodeComments $ fst x, nodeComments $ snd x]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsStandaloneKindSig (StandaloneKindSig x _ _) =   mconcat $ fmap nodeComments x #else nodeCommentsStandaloneKindSig (StandaloneKindSig x _ _) = nodeComments x@@ -865,7 +758,10 @@   nodeComments = nodeCommentsDefaultDecl  nodeCommentsDefaultDecl :: DefaultDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsDefaultDecl (DefaultDecl (a, b, c) _ _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsDefaultDecl (DefaultDecl x _) = mconcat $ fmap nodeComments x #else nodeCommentsDefaultDecl (DefaultDecl x _) = nodeComments x@@ -874,7 +770,12 @@   nodeComments = nodeCommentsForeignDecl  nodeCommentsForeignDecl :: ForeignDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsForeignDecl ForeignImport {fd_i_ext = (a, b, c)} =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsForeignDecl ForeignExport {fd_e_ext = (a, b, c)} =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsForeignDecl ForeignImport {..} =   mconcat $ fmap nodeComments fd_i_ext nodeCommentsForeignDecl ForeignExport {..} =@@ -896,7 +797,10 @@   nodeComments = nodeCommentsRoleAnnotDecl  nodeCommentsRoleAnnotDecl :: RoleAnnotDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsRoleAnnotDecl (RoleAnnotDecl x _ _) =+  mconcat [nodeComments $ fst x, nodeComments $ snd x]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsRoleAnnotDecl (RoleAnnotDecl x _ _) = mconcat $ fmap nodeComments x #else nodeCommentsRoleAnnotDecl (RoleAnnotDecl x _ _) = nodeComments x@@ -905,8 +809,11 @@   nodeComments = nodeCommentsTyFamInstDecl  nodeCommentsTyFamInstDecl :: TyFamInstDecl GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) nodeCommentsTyFamInstDecl TyFamInstDecl {..} =+  mconcat [nodeComments $ fst tfid_xtn, nodeComments $ snd tfid_xtn]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsTyFamInstDecl TyFamInstDecl {..} =   mconcat $ fmap nodeComments tfid_xtn #else nodeCommentsTyFamInstDecl TyFamInstDecl {..} = nodeComments tfid_xtn@@ -915,10 +822,10 @@   nodeComments = nodeCommentsPatSynBind  nodeCommentsPatSynBind :: PatSynBind GhcPs GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsPatSynBind PSB {..} = mconcat $ fmap nodeComments psb_ext-#else+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsPatSynBind PSB {..} = nodeComments psb_ext+#else+nodeCommentsPatSynBind PSB {..} = mconcat $ fmap nodeComments psb_ext #endif instance CommentExtraction InlineSpec where   nodeComments = nodeCommentsInlineSpec@@ -931,30 +838,16 @@ #if MIN_VERSION_ghc_lib_parser(9, 4, 1) nodeCommentsInlineSpec Opaque {} = emptyNodeComments #endif-instance CommentExtraction (HsPragE GhcPs) where-  nodeComments = nodeCommentsHsPragE--nodeCommentsHsPragE :: HsPragE GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 6, 1)-nodeCommentsHsPragE (HsPragSCC (x, _) _) = nodeComments x-#else-nodeCommentsHsPragE (HsPragSCC x _ _) = nodeComments x-#endif-instance CommentExtraction (IPBind GhcPs) where-  nodeComments = nodeCommentsIPBind--nodeCommentsIPBind :: IPBind GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsIPBind (IPBind x _ _) = mconcat $ fmap nodeComments x-#else-nodeCommentsIPBind (IPBind x _ _) = nodeComments x-#endif instance CommentExtraction (DerivStrategy GhcPs) where   nodeComments = nodeCommentsDerivStrategy  nodeCommentsDerivStrategy :: DerivStrategy GhcPs -> NodeComments nodeCommentsDerivStrategy (ViaStrategy x) = nodeComments x-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsDerivStrategy (StockStrategy x) = nodeComments x+nodeCommentsDerivStrategy (AnyclassStrategy x) = nodeComments x+nodeCommentsDerivStrategy (NewtypeStrategy x) = nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsDerivStrategy (StockStrategy x) = mconcat $ fmap nodeComments x nodeCommentsDerivStrategy (AnyclassStrategy x) = mconcat $ fmap nodeComments x nodeCommentsDerivStrategy (NewtypeStrategy x) = mconcat $ fmap nodeComments x@@ -967,43 +860,19 @@   nodeComments = nodeCommentsXViaStrategyPs  nodeCommentsXViaStrategyPs :: XViaStrategyPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsXViaStrategyPs (XViaStrategyPs x _) = mconcat $ fmap nodeComments x-#else+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsXViaStrategyPs (XViaStrategyPs x _) = nodeComments x-#endif-instance CommentExtraction (HsCmd GhcPs) where-  nodeComments = nodeCommentsHsCmd--nodeCommentsHsCmd :: HsCmd GhcPs -> NodeComments-nodeCommentsHsCmd (HsCmdArrApp x _ _ _ _) = nodeComments x-nodeCommentsHsCmd (HsCmdArrForm x _ _ _ _) = nodeComments x-nodeCommentsHsCmd HsCmdLam {} = emptyNodeComments-nodeCommentsHsCmd (HsCmdCase x _ _) = nodeComments x-nodeCommentsHsCmd (HsCmdIf x _ _ _ _) = nodeComments x-nodeCommentsHsCmd (HsCmdDo x _) = nodeComments x-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsHsCmd HsCmdApp {} = emptyNodeComments #else-nodeCommentsHsCmd (HsCmdApp x _ _) = nodeComments x-#endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)-nodeCommentsHsCmd HsCmdPar {} = emptyNodeComments-nodeCommentsHsCmd HsCmdLet {} = emptyNodeComments-#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)-nodeCommentsHsCmd (HsCmdPar x _ _ _) = nodeComments x-nodeCommentsHsCmd (HsCmdLamCase x _ _) = nodeComments x-nodeCommentsHsCmd (HsCmdLet x _ _ _ _) = nodeComments x-#else-nodeCommentsHsCmd (HsCmdPar x _) = nodeComments x-nodeCommentsHsCmd (HsCmdLamCase x _) = nodeComments x-nodeCommentsHsCmd (HsCmdLet x _ _) = nodeComments x+nodeCommentsXViaStrategyPs (XViaStrategyPs x _) = mconcat $ fmap nodeComments x #endif instance CommentExtraction (RuleBndr GhcPs) where   nodeComments = nodeCommentsRuleBndr  nodeCommentsRuleBndr :: RuleBndr GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsRuleBndr (RuleBndr x _) = nodeComments x+nodeCommentsRuleBndr (RuleBndrSig x _ _) = nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsRuleBndr (RuleBndr x _) = mconcat $ fmap nodeComments x nodeCommentsRuleBndr (RuleBndrSig x _ _) = mconcat $ fmap nodeComments x #else@@ -1018,7 +887,9 @@   nodeComments = nodeCommentsHsUntypedSplice  nodeCommentsHsUntypedSplice :: HsUntypedSplice GhcPs -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsUntypedSplice (HsUntypedSpliceExpr x _) = nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsHsUntypedSplice (HsUntypedSpliceExpr x _) =   mconcat $ fmap nodeComments x #else@@ -1038,14 +909,13 @@ instance CommentExtraction (WithHsDocIdentifiers StringLiteral GhcPs) where   nodeComments WithHsDocIdentifiers {} = emptyNodeComments -instance CommentExtraction (DotFieldOcc GhcPs) where-  nodeComments DotFieldOcc {..} = nodeComments dfoExt- instance CommentExtraction (HsFieldBind a b) where   nodeComments = nodeCommentsHsFieldBind  nodeCommentsHsFieldBind :: HsFieldBind a b -> NodeComments-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsFieldBind HsFieldBind {..} = maybe mempty nodeComments hfbAnn+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1) nodeCommentsHsFieldBind HsFieldBind {..} = mconcat $ fmap nodeComments hfbAnn #else nodeCommentsHsFieldBind HsFieldBind {..} = nodeComments hfbAnn@@ -1053,14 +923,8 @@ #else instance CommentExtraction (HsFieldLabel GhcPs) where   nodeComments HsFieldLabel {..} = nodeComments hflExt--instance CommentExtraction RecConField where-  nodeComments (RecConField x) = nodeComments x #endif-#if MIN_VERSION_ghc_lib_parser(9, 4, 1)-instance CommentExtraction RecConField where-  nodeComments (RecConField x) = nodeComments x-#else+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1) instance CommentExtraction (HsBracket GhcPs) where   nodeComments ExpBr {} = emptyNodeComments   nodeComments PatBr {} = emptyNodeComments@@ -1082,11 +946,6 @@  instance CommentExtraction (ForeignExport GhcPs) where   nodeComments CExport {} = emptyNodeComments--instance CommentExtraction (HsTyLit GhcPs) where-  nodeComments HsNumTy {} = emptyNodeComments-  nodeComments HsStrTy {} = emptyNodeComments-  nodeComments HsCharTy {} = emptyNodeComments #else instance CommentExtraction (HsSplice GhcPs) where   nodeComments (HsTypedSplice x _ _ _) = nodeComments x@@ -1099,11 +958,6 @@  instance CommentExtraction ForeignExport where   nodeComments CExport {} = emptyNodeComments--instance CommentExtraction HsTyLit where-  nodeComments HsNumTy {} = emptyNodeComments-  nodeComments HsStrTy {} = emptyNodeComments-  nodeComments HsCharTy {} = emptyNodeComments #endif #if MIN_VERSION_ghc_lib_parser(9, 8, 1) instance CommentExtraction@@ -1127,7 +981,7 @@   nodeComments HsTypeArg {} = emptyNodeComments   nodeComments HsArgPar {} = emptyNodeComments #endif-#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) instance CommentExtraction (EpAnn a) where   nodeComments (EpAnn ann _ cs) = NodeComments {..}     where@@ -1136,30 +990,26 @@       commentsAfter =         filter (not . isCommentOnSameLine) $ getFollowingComments cs       isCommentOnSameLine (L comAnn _) =-        srcSpanEndLine (anchor ann) == srcSpanStartLine (anchor comAnn)+        srcSpanEndLine (epaLocationRealSrcSpan ann)+          == srcSpanStartLine (epaLocationRealSrcSpan comAnn)  instance CommentExtraction (EpaLocation' NoComments) where   nodeComments EpaSpan {} = emptyNodeComments   nodeComments EpaDelta {} = emptyNodeComments--instance CommentExtraction AnnList where-  nodeComments AnnList {..} = mconcat [a, b, c, d, e]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+instance CommentExtraction (EpAnn a) where+  nodeComments (EpAnn ann _ cs) = NodeComments {..}     where-      a = maybe mempty nodeComments al_anchor-      b = maybe mempty nodeComments al_open-      c = maybe mempty nodeComments al_close-      d = mconcat $ fmap nodeComments al_rest-      e = mconcat $ fmap nodeComments al_trailing--instance CommentExtraction TrailingAnn where-  nodeComments AddSemiAnn {..} = nodeComments ta_location-  nodeComments AddCommaAnn {..} = nodeComments ta_location-  nodeComments AddVbarAnn {..} = nodeComments ta_location-  nodeComments AddDarrowAnn {..} = nodeComments ta_location-  nodeComments AddDarrowUAnn {..} = nodeComments ta_location+      commentsBefore = priorComments cs+      commentsOnSameLine = filter isCommentOnSameLine $ getFollowingComments cs+      commentsAfter =+        filter (not . isCommentOnSameLine) $ getFollowingComments cs+      isCommentOnSameLine (L comAnn _) =+        srcSpanEndLine (anchor ann) == srcSpanStartLine (anchor comAnn) -instance CommentExtraction AnnParen where-  nodeComments AnnParen {..} = mconcat $ fmap nodeComments [ap_open, ap_close]+instance CommentExtraction (EpaLocation' NoComments) where+  nodeComments EpaSpan {} = emptyNodeComments+  nodeComments EpaDelta {} = emptyNodeComments #else instance CommentExtraction Anchor where   nodeComments Anchor {} = emptyNodeComments@@ -1178,6 +1028,163 @@         srcSpanEndLine (anchor ann) == srcSpanStartLine (anchor comAnn)   nodeComments EpAnnNotUsed = emptyNodeComments #endif++#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+instance CommentExtraction a => CommentExtraction (AnnList a) where+  nodeComments AnnList {..} = mconcat [a, b, c, d, e]+    where+      a = maybe mempty nodeComments al_anchor+      b = nodeComments al_brackets+      c = mconcat $ fmap nodeComments al_semis+      d = nodeComments al_rest+      e = mconcat $ fmap nodeComments al_trailing+#else+instance CommentExtraction AnnList where+  nodeComments AnnList {..} = mconcat [a, b, c, d, e]+    where+      a = maybe mempty nodeComments al_anchor+      b = maybe mempty nodeComments al_open+      c = maybe mempty nodeComments al_close+      d = mconcat $ fmap nodeComments al_rest+      e = mconcat $ fmap nodeComments al_trailing+#endif+instance CommentExtraction AnnParen where+  nodeComments = nodeCommentsAnnParen++nodeCommentsAnnParen :: AnnParen -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnParen (AnnParens open close) =+  mconcat [nodeComments open, nodeComments close]+nodeCommentsAnnParen (AnnParensHash open close) =+  mconcat [nodeComments open, nodeComments close]+nodeCommentsAnnParen (AnnParensSquare open close) =+  mconcat [nodeComments open, nodeComments close]+#else+nodeCommentsAnnParen AnnParen {..} =+  mconcat $ fmap nodeComments [ap_open, ap_close]+#endif+instance CommentExtraction TrailingAnn where+  nodeComments = nodeCommentsTrailingAnn++nodeCommentsTrailingAnn :: TrailingAnn -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsTrailingAnn (AddSemiAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddCommaAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddVbarAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddDarrowAnn token) = nodeComments token+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsTrailingAnn AddSemiAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddCommaAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddVbarAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddDarrowAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddDarrowUAnn {..} = nodeComments ta_location+#else+nodeCommentsTrailingAnn (AddSemiAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddCommaAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddVbarAnn token) = nodeComments token+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+instance CommentExtraction AnnTransStmt where+  nodeComments AnnTransStmt {..} =+    mconcat+      [ nodeComments ats_then+      , maybe emptyNodeComments nodeComments ats_group+      , maybe emptyNodeComments nodeComments ats_by+      , maybe emptyNodeComments nodeComments ats_using+      ]++instance CommentExtraction (EpToken a) where+  nodeComments NoEpTok = emptyNodeComments+  nodeComments (EpTok x) = nodeComments x++instance CommentExtraction AnnTyVarBndr where+  nodeComments AnnTyVarBndr {..} =+    mconcat+      [ mconcat $ fmap nodeComments atv_opens+      , mconcat $ fmap nodeComments atv_closes+      , nodeComments atv_tv+      , nodeComments atv_dcolon+      ]++instance CommentExtraction (EpUniToken a b) where+  nodeComments NoEpUniTok = emptyNodeComments+  nodeComments (EpUniTok x _) = nodeComments x++instance CommentExtraction AnnPSB where+  nodeComments AnnPSB {..} =+    mconcat+      [ nodeComments ap_pattern+      , maybe emptyNodeComments nodeComments ap_openc+      , maybe emptyNodeComments nodeComments ap_closec+      , maybe emptyNodeComments nodeComments ap_larrow+      , maybe emptyNodeComments nodeComments ap_equal+      ]++instance CommentExtraction NamespaceSpecifier where+  nodeComments NoNamespaceSpecifier = emptyNodeComments+  nodeComments (TypeNamespaceSpecifier x) = nodeComments x+  nodeComments (DataNamespaceSpecifier x) = nodeComments x++instance CommentExtraction AnnFamilyDecl where+  nodeComments AnnFamilyDecl {..} =+    mconcat+      [ mconcat $ fmap nodeComments afd_openp+      , mconcat $ fmap nodeComments afd_closep+      , nodeComments afd_type+      , nodeComments afd_data+      , nodeComments afd_family+      , nodeComments afd_dcolon+      , nodeComments afd_equal+      , nodeComments afd_vbar+      , nodeComments afd_where+      , nodeComments afd_openc+      , nodeComments afd_dotdot+      , nodeComments afd_closec+      ]++instance CommentExtraction AnnListBrackets where+  nodeComments (ListParens s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments (ListBraces s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments (ListSquare s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments (ListBanana s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments ListNone = emptyNodeComments++instance CommentExtraction () where+  nodeComments () = emptyNodeComments++instance CommentExtraction AnnArithSeq where+  nodeComments AnnArithSeq {..} =+    mconcat+      [ nodeComments aas_open+      , maybe emptyNodeComments nodeComments aas_comma+      , nodeComments aas_dotdot+      , nodeComments aas_close+      ]++instance (CommentExtraction a, CommentExtraction b) =>+         CommentExtraction (BracketAnn a b) where+  nodeComments (BracketNoE x) = nodeComments x+  nodeComments (BracketHasE x) = nodeComments x++instance CommentExtraction AnnSpecSig where+  nodeComments AnnSpecSig {..} =+    mconcat+      [ nodeComments ass_open+      , nodeComments ass_close+      , nodeComments ass_dcolon+      , nodeComments ass_act+      ]++instance CommentExtraction ActivationAnn where+  nodeComments ActivationAnn {..} =+    mconcat+      [ nodeComments aa_openc+      , nodeComments aa_closec+      , maybe emptyNodeComments nodeComments aa_tilde+      , maybe emptyNodeComments nodeComments aa_val+      ]+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1) -- | Marks an AST node as never appearing in the AST. -- -- Some AST node types are only used in the renaming or type-checking phase.@@ -1185,7 +1192,7 @@ notUsedInParsedStage =   error     "This AST should never appears in an AST. It only appears in the renaming or type checked stages."-+#endif -- | A 'NodeComment' with no comments. emptyNodeComments :: NodeComments emptyNodeComments = NodeComments [] [] []

src/HIndent/Pretty/SigBindFamily.hs view

@@ -13,18 +13,19 @@   ) where  import Data.Function-import Data.List+import Data.List (sortBy) import Data.Maybe import GHC.Hs import GHC.Types.SrcLoc  -- | A sum type containing one of those: function signature, function--- binding, type family, type family instance, and data family instance.+-- binding, family declaration (type or data), type family instance, and data family instance. data SigBindFamily   = Sig (Sig GhcPs)   | Bind (HsBindLR GhcPs GhcPs)-  | TypeFamily (FamilyDecl GhcPs)+  | Family (FamilyDecl GhcPs)   | TyFamInst (TyFamInstDecl GhcPs)+  | TyFamDeflt (TyFamDefltDecl GhcPs)   | DataFamInst (DataFamInstDecl GhcPs)  -- | 'SigBindFamily' with the location information.@@ -37,11 +38,12 @@   -> [LHsBindLR GhcPs GhcPs]   -> [LFamilyDecl GhcPs]   -> [LTyFamInstDecl GhcPs]+  -> [LTyFamDefltDecl GhcPs]   -> [LDataFamInstDecl GhcPs]   -> [LSigBindFamily]-mkSortedLSigBindFamilyList sigs binds fams datafams =+mkSortedLSigBindFamilyList sigs binds fams insts deflts datafams =   sortBy (compare `on` realSrcSpan . locA . getLoc)-    . mkLSigBindFamilyList sigs binds fams datafams+    $ mkLSigBindFamilyList sigs binds fams insts deflts datafams  -- | Creates a list of 'LSigBindFamily' from arguments. mkLSigBindFamilyList ::@@ -49,13 +51,15 @@   -> [LHsBindLR GhcPs GhcPs]   -> [LFamilyDecl GhcPs]   -> [LTyFamInstDecl GhcPs]+  -> [LTyFamDefltDecl GhcPs]   -> [LDataFamInstDecl GhcPs]   -> [LSigBindFamily]-mkLSigBindFamilyList sigs binds fams insts datafams =+mkLSigBindFamilyList sigs binds fams insts deflts datafams =   fmap (fmap Sig) sigs     ++ fmap (fmap Bind) binds-    ++ fmap (fmap TypeFamily) fams+    ++ fmap (fmap Family) fams     ++ fmap (fmap TyFamInst) insts+    ++ fmap (fmap TyFamDeflt) deflts     ++ fmap (fmap DataFamInst) datafams  -- | Destructs a list of 'LSigBindFamily'@@ -65,13 +69,15 @@      , [LHsBindLR GhcPs GhcPs]      , [LFamilyDecl GhcPs]      , [LTyFamInstDecl GhcPs]+     , [LTyFamDefltDecl GhcPs]      , [LDataFamInstDecl GhcPs]) destructLSigBindFamilyList =-  (,,,,)+  (,,,,,)     <$> filterLSig     <*> filterLBind-    <*> filterLTypeFamily+    <*> filterLFamily     <*> filterLTyFamInst+    <*> filterLTyFamDeflt     <*> filterLDataFamInst  -- | Filters out 'Sig's and extract the wrapped values.@@ -90,12 +96,12 @@        (L l (Bind x)) -> Just $ L l x        _ -> Nothing) --- | Filters out 'TypeFamily's and extract the wrapped values.-filterLTypeFamily :: [LSigBindFamily] -> [LFamilyDecl GhcPs]-filterLTypeFamily =+-- | Filters out 'Family's and extract the wrapped values.+filterLFamily :: [LSigBindFamily] -> [LFamilyDecl GhcPs]+filterLFamily =   mapMaybe     (\case-       (L l (TypeFamily x)) -> Just $ L l x+       (L l (Family x)) -> Just $ L l x        _ -> Nothing)  -- | Filters out 'TyFamInst's and extract the wrapped values.@@ -104,6 +110,14 @@   mapMaybe     (\case        (L l (TyFamInst x)) -> Just $ L l x+       _ -> Nothing)++-- | Filters out 'TyFamDeflt's and extract the wrapped values.+filterLTyFamDeflt :: [LSigBindFamily] -> [LTyFamDefltDecl GhcPs]+filterLTyFamDeflt =+  mapMaybe+    (\case+       (L l (TyFamDeflt x)) -> Just $ L l x        _ -> Nothing)  -- | Filters out 'DataFamInst's and extract the wrapped values.

src/HIndent/Pretty/Types.hs view

@@ -7,160 +7,26 @@ -- functions to print comments easily using the 'Pretty' implementation of -- 'GenLocated'. module HIndent.Pretty.Types-  ( InfixExpr(..)-  , InfixOp(..)-  , PrefixOp(..)-  , InfixApp(..)-  , GRHSsExpr(..)-  , GRHSExpr(..)-  , GRHSProc(..)-  , RecConPat(..)-  , RecConField(..)-  , HsSigType'(..)-  , pattern HsSigTypeInsideInstDecl-  , pattern HsSigTypeInsideVerticalFuncSig-  , pattern HsSigTypeInsideDeclSig-  , HsType'(..)-  , pattern HsTypeInsideVerticalFuncSig-  , pattern HsTypeInsideDeclSig-  , pattern HsTypeInsideInstDecl-  , pattern HsTypeWithVerticalAppTy-  , DataFamInstDecl'(..)+  ( DataFamInstDecl'(..)   , pattern DataFamInstDeclTopLevel   , pattern DataFamInstDeclInsideClassInst   , FamEqn'(..)   , pattern FamEqnTopLevel   , pattern FamEqnInsideClassInst-  , StmtLRInsideVerticalList(..)-  , ParStmtBlockInsideVerticalList(..)   , TopLevelTyFamInstDecl(..)   , Context(..)   , HorizontalContext(..)   , VerticalContext(..)-  , ModuleNameWithPrefix(..)-  , PatInsidePatDecl(..)-  , LambdaCase(..)-  , ListComprehension(..)-  , DoExpression(..)   , DoOrMdo(..)   , QualifiedDo(..)-  , LetIn(..)-  , GRHSExprType(..)-  , GRHSProcType(..)-  , HsTypeFor(..)-  , HsTypeDir(..)-  , CaseOrCases(..)   , DataFamInstDeclFor(..)   ) where -import Data.List.NonEmpty import GHC.Hs-import GHC.Types.Name.Reader+import {-# SOURCE #-} qualified HIndent.Ast.Module.Name as HIndent #if !MIN_VERSION_ghc_lib_parser(9,6,1) import GHC.Unit #endif--- | `LHsExpr` used as a infix operator-newtype InfixExpr =-  InfixExpr (LHsExpr GhcPs)--newtype InfixOp =-  InfixOp RdrName---- | A wrapper type for printing an identifier as a prefix operator.------ Printing a `PrefixOp` value containing a symbol operator wraps it with--- parentheses.-newtype PrefixOp =-  PrefixOp RdrName---- | An infix operator application.------ `immediatelyAfterDo` is `True` if an application is next to a `do`--- keyword. It needs an extra indent in such cases because------ > do a--- > * b------ is not a valid Haskell code.-data InfixApp = InfixApp-  { lhs :: LHsExpr GhcPs-  , op :: LHsExpr GhcPs-  , rhs :: LHsExpr GhcPs-  }---- | `GRHSs` with a label indicating in which context the RHS is located--- in.-data GRHSsExpr = GRHSsExpr-  { grhssExprType :: GRHSExprType-  , grhssExpr :: GRHSs GhcPs (LHsExpr GhcPs)-  }---- | 'GRHS' for a normal binding.-data GRHSExpr = GRHSExpr-  { grhsExprType :: GRHSExprType-  , grhsExpr :: GRHS GhcPs (LHsExpr GhcPs)-  }---- | 'GRHS' for a @proc@ binding.-newtype GRHSProc =-  GRHSProc (GRHS GhcPs (LHsCmd GhcPs))---- | A pattern match against a record.-newtype RecConPat =-  RecConPat (HsRecFields GhcPs (LPat GhcPs))-#if MIN_VERSION_ghc_lib_parser(9,4,1)--- | A record field in a pattern match.-newtype RecConField =-  RecConField (HsFieldBind (LFieldOcc GhcPs) (LPat GhcPs))-#else--- | A record field in a pattern match.-newtype RecConField =-  RecConField (HsRecField' (FieldOcc GhcPs) (LPat GhcPs))-#endif--- | A wrapper for `HsSigType`.-data HsSigType' = HsSigType'-  { hsSigTypeFor :: HsTypeFor -- ^ In which context a `HsSigType` is located in.-  , hsSigTypeDir :: HsTypeDir -- ^ How a `HsSigType` should be printed;-                                -- either horizontally or vertically.-  , hsSigType :: HsSigType GhcPs -- ^ The actual signature.-  }---- | `HsSigType'` for instance declarations.-pattern HsSigTypeInsideInstDecl :: HsSigType GhcPs -> HsSigType'-pattern HsSigTypeInsideInstDecl x = HsSigType' HsTypeForInstDecl HsTypeNoDir x---- | `HsSigType'` for function declarations; printed horizontally.-pattern HsSigTypeInsideVerticalFuncSig :: HsSigType GhcPs -> HsSigType'-pattern HsSigTypeInsideVerticalFuncSig x = HsSigType' HsTypeForFuncSig HsTypeVertical x---- | `HsSigType'` for a top-level function signature.-pattern HsSigTypeInsideDeclSig :: HsSigType GhcPs -> HsSigType'-pattern HsSigTypeInsideDeclSig x = HsSigType' HsTypeForDeclSig HsTypeNoDir x---- | A wrapper for `HsType`.-data HsType' = HsType'-  { hsTypeFor :: HsTypeFor -- ^ In which context a `HsType` is located in.-  , hsTypeDir :: HsTypeDir -- ^ How a function signature is printed;-                           -- either horizontally or vertically.-  , hsType :: HsType GhcPs -- ^ The actual type.-  }---- | `HsType'` inside a function signature declaration; printed horizontally.-pattern HsTypeInsideVerticalFuncSig :: HsType GhcPs -> HsType'-pattern HsTypeInsideVerticalFuncSig x = HsType' HsTypeForFuncSig HsTypeVertical x---- | `HsType'` inside a top-level function signature declaration.-pattern HsTypeInsideDeclSig :: HsType GhcPs -> HsType'-pattern HsTypeInsideDeclSig x = HsType' HsTypeForDeclSig HsTypeNoDir x---- | `HsType'` inside a instance signature declaration.-pattern HsTypeInsideInstDecl :: HsType GhcPs -> HsType'-pattern HsTypeInsideInstDecl x = HsType' HsTypeForInstDecl HsTypeNoDir x---- | `HsType'` to pretty-print a `HsAppTy` vertically.-pattern HsTypeWithVerticalAppTy :: HsType GhcPs -> HsType'-pattern HsTypeWithVerticalAppTy x = HsType' HsTypeForVerticalAppTy HsTypeVertical x- -- | A wrapper of `DataFamInstDecl`. data DataFamInstDecl' = DataFamInstDecl'   { dataFamInstDeclFor :: DataFamInstDeclFor -- ^ Where a data family instance is declared.@@ -193,14 +59,6 @@ pattern FamEqnInsideClassInst :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn' pattern FamEqnInsideClassInst x = FamEqn' DataFamInstDeclForInsideClassInst x --- | `StmtLR` inside a vertically printed list.-newtype StmtLRInsideVerticalList =-  StmtLRInsideVerticalList (StmtLR GhcPs GhcPs (LHsExpr GhcPs))---- | `ParStmtBlock` inside a vertically printed list.-newtype ParStmtBlockInsideVerticalList =-  ParStmtBlockInsideVerticalList (ParStmtBlock GhcPs GhcPs)- -- | A top-level type family instance declaration. newtype TopLevelTyFamInstDecl =   TopLevelTyFamInstDecl (TyFamInstDecl GhcPs)@@ -233,45 +91,6 @@ newtype VerticalContext =   VerticalContext (Maybe (LHsContext GhcPs)) #endif--- | A wrapper type for pretty-printing a value of @ModuleName@ with the--- @module @ prefix.------ Pretty-printing it via @(string "module " >> pretty (name ::--- ModuleName))@ locates comments before @name@ in the same line as @module--- @ and the name will be in the next line. This type is to avoid the--- problem.-newtype ModuleNameWithPrefix =-  ModuleNameWithPrefix ModuleName---- | A wrapper for 'LPat' inside a pattern declaration. Here, all infix--- patterns have extra spaces around the operators, like x : xs.-newtype PatInsidePatDecl =-  PatInsidePatDecl (Pat GhcPs)---- | Lambda case.-data LambdaCase = LambdaCase-  { lamCaseGroup :: MatchGroup GhcPs (LHsExpr GhcPs)-  , caseOrCases :: CaseOrCases-  }---- | Use this type to pretty-print a list comprehension.-data ListComprehension = ListComprehension-  { listCompLhs :: ExprLStmt GhcPs -- ^ @f x@ of @[f x| x <- xs]@.-  , listCompRhs :: NonEmpty (ExprLStmt GhcPs) -- ^ @x <- xs@ of @[f x| x <- xs]@.-  }---- | Use this type to pretty-print a do expression.-data DoExpression = DoExpression-  { doStmts :: [ExprLStmt GhcPs]-  , qualifiedDo :: QualifiedDo-  }---- | Use this type to pretty-print a @let ... in ...@ expression.-data LetIn = LetIn-  { letBinds :: HsLocalBinds GhcPs-  , inExpr :: LHsExpr GhcPs-  }- -- | Values indicating whether `do` or `mdo` is used. data DoOrMdo   = Do@@ -280,39 +99,7 @@ -- | Values indicating whether the `do` is qualified with a module name (and -- whether `do` or `mdo` is used) data QualifiedDo =-  QualifiedDo (Maybe ModuleName) DoOrMdo---- | Values indicating in which context a RHS is located.-data GRHSExprType-  = GRHSExprNormal-  | GRHSExprCase-  | GRHSExprMultiWayIf-  | GRHSExprLambda-  deriving (Eq)---- | Values indicating in which context a RHS in a proc expression is located.-data GRHSProcType-  = GRHSProcCase-  | GRHSProcLambda---- | Values indicating in which context a `HsType` is located.-data HsTypeFor-  = HsTypeForNormalDecl-  | HsTypeForInstDecl-  | HsTypeForFuncSig-  | HsTypeForDeclSig-  | HsTypeForVerticalAppTy---- | Values indicating how a node should be printed; either horizontally or--- vertically.-data HsTypeDir-  = HsTypeNoDir-  | HsTypeVertical---- | Values indicating whether `case` or `cases` is used.-data CaseOrCases-  = Case-  | Cases+  QualifiedDo (Maybe HIndent.ModuleName) DoOrMdo  -- | Values indicating where a data family instance is declared. data DataFamInstDeclFor