From d9a8bd5fec9e7c180841f10863cf81732d3e1f02 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 11 Mar 2024 19:32:13 +0100 Subject: [PATCH] ghc-lib-parser 9.10 --- .github/workflows/ci.yml | 2 +- CHANGELOG.md | 14 ++ cabal.project | 4 + data/examples/backpack/signature-0-out.hsig | 6 +- .../declaration/signature/fixity/infix-out.hs | 2 + .../declaration/signature/fixity/infix.hs | 2 + .../signature/fixity/infixl-out.hs | 2 + .../declaration/signature/fixity/infixl.hs | 2 + .../signature/fixity/infixr-out.hs | 2 + .../declaration/signature/fixity/infixr.hs | 2 + .../declaration/value/function/pragmas-out.hs | 2 +- .../function/required-type-arguments-out.hs | 21 ++ .../value/function/required-type-arguments.hs | 13 ++ .../value/function/type-abstractions-out.hs | 9 + .../value/function/type-abstractions.hs | 8 + .../warning/warning-multiline-out.hs | 9 + .../declaration/warning/warning-multiline.hs | 8 + .../warning/warning-single-line-out.hs | 12 +- .../warning/warning-single-line.hs | 10 +- .../import/docstrings-after-exports-out.hs | 12 ++ .../import/docstrings-after-exports.hs | 11 ++ expected-failures/Agda.txt | 48 ----- expected-failures/default.nix | 2 - expected-failures/hlint.txt | 2 +- expected-failures/leksah.txt | 16 -- expected-failures/pandoc.txt | 14 -- expected-failures/purescript.txt | 41 ---- .../extract-hackage-info.cabal | 4 +- flake.lock | 179 +++++++++++------ flake.nix | 6 +- ormolu-live/cabal.project | 2 +- ormolu.cabal | 26 +-- src/Ormolu/Diff/ParseResult.hs | 16 +- src/Ormolu/Diff/Text.hs | 5 +- src/Ormolu/Fixity/Imports.hs | 8 +- src/Ormolu/Fixity/Parser.hs | 11 ++ src/Ormolu/Imports.hs | 41 ++-- src/Ormolu/Parser.hs | 2 +- src/Ormolu/Parser/CommentStream.hs | 7 +- src/Ormolu/Printer/Combinators.hs | 13 +- src/Ormolu/Printer/Internal.hs | 12 ++ src/Ormolu/Printer/Meat/Common.hs | 32 +-- src/Ormolu/Printer/Meat/Declaration.hs | 10 +- src/Ormolu/Printer/Meat/Declaration/Data.hs | 28 +-- .../Printer/Meat/Declaration/Foreign.hs | 2 +- .../Printer/Meat/Declaration/Instance.hs | 16 +- src/Ormolu/Printer/Meat/Declaration/OpTree.hs | 3 +- .../Printer/Meat/Declaration/Signature.hs | 9 +- src/Ormolu/Printer/Meat/Declaration/Value.hs | 183 ++++++++++-------- .../Printer/Meat/Declaration/Warning.hs | 24 +-- src/Ormolu/Printer/Meat/ImportExport.hs | 66 +++++-- src/Ormolu/Printer/Meat/Type.hs | 16 +- src/Ormolu/Printer/Operators.hs | 5 +- src/Ormolu/Printer/SpanStream.hs | 8 +- src/Ormolu/Utils.hs | 17 -- stack.yaml | 5 +- 56 files changed, 603 insertions(+), 429 deletions(-) create mode 100644 data/examples/declaration/value/function/required-type-arguments-out.hs create mode 100644 data/examples/declaration/value/function/required-type-arguments.hs create mode 100644 data/examples/declaration/value/function/type-abstractions-out.hs create mode 100644 data/examples/declaration/value/function/type-abstractions.hs create mode 100644 data/examples/import/docstrings-after-exports-out.hs create mode 100644 data/examples/import/docstrings-after-exports.hs delete mode 100644 expected-failures/Agda.txt delete mode 100644 expected-failures/purescript.txt diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 698af39f4..e6c2f3851 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -12,7 +12,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: [ghc947, ghc963, ghc981] + ghc: [ghc965, ghc982, ghc9101] name: Build and test on ${{ matrix.ghc }} runs-on: ubuntu-latest steps: diff --git a/CHANGELOG.md b/CHANGELOG.md index d96d95517..7b3574a1c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,17 @@ +## Unreleased + +* Switched to `ghc-lib-parser-9.10`, with the following new syntactic features/behaviors: + * GHC proposal [#575](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0575-deprecated-instances.rst): deprecated instances. + * GHC proposal [#281](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0281-visible-forall.rst): visible forall in types of terms. + Enabled by `RequiredTypeArguments` (enabled by default). + * `LinearTypes`: `let` and `where` bindings can now be linear, in particular have multiplicity annotations. + * Using `forall` as an identifier is now a parse error. + * GHC proposal [#65](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0065-type-infix.rst): namespacing fixity declarations for type names and WARNING/DEPRECATED pragmas. + * `TypeAbstractions` now supports `@`-binders in lambdas and function equations. + * Support for the `GHC2024` language. + +* Updated to `Cabal-syntax-3.12`. + ## Ormolu 0.7.4.0 * Don't error when the `JavaScriptFFI` language pragma is present. [Issue diff --git a/cabal.project b/cabal.project index 34579c52d..44190bfec 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,7 @@ packages: . extract-hackage-info constraints: ormolu +dev + +if impl(ghc >=9.10) + allow-newer: base, template-haskell, ghc-prim, path-io:filepath + constraints: unix installed diff --git a/data/examples/backpack/signature-0-out.hsig b/data/examples/backpack/signature-0-out.hsig index 99beb5911..0e98dd1f8 100644 --- a/data/examples/backpack/signature-0-out.hsig +++ b/data/examples/backpack/signature-0-out.hsig @@ -15,10 +15,10 @@ instance Primitive Prim name :: String --- \| The name of the primitive used as the seed stretcher --- \| Test line 2 +-- | The name of the primitive used as the seed stretcher +-- | Test line 2 -- | Test line 3 --- \|Test line 4 +-- |Test line 4 primName :: String randomBlocks :: diff --git a/data/examples/declaration/signature/fixity/infix-out.hs b/data/examples/declaration/signature/fixity/infix-out.hs index 1ab50a150..a2ad248ca 100644 --- a/data/examples/declaration/signature/fixity/infix-out.hs +++ b/data/examples/declaration/signature/fixity/infix-out.hs @@ -3,3 +3,5 @@ infix 0 infix 9 <^-^> infix 2 -> + +infix 0 type diff --git a/data/examples/declaration/signature/fixity/infix.hs b/data/examples/declaration/signature/fixity/infix.hs index 47720f3a0..c4555f664 100644 --- a/data/examples/declaration/signature/fixity/infix.hs +++ b/data/examples/declaration/signature/fixity/infix.hs @@ -2,3 +2,5 @@ infix 0 infix 9 <^-^> infix 2 -> + +infix 0 type diff --git a/data/examples/declaration/signature/fixity/infixl-out.hs b/data/examples/declaration/signature/fixity/infixl-out.hs index 1f720d1e8..10aa2e0f5 100644 --- a/data/examples/declaration/signature/fixity/infixl-out.hs +++ b/data/examples/declaration/signature/fixity/infixl-out.hs @@ -1,3 +1,5 @@ infixl 8 *** infixl 0 $, *, +, &&, ** + +infixl 9 type $ diff --git a/data/examples/declaration/signature/fixity/infixl.hs b/data/examples/declaration/signature/fixity/infixl.hs index 8dd5c3320..4345ca7e7 100644 --- a/data/examples/declaration/signature/fixity/infixl.hs +++ b/data/examples/declaration/signature/fixity/infixl.hs @@ -1,2 +1,4 @@ infixl 8 *** infixl 0 $, *, +, &&, ** + +infixl 9 type $ diff --git a/data/examples/declaration/signature/fixity/infixr-out.hs b/data/examples/declaration/signature/fixity/infixr-out.hs index 041c7fc14..661e0a070 100644 --- a/data/examples/declaration/signature/fixity/infixr-out.hs +++ b/data/examples/declaration/signature/fixity/infixr-out.hs @@ -1,3 +1,5 @@ infixr 8 `Foo` infixr 0 ***, &&& + +infixr 0 data $ diff --git a/data/examples/declaration/signature/fixity/infixr.hs b/data/examples/declaration/signature/fixity/infixr.hs index f44ad5e85..a07e76647 100644 --- a/data/examples/declaration/signature/fixity/infixr.hs +++ b/data/examples/declaration/signature/fixity/infixr.hs @@ -1,2 +1,4 @@ infixr 8 `Foo` infixr 0 ***, &&& + +infixr 0 data $ diff --git a/data/examples/declaration/value/function/pragmas-out.hs b/data/examples/declaration/value/function/pragmas-out.hs index ca32d8e00..436970dea 100644 --- a/data/examples/declaration/value/function/pragmas-out.hs +++ b/data/examples/declaration/value/function/pragmas-out.hs @@ -1,4 +1,4 @@ -sccfoo = {-# SCC foo #-} 1 +sccfoo = {-# SCC "foo" #-} 1 sccbar = {-# SCC "barbaz" #-} diff --git a/data/examples/declaration/value/function/required-type-arguments-out.hs b/data/examples/declaration/value/function/required-type-arguments-out.hs new file mode 100644 index 000000000..895b7d5c7 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments-out.hs @@ -0,0 +1,21 @@ +vshow :: forall a -> (Show a) => a -> String +vshow t x = show (x :: t) + +s1 = vshow Int 42 + +s2 = vshow Double 42 + +a1 = f (type (Int -> Bool)) + +a2 = f (type ((Read T) => T)) + +a3 = f (type (forall a. a)) + +a4 = f (type (forall a. (Read a) => String -> a)) + +foo = + f + ( type ( Maybe + Int + ) + ) diff --git a/data/examples/declaration/value/function/required-type-arguments.hs b/data/examples/declaration/value/function/required-type-arguments.hs new file mode 100644 index 000000000..25d195966 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments.hs @@ -0,0 +1,13 @@ +vshow :: forall a -> Show a => a -> String +vshow t x = show (x :: t) + +s1 = vshow Int 42 +s2 = vshow Double 42 + +a1 = f (type (Int -> Bool)) +a2 = f (type (Read T => T)) +a3 = f (type (forall a. a)) +a4 = f (type (forall a. Read a => String -> a)) + +foo = f (type (Maybe + Int)) diff --git a/data/examples/declaration/value/function/type-abstractions-out.hs b/data/examples/declaration/value/function/type-abstractions-out.hs new file mode 100644 index 000000000..8be2185a4 --- /dev/null +++ b/data/examples/declaration/value/function/type-abstractions-out.hs @@ -0,0 +1,9 @@ +id :: forall a. a -> a +id @t x = x :: t + +f1 :: forall a. a -> forall b. b -> (a, b) +f1 @a x @b y = (x :: a, y :: b) + +f2 = + (\ @a x @b y -> (x :: a, y :: b)) :: + forall a. a -> forall b. b -> (a, b) diff --git a/data/examples/declaration/value/function/type-abstractions.hs b/data/examples/declaration/value/function/type-abstractions.hs new file mode 100644 index 000000000..365db2dd0 --- /dev/null +++ b/data/examples/declaration/value/function/type-abstractions.hs @@ -0,0 +1,8 @@ +id :: forall a. a -> a +id @t x = x :: t + +f1 :: forall a. a -> forall b. b -> (a, b) +f1 @a x @b y = (x :: a, y :: b) + +f2 = (\ @a x @b y -> (x :: a, y :: b) ) + :: forall a. a -> forall b. b -> (a, b) diff --git a/data/examples/declaration/warning/warning-multiline-out.hs b/data/examples/declaration/warning/warning-multiline-out.hs index 9b32f06ad..03c6b004f 100644 --- a/data/examples/declaration/warning/warning-multiline-out.hs +++ b/data/examples/declaration/warning/warning-multiline-out.hs @@ -7,3 +7,12 @@ #-} test :: IO () test = pure () + +instance + {-# WARNING "Don't use" #-} + Show G1 where + show = "G1" + +deriving instance + {-# WARNING "to be removed" #-} + Eq G2 diff --git a/data/examples/declaration/warning/warning-multiline.hs b/data/examples/declaration/warning/warning-multiline.hs index 96b809950..bf76c60db 100644 --- a/data/examples/declaration/warning/warning-multiline.hs +++ b/data/examples/declaration/warning/warning-multiline.hs @@ -2,3 +2,11 @@ foo ["These are bad functions", "Really bad!"] #-} test :: IO () test = pure () + +instance + {-# WARNING "Don't use" #-} + Show G1 where + show = "G1" + +deriving instance + {-# WARNING "to be removed" #-} Eq G2 diff --git a/data/examples/declaration/warning/warning-single-line-out.hs b/data/examples/declaration/warning/warning-single-line-out.hs index a16893085..728c4168b 100644 --- a/data/examples/declaration/warning/warning-single-line-out.hs +++ b/data/examples/declaration/warning/warning-single-line-out.hs @@ -6,11 +6,19 @@ test = pure () bar = 3 {-# DEPRECATED bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-} +{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5 data Number = Number Dobule -{-# DEPRECATED Number "Use Scientific instead." #-} +{-# DEPRECATED type Number "Use Scientific instead." #-} head (a : _) = a {-# WARNING in "x-partial" head "This function is partial..." #-} + +instance {-# DEPRECATED "Don't use" #-} Show T1 + +instance {-# WARNING "Don't use either" #-} Show G1 + +deriving instance {-# DEPRECATED "to be removed" #-} Eq T2 + +deriving instance {-# WARNING "to be removed as well" #-} Eq G2 diff --git a/data/examples/declaration/warning/warning-single-line.hs b/data/examples/declaration/warning/warning-single-line.hs index a029076bc..a94560160 100644 --- a/data/examples/declaration/warning/warning-single-line.hs +++ b/data/examples/declaration/warning/warning-single-line.hs @@ -8,11 +8,17 @@ bar = 3 {-# Deprecated bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-} +{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5 data Number = Number Dobule -{-# DEPRECATED Number "Use Scientific instead." #-} +{-# DEPRECATED type Number "Use Scientific instead." #-} head (a:_) = a {-# WARNING in "x-partial" head "This function is partial..." #-} + +instance {-# DEPRECATED "Don't use" #-} Show T1 where +instance {-# WARNING "Don't use either" #-} Show G1 where + +deriving instance {-# DEPRECATED "to be removed" #-} Eq T2 +deriving instance {-# WARNING "to be removed as well" #-} Eq G2 diff --git a/data/examples/import/docstrings-after-exports-out.hs b/data/examples/import/docstrings-after-exports-out.hs new file mode 100644 index 000000000..1676302a6 --- /dev/null +++ b/data/examples/import/docstrings-after-exports-out.hs @@ -0,0 +1,12 @@ +module Test + ( since1, -- ^ @since 1.0 + since2, -- ^ @since 2.0 + since3, -- ^ @since 3.0 + SinceType (..), -- ^ @since 4.0 + SinceClass (..), -- ^ @since 5.0 + Multi (..), + -- ^ since 6.0 + -- multi + -- line + ) +where diff --git a/data/examples/import/docstrings-after-exports.hs b/data/examples/import/docstrings-after-exports.hs new file mode 100644 index 000000000..876400202 --- /dev/null +++ b/data/examples/import/docstrings-after-exports.hs @@ -0,0 +1,11 @@ +module Test ( + since1, -- ^ @since 1.0 + since2 -- ^ @since 2.0 + , since3 -- ^ @since 3.0 + , SinceType(..) -- ^ @since 4.0 + , SinceClass(..) -- ^ @since 5.0 + , Multi(..) + -- ^ since 6.0 + -- multi + -- line + ) where diff --git a/expected-failures/Agda.txt b/expected-failures/Agda.txt deleted file mode 100644 index a1fac2a2b..000000000 --- a/expected-failures/Agda.txt +++ /dev/null @@ -1,48 +0,0 @@ -src/full/Agda/Syntax/Internal.hs -@@ -628,32 +676,28 @@ - _ -> Nothing - - ----------------------------------------------------------------------------- -+ - -- * Explicit substitutions -+ - ----------------------------------------------------------------------------- - - -- | Substitutions. -- - data Substitution' a -- -- = IdS -- -- ^ Identity substitution. -+ = -- | Identity substitution. - -- @Γ ⊢ IdS : Γ@ -- -- | EmptyS Impossible -- -- ^ Empty substitution, lifts from the empty context. First argument is @__IMPOSSIBLE__@. -+ IdS -+ | -- | Empty substitution, lifts from the empty context. First argument is @__IMPOSSIBLE__@. - -- Apply this to closed terms you want to use in a non-empty context. - -- @Γ ⊢ EmptyS : ()@ -- -- | a :# Substitution' a -- -- ^ Substitution extension, ``cons''. -+ EmptyS Impossible -+ | -- | Substitution extension, ``cons''. - -- @ - -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ - -- ---------------------- - -- Γ ⊢ u :# ρ : Δ, A - -- @ -- -- | Strengthen Impossible !Int (Substitution' a) -- -- ^ Strengthening substitution. First argument is @__IMPOSSIBLE__@. -+ a :# Substitution' a -+ | -- | Strengthening substitution. First argument is @__IMPOSSIBLE__@. - -- In @'Strengthen err n ρ@ the number @n@ must be non-negative. - -- This substitution should only be applied to values @t@ for - -- which none of the variables @0@ up to @n - 1@ are free in - - AST of input and AST of formatted code differ. - at src/full/Agda/Syntax/Internal.hs:647:5 - Please, consider reporting the bug. - To format anyway, use --unsafe. diff --git a/expected-failures/default.nix b/expected-failures/default.nix index 201ec912f..47867486b 100644 --- a/expected-failures/default.nix +++ b/expected-failures/default.nix @@ -3,7 +3,6 @@ let inherit (pkgs) lib; expectedFailures = [ - "Agda" "brittany" "esqueleto" "hlint" @@ -12,7 +11,6 @@ let "pandoc" "pipes" "postgrest" - "purescript" ]; ormolizedPackages = let diff --git a/expected-failures/hlint.txt b/expected-failures/hlint.txt index d254ccf7d..49c313622 100644 --- a/expected-failures/hlint.txt +++ b/expected-failures/hlint.txt @@ -13,7 +13,7 @@ src/Extension.hs Formatting is not idempotent. Please, consider reporting the bug. src/Hint/Bracket.hs -@@ -258,8 +258,11 @@ +@@ -265,8 +265,11 @@ let y = noLocA $ HsApp EpAnnNotUsed a1 (nlHsPar a2), let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)" ] diff --git a/expected-failures/leksah.txt b/expected-failures/leksah.txt index 9dc9a8d4d..2592d0f9a 100644 --- a/expected-failures/leksah.txt +++ b/expected-failures/leksah.txt @@ -2,19 +2,3 @@ src/IDE/Find.hs:615:36-46 The GHC parser (in Haddock mode) failed: [GHC-95644] Bang pattern in expression context: !matchIndex Did you mean to add a space after the '!'? -src/IDE/Pane/Modules.hs -@@ -1183,9 +1183,9 @@ - let modId = mdModuleId modDescr - modName = modu modId - mFilePath = mdMbSourcePath modDescr -- -- show relative file path for Main modules -+ in -- show relative file path for Main modules - -- since we can have several -- in case (components modName, mFilePath) of -+ case (components modName, mFilePath) of - (["Main"], Just fp) -> - let sfp = case (pdMbSourcePath (snd pair)) of - Nothing -> fp - - Formatting is not idempotent. - Please, consider reporting the bug. diff --git a/expected-failures/pandoc.txt b/expected-failures/pandoc.txt index 9f0d525d6..ed912b44f 100644 --- a/expected-failures/pandoc.txt +++ b/expected-failures/pandoc.txt @@ -12,17 +12,3 @@ src/Text/Pandoc/Readers/Org/Inlines.hs Formatting is not idempotent. Please, consider reporting the bug. -src/Text/Pandoc/Readers/RST.hs -@@ -1125,7 +1125,7 @@ - -- if no ":class:" field is given, the default is the role name - classFieldClasses = maybe [role] T.words (lookup "class" fields) -- -- nub in case role name & language class are the same -- in nub (classFieldClasses ++ codeLanguageClass ++ oldClasses) -+ in -- nub in case role name & language class are the same -+ nub (classFieldClasses ++ codeLanguageClass ++ oldClasses) - - attr = - let (ident, baseClasses, keyValues) = baseAttr - - Formatting is not idempotent. - Please, consider reporting the bug. diff --git a/expected-failures/purescript.txt b/expected-failures/purescript.txt deleted file mode 100644 index a52e3a5fc..000000000 --- a/expected-failures/purescript.txt +++ /dev/null @@ -1,41 +0,0 @@ -src/Language/PureScript/CoreFn/CSE.hs -@@ -227,11 +227,12 @@ - at d . non mempty . at e %%<~ \case - Nothing -> freshIdent (nameHint e) <&> \ident -> ((True, ident), Just ident) - Just ident -> pure ((False, ident), Just ident) -+ where - -- A reminder: as with %%=, the first element of the returned pair is the - -- final result of the expression, and the second element is the value to - -- stuff back through the lens into the state. (The difference is that %%<~ - -- enables doing monadic work in the RHS, namely `freshIdent` here.) -- where -+ - nameHint = \case - App _ v1 v2 - | Var _ n <- v1, - - Formatting is not idempotent. - Please, consider reporting the bug. -src/Language/PureScript/CoreFn/Laziness.hs -@@ -525,12 +525,12 @@ - makeForceCall ann ident' - q -> Var ann q - in (ident, rewriteExpr <$> item) -- -- All that's left to do is run the above replacement on every item, -- -- translate items from our `RecursiveGroupItem` representation back into the -- -- form CoreFn expects, and inform the caller whether we made any laziness -- -- transformations after all. (That last bit of information is used to -- -- determine if the runtime factory function needs to be injected.) -- in (uncurry fromRGI . replaceReferencesWithForceCall <$> items, Any . not $ IM.null replacements) -+ in -- All that's left to do is run the above replacement on every item, -+ -- translate items from our `RecursiveGroupItem` representation back into the -+ -- form CoreFn expects, and inform the caller whether we made any laziness -+ -- transformations after all. (That last bit of information is used to -+ -- determine if the runtime factory function needs to be injected.) -+ (uncurry fromRGI . replaceReferencesWithForceCall <$> items, Any . not $ IM.null replacements) - where - nullAnn = ssAnn nullSourceSpan - runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory - - Formatting is not idempotent. - Please, consider reporting the bug. diff --git a/extract-hackage-info/extract-hackage-info.cabal b/extract-hackage-info/extract-hackage-info.cabal index ba3c42e49..3fdbabdb5 100644 --- a/extract-hackage-info/extract-hackage-info.cabal +++ b/extract-hackage-info/extract-hackage-info.cabal @@ -11,13 +11,13 @@ executable extract-hackage-info default-language: GHC2021 ghc-options: -O2 -Wall -rtsopts -Wunused-packages build-depends: - Cabal-syntax >=3.10 && <3.11, + Cabal-syntax >=3.12 && <3.13, base >=4.12 && <5, binary >=0.8 && <0.9, bytestring >=0.10 && <0.13, containers >=0.6 && <0.8, directory >=1 && <2, - filepath >=1.2 && <1.5, + filepath >=1.2 && <1.6, optparse-applicative >=0.14 && <0.19, ormolu, text >=2 && <3, diff --git a/flake.lock b/flake.lock index 3deb63022..910b60272 100644 --- a/flake.lock +++ b/flake.lock @@ -177,11 +177,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1694529238, - "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", "type": "github" }, "original": { @@ -195,11 +195,11 @@ "systems": "systems_2" }, "locked": { - "lastModified": 1692799911, - "narHash": "sha256-3eihraek4qL744EvQXsK1Ha6C3CR7nnT8X2qWap4RNk=", + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "f9e7cf818399d17d347f847525c5a5a8032e4e44", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", "type": "github" }, "original": { @@ -277,11 +277,11 @@ }, "locked": { "host": "gitlab.haskell.org", - "lastModified": 1696827923, - "narHash": "sha256-SJYF9+O3n7KIumeSgPsj10tZsVEH4bI4yourZx+aSvs=", + "lastModified": 1714990373, + "narHash": "sha256-SLyr3puPer2cger41FfURaFDEo0SjpQC/s8LLOyru/g=", "owner": "ghc", "repo": "ghc-wasm-meta", - "rev": "aeec925988b64371f593eb17660d0a1794ab245d", + "rev": "aa34e7f010aa59a95b3813cf49bafd4bed250e75", "type": "gitlab" }, "original": { @@ -291,33 +291,33 @@ "type": "gitlab" } }, - "ghc98X": { + "ghc910X": { "flake": false, "locked": { - "lastModified": 1696643148, - "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", - "ref": "ghc-9.8", - "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", - "revCount": 61642, + "lastModified": 1714520650, + "narHash": "sha256-4uz6RA1hRr0RheGNDM49a/B3jszqNNU8iHIow4mSyso=", + "ref": "ghc-9.10", + "rev": "2c6375b9a804ac7fca1e82eb6fcfc8594c67c5f5", + "revCount": 62663, "submodules": true, "type": "git", "url": "https://gitlab.haskell.org/ghc/ghc" }, "original": { - "ref": "ghc-9.8", + "ref": "ghc-9.10", "submodules": true, "type": "git", "url": "https://gitlab.haskell.org/ghc/ghc" } }, - "ghc99": { + "ghc911": { "flake": false, "locked": { - "lastModified": 1697054644, - "narHash": "sha256-kKarOuXUaAH3QWv7ASx+gGFMHaHKe0pK5Zu37ky2AL4=", + "lastModified": 1714817013, + "narHash": "sha256-m2je4UvWfkgepMeUIiXHMwE6W+iVfUY38VDGkMzjCcc=", "ref": "refs/heads/master", - "rev": "f383a242c76f90bcca8a4d7ee001dcb49c172a9a", - "revCount": 62040, + "rev": "fc24c5cf6c62ca9e3c8d236656e139676df65034", + "revCount": 62816, "submodules": true, "type": "git", "url": "https://gitlab.haskell.org/ghc/ghc" @@ -352,11 +352,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1697329475, - "narHash": "sha256-cyp4bvVyDWa27pv6Fc9mIXM7+Kn9dNv2tlGx13A0XsI=", + "lastModified": 1715560494, + "narHash": "sha256-JAPXpr+I48XosjkYiXDyRRV1K8UJwEn7ypSR30Q812U=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "c1d90e14c6ea1048275a97cd56546c3db116ad47", + "rev": "a62dac66a95f2fb407c824592c6f325b8f7d0b60", "type": "github" }, "original": { @@ -374,14 +374,17 @@ "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc98X": "ghc98X", - "ghc99": "ghc99", + "ghc910X": "ghc910X", + "ghc911": "ghc911", "hackage": "hackage", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", "hls-2.2": "hls-2.2", "hls-2.3": "hls-2.3", "hls-2.4": "hls-2.4", + "hls-2.5": "hls-2.5", + "hls-2.6": "hls-2.6", + "hls-2.7": "hls-2.7", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -395,16 +398,17 @@ "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", "nixpkgs-2305": "nixpkgs-2305", + "nixpkgs-2311": "nixpkgs-2311", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1697331007, - "narHash": "sha256-QlYAA297LBDka7S6llYzVD4ZVjoWxEIQA5i/0y6gRdE=", + "lastModified": 1715582070, + "narHash": "sha256-B5gSgOPrULR6NILQ3KTZTCRz8nd5lkJezdFn6nGiow0=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "928f59ac2f6d6c371b7564d82a39de77b51c5d23", + "rev": "d5f5c7e4ebe096e6e228a714537adb68343ddb35", "type": "github" }, "original": { @@ -484,16 +488,67 @@ "hls-2.4": { "flake": false, "locked": { - "lastModified": 1696939266, - "narHash": "sha256-VOMf5+kyOeOmfXTHlv4LNFJuDGa7G3pDnOxtzYR40IU=", + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", "owner": "haskell", "repo": "haskell-language-server", - "rev": "362fdd1293efb4b82410b676ab1273479f6d17ee", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", "type": "github" }, "original": { "owner": "haskell", - "ref": "2.4.0.0", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.5": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.6": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.7": { + "flake": false, + "locked": { + "lastModified": 1708965829, + "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.7.0.0", "repo": "haskell-language-server", "type": "github" } @@ -540,18 +595,18 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1691634696, - "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", - "ref": "hkm/remote-iserv", - "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", - "revCount": 14, - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + "lastModified": 1708894040, + "narHash": "sha256-Rv+PajrnuJ6AeyhtqzMN+bcR8z9+aEnrUass+N951CQ=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "2f2a318fd8837f8063a0d91f329aeae29055fba9", + "type": "github" }, "original": { - "ref": "hkm/remote-iserv", - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", + "type": "github" } }, "lowdown-src": { @@ -643,16 +698,16 @@ }, "nixpkgs": { "locked": { - "lastModified": 1694343207, - "narHash": "sha256-jWi7OwFxU5Owi4k2JmiL1sa/OuBCQtpaAesuj5LXC8w=", + "lastModified": 1714906307, + "narHash": "sha256-UlRZtrCnhPFSJlDQE7M0eyhgvuuHBTe1eJ9N9AQlJQ0=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "78058d810644f5ed276804ce7ea9e82d92bee293", + "rev": "25865a40d14b3f9cf19f19b924e2ab4069b09588", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", + "ref": "nixos-unstable", "repo": "nixpkgs", "type": "github" } @@ -739,11 +794,11 @@ }, "nixpkgs-2305": { "locked": { - "lastModified": 1695416179, - "narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=", + "lastModified": 1701362232, + "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6", + "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", "type": "github" }, "original": { @@ -753,6 +808,22 @@ "type": "github" } }, + "nixpkgs-2311": { + "locked": { + "lastModified": 1701386440, + "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -787,17 +858,17 @@ }, "nixpkgs-unstable": { "locked": { - "lastModified": 1695318763, - "narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=", + "lastModified": 1694822471, + "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e12483116b3b51a185a33a272bf351e357ba9a99", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 0f244ab21..9ac906806 100644 --- a/flake.nix +++ b/flake.nix @@ -36,7 +36,7 @@ inherit (pkgs) lib haskell-nix; inherit (haskell-nix) haskellLib; - ghcVersions = [ "ghc963" "ghc947" "ghc981" ]; + ghcVersions = [ "ghc965" "ghc982" "ghc9101" ]; defaultGHCVersion = builtins.head ghcVersions; perGHC = lib.genAttrs ghcVersions (ghcVersion: let @@ -157,7 +157,7 @@ tools = { cabal = "latest"; haskell-language-server = { - src = inputs.haskellNix.inputs."hls-2.4"; + src = inputs.haskellNix.inputs."hls-2.7"; configureArgs = "--disable-benchmarks --disable-tests"; }; }; @@ -173,10 +173,12 @@ nixConfig = { extra-substituters = [ "https://cache.iog.io" + "https://cache.zw3rk.com" "https://tweag-ormolu.cachix.org" ]; extra-trusted-public-keys = [ "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" + "loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk=" "tweag-ormolu.cachix.org-1:3O4XG3o4AGquSwzzmhF6lov58PYG6j9zHcTDiROqkjM=" ]; }; diff --git a/ormolu-live/cabal.project b/ormolu-live/cabal.project index ebc33a7ef..95c48e85d 100644 --- a/ormolu-live/cabal.project +++ b/ormolu-live/cabal.project @@ -1,6 +1,6 @@ packages: . .. -index-state: 2023-10-15T12:29:38Z +index-state: 2024-05-12T09:50:27Z package ormolu -- The WASM backend does not support TH. diff --git a/ormolu.cabal b/ormolu.cabal index f1cf53feb..09e75397e 100644 --- a/ormolu.cabal +++ b/ormolu.cabal @@ -4,7 +4,7 @@ version: 0.7.4.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov -tested-with: ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1 +tested-with: ghc ==9.6.5 ghc ==9.8.2 ghc ==9.10.1 homepage: https://github.com/tweag/ormolu bug-reports: https://github.com/tweag/ormolu/issues synopsis: A formatter for Haskell source code @@ -97,10 +97,10 @@ library other-modules: GHC.DynFlags default-language: GHC2021 build-depends: - Cabal-syntax >=3.10 && <3.11, + Cabal-syntax >=3.12 && <3.13, Diff >=0.4 && <1, MemoTrie >=0.6 && <0.7, - ansi-terminal >=0.10 && <1.1, + ansi-terminal >=0.10 && <1.2, array >=0.5 && <0.6, base >=4.14 && <5, binary >=0.8 && <0.9, @@ -109,8 +109,8 @@ library deepseq >=1.4 && <1.6, directory ^>=1.3, file-embed >=0.0.15 && <0.1, - filepath >=1.2 && <1.5, - ghc-lib-parser >=9.8 && <9.9, + filepath >=1.2 && <1.6, + ghc-lib-parser >=9.10 && <9.11, megaparsec >=9, mtl >=2 && <3, syb >=0.7 && <0.8, @@ -134,12 +134,12 @@ executable ormolu autogen-modules: Paths_ormolu default-language: GHC2021 build-depends: - Cabal-syntax >=3.10 && <3.11, + Cabal-syntax >=3.12 && <3.13, base >=4.12 && <5, - containers >=0.5 && <0.7, + containers >=0.5 && <0.8, directory ^>=1.3, - filepath >=1.2 && <1.5, - ghc-lib-parser >=9.8 && <9.9, + filepath >=1.2 && <1.6, + ghc-lib-parser >=9.10 && <9.11, optparse-applicative >=0.14 && <0.19, ormolu, text >=2 && <3, @@ -172,13 +172,13 @@ test-suite tests default-language: GHC2021 build-depends: - Cabal-syntax >=3.10 && <3.11, + Cabal-syntax >=3.12 && <3.13, QuickCheck >=2.14, base >=4.14 && <5, - containers >=0.5 && <0.7, + containers >=0.5 && <0.8, directory ^>=1.3, - filepath >=1.2 && <1.5, - ghc-lib-parser >=9.8 && <9.9, + filepath >=1.2 && <1.6, + ghc-lib-parser >=9.10 && <9.11, hspec >=2 && <3, hspec-megaparsec >=2.2, megaparsec >=9, diff --git a/src/Ormolu/Diff/ParseResult.hs b/src/Ormolu/Diff/ParseResult.hs index 1d32f5211..c852b807e 100644 --- a/src/Ormolu/Diff/ParseResult.hs +++ b/src/Ormolu/Diff/ParseResult.hs @@ -93,17 +93,20 @@ diffHsModule = genericQuery `extQ` considerEqual @SourceText `extQ` hsDocStringEq `extQ` importDeclQualifiedStyleEq - `extQ` considerEqual @(LayoutInfo GhcPs) `extQ` classDeclCtxEq `extQ` derivedTyClsParensEq `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token `extQ` considerEqual @EpaLocation + `extQ` considerEqual @EpLayout + `extQ` considerEqual @[AddEpAnn] + `extQ` considerEqual @AnnSig + `extQ` considerEqual @HsRuleAnn `ext2Q` forLocated -- unicode-related - `extQ` considerEqual @(HsUniToken "->" "→") - `extQ` considerEqual @(HsUniToken "::" "∷") - `extQ` considerEqual @(HsLinearArrowTokens GhcPs) + `extQ` considerEqual @(EpUniToken "->" "→") + `extQ` considerEqual @(EpUniToken "::" "∷") + `extQ` considerEqual @EpLinearArrow ) x y @@ -141,7 +144,10 @@ diffHsModule = genericQuery GenLocated e0 e1 -> GenericQ ParseResultDiff forLocated x@(L mspn _) y = - maybe id appendSpan (cast `ext1Q` (Just . locA) $ mspn) (genericQuery x y) + maybe id appendSpan (cast `ext1Q` (Just . epAnnLoc) $ mspn) (genericQuery x y) + where + epAnnLoc :: EpAnn ann -> SrcSpan + epAnnLoc = locA appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff appendSpan s' d@(Different ss) = case s' of diff --git a/src/Ormolu/Diff/Text.hs b/src/Ormolu/Diff/Text.hs index 94c8de086..bd708f981 100644 --- a/src/Ormolu/Diff/Text.hs +++ b/src/Ormolu/Diff/Text.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QualifiedDo #-} @@ -17,13 +18,15 @@ import Data.Algorithm.Diff qualified as D import Data.Foldable (for_) import Data.IntSet (IntSet) import Data.IntSet qualified as IntSet -import Data.List (foldl') import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as T import GHC.Types.SrcLoc import Ormolu.Terminal import Ormolu.Terminal.QualifiedDo qualified as Term +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif ---------------------------------------------------------------------------- -- Types diff --git a/src/Ormolu/Fixity/Imports.hs b/src/Ormolu/Fixity/Imports.hs index bb5be97b8..c0c26d65e 100644 --- a/src/Ormolu/Fixity/Imports.hs +++ b/src/Ormolu/Fixity/Imports.hs @@ -69,10 +69,10 @@ extractFixityImport ImportDecl {..} = ieToOccNames :: IE GhcPs -> [OccName] ieToOccNames = \case - IEVar _ (L _ x) -> [occName x] - IEThingAbs _ (L _ x) -> [occName x] - IEThingAll _ (L _ x) -> [occName x] -- TODO not quite correct, but how to do better? - IEThingWith _ (L _ x) _ xs -> occName x : fmap (occName . unLoc) xs + IEVar _ (L _ x) _ -> [occName x] + IEThingAbs _ (L _ x) _ -> [occName x] + IEThingAll _ (L _ x) _ -> [occName x] -- TODO not quite correct, but how to do better? + IEThingWith _ (L _ x) _ xs _ -> occName x : fmap (occName . unLoc) xs _ -> [] -- | Apply given module re-exports. diff --git a/src/Ormolu/Fixity/Parser.hs b/src/Ormolu/Fixity/Parser.hs index 16bdb7c44..01cac4fc7 100644 --- a/src/Ormolu/Fixity/Parser.hs +++ b/src/Ormolu/Fixity/Parser.hs @@ -45,6 +45,17 @@ import Text.Megaparsec.Char.Lexer qualified as L type Parser = Parsec Void Text +-- TODO Support fixity namespacing? +-- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0065-type-infix.rst +-- +-- Note that currently, our fixity machinery does *not* do any namespacing: +-- +-- - https://github.com/tweag/ormolu/pull/994#pullrequestreview-1396958951 +-- brought this up in the past +-- +-- - https://github.com/tweag/ormolu/pull/1029#issue-1718217029 +-- has a concrete example (morley-prelude) where namespacing would matter + -- | Parse textual representation of 'FixityOverrides'. parseDotOrmolu :: -- | Location of the file we are parsing (only for parse errors) diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs index 9f476015d..71140eb06 100644 --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -13,7 +14,7 @@ where import Data.Bifunctor import Data.Char (isAlphaNum) import Data.Function (on) -import Data.List (foldl', nubBy, sortBy, sortOn) +import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as M import GHC.Data.FastString @@ -24,6 +25,9 @@ import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Utils (notImplemented, showOutputable) +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif -- | Sort and normalize imports. normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] @@ -138,33 +142,34 @@ normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty alter = \case Nothing -> Just . L new_l $ case new of - IEThingWith _ n wildcard g -> - IEThingWith (Nothing, EpAnnNotUsed) n wildcard (normalizeWNames g) + IEThingWith x n wildcard g _ -> + IEThingWith x n wildcard (normalizeWNames g) Nothing other -> other Just old -> let f = \case - IEVar _ n -> IEVar Nothing n - IEThingAbs _ _ -> new - IEThingAll _ n -> IEThingAll (Nothing, EpAnnNotUsed) n - IEThingWith _ n wildcard g -> + IEVar _ n _ -> IEVar Nothing n Nothing + IEThingAbs _ _ _ -> new + IEThingAll x n _ -> IEThingAll x n Nothing + IEThingWith _ n wildcard g _ -> case new of - IEVar _ _ -> + IEVar _ _ _ -> error "Ormolu.Imports broken presupposition" - IEThingAbs _ _ -> - IEThingWith (Nothing, EpAnnNotUsed) n wildcard g - IEThingAll _ n' -> - IEThingAll (Nothing, EpAnnNotUsed) n' - IEThingWith _ n' wildcard' g' -> + IEThingAbs x _ _ -> + IEThingWith x n wildcard g Nothing + IEThingAll x n' _ -> + IEThingAll x n' Nothing + IEThingWith x n' wildcard' g' _ -> let combinedWildcard = case (wildcard, wildcard') of (IEWildcard _, _) -> IEWildcard 0 (_, IEWildcard _) -> IEWildcard 0 _ -> NoIEWildcard in IEThingWith - (Nothing, EpAnnNotUsed) + x n' combinedWildcard (normalizeWNames (g <> g')) + Nothing IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" @@ -187,10 +192,10 @@ instance Ord IEWrappedNameOrd where -- | Project @'IEWrappedName' 'GhcPs'@ from @'IE' 'GhcPs'@. getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case - IEVar _ x -> IEWrappedNameOrd (unLoc x) - IEThingAbs _ x -> IEWrappedNameOrd (unLoc x) - IEThingAll _ x -> IEWrappedNameOrd (unLoc x) - IEThingWith _ x _ _ -> IEWrappedNameOrd (unLoc x) + IEVar _ x _ -> IEWrappedNameOrd (unLoc x) + IEThingAbs _ x _ -> IEWrappedNameOrd (unLoc x) + IEThingAll _ x _ -> IEWrappedNameOrd (unLoc x) + IEThingWith _ x _ _ _ -> IEWrappedNameOrd (unLoc x) IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs index 14dd69c51..10a43456f 100644 --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -212,7 +212,7 @@ normalizeModule hsmod = patchContext :: LHsContext GhcPs -> LHsContext GhcPs patchContext = fmap $ \case [x@(L _ (HsParTy _ _))] -> [x] - [x@(L lx _)] -> [L lx (HsParTy EpAnnNotUsed x)] + [x@(L lx _)] -> [L lx (HsParTy noAnn x)] xs -> xs -- | Enable all language extensions that we think should be enabled by diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs index 4dcd4a84d..58d01ef6f 100644 --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -223,7 +223,7 @@ extractPragmas input = go initialLs id id -- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'. unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text) -unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) = +unAnnotationComment (L epaLoc (GHC.EpaComment eck _)) = case eck of GHC.EpaDocComment s -> let trigger = case s of @@ -239,9 +239,10 @@ unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) = "---" -> s _ -> insertAt " " s 3 GHC.EpaBlockComment s -> mkL (T.pack s) - GHC.EpaEofComment -> Nothing where - mkL = Just . L anchor + mkL = case epaLoc of + GHC.EpaSpan (RealSrcSpan s _) -> Just . L s + _ -> const Nothing insertAt x xs n = T.take (n - 1) xs <> x <> T.drop (n - 1) xs haddock mtrigger = mkL . dashPrefix . escapeHaddockTriggers . (trigger <>) <=< dropBlank diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs index f8be7747e..46150f2d2 100644 --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -11,6 +11,7 @@ module Ormolu.Printer.Combinators runR, getEnclosingSpan, getEnclosingSpanWhere, + getEnclosingComments, isExtensionEnabled, -- * Combinators @@ -76,10 +77,10 @@ import Control.Monad import Data.List (intersperse) import Data.Text (Text) import GHC.Data.Strict qualified as Strict +import GHC.Parser.Annotation import GHC.Types.SrcLoc import Ormolu.Printer.Comments import Ormolu.Printer.Internal -import Ormolu.Utils (HasSrcSpan (..), getLoc') ---------------------------------------------------------------------------- -- Basic @@ -99,13 +100,13 @@ inciIf b m = if b then inci m else m -- 'Located' wrapper, it should be “discharged” with a corresponding -- 'located' invocation. located :: - (HasSrcSpan l) => + (HasLoc l) => -- | Thing to enter GenLocated l a -> -- | How to render inner value (a -> R ()) -> R () -located (L l' a) f = case loc' l' of +located (L l' a) f = case locA l' of UnhelpfulSpan _ -> f a RealSrcSpan l _ -> do spitPrecedingComments l @@ -117,7 +118,7 @@ located (L l' a) f = case loc' l' of -- virtual elements at the start and end of the source span to prevent comments -- from "floating out". encloseLocated :: - (HasSrcSpan l) => + (HasLoc l) => GenLocated l [a] -> ([a] -> R ()) -> R () @@ -126,13 +127,13 @@ encloseLocated la f = located la $ \a -> do f a when (null a) $ located (L endSpan ()) pure where - l = getLoc' la + l = locA la (startLoc, endLoc) = (srcSpanStart l, srcSpanEnd l) (startSpan, endSpan) = (mkSrcSpan startLoc startLoc, mkSrcSpan endLoc endLoc) -- | A version of 'located' with arguments flipped. located' :: - (HasSrcSpan l) => + (HasLoc l) => -- | How to render inner value (a -> R ()) -> -- | Thing to enter diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs index a1fadd8b0..2fc2c2172 100644 --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -37,6 +37,7 @@ module Ormolu.Printer.Internal trimSpanStream, nextEltSpan, popComment, + getEnclosingComments, getEnclosingSpan, getEnclosingSpanWhere, withEnclosingSpan, @@ -59,6 +60,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Bool (bool) import Data.Coerce +import Data.Functor ((<&>)) import Data.List (find) import Data.Maybe (listToMaybe) import Data.Text (Text) @@ -500,6 +502,16 @@ popComment f = R $ do return $ Just x _ -> return Nothing +-- | Get the comments contained in the enclosing span. +getEnclosingComments :: R [LComment] +getEnclosingComments = do + isEnclosed <- + getEnclosingSpan <&> \case + Just enclSpan -> containsSpan enclSpan + Nothing -> const False + CommentStream cstream <- R $ gets scCommentStream + pure $ takeWhile (isEnclosed . getLoc) cstream + -- | Get the immediately enclosing 'RealSrcSpan'. getEnclosingSpan :: R (Maybe RealSrcSpan) getEnclosingSpan = getEnclosingSpanWhere (const True) diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs index 6e440783a..a117be2a3 100644 --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -13,12 +13,14 @@ module Ormolu.Printer.Meat.Common p_hsDoc, p_hsDocName, p_sourceText, + p_namespaceSpec, ) where import Control.Monad import Data.Text qualified as T import GHC.Data.FastString +import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp @@ -66,18 +68,16 @@ p_ieWrappedName = \case p_rdrName :: LocatedN RdrName -> R () p_rdrName l = located l $ \x -> do unboxedSums <- isExtensionEnabled UnboxedSums - let wrapper = \case - EpAnn {anns} -> case anns of - NameAnnQuote {nann_quoted} -> tickPrefix . wrapper (ann nann_quoted) - NameAnn {nann_adornment = NameParens} -> - parens N . handleUnboxedSumsAndHashInteraction - NameAnn {nann_adornment = NameBackquotes} -> backticks - -- whether the `->` identifier is parenthesized - NameAnnRArrow {nann_mopen = Just _} -> parens N - -- special case for unboxed unit tuples - NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)" - _ -> id - EpAnnNotUsed -> id + let wrapper EpAnn {anns} = case anns of + NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted + NameAnn {nann_adornment = NameParens} -> + parens N . handleUnboxedSumsAndHashInteraction + NameAnn {nann_adornment = NameBackquotes} -> backticks + -- whether the `->` identifier is parenthesized + NameAnnRArrow {nann_mopen = Just _} -> parens N + -- special case for unboxed unit tuples + NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)" + _ -> id -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to -- insert spaces when we have a parenthesized operator starting with `#`. @@ -88,7 +88,7 @@ p_rdrName l = located l $ \x -> do \y -> space *> y <* space | otherwise = id - wrapper (ann . getLoc $ l) $ case x of + wrapper (getLoc l) $ case x of Unqual occName -> atom occName Qual mname occName -> @@ -192,3 +192,9 @@ p_sourceText :: SourceText -> R () p_sourceText = \case NoSourceText -> pure () SourceText s -> atom @FastString s + +p_namespaceSpec :: NamespaceSpecifier -> R () +p_namespaceSpec = \case + NoNamespaceSpecifier -> pure () + TypeNamespaceSpecifier _ -> txt "type" *> space + DataNamespaceSpecifier _ -> txt "data" *> space diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs index f64336233..a2d3e43e8 100644 --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -260,7 +260,7 @@ pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ (TypeAnnProvenance (L _ n)) _) pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _) pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _)) pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _) -pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ _ (L _ n) _ _ _ _ _ _ _ _) +pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _) pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) @@ -296,7 +296,7 @@ defSigRdrNames _ = Nothing funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] funRdrNames (ValD _ (FunBind _ (L _ n) _)) = Just [n] -funRdrNames (ValD _ (PatBind _ (L _ n) _)) = Just $ patBindNames n +funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n funRdrNames _ = Nothing patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] @@ -315,9 +315,9 @@ patBindNames (VarPat _ (L _ n)) = [n] patBindNames (WildPat _) = [] patBindNames (LazyPat _ (L _ p)) = patBindNames p patBindNames (BangPat _ (L _ p)) = patBindNames p -patBindNames (ParPat _ _ (L _ p) _) = patBindNames p +patBindNames (ParPat _ (L _ p)) = patBindNames p patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps -patBindNames (AsPat _ (L _ n) _ (L _ p)) = n : patBindNames p +patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p patBindNames (SumPat _ (L _ p) _ _) = patBindNames p patBindNames (ViewPat _ _ (L _ p)) = patBindNames p patBindNames (SplicePat _ _) = [] @@ -326,3 +326,5 @@ patBindNames (SigPat _ (L _ p) _) = patBindNames p patBindNames (NPat _ _ _ _) = [] patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n] patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d) +patBindNames (EmbTyPat _ _) = [] +patBindNames (InvisPat _ _) = [] diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs index 0bd0dc82d..2b626e206 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -13,7 +13,7 @@ where import Control.Monad import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE -import Data.Maybe (isJust, maybeToList) +import Data.Maybe (isJust, mapMaybe, maybeToList) import Data.Void import GHC.Data.Strict qualified as Strict import GHC.Hs @@ -139,8 +139,8 @@ p_conDecl singleConstRec = \case <> conArgsSpans where conArgsSpans = case con_g_args of - PrefixConGADT xs -> getLocA . hsScaledThing <$> xs - RecConGADT x _ -> [getLocA x] + PrefixConGADT NoExtField xs -> getLocA . hsScaledThing <$> xs + RecConGADT _ x -> [getLocA x] switchLayout conDeclSpn $ do let c :| cs = con_names p_rdrName c @@ -149,23 +149,24 @@ p_conDecl singleConstRec = \case sep commaDel p_rdrName cs inci $ do let conTy = case con_g_args of - PrefixConGADT xs -> - let go (HsScaled a b) t = addCLocAA t b (HsFunTy EpAnnNotUsed a b t) + PrefixConGADT NoExtField xs -> + let go (HsScaled a b) t = addCLocA t b (HsFunTy NoExtField a b t) in foldr go con_res_ty xs - RecConGADT r _ -> - addCLocAA r con_res_ty $ + RecConGADT _ r -> + addCLocA r con_res_ty $ HsFunTy - EpAnnNotUsed - (HsUnrestrictedArrow noHsUniTok) - (la2la $ HsRecTy EpAnnNotUsed <$> r) + NoExtField + (HsUnrestrictedArrow noAnn) + (la2la $ HsRecTy noAnn <$> r) con_res_ty qualTy = case con_mb_cxt of Nothing -> conTy Just qs -> - addCLocAA qs conTy $ + addCLocA qs conTy $ HsQualTy NoExtField qs conTy + quantifiedTy :: LHsType GhcPs quantifiedTy = - addCLocAA con_bndrs qualTy $ + addCLocA con_bndrs qualTy $ hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy space txt "::" @@ -178,7 +179,8 @@ p_conDecl singleConstRec = \case let conNameSpn = getLocA con_name conNameWithContextSpn = [ RealSrcSpan real Strict.Nothing - | Just (EpaSpan real _) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext + | EpaSpan (RealSrcSpan real _) <- + mapMaybe (matchAddEpAnn AnnForall) con_ext ] <> fmap getLocA con_ex_tvs <> maybeToList (fmap getLocA con_mb_cxt) diff --git a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs index b808a33b9..60d869540 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs @@ -55,7 +55,7 @@ p_foreignImport (CImport sourceText cCallConv safety _ _) = do space located cCallConv atom -- Need to check for 'noLoc' for the 'safe' annotation - when (isGoodSrcSpan $ getLoc safety) (space >> atom safety) + when (isGoodSrcSpan $ getLocA safety) (space >> atom safety) space located sourceText p_sourceText diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs index 1487f6f8f..8fd643a9f 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -15,6 +15,7 @@ import Control.Monad import Data.Foldable import Data.Function (on) import Data.List (sortBy) +import Data.Maybe (maybeToList) import GHC.Hs import GHC.Types.Basic import GHC.Types.SrcLoc @@ -23,13 +24,17 @@ import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import Ormolu.Printer.Meat.Declaration.Data import Ormolu.Printer.Meat.Declaration.TypeFamily +import Ormolu.Printer.Meat.Declaration.Warning import Ormolu.Printer.Meat.Type p_standaloneDerivDecl :: DerivDecl GhcPs -> R () -p_standaloneDerivDecl DerivDecl {..} = do +p_standaloneDerivDecl DerivDecl {deriv_ext = (mWarnTxt, _), ..} = do let typesAfterInstance = located (hswc_body deriv_type) p_hsSigType instTypes toIndent = inci $ do txt "instance" + for_ mWarnTxt $ \warnTxt -> do + breakpoint + located warnTxt p_warningTxt breakpoint match_overlap_mode deriv_overlap_mode breakpoint inciIf toIndent typesAfterInstance @@ -56,7 +61,7 @@ p_standaloneDerivDecl DerivDecl {..} = do instTypes True p_clsInstDecl :: ClsInstDecl GhcPs -> R () -p_clsInstDecl ClsInstDecl {..} = do +p_clsInstDecl ClsInstDecl {cid_ext = (mWarnTxt, _, _), ..} = do txt "instance" -- GHC's AST does not necessarily store each kind of element in source -- location order. This happens because different declarations are stored in @@ -74,9 +79,12 @@ p_clsInstDecl ClsInstDecl {..} = do <$> cid_datafam_insts allDecls = snd <$> sortBy (leftmost_smallest `on` fst) (sigs <> vals <> tyFamInsts <> dataFamInsts) - located cid_poly_ty $ \sigTy -> do + switchLayout (maybeToList (getLocA <$> mWarnTxt) <> [getLocA cid_poly_ty]) $ do + for_ mWarnTxt $ \warnTxt -> do + breakpoint + located warnTxt p_warningTxt breakpoint - inci $ do + located cid_poly_ty $ \sigTy -> inci $ do match_overlap_mode cid_overlap_mode breakpoint p_hsSigType sigTy unless (null allDecls) $ do diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs index c3f46ed27..e953fcc8e 100644 --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -34,7 +34,6 @@ import Ormolu.Printer.Meat.Declaration.Value ) import Ormolu.Printer.Meat.Type (p_hsType) import Ormolu.Printer.Operators -import Ormolu.Utils (HasSrcSpan) -- | Extract the operator name of the specified 'HsExpr' if this expression -- corresponds to an operator. @@ -49,7 +48,7 @@ getOpNameStr = occNameString . rdrNameOcc -- | Decide if the operands of an operator chain should be hanging. opBranchPlacement :: - (HasSrcSpan l) => + (HasLoc l) => -- | Placer function for nodes (ty -> Placement) -> -- | first expression of the chain diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs index 376140383..6f876e29d 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -93,7 +93,7 @@ p_fixSig :: FixitySig GhcPs -> R () p_fixSig = \case - FixitySig NoExtField names (Fixity _ n dir) -> do + FixitySig namespace names (Fixity _ n dir) -> do txt $ case dir of InfixL -> "infixl" InfixR -> "infixr" @@ -101,6 +101,7 @@ p_fixSig = \case space atom n space + p_namespaceSpec namespace sitcc $ sep commaDel p_rdrName names p_inlineSig :: @@ -198,12 +199,12 @@ p_booleanFormula = \case p_completeSig :: -- | Constructors\/patterns - Located [LocatedN RdrName] -> + [LIdP GhcPs] -> -- | Type Maybe (LocatedN RdrName) -> R () -p_completeSig cs' mty = - located cs' $ \cs -> +p_completeSig cs mty = + switchLayout (getLocA <$> cs) $ pragma "COMPLETE" . inci $ do sep commaDel p_rdrName cs forM_ mty $ \ty -> do diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs index 810e9c943..ae7e8e447 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -69,7 +69,8 @@ data GroupStyle p_valDecl :: HsBind GhcPs -> R () p_valDecl = \case FunBind _ funId funMatches -> p_funBind funId funMatches - PatBind _ pat grhss -> p_match PatternBind False NoSrcStrict [pat] grhss + PatBind _ pat multAnn grhss -> + p_match PatternBind False multAnn NoSrcStrict [pat] grhss VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker PatSynBind _ psb -> p_patSynBind psb @@ -86,7 +87,7 @@ p_matchGroup :: p_matchGroup = p_matchGroup' exprPlacement p_hsExpr p_matchGroup' :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, + ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => -- | How to get body placement @@ -116,6 +117,7 @@ p_matchGroup' placer render style mg@MG {..} = do render (adjustMatchGroupStyle m style) (isInfixMatch m) + (HsNoMultAnn NoExtField) (matchStrictness m) m_pats m_grhss @@ -145,6 +147,8 @@ p_match :: MatchGroupStyle -> -- | Is this an infix match? Bool -> + -- | Multiplicity annotation + HsMultAnn GhcPs -> -- | Strictness prefix (FunBind) SrcStrictness -> -- | Argument patterns @@ -155,7 +159,7 @@ p_match :: p_match = p_match' exprPlacement p_hsExpr p_match' :: - (Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns) => + (Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO) => -- | How to get body placement (body -> Placement) -> -- | How to print body @@ -164,6 +168,8 @@ p_match' :: MatchGroupStyle -> -- | Is this an infix match? Bool -> + -- | Multiplicity annotation + HsMultAnn GhcPs -> -- | Strictness prefix (FunBind) SrcStrictness -> -- | Argument patterns @@ -171,7 +177,7 @@ p_match' :: -- | Equations GRHSs GhcPs (LocatedA body) -> R () -p_match' placer render style isInfix strictness m_pats GRHSs {..} = do +p_match' placer render style isInfix multAnn strictness m_pats GRHSs {..} = do -- Normally, since patterns may be placed in a multi-line layout, it is -- necessary to bump indentation for the pattern group so it's more -- indented than function name. This in turn means that indentation for @@ -179,6 +185,13 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do -- would start with two indentation steps applied, which is ugly, so we -- need to be a bit more clever here and bump indentation level only when -- pattern group is multiline. + case multAnn of + HsNoMultAnn NoExtField -> pure () + HsPct1Ann _ -> txt "%1" *> space + HsMultAnn _ ty -> do + txt "%" + located ty p_hsType + space case strictness of NoSrcStrict -> return () SrcStrict -> txt "!" @@ -210,6 +223,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do LazyPat _ _ -> True BangPat _ _ -> True SplicePat _ _ -> True + InvisPat _ _ -> True _ -> False txt "\\" when needsSpace space @@ -358,15 +372,13 @@ p_hsCmd' isApp s = \case located cmd (p_hsCmd' Applicand s) breakpoint inci $ located expr p_hsExpr - HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup - HsCmdPar _ _ c _ -> parens N (located c p_hsCmd) + HsCmdLam _ variant mgroup -> p_lam isApp variant cmdPlacement p_hsCmd mgroup + HsCmdPar _ c -> parens N (located c p_hsCmd) HsCmdCase _ e mgroup -> p_case isApp cmdPlacement p_hsCmd e mgroup - HsCmdLamCase _ variant mgroup -> - p_lamcase isApp variant cmdPlacement p_hsCmd mgroup HsCmdIf anns _ if' then' else' -> p_if cmdPlacement p_hsCmd anns if' then' else' - HsCmdLet _ _ localBinds _ c -> + HsCmdLet _ localBinds c -> p_let p_hsCmd localBinds c HsCmdDo _ es -> do txt "do" @@ -551,11 +563,10 @@ p_hsLocalBinds = \case -- of p_hsLocalBinds). Hence, we introduce a manual Located as we -- depend on the layout being correctly set. pseudoLocated = \case - EpAnn {anns = AnnList {al_anchor = Just Anchor {anchor}}} - | let sp = RealSrcSpan anchor Strict.Nothing, - -- excluding cases where there are no bindings - not $ isZeroWidthSpan sp -> - located (L sp ()) . const + EpAnn {anns = AnnList {al_anchor}} + | -- excluding cases where there are no bindings + not $ isZeroWidthSpan (locA al_anchor) -> + located (L al_anchor ()) . const _ -> id p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R () @@ -569,7 +580,7 @@ p_fieldOcc :: FieldOcc GhcPs -> R () p_fieldOcc FieldOcc {..} = p_rdrName foLabel p_hsFieldBind :: - (lhs ~ GenLocated l a, HasSrcSpan l) => + (lhs ~ GenLocated l a, HasLoc l) => (lhs -> R ()) -> HsFieldBind lhs (LHsExpr GhcPs) -> R () @@ -579,7 +590,7 @@ p_hsFieldBind p_lhs HsFieldBind {..} = do space equals let placement = - if onTheSameLine (getLoc' hfbLHS) (getLocA hfbRHS) + if onTheSameLine (getLocA hfbLHS) (getLocA hfbRHS) then exprPlacement (unLoc hfbRHS) else Normal placeHanging placement (located hfbRHS p_hsExpr) @@ -618,10 +629,8 @@ p_hsExpr' isApp s = \case HsString (SourceText stxt) _ -> p_stringLit stxt HsStringPrim (SourceText stxt) _ -> p_stringLit stxt r -> atom r - HsLam _ mgroup -> - p_matchGroup Lambda mgroup - HsLamCase _ variant mgroup -> - p_lamcase isApp variant exprPlacement p_hsExpr mgroup + HsLam _ variant mgroup -> + p_lam isApp variant exprPlacement p_hsExpr mgroup HsApp _ f x -> do let -- In order to format function applications with multiple parameters -- nicer, traverse the AST to gather the function and all the @@ -667,7 +676,7 @@ p_hsExpr' isApp s = \case sep breakpoint (located' p_hsExpr) initp placeHanging placement $ located lastp p_hsExpr - HsAppType _ e _ a -> do + HsAppType _ e a -> do located e p_hsExpr breakpoint inci $ do @@ -696,7 +705,7 @@ p_hsExpr' isApp s = \case -- negated literals, as `- 1` and `-1` have differing AST. when (negativeLiterals && isLiteral) space located e p_hsExpr - HsPar _ _ e _ -> + HsPar _ e -> parens s (located e (dontUseBraces . p_hsExpr)) SectionL _ x op -> do located x p_hsExpr @@ -739,7 +748,7 @@ p_hsExpr' isApp s = \case txt "if" breakpoint inciApplicand isApp $ sep newline (located' (p_grhs RightArrow)) guards - HsLet _ _ localBinds _ e -> + HsLet _ localBinds e -> p_let p_hsExpr localBinds e HsDo _ doFlavor es -> do let doBody moduleName header = do @@ -840,7 +849,7 @@ p_hsExpr' isApp s = \case located expr p_hsExpr breakpoint' txt "||]" - HsUntypedBracket epAnn x -> p_hsQuote epAnn x + HsUntypedBracket anns x -> p_hsQuote anns x HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice HsProc _ p e -> do @@ -864,6 +873,10 @@ p_hsExpr' isApp s = \case breakpoint let inciIfS = case s of N -> id; S -> inci inciIfS $ located x p_hsExpr + HsEmbTy _ HsWC {hswc_body} -> do + txt "type" + space + located hswc_body p_hsType p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do @@ -925,7 +938,7 @@ p_patSynBind PSB {..} = do inci (rhs conSpans) p_case :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, + ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => IsApplicand -> @@ -947,13 +960,13 @@ p_case isApp placer render e mgroup = do breakpoint inciApplicand isApp (p_matchGroup' placer render Case mgroup) -p_lamcase :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, +p_lam :: + ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => IsApplicand -> - -- | Variant (@\\case@ or @\\cases@) - LamCaseVariant -> + -- | Variant (@\\@ or @\\case@ or @\\cases@) + HsLamVariant -> -- | Placer (body -> Placement) -> -- | Render @@ -961,12 +974,19 @@ p_lamcase :: -- | Expression MatchGroup GhcPs (LocatedA body) -> R () -p_lamcase isApp variant placer render mgroup = do - txt $ case variant of - LamCase -> "\\case" - LamCases -> "\\cases" - breakpoint - inciApplicand isApp (p_matchGroup' placer render LambdaCase mgroup) +p_lam isApp variant placer render mgroup = do + let mCaseTxt = case variant of + LamSingle -> Nothing + LamCase -> Just "\\case" + LamCases -> Just "\\cases" + mgs = if isJust mCaseTxt then LambdaCase else Lambda + pMatchGroup = p_matchGroup' placer render mgs mgroup + case mCaseTxt of + Nothing -> pMatchGroup + Just caseTxt -> do + txt caseTxt + breakpoint + inciApplicand isApp pMatchGroup p_if :: -- | Placer @@ -974,7 +994,7 @@ p_if :: -- | Render (body -> R ()) -> -- | Annotations - EpAnn AnnsIf -> + AnnsIf -> -- | If LHsExpr GhcPs -> -- | Then @@ -982,11 +1002,30 @@ p_if :: -- | Else LocatedA body -> R () -p_if placer render epAnn if' then' else' = do +p_if placer render anns if' then' else' = do txt "if" space located if' p_hsExpr breakpoint + commentSpans <- fmap getLoc <$> getEnclosingComments + let (thenSpan, elseSpan) = (locA aiThen, locA aiElse) + where + AnnsIf {aiThen, aiElse} = anns + + locatedToken tokenSpan token = + located (L tokenSpan ()) $ \_ -> txt token + + betweenSpans spanA spanB s = spanA < s && s < spanB + + placeHangingLocated tokenSpan bodyLoc@(L _ body) = do + let bodySpan = getLocA bodyLoc + hasComments = fromMaybe False $ do + tokenRealSpan <- srcSpanToRealSrcSpan tokenSpan + bodyRealSpan <- srcSpanToRealSrcSpan bodySpan + pure $ any (betweenSpans tokenRealSpan bodyRealSpan) commentSpans + placement = if hasComments then Normal else placer body + switchLayout [tokenSpan, bodySpan] $ + placeHanging placement (located bodyLoc render) inci $ do locatedToken thenSpan "then" space @@ -995,34 +1034,6 @@ p_if placer render epAnn if' then' else' = do locatedToken elseSpan "else" space placeHangingLocated elseSpan else' - where - (thenSpan, elseSpan, commentSpans) = - case epAnn of - EpAnn {anns = AnnsIf {aiThen, aiElse}, comments} -> - ( loc' $ epaLocationRealSrcSpan aiThen, - loc' $ epaLocationRealSrcSpan aiElse, - map (anchor . getLoc) $ - case comments of - EpaComments cs -> cs - EpaCommentsBalanced pre post -> pre <> post - ) - EpAnnNotUsed -> - (noSrcSpan, noSrcSpan, []) - - locatedToken tokenSpan token = - located (L tokenSpan ()) $ \_ -> txt token - - betweenSpans spanA spanB s = spanA < s && s < spanB - - placeHangingLocated tokenSpan bodyLoc@(L _ body) = do - let bodySpan = getLoc' bodyLoc - hasComments = fromMaybe False $ do - tokenRealSpan <- srcSpanToRealSrcSpan tokenSpan - bodyRealSpan <- srcSpanToRealSrcSpan bodySpan - pure $ any (betweenSpans tokenRealSpan bodyRealSpan) commentSpans - placement = if hasComments then Normal else placer body - switchLayout [tokenSpan, bodySpan] $ - placeHanging placement (located bodyLoc render) p_let :: -- | Render @@ -1046,11 +1057,11 @@ p_pat = \case LazyPat _ pat -> do txt "~" located pat p_pat - AsPat _ name _ pat -> do + AsPat _ name pat -> do p_rdrName name txt "@" located pat p_pat - ParPat _ _ pat _ -> + ParPat _ pat -> located pat (parens S . p_pat) BangPat _ pat -> do txt "!" @@ -1115,12 +1126,17 @@ p_pat = \case SigPat _ pat HsPS {..} -> do located pat p_pat p_typeAscription (lhsTypeToSigType hsps_body) + EmbTyPat _ (HsTP _ ty) -> do + txt "type" + space + located ty p_hsType + InvisPat _ tyPat -> p_tyPat tyPat -p_hsPatSigType :: HsPatSigType GhcPs -> R () -p_hsPatSigType (HsPS _ ty) = txt "@" *> located ty p_hsType +p_tyPat :: HsTyPat GhcPs -> R () +p_tyPat (HsTP _ ty) = txt "@" *> located ty p_hsType p_hsConPatTyArg :: HsConPatTyArg GhcPs -> R () -p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_hsPatSigType patSigTy +p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_tyPat patSigTy p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () p_pat_hsFieldBind HsFieldBind {..} = do @@ -1175,11 +1191,11 @@ p_hsSpliceTH isTyped expr = \case where decoSymbol = if isTyped then "$$" else "$" -p_hsQuote :: EpAnn [AddEpAnn] -> HsQuote GhcPs -> R () -p_hsQuote epAnn = \case +p_hsQuote :: [AddEpAnn] -> HsQuote GhcPs -> R () +p_hsQuote anns = \case ExpBr _ expr -> do let name - | any isJust (matchAddEpAnn AnnOpenEQ <$> epAnnAnns epAnn) = "" + | any (isJust . matchAddEpAnn AnnOpenEQ) anns = "" | otherwise = "e" quote name (located expr p_hsExpr) PatBr _ pat -> located pat (quote "p" . p_pat) @@ -1288,10 +1304,9 @@ blockPlacement _ _ = Normal -- | Determine placement of a given command. cmdPlacement :: HsCmd GhcPs -> Placement cmdPlacement = \case - HsCmdLam _ _ -> Hanging - HsCmdCase _ _ _ -> Hanging - HsCmdLamCase _ _ _ -> Hanging - HsCmdDo _ _ -> Hanging + HsCmdLam {} -> Hanging + HsCmdCase {} -> Hanging + HsCmdDo {} -> Hanging _ -> Normal -- | Determine placement of a top level command. @@ -1302,12 +1317,14 @@ cmdTopPlacement (HsCmdTop _ (L _ x)) = cmdPlacement x exprPlacement :: HsExpr GhcPs -> Placement exprPlacement = \case -- Only hang lambdas with single line parameter lists - HsLam _ mg -> case mg of - MG _ (L _ [L _ (Match _ _ (x : xs) _)]) - | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> - Hanging - _ -> Normal - HsLamCase _ _ _ -> Hanging + HsLam _ variant mg -> case variant of + LamSingle -> case mg of + MG _ (L _ [L _ (Match _ _ (x : xs) _)]) + | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> + Hanging + _ -> Normal + LamCase -> Hanging + LamCases -> Hanging HsCase _ _ _ -> Hanging HsDo _ (DoExpr _) _ -> Hanging HsDo _ (MDoExpr _) _ -> Hanging diff --git a/src/Ormolu/Printer/Meat/Declaration/Warning.hs b/src/Ormolu/Printer/Meat/Declaration/Warning.hs index 5a209bffa..d819c395b 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Warning.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Warning.hs @@ -12,7 +12,6 @@ import Data.Foldable import Data.Text (Text) import Data.Text qualified as T import GHC.Hs -import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Warnings @@ -25,24 +24,21 @@ p_warnDecls (Warnings _ warnings) = traverse_ (located' p_warnDecl) warnings p_warnDecl :: WarnDecl GhcPs -> R () -p_warnDecl (Warning _ functions warningTxt) = - p_topLevelWarning functions warningTxt - -p_warningTxt :: WarningTxt GhcPs -> R () -p_warningTxt wtxt = do - let (pragmaText, lits) = warningText wtxt - inci $ pragma pragmaText $ inci $ p_lits lits - -p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt GhcPs -> R () -p_topLevelWarning fnames wtxt = do +p_warnDecl (Warning (namespace, _) fnames wtxt) = do let (pragmaText, lits) = warningText wtxt - switchLayout (fmap getLocA fnames ++ fmap getLoc lits) $ + switchLayout (fmap getLocA fnames ++ fmap getLocA lits) $ pragma pragmaText . inci $ do + p_namespaceSpec namespace sep commaDel p_rdrName fnames breakpoint p_lits lits -warningText :: WarningTxt GhcPs -> (Text, [Located StringLiteral]) +p_warningTxt :: WarningTxt GhcPs -> R () +p_warningTxt wtxt = do + let (pragmaText, lits) = warningText wtxt + inci $ pragma pragmaText $ inci $ p_lits lits + +warningText :: WarningTxt GhcPs -> (Text, [LocatedE StringLiteral]) warningText = \case WarningTxt mcat _ lits -> ("WARNING" <> T.pack cat, fmap hsDocString <$> lits) where @@ -52,7 +48,7 @@ warningText = \case Nothing -> "" DeprecatedTxt _ lits -> ("DEPRECATED", fmap hsDocString <$> lits) -p_lits :: [Located StringLiteral] -> R () +p_lits :: [LocatedE StringLiteral] -> R () p_lits = \case [l] -> atom l ls -> brackets N $ sep commaDel atom ls diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs index 1fc2240b4..bfaa55efa 100644 --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -10,7 +10,7 @@ module Ormolu.Printer.Meat.ImportExport where import Control.Monad -import Data.Foldable (for_) +import Data.Foldable (for_, traverse_) import GHC.Hs import GHC.LanguageExtensions.Type import GHC.Types.PkgQual @@ -26,8 +26,13 @@ p_hsmodExports xs = layout <- getLayout sep breakpoint - (\(p, l) -> sitcc (located l (p_lie layout p))) + (\(p, l) -> sitcc (located (addDocSrcSpan l) (p_lie layout p))) (attachRelativePos xs) + where + -- In order to correctly set the layout when a doc comment is present. + addDocSrcSpan lie@(L l ie) = case ieExportDoc ie of + Nothing -> lie + Just (L l' _) -> L (l <> noAnnSrcSpan l') ie p_hsmodImport :: ImportDecl GhcPs -> R () p_hsmodImport ImportDecl {..} = do @@ -76,33 +81,38 @@ p_hsmodImport ImportDecl {..} = do p_lie :: Layout -> RelativePos -> IE GhcPs -> R () p_lie encLayout relativePos = \case - IEVar mwarn l1 -> do + IEVar mwarn l1 exportDoc -> do for_ mwarn $ \warnTxt -> do located warnTxt p_warningTxt breakpoint located l1 p_ieWrappedName p_comma - IEThingAbs _ l1 -> do + p_exportDoc exportDoc + IEThingAbs _ l1 exportDoc -> do located l1 p_ieWrappedName p_comma - IEThingAll _ l1 -> do + p_exportDoc exportDoc + IEThingAll _ l1 exportDoc -> do located l1 p_ieWrappedName space txt "(..)" p_comma - IEThingWith _ l1 w xs -> sitcc $ do - located l1 p_ieWrappedName - breakpoint - inci $ do - let names :: [R ()] - names = located' p_ieWrappedName <$> xs - parens N . sep commaDel sitcc $ - case w of - NoIEWildcard -> names - IEWildcard n -> - let (before, after) = splitAt n names - in before ++ [txt ".."] ++ after - p_comma + p_exportDoc exportDoc + IEThingWith _ l1 w xs exportDoc -> do + sitcc $ do + located l1 p_ieWrappedName + breakpoint + inci $ do + let names :: [R ()] + names = located' p_ieWrappedName <$> xs + parens N . sep commaDel sitcc $ + case w of + NoIEWildcard -> names + IEWildcard n -> + let (before, after) = splitAt n names + in before ++ [txt ".."] ++ after + p_comma + p_exportDoc exportDoc IEModuleContents _ l1 -> do located l1 p_hsmodName p_comma @@ -126,3 +136,23 @@ p_lie encLayout relativePos = \case MiddlePos -> comma LastPos -> return () MultiLine -> comma + + -- This is used to support `@since` annotations for (re)exported items. It + -- /must/ use caret style comments, see + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12098 and + -- https://github.com/haskell/haddock/issues/1629#issuecomment-1931354411. + p_exportDoc :: Maybe (ExportDoc GhcPs) -> R () + p_exportDoc = traverse_ $ \exportDoc -> do + breakpoint + p_hsDoc Caret False exportDoc + +ieExportDoc :: IE GhcPs -> Maybe (ExportDoc GhcPs) +ieExportDoc = \case + IEVar _ _ doc -> doc + IEThingAbs _ _ doc -> doc + IEThingAll _ _ doc -> doc + IEThingWith _ _ _ _ doc -> doc + IEModuleContents {} -> Nothing + IEGroup {} -> Nothing + IEDoc {} -> Nothing + IEDocNamed {} -> Nothing diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs index fc6ab6bf0..d12178a9d 100644 --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -73,7 +73,7 @@ p_hsType' multilineArgs = \case breakpoint inci $ sep breakpoint (located' p_hsType) args - HsAppKindTy _ ty _ kd -> sitcc $ do + HsAppKindTy _ ty kd -> sitcc $ do -- The first argument is the location of the "@..." part. Not 100% sure, -- but I think we can ignore it as long as we use 'located' on both the -- type and the kind. @@ -88,7 +88,7 @@ p_hsType' multilineArgs = \case case arrow of HsUnrestrictedArrow _ -> txt "->" HsLinearArrow _ -> txt "%1 ->" - HsExplicitMult _ mult _ -> do + HsExplicitMult _ mult -> do txt "%" p_hsTypeR (unLoc mult) space @@ -215,7 +215,7 @@ instance IsTyVarBndrFlag Specificity where instance IsTyVarBndrFlag (HsBndrVis GhcPs) where isInferred _ = False p_tyVarBndrFlag = \case - HsBndrRequired -> pure () + HsBndrRequired NoExtField -> pure () HsBndrInvisible _ -> txt "@" p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R () @@ -236,7 +236,7 @@ data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables. p_forallBndrs :: - (HasSrcSpan l) => + (HasLoc l) => ForAllVisibility -> (a -> R ()) -> [GenLocated l a] -> @@ -244,7 +244,7 @@ p_forallBndrs :: p_forallBndrs ForAllInvis _ [] = txt "forall." p_forallBndrs ForAllVis _ [] = txt "forall ->" p_forallBndrs vis p tyvars = - switchLayout (getLoc' <$> tyvars) $ do + switchLayout (locA <$> tyvars) $ do txt "forall" breakpoint inci $ do @@ -272,7 +272,7 @@ p_conDeclField ConDeclField {..} = do p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case - HsValArg ty -> located ty p_hsType + HsValArg NoExtField ty -> located ty p_hsType -- first argument is the SrcSpan of the @, -- but the @ always has to be directly before the type argument HsTypeArg _ ty -> txt "@" *> located ty p_hsType @@ -294,8 +294,8 @@ hsOuterTyVarBndrsToHsType :: hsOuterTyVarBndrsToHsType obndrs ty = case obndrs of HsOuterImplicit NoExtField -> unLoc ty HsOuterExplicit _ bndrs -> - HsForAllTy NoExtField (mkHsForAllInvisTele EpAnnNotUsed bndrs) ty + HsForAllTy NoExtField (mkHsForAllInvisTele noAnn bndrs) ty lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs lhsTypeToSigType ty = - reLocA . L (getLocA ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty + L (getLoc ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs index debaf1596..35daaf6a2 100644 --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -15,6 +15,7 @@ where import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE +import GHC.Parser.Annotation import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Fixity @@ -81,8 +82,8 @@ compareOp _ -> False -- | Return combined 'SrcSpan's of all elements in this 'OpTree'. -opTreeLoc :: (HasSrcSpan l) => OpTree (GenLocated l a) b -> SrcSpan -opTreeLoc (OpNode n) = getLoc' n +opTreeLoc :: (HasLoc l) => OpTree (GenLocated l a) b -> SrcSpan +opTreeLoc (OpNode n) = getHasLoc n opTreeLoc (OpBranches exprs _) = combineSrcSpans' . fmap opTreeLoc $ exprs diff --git a/src/Ormolu/Printer/SpanStream.hs b/src/Ormolu/Printer/SpanStream.hs index 8c2c0cd3a..8e6e09e58 100644 --- a/src/Ormolu/Printer/SpanStream.hs +++ b/src/Ormolu/Printer/SpanStream.hs @@ -33,7 +33,7 @@ mkSpanStream a = SpanStream . sortOn realSrcSpanStart . toList - $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` querySrcSpanAnn) a + $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` queryEpAnn) a where queryLocated :: (Data e0) => @@ -41,7 +41,9 @@ mkSpanStream a = Seq RealSrcSpan queryLocated (L mspn _) = maybe mempty srcSpanToRealSrcSpanSeq (cast mspn :: Maybe SrcSpan) - querySrcSpanAnn :: SrcSpanAnn' a -> Seq RealSrcSpan - querySrcSpanAnn = srcSpanToRealSrcSpanSeq . locA + + queryEpAnn :: EpAnn ann -> Seq RealSrcSpan + queryEpAnn = srcSpanToRealSrcSpanSeq . locA + srcSpanToRealSrcSpanSeq = Seq.fromList . maybeToList . srcSpanToRealSrcSpan diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs index b4b946c85..b0a5c0119 100644 --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -13,8 +13,6 @@ module Ormolu.Utils separatedByBlank, separatedByBlankNE, onTheSameLine, - HasSrcSpan (..), - getLoc', matchAddEpAnn, textToStringBuffer, ghcModuleNameToCabal, @@ -141,21 +139,6 @@ onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b = isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b)) -class HasSrcSpan l where - loc' :: l -> SrcSpan - -instance HasSrcSpan SrcSpan where - loc' = id - -instance HasSrcSpan RealSrcSpan where - loc' l = RealSrcSpan l Strict.Nothing - -instance HasSrcSpan (SrcSpanAnn' ann) where - loc' = locA - -getLoc' :: (HasSrcSpan l) => GenLocated l a -> SrcSpan -getLoc' = loc' . getLoc - -- | Check whether the given 'AnnKeywordId' or its Unicode variant is in an -- 'AddEpAnn', and return the 'EpaLocation' if so. matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation diff --git a/stack.yaml b/stack.yaml index 6bee76e43..d4c511335 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,11 +1,12 @@ -resolver: nightly-2023-10-09 +resolver: nightly-2024-05-10 packages: - '.' - extract-hackage-info extra-deps: -- ghc-lib-parser-9.8.1.20231009 +- ghc-lib-parser-9.10.1.20240511 +- Cabal-syntax-3.12.0.0 nix: packages: