diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,55 @@ +## Fourmolu 0.10.0.0 + +New options: + +* New `leading-args` option to `function-arrows` configuration that allows leading arrows only for function arguments ([#233](https://github.com/fourmolu/fourmolu/issues/233)) +* Add `haddock-style-module` option ([#135](https://github.com/fourmolu/fourmolu/pull/135)) + +Improvements of existing options: + +* Add unicode formatting for quasiquotes and arrow brackets ([#261](https://github.com/fourmolu/fourmolu/pull/261)) + +Bug fixes: + +* Fix bug with `let-style` changing single-line let-in blocks in `do` blocks to multiline. +* Don't consider the first space after `--` part of the comment ([#255](https://github.com/fourmolu/fourmolu/pull/255)) + +### Upstream changes: + +#### Ormolu 0.5.1.0 + +* Imports are now sorted by package qualifier, if one is present. + [Issue 905](https://github.com/tweag/ormolu/issues/905). + +* Extension packs like `GHC2021` and `Haskell2010` are now bumped to the top of + the list of language pragmas. [Issue + 922](https://github.com/tweag/ormolu/issues/922). + +* Fix formatting of `SCC` pragmas in `do` blocks. [Issue + 925](https://github.com/tweag/ormolu/issues/925). + +* Support type applications in patterns. [Issue + 930](https://github.com/tweag/ormolu/issues/930). + +* Handle `UnicodeSyntax` variants more consistently. [Issue + 934](https://github.com/tweag/ormolu/issues/934). + +* Fix an inconsistency in formatting of types in GADT declarations in + certain cases. [PR 932](https://github.com/tweag/ormolu/pull/932). + +* Switched to `ghc-lib-parser-9.4`, which brings support for the following new + syntactic features: + * `\cases` via `LambdaCase` + * `OPAQUE` pragmas + * Unboxed sum type constructors like `(# | #)`. + +* Updated to `Cabal-syntax-3.8`, supporting `cabal-version: 3.8`. + ## Fourmolu 0.9.0.0 New configuration options: -* Add `let-style` and `in-style` configuration options ([#229](https://github.com/fourmolu/fourmolu/pull/229)). The default is set to `let-style: auto` and `in-style: right-align`, which should not reformat already formatted files, but allows users to format with `newline` without additional configuration. +* Add `let-style` and `in-style` configuration options ([#229](https://github.com/fourmolu/fourmolu/pull/229)). The default is set to `let-style: auto` and `in-style: right-align`, which should not reformat already formatted files _(with some exceptions depending on comment placement)_, but allows users to format with `newline` without additional configuration. * Add `unicode` configuration ([#206](https://github.com/fourmolu/fourmolu/pull/206)) Bug fixes: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,16 +46,17 @@ | Configuration option | Valid options | Description |--------------------------|-------------------------------------------------------|------------- | `indentation` | any non-negative integer (**`4`**) | How many spaces to use as an indent -| `function-arrows` | **`trailing`**, `leading` | Where to place arrows in type signatures +| `function-arrows` | **`trailing`**, `leading`, `leading-args` | Where to place arrows in type signatures | `comma-style` | **`leading`**, `trailing` | Where to place commas in lists, tuples, etc. | `import-export-style` | `leading`, `trailing`, **`diff-friendly`** | How to format multiline import/export lists (`diff-friendly` lists have trailing commas but keep the opening parenthesis on the same line as `import`) | `indent-wheres` | `true`, **`false`** | Use an extra level of indentation _vs_ only half-indent the `where` keyword | `record-brace-space` | `true`, **`false`** | `rec {x = 1}` _vs_ `rec{x = 1}` | `newlines-between-decls` | any integer (**`1`**) | Number of newlines between top-level declarations | `haddock-style` | `single-line`, **`multi-line`**, `multi-line-compact` | Use `-- \|`, `{- \|`, or `{-\|` for multiline haddocks (single-line haddocks always use `--`) +| `haddock-style-module` | same as `haddock-style` | `haddock-style`, but specifically for the module docstring (not specifying anything = use the same setting as `haddock-style`) | | `let-style` | `inline`, `newline`, **`auto`**, `mixed` | How to style `let` blocks (`auto` uses `newline` if there's a newline in the input and `inline` otherwise, and `mixed` uses `inline` only when the `let` has exactly one binding) | `in-style` | `left-align`, **`right-align`** | How to align the `in` keyword with respect to `let` -| `unicode` | `always`, `detect`, **`never`** | Output Unicode syntax. With `detect` we output Unicode syntax exactly when the extension is seen to be enabled. +| `unicode` | `always`, `detect`, **`never`** | Output Unicode syntax. With `detect` we output Unicode syntax exactly when the extension is seen to be enabled. When using `always`, make sure to have the `UnicodeSyntax` extension enabled, or Fourmolu will throw errors. | `respectful` | **`true`**, `false` | Be less aggressive in reformatting input, e.g. keep empty lines in import list | `fixities` | list of strings (**`[]`**) | See the "Language extensions, dependencies, and fixities" section below @@ -76,6 +77,7 @@ record-brace-space: false newlines-between-decls: 1 haddock-style: multi-line +haddock-style-module: let-style: auto in-style: right-align respectful: true @@ -94,6 +96,7 @@ record-brace-space: true newlines-between-decls: 1 haddock-style: single-line +haddock-style-module: let-style: inline in-style: right-align respectful: false @@ -135,27 +138,24 @@ $ fourmolu -i Module.hs ``` -Use `find` to format a tree recursively: +Specify a directory to recursively process all of its `.hs` files: ```console -$ fourmolu -i $(find . -name '*.hs') +$ fourmolu -i src ``` Or find all files in a project with `git ls-files`: -```console +```bash $ fourmolu --mode inplace $(git ls-files '*.hs') -``` - -Or directly specify a directory (will recursively process all *.hs files) -```console -$ fourmolu -i src +# Or to avoid hitting command line length limits: +$ git ls-files -z '*.hs' | xargs -0 fourmolu --mode inplace ``` To check if files are are already formatted (useful on CI): ```console -$ fourmolu --mode check $(find . -name '*.hs') +$ fourmolu --mode check src ``` #### :zap: Beware git's `core.autocrlf` on Windows :zap: diff --git a/data/examples/declaration/data/existential-unicode-four-out.hs b/data/examples/declaration/data/existential-unicode-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo + = forall a. + Foo + +data Bar + = forall a. + Bar diff --git a/data/examples/declaration/data/existential-unicode-out.hs b/data/examples/declaration/data/existential-unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo + = forall a. + Foo + +data Bar + = forall a. + Bar diff --git a/data/examples/declaration/data/existential-unicode.hs b/data/examples/declaration/data/existential-unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo = forall + a. Foo + +data Bar = ∀ + a. Bar diff --git a/data/examples/declaration/signature/inline/noinline-four-out.hs b/data/examples/declaration/signature/inline/noinline-four-out.hs --- a/data/examples/declaration/signature/inline/noinline-four-out.hs +++ b/data/examples/declaration/signature/inline/noinline-four-out.hs @@ -9,3 +9,7 @@ baz :: Int -> Int baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# OPAQUE blub #-} diff --git a/data/examples/declaration/signature/inline/noinline-out.hs b/data/examples/declaration/signature/inline/noinline-out.hs --- a/data/examples/declaration/signature/inline/noinline-out.hs +++ b/data/examples/declaration/signature/inline/noinline-out.hs @@ -9,3 +9,7 @@ baz :: Int -> Int baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# OPAQUE blub #-} diff --git a/data/examples/declaration/signature/inline/noinline.hs b/data/examples/declaration/signature/inline/noinline.hs --- a/data/examples/declaration/signature/inline/noinline.hs +++ b/data/examples/declaration/signature/inline/noinline.hs @@ -11,3 +11,7 @@ baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# opaque blub #-} diff --git a/data/examples/declaration/splice/bracket-unicode-four-out.hs b/data/examples/declaration/splice/bracket-unicode-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode-four-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = [|x|] diff --git a/data/examples/declaration/splice/bracket-unicode-out.hs b/data/examples/declaration/splice/bracket-unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = [|x|] diff --git a/data/examples/declaration/splice/bracket-unicode.hs b/data/examples/declaration/splice/bracket-unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = ⟦x⟧ diff --git a/data/examples/declaration/value/function/lambda-case-four-out.hs b/data/examples/declaration/value/function/lambda-case-four-out.hs --- a/data/examples/declaration/value/function/lambda-case-four-out.hs +++ b/data/examples/declaration/value/function/lambda-case-four-out.hs @@ -7,3 +7,11 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just{} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 diff --git a/data/examples/declaration/value/function/lambda-case-out.hs b/data/examples/declaration/value/function/lambda-case-out.hs --- a/data/examples/declaration/value/function/lambda-case-out.hs +++ b/data/examples/declaration/value/function/lambda-case-out.hs @@ -7,3 +7,11 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just {} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 diff --git a/data/examples/declaration/value/function/lambda-case.hs b/data/examples/declaration/value/function/lambda-case.hs --- a/data/examples/declaration/value/function/lambda-case.hs +++ b/data/examples/declaration/value/function/lambda-case.hs @@ -7,3 +7,11 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just{} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 diff --git a/data/examples/declaration/value/function/pragmas-four-out.hs b/data/examples/declaration/value/function/pragmas-four-out.hs --- a/data/examples/declaration/value/function/pragmas-four-out.hs +++ b/data/examples/declaration/value/function/pragmas-four-out.hs @@ -3,6 +3,11 @@ {-# SCC "barbaz" #-} "hello" +foo = do + {-# SCC "foo" #-} + fmap succ $ do + {-# SCC "bar" #-} pure 1 + -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d corefoo = {-# CORE "foo"#-} 1 diff --git a/data/examples/declaration/value/function/pragmas-out.hs b/data/examples/declaration/value/function/pragmas-out.hs --- a/data/examples/declaration/value/function/pragmas-out.hs +++ b/data/examples/declaration/value/function/pragmas-out.hs @@ -4,6 +4,11 @@ {-# SCC "barbaz" #-} "hello" +foo = do + {-# SCC "foo" #-} + fmap succ $ do + {-# SCC "bar" #-} pure 1 + -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d corefoo = {-# CORE "foo"#-} 1 diff --git a/data/examples/declaration/value/function/pragmas.hs b/data/examples/declaration/value/function/pragmas.hs --- a/data/examples/declaration/value/function/pragmas.hs +++ b/data/examples/declaration/value/function/pragmas.hs @@ -2,6 +2,10 @@ sccbar = {-# SCC "barbaz"#-} "hello" +foo = do + {-# SCC "foo" #-} fmap succ $ do + {-# SCC "bar" #-} pure 1 + -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d corefoo = {-# CORE "foo"#-} 1 diff --git a/data/examples/declaration/value/function/type-applications-four-out.hs b/data/examples/declaration/value/function/type-applications-four-out.hs --- a/data/examples/declaration/value/function/type-applications-four-out.hs +++ b/data/examples/declaration/value/function/type-applications-four-out.hs @@ -14,3 +14,11 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t + @u + v -> + "" diff --git a/data/examples/declaration/value/function/type-applications-out.hs b/data/examples/declaration/value/function/type-applications-out.hs --- a/data/examples/declaration/value/function/type-applications-out.hs +++ b/data/examples/declaration/value/function/type-applications-out.hs @@ -14,3 +14,11 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t + @u + v -> + "" diff --git a/data/examples/declaration/value/function/type-applications.hs b/data/examples/declaration/value/function/type-applications.hs --- a/data/examples/declaration/value/function/type-applications.hs +++ b/data/examples/declaration/value/function/type-applications.hs @@ -11,3 +11,9 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t @u v + -> "" diff --git a/data/examples/declaration/value/function/unboxed-sums-four-out.hs b/data/examples/declaration/value/function/unboxed-sums-four-out.hs --- a/data/examples/declaration/value/function/unboxed-sums-four-out.hs +++ b/data/examples/declaration/value/function/unboxed-sums-four-out.hs @@ -22,3 +22,5 @@ (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/declaration/value/function/unboxed-sums-out.hs b/data/examples/declaration/value/function/unboxed-sums-out.hs --- a/data/examples/declaration/value/function/unboxed-sums-out.hs +++ b/data/examples/declaration/value/function/unboxed-sums-out.hs @@ -22,3 +22,5 @@ (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/declaration/value/function/unboxed-sums.hs b/data/examples/declaration/value/function/unboxed-sums.hs --- a/data/examples/declaration/value/function/unboxed-sums.hs +++ b/data/examples/declaration/value/function/unboxed-sums.hs @@ -12,3 +12,5 @@ baz = (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/import/sorted-package-imports-four-out.hs b/data/examples/import/sorted-package-imports-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports-four-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import D +import "a" Ab +import "b" Aa +import "b" Bb +import "c" Ba diff --git a/data/examples/import/sorted-package-imports-out.hs b/data/examples/import/sorted-package-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import D +import "a" Ab +import "b" Aa +import "b" Bb +import "c" Ba diff --git a/data/examples/import/sorted-package-imports.hs b/data/examples/import/sorted-package-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import "b" Aa +import "a" Ab +import "c" Ba +import D +import "b" Bb diff --git a/data/examples/module-header/leading-empty-line-four-out.hs b/data/examples/module-header/leading-empty-line-four-out.hs --- a/data/examples/module-header/leading-empty-line-four-out.hs +++ b/data/examples/module-header/leading-empty-line-four-out.hs @@ -1,12 +1,12 @@ {- | - Module : Text.Megaparsec - Copyright : © 2015–2019 Megaparsec contributors - © 2007 Paolo Martini - © 1999–2001 Daan Leijen - License : FreeBSD +Module : Text.Megaparsec +Copyright : © 2015–2019 Megaparsec contributors + © 2007 Paolo Martini + © 1999–2001 Daan Leijen +License : FreeBSD - Maintainer : Mark Karpov - Stability : experimental - Portability : portable +Maintainer : Mark Karpov +Stability : experimental +Portability : portable -} module Main where diff --git a/data/examples/module-header/named-section-four-out.hs b/data/examples/module-header/named-section-four-out.hs --- a/data/examples/module-header/named-section-four-out.hs +++ b/data/examples/module-header/named-section-four-out.hs @@ -10,5 +10,5 @@ {- $explanation - Here it goes. +Here it goes. -} diff --git a/data/examples/other/comment-spacing-four-out.hs b/data/examples/other/comment-spacing-four-out.hs --- a/data/examples/other/comment-spacing-four-out.hs +++ b/data/examples/other/comment-spacing-four-out.hs @@ -1,7 +1,7 @@ --- |Something. +-- | Something. foo :: - -- |Foo. + -- | Foo. Int -> - -- |Bar. + -- | Bar. IO () foo _ = pure () -- comment diff --git a/data/examples/other/comment-spacing-out.hs b/data/examples/other/comment-spacing-out.hs --- a/data/examples/other/comment-spacing-out.hs +++ b/data/examples/other/comment-spacing-out.hs @@ -1,7 +1,7 @@ --- |Something. +-- | Something. foo :: - -- |Foo. + -- | Foo. Int -> - -- |Bar. + -- | Bar. IO () foo _ = pure () -- comment diff --git a/data/examples/other/comment-style-transform-out.hs b/data/examples/other/comment-style-transform-out.hs --- a/data/examples/other/comment-style-transform-out.hs +++ b/data/examples/other/comment-style-transform-out.hs @@ -1,17 +1,17 @@ -- | ---Module: Data.Aeson.TH ---Copyright: (c) 2011-2016 Bryan O'Sullivan --- (c) 2011 MailRank, Inc. ---License: BSD3 ---Stability: experimental ---Portability: portable +-- Module: Data.Aeson.TH +-- Copyright: (c) 2011-2016 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Stability: experimental +-- Portability: portable module Main where -- | -- ---Here is a snippet: +-- Here is a snippet: -- ---@ ---x = y + 2 ---@ +-- @ +-- x = y + 2 +-- @ x = y + 2 diff --git a/data/examples/other/following-comment-last-3-four-out.hs b/data/examples/other/following-comment-last-3-four-out.hs --- a/data/examples/other/following-comment-last-3-four-out.hs +++ b/data/examples/other/following-comment-last-3-four-out.hs @@ -3,5 +3,5 @@ -- | Another datatype... data D' {- ^ ...with two docstrings. - even on second line +even on second line -} diff --git a/data/examples/other/haddock-sections-four-out.hs b/data/examples/other/haddock-sections-four-out.hs --- a/data/examples/other/haddock-sections-four-out.hs +++ b/data/examples/other/haddock-sections-four-out.hs @@ -1,9 +1,9 @@ {- $weird #anchor# - Section 1 +Section 1 -} {- $normal - Section 2 +Section 2 -} diff --git a/data/examples/other/invalid-haddock-weird-four-out.hs b/data/examples/other/invalid-haddock-weird-four-out.hs --- a/data/examples/other/invalid-haddock-weird-four-out.hs +++ b/data/examples/other/invalid-haddock-weird-four-out.hs @@ -1,3 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo -- \|# ${ +foo = foo + +-- \|# ${ diff --git a/data/examples/other/invalid-haddock-weird-out.hs b/data/examples/other/invalid-haddock-weird-out.hs --- a/data/examples/other/invalid-haddock-weird-out.hs +++ b/data/examples/other/invalid-haddock-weird-out.hs @@ -1,3 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo -- \|# ${ +foo = foo + +-- \|# ${ diff --git a/data/examples/other/pragma-sorting-four-out.hs b/data/examples/other/pragma-sorting-four-out.hs --- a/data/examples/other/pragma-sorting-four-out.hs +++ b/data/examples/other/pragma-sorting-four-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/data/examples/other/pragma-sorting-out.hs b/data/examples/other/pragma-sorting-out.hs --- a/data/examples/other/pragma-sorting-out.hs +++ b/data/examples/other/pragma-sorting-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/data/examples/other/pragma-sorting.hs b/data/examples/other/pragma-sorting.hs --- a/data/examples/other/pragma-sorting.hs +++ b/data/examples/other/pragma-sorting.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GHC2021 #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NondecreasingIndentation #-} diff --git a/data/fourmolu/function-arrows/output-LeadingArgsArrows.hs b/data/fourmolu/function-arrows/output-LeadingArgsArrows.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/function-arrows/output-LeadingArgsArrows.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LinearTypes #-} + +module Main where + +-- | Something else. +class Bar a where + -- | Bar + bar :: + String + -> String + -> a + -- Pointless comment + default bar :: + ( Read a + , Semigroup a + ) => + a + -> a + -> a + -- Even more pointless comment + bar + a + b = + read a <> read b + +-- | Here goes a comment. +data Foo a where + -- | 'Foo' is wonderful. + Foo :: + forall a b. + (Show a, Eq b) => -- foo + -- bar + a + -> b + -> Foo 'Int + -- | But 'Bar' is also not too bad. + Bar :: + Int + -- ^ An Int + -> Maybe Text + -- ^ And a Maybe Text + -> Foo 'Bool + -- | So is 'Baz'. + Baz :: + forall a. + a + -> Foo 'String + (:~>) :: Foo a -> Foo a -> Foo a + +-- Single line type signature is preserved +instance Eq Int where + (==) :: Int -> Int -> Bool + (==) _ _ = False +singleLineFun :: forall a. (C1, C2) => Int -> Bool + +instance Ord Int where + compare :: + Int + -> Int + -> Ordering + compare + _ + _ = + GT + +functionName :: + (C1, C2, C3, C4, C5) => + a + -> b + -> ( forall a. + (C6, C7) => + LongDataTypeName + -> a + -> AnotherLongDataTypeName + -> b + -> c + ) + -> (c -> d) + -> (a, b, c, d) +functionWithInterleavedCommentsTrailing :: + -- arg + Int + -- result + -> Bool +functionWithInterleavedCommentsLeading :: + -- arg + Int + -- result + -> Bool + +multilineExprSig = do + bar + ( x :: + Int + -> Bool + ) + bar + ( x :: + -- arg + Int + -- result + -> Bool + ) + bar + ( x :: + -- arg + Int + -- result + -> Bool + ) + +data Record = Record + { recFun :: + forall a. + (C1, C2) => + Int + -> Int + -> Bool + , recOther :: Bool + } + +foo :: + Int + %1 -> Bool +foo :: + forall x. + Int + %Many -> Bool diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLine.hs b/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLine.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLine.hs @@ -0,0 +1,31 @@ +{- | This is a test multiline +module haddock +-} +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +{- | This is a multiline +function haddock +-} +multi1 :: Int + +{- | +This is a multiline +function haddock +-} +multi2 :: Int + +{- | This is a haddock + +with two consecutive newlines + + +https://github.com/fourmolu/fourmolu/issues/172 +-} +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLineCompact.hs b/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLineCompact.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLineCompact.hs @@ -0,0 +1,31 @@ +{-| This is a test multiline +module haddock +-} +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +{- | This is a multiline +function haddock +-} +multi1 :: Int + +{- | +This is a multiline +function haddock +-} +multi2 :: Int + +{- | This is a haddock + +with two consecutive newlines + + +https://github.com/fourmolu/fourmolu/issues/172 +-} +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockSingleLine.hs b/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockSingleLine.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockSingleLine.hs @@ -0,0 +1,30 @@ +-- | This is a test multiline +-- module haddock +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +{- | This is a multiline +function haddock +-} +multi1 :: Int + +{- | +This is a multiline +function haddock +-} +multi2 :: Int + +{- | This is a haddock + +with two consecutive newlines + + +https://github.com/fourmolu/fourmolu/issues/172 +-} +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLine.hs b/data/fourmolu/haddock-style/output-HaddockMultiLine.hs --- a/data/fourmolu/haddock-style/output-HaddockMultiLine.hs +++ b/data/fourmolu/haddock-style/output-HaddockMultiLine.hs @@ -1,5 +1,5 @@ {- | This is a test multiline - module haddock +module haddock -} module Foo where @@ -10,7 +10,7 @@ single2 :: Int {- | This is a multiline - function haddock +function haddock -} multi1 :: Int @@ -22,10 +22,10 @@ {- | This is a haddock - with two consecutive newlines +with two consecutive newlines - https://github.com/fourmolu/fourmolu/issues/172 +https://github.com/fourmolu/fourmolu/issues/172 -} foo :: Int foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLine.hs b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLine.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLine.hs @@ -0,0 +1,31 @@ +{- | This is a test multiline +module haddock +-} +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +{-| This is a multiline +function haddock +-} +multi1 :: Int + +{-| +This is a multiline +function haddock +-} +multi2 :: Int + +{-| This is a haddock + +with two consecutive newlines + + +https://github.com/fourmolu/fourmolu/issues/172 +-} +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLineCompact.hs b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLineCompact.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLineCompact.hs @@ -0,0 +1,31 @@ +{-| This is a test multiline +module haddock +-} +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +{-| This is a multiline +function haddock +-} +multi1 :: Int + +{-| +This is a multiline +function haddock +-} +multi2 :: Int + +{-| This is a haddock + +with two consecutive newlines + + +https://github.com/fourmolu/fourmolu/issues/172 +-} +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockSingleLine.hs b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockSingleLine.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockSingleLine.hs @@ -0,0 +1,30 @@ +-- | This is a test multiline +-- module haddock +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +{-| This is a multiline +function haddock +-} +multi1 :: Int + +{-| +This is a multiline +function haddock +-} +multi2 :: Int + +{-| This is a haddock + +with two consecutive newlines + + +https://github.com/fourmolu/fourmolu/issues/172 +-} +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs --- a/data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs +++ b/data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs @@ -1,5 +1,5 @@ {-| This is a test multiline - module haddock +module haddock -} module Foo where @@ -10,7 +10,7 @@ single2 :: Int {-| This is a multiline - function haddock +function haddock -} multi1 :: Int @@ -22,10 +22,10 @@ {-| This is a haddock - with two consecutive newlines +with two consecutive newlines - https://github.com/fourmolu/fourmolu/issues/172 +https://github.com/fourmolu/fourmolu/issues/172 -} foo :: Int foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLine.hs b/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLine.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLine.hs @@ -0,0 +1,28 @@ +{- | This is a test multiline +module haddock +-} +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +-- | This is a multiline +-- function haddock +multi1 :: Int + +-- | +-- This is a multiline +-- function haddock +multi2 :: Int + +-- | This is a haddock +-- +-- with two consecutive newlines +-- +-- +-- https://github.com/fourmolu/fourmolu/issues/172 +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLineCompact.hs b/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLineCompact.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLineCompact.hs @@ -0,0 +1,28 @@ +{-| This is a test multiline +module haddock +-} +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +-- | This is a multiline +-- function haddock +multi1 :: Int + +-- | +-- This is a multiline +-- function haddock +multi2 :: Int + +-- | This is a haddock +-- +-- with two consecutive newlines +-- +-- +-- https://github.com/fourmolu/fourmolu/issues/172 +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockSingleLine.hs b/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockSingleLine.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockSingleLine.hs @@ -0,0 +1,27 @@ +-- | This is a test multiline +-- module haddock +module Foo where + +-- | This is a singleline function haddock +single1 :: Int + +-- | This is a singleline function haddock +single2 :: Int + +-- | This is a multiline +-- function haddock +multi1 :: Int + +-- | +-- This is a multiline +-- function haddock +multi2 :: Int + +-- | This is a haddock +-- +-- with two consecutive newlines +-- +-- +-- https://github.com/fourmolu/fourmolu/issues/172 +foo :: Int +foo = 42 diff --git a/data/fourmolu/haddock-style/output-HaddockSingleLine.hs b/data/fourmolu/haddock-style/output-HaddockSingleLine.hs --- a/data/fourmolu/haddock-style/output-HaddockSingleLine.hs +++ b/data/fourmolu/haddock-style/output-HaddockSingleLine.hs @@ -13,8 +13,8 @@ multi1 :: Int -- | ---This is a multiline ---function haddock +-- This is a multiline +-- function haddock multi2 :: Int -- | This is a haddock diff --git a/data/fourmolu/let-style/input.hs b/data/fourmolu/let-style/input.hs --- a/data/fourmolu/let-style/input.hs +++ b/data/fourmolu/let-style/input.hs @@ -26,6 +26,11 @@ a = 1 in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 b = 2 @@ -61,6 +66,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=2.hs b/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=2.hs @@ -26,6 +26,13 @@ a = 1 in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 b = 2 @@ -61,6 +68,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=4.hs b/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=4.hs @@ -26,6 +26,13 @@ a = 1 in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 b = 2 @@ -61,6 +68,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=2.hs b/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=2.hs @@ -26,6 +26,13 @@ a = 1 in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 b = 2 @@ -61,6 +68,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=4.hs b/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=4.hs @@ -26,6 +26,13 @@ a = 1 in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 b = 2 @@ -61,6 +68,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=2.hs b/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=2.hs @@ -26,6 +26,11 @@ a = 1 in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 b = 2 @@ -57,6 +62,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=4.hs b/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=4.hs @@ -26,6 +26,11 @@ a = 1 in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 b = 2 @@ -57,6 +62,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=2.hs b/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=2.hs @@ -26,6 +26,11 @@ a = 1 in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 b = 2 @@ -57,6 +62,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=4.hs b/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetInline-InRightAlign-indent=4.hs @@ -26,6 +26,11 @@ a = 1 in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 b = 2 @@ -57,6 +62,8 @@ let d = "hello" e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=2.hs b/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=2.hs @@ -28,6 +28,11 @@ in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 @@ -66,6 +71,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=4.hs b/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=4.hs @@ -28,6 +28,11 @@ in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 @@ -66,6 +71,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=2.hs b/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=2.hs @@ -28,6 +28,11 @@ in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 @@ -66,6 +71,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=4.hs b/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=4.hs @@ -28,6 +28,11 @@ in a + 2 +let_single_comment = + let -- a comment + a = 1 + in a + 2 + let_multi = let a = 1 @@ -66,6 +71,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=2.hs b/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=2.hs @@ -30,6 +30,13 @@ in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 @@ -73,6 +80,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=4.hs b/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=4.hs @@ -30,6 +30,13 @@ in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 @@ -73,6 +80,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=2.hs b/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=2.hs --- a/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=2.hs +++ b/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=2.hs @@ -30,6 +30,13 @@ in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 @@ -73,6 +80,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=4.hs b/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=4.hs --- a/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=4.hs +++ b/data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=4.hs @@ -30,6 +30,13 @@ in a + 2 +let_single_comment = + let + -- a comment + a = 1 + in + a + 2 + let_multi = let a = 1 @@ -73,6 +80,8 @@ e = "world" in print (d ++ e) + + let f = 1 in print f {-- list comprehension --} diff --git a/data/fourmolu/unicode-syntax/input.hs b/data/fourmolu/unicode-syntax/input.hs --- a/data/fourmolu/unicode-syntax/input.hs +++ b/data/fourmolu/unicode-syntax/input.hs @@ -74,6 +74,9 @@ add1 :: Quote m => Int -> m Exp add1 x = [|x + 1|] +decl :: Quote m => m Decl +decl = [d|data Foo|] + monad = do putStr "x: " l <- getLine @@ -84,6 +87,7 @@ g -< 2 * y let z = x + y t <- h -< x * z + (| f (\y -> returnA -< y) |) ys returnA -< t + z elem :: (Eq a) => a -> [a] -> Bool diff --git a/data/fourmolu/unicode-syntax/output-UnicodeAlways.hs b/data/fourmolu/unicode-syntax/output-UnicodeAlways.hs --- a/data/fourmolu/unicode-syntax/output-UnicodeAlways.hs +++ b/data/fourmolu/unicode-syntax/output-UnicodeAlways.hs @@ -72,8 +72,11 @@ _ == _ = False add1 ∷ Quote m ⇒ Int → m Exp -add1 x = [|x + 1|] +add1 x = ⟦x + 1⟧ +decl ∷ Quote m ⇒ m Decl +decl = [d|data Foo|] + monad = do putStr "x: " l ← getLine @@ -84,6 +87,7 @@ g ⤙ 2 * y let z = x + y t ← h ⤙ x * z + ⦇ f (\y → returnA ⤙ y) ⦈ ys returnA ⤙ t + z elem ∷ (Eq a) ⇒ a → [a] → Bool diff --git a/data/fourmolu/unicode-syntax/output-UnicodeDetect.hs b/data/fourmolu/unicode-syntax/output-UnicodeDetect.hs --- a/data/fourmolu/unicode-syntax/output-UnicodeDetect.hs +++ b/data/fourmolu/unicode-syntax/output-UnicodeDetect.hs @@ -72,8 +72,11 @@ _ == _ = False add1 ∷ Quote m ⇒ Int → m Exp -add1 x = [|x + 1|] +add1 x = ⟦x + 1⟧ +decl ∷ Quote m ⇒ m Decl +decl = [d|data Foo|] + monad = do putStr "x: " l ← getLine @@ -84,6 +87,7 @@ g ⤙ 2 * y let z = x + y t ← h ⤙ x * z + ⦇ f (\y → returnA ⤙ y) ⦈ ys returnA ⤙ t + z elem ∷ (Eq a) ⇒ a → [a] → Bool diff --git a/data/fourmolu/unicode-syntax/output-UnicodeNever.hs b/data/fourmolu/unicode-syntax/output-UnicodeNever.hs --- a/data/fourmolu/unicode-syntax/output-UnicodeNever.hs +++ b/data/fourmolu/unicode-syntax/output-UnicodeNever.hs @@ -74,6 +74,9 @@ add1 :: Quote m => Int -> m Exp add1 x = [|x + 1|] +decl :: Quote m => m Decl +decl = [d|data Foo|] + monad = do putStr "x: " l <- getLine @@ -84,6 +87,7 @@ g -< 2 * y let z = x + y t <- h -< x * z + (| f (\y -> returnA -< y) |) ys returnA -< t + z elem :: (Eq a) => a -> [a] -> Bool diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,15 +1,15 @@ cabal-version: 2.4 name: fourmolu -version: 0.9.0.0 +version: 0.10.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Matt Parsons George Thomas Brandon Chinn -tested-with: ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.1 -homepage: https://github.com/parsonsmatt/fourmolu -bug-reports: https://github.com/parsonsmatt/fourmolu/issues +tested-with: ghc ==9.0.2 ghc ==9.2.4 +homepage: https://github.com/fourmolu/fourmolu +bug-reports: https://github.com/fourmolu/fourmolu/issues synopsis: A formatter for Haskell source code description: A formatter for Haskell source code. category: Development, Formatting @@ -30,7 +30,7 @@ source-repository head type: git - location: https://github.com/parsonsmatt/fourmolu.git + location: https://github.com/fourmolu/fourmolu.git flag dev description: Turn on development settings. @@ -100,7 +100,7 @@ other-modules: GHC.DynFlags default-language: Haskell2010 build-depends: - Cabal >=3.6 && <3.7, + Cabal-syntax >=3.8 && <3.9, Diff >=0.4 && <1.0, MemoTrie >=0.6 && <0.7, aeson >=1.0 && <3.0, @@ -113,7 +113,7 @@ dlist >=0.8 && <2.0, exceptions >=0.6 && <0.11, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.2 && <9.3, + ghc-lib-parser >=9.4 && <9.5, megaparsec >=9.0, mtl >=2.0 && <3.0, syb >=0.7 && <0.8, @@ -150,7 +150,7 @@ base >=4.12 && <5.0, containers >=0.5 && <0.7, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.2 && <9.3, + ghc-lib-parser >=9.4 && <9.5, gitrev >=1.3 && <1.4, optparse-applicative >=0.14 && <0.18, text >=0.2 && <3.0, @@ -201,7 +201,7 @@ containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.2 && <9.3, + ghc-lib-parser >=9.4 && <9.5, hspec >=2.0 && <3.0, hspec-megaparsec >=2.2, megaparsec >=9.0, diff --git a/fourmolu.yaml b/fourmolu.yaml --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -7,6 +7,7 @@ record-brace-space: true newlines-between-decls: 1 haddock-style: single-line +haddock-style-module: let-style: inline in-style: right-align unicode: never diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -38,6 +38,7 @@ platformIsCrossCompiling = False, platformLeadingUnderscore = False, platformTablesNextToCode = False, + platformHasLibm = False, platform_constants = Nothing }, sPlatformMisc = PlatformMisc {}, diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -34,6 +34,7 @@ fillMissingPrinterOpts, CommaStyle (..), HaddockPrintStyle (..), + HaddockPrintStyleModule (..), ImportExportStyle (..), LetStyle (..), InStyle (..), @@ -227,6 +228,7 @@ poRecordBraceSpace <- f poRecordBraceSpace0 poNewlinesBetweenDecls <- f poNewlinesBetweenDecls0 poHaddockStyle <- f poHaddockStyle0 + poHaddockStyleModule <- f poHaddockStyleModule0 poLetStyle <- f poLetStyle0 poInStyle <- f poInStyle0 poUnicode <- f poUnicode0 @@ -344,6 +346,14 @@ (showAllValues haddockPrintStyleMap), metaDefault = HaddockMultiLine }, + poHaddockStyleModule = + PrinterOptsFieldMeta + { metaName = "haddock-style-module", + metaGetField = poHaddockStyleModule, + metaPlaceholder = "STYLE", + metaHelp = "How to print module docstring", + metaDefault = PrintStyleInherit + }, poLetStyle = PrinterOptsFieldMeta { metaName = "let-style", @@ -418,7 +428,8 @@ functionArrowsStyleMap = $( mkBijectiveMap [ ('TrailingArrows, "trailing"), - ('LeadingArrows, "leading") + ('LeadingArrows, "leading"), + ('LeadingArgsArrows, "leading-args") ] ) @@ -481,6 +492,18 @@ parseJSON = parseJSONWith haddockPrintStyleMap "HaddockPrintStyle" parseText = parseTextWith haddockPrintStyleMap showText = show . showTextWith haddockPrintStyleMap + +instance PrinterOptsFieldType HaddockPrintStyleModule where + parseJSON = \case + Aeson.Null -> pure PrintStyleInherit + Aeson.String "" -> pure PrintStyleInherit + v -> PrintStyleOverride <$> parseJSON v + parseText = \case + "" -> pure PrintStyleInherit + s -> PrintStyleOverride <$> parseText s + showText = \case + PrintStyleInherit -> "same as 'haddock-style'" + PrintStyleOverride x -> showText x instance PrinterOptsFieldType ImportExportStyle where parseJSON = parseJSONWith importExportStyleMap "ImportExportStyle" diff --git a/src/Ormolu/Config/Types.hs b/src/Ormolu/Config/Types.hs --- a/src/Ormolu/Config/Types.hs +++ b/src/Ormolu/Config/Types.hs @@ -6,6 +6,7 @@ CommaStyle (..), FunctionArrowsStyle (..), HaddockPrintStyle (..), + HaddockPrintStyleModule (..), ImportExportStyle (..), LetStyle (..), InStyle (..), @@ -33,6 +34,8 @@ poNewlinesBetweenDecls :: f Int, -- | How to print doc comments poHaddockStyle :: f HaddockPrintStyle, + -- | How to print the module docstring (defaults to poHaddockStyle) + poHaddockStyleModule :: f HaddockPrintStyleModule, -- | Styling of let blocks poLetStyle :: f LetStyle, -- | How to align in keyword @@ -52,6 +55,7 @@ data FunctionArrowsStyle = TrailingArrows | LeadingArrows + | LeadingArgsArrows deriving (Eq, Show, Enum, Bounded) data HaddockPrintStyle @@ -59,6 +63,11 @@ | HaddockMultiLine | HaddockMultiLineCompact deriving (Eq, Show, Enum, Bounded) + +data HaddockPrintStyleModule + = PrintStyleInherit + | PrintStyleOverride HaddockPrintStyle + deriving (Eq, Show) data ImportExportStyle = ImportExportLeading diff --git a/src/Ormolu/Diff/ParseResult.hs b/src/Ormolu/Diff/ParseResult.hs --- a/src/Ormolu/Diff/ParseResult.hs +++ b/src/Ormolu/Diff/ParseResult.hs @@ -1,9 +1,13 @@ {-# LANGUAGE BangPatterns #-} --- needed on GHC 9.0 due to simplified subsumption -{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +#if !MIN_VERSION_base(4,17,0) +-- needed on GHC 9.0 and 9.2 due to simplified subsumption +{-# LANGUAGE ImpredicativeTypes #-} +#endif -- | This module allows us to diff two 'ParseResult's. module Ormolu.Diff.ParseResult @@ -146,7 +150,7 @@ -- as we normalize arrow styles (e.g. -> vs →), we consider them equal here unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff unicodeArrowStyleEq (HsUnrestrictedArrow _) (castArrow -> Just (HsUnrestrictedArrow _)) = Same - unicodeArrowStyleEq (HsLinearArrow _ _) (castArrow -> Just (HsLinearArrow _ _)) = Same + unicodeArrowStyleEq (HsLinearArrow _) (castArrow -> Just (HsLinearArrow _)) = Same unicodeArrowStyleEq (HsExplicitMult _ _ t) (castArrow -> Just (HsExplicitMult _ _ t')) = genericQuery t t' unicodeArrowStyleEq _ _ = Different [] castArrow :: Typeable a => a -> Maybe (HsArrow GhcPs) diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -20,6 +20,7 @@ import GHC.Hs import GHC.Hs.ImpExp as GHC import GHC.Types.Name.Reader +import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Name @@ -74,8 +75,8 @@ -- the same 'ImportId' they can be merged. data ImportId = ImportId { importIsPrelude :: Bool, - importIdName :: ModuleName, importPkgQual :: Maybe LexicalFastString, + importIdName :: ModuleName, importSource :: IsBootInterface, importSafe :: Bool, importQualified :: Bool, @@ -91,7 +92,7 @@ ImportId { importIsPrelude = isPrelude, importIdName = moduleName, - importPkgQual = LexicalFastString . sl_fs <$> ideclPkgQual, + importPkgQual = rawPkgQualToLFS ideclPkgQual, importSource = ideclSource, importSafe = ideclSafe, importQualified = case ideclQualified of @@ -105,6 +106,9 @@ where isPrelude = moduleNameString moduleName == "Prelude" moduleName = unLoc ideclName + rawPkgQualToLFS = \case + RawPkgQual fs -> Just . LexicalFastString . sl_fs $ fs + NoRawPkgQual -> Nothing -- | Normalize a collection of import\/export items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -19,23 +19,24 @@ import Data.Generics import qualified Data.List as L import qualified Data.List.NonEmpty as NE -import Data.Ord (Down (Down)) import GHC.Data.Bag (bagToList) import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC import qualified GHC.Driver.CmdLine as GHC +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Session as GHC import GHC.DynFlags (baseDynFlags) import GHC.Hs hiding (UnicodeSyntax) import GHC.LanguageExtensions.Type (Extension (..)) import qualified GHC.Parser as GHC -import GHC.Parser.Errors.Ppr (pprError) import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC +import GHC.Types.Error (getMessages) import qualified GHC.Types.SourceError as GHC (handleSourceError) import GHC.Types.SrcLoc -import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan) +import GHC.Utils.Error +import GHC.Utils.Outputable (defaultSDocContext) import qualified GHC.Utils.Panic as GHC import Ormolu.Config import Ormolu.Exception @@ -44,7 +45,7 @@ import Ormolu.Parser.Result import Ormolu.Processing.Common import Ormolu.Processing.Preprocess -import Ormolu.Utils (incSpanLine) +import Ormolu.Utils (incSpanLine, showOutputable) -- | Parse a complete module from string. parseModule :: @@ -98,13 +99,22 @@ parseModuleSnippet Config {..} fixityMap dynFlags path rawInput = liftIO $ do let (input, indent) = removeIndentation . linesInRegion cfgRegion $ rawInput let pStateErrors pstate = - let errs = fmap pprError . bagToList $ GHC.getErrorMessages pstate + let errs = bagToList . getMessages $ GHC.getPsErrorMessages pstate fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion) - in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of + rateSeverity = \case + SevError -> 1 :: Int + SevWarning -> 2 + SevIgnore -> 3 + showErr = + showOutputable + . formatBulleted defaultSDocContext + . diagnosticMessage + . errMsgDiagnostic + in case L.sortOn (rateSeverity . errMsgSeverity) errs of [] -> Nothing err : _ -> -- Show instance returns a short error message - Just (fixupErrSpan (errMsgSpan err), show err) + Just (fixupErrSpan (errMsgSpan err), showErr err) parser = case cfgSourceType of ModuleSource -> GHC.parseModule SignatureSource -> GHC.parseSignature @@ -149,12 +159,12 @@ hsmodDecls = filter (not . isBlankDocD . unLoc) (hsmodDecls hsmod), hsmodHaddockModHeader = - mfilter (not . isBlankDocString . unLoc) (hsmodHaddockModHeader hsmod), + mfilter (not . isBlankDocString) (hsmodHaddockModHeader hsmod), hsmodExports = (fmap . fmap) (filter (not . isBlankDocIE . unLoc)) (hsmodExports hsmod) } where - isBlankDocString = all isSpace . unpackHDS + isBlankDocString = all isSpace . renderHsDocString . hsDocString . unLoc isBlankDocD = \case DocD _ s -> isBlankDocString $ docDeclDoc s _ -> False @@ -164,8 +174,8 @@ _ -> False dropBlankTypeHaddocks = \case - L _ (HsDocTy _ ty (L _ ds)) :: LHsType GhcPs - | isBlankDocString ds -> ty + L _ (HsDocTy _ ty s) :: LHsType GhcPs + | isBlankDocString s -> ty a -> a -- | Enable all language extensions that we think should be enabled by @@ -223,34 +233,7 @@ where location = mkRealSrcLoc (GHC.mkFastString filename) 1 1 buffer = GHC.stringToStringBuffer input - parseState = GHC.initParserState (opts flags) buffer location - opts = - GHC.mkParserOpts - <$> GHC.warningFlags - <*> GHC.extensionFlags - <*> GHC.safeImportsOn - <*> GHC.gopt GHC.Opt_Haddock - <*> GHC.gopt GHC.Opt_KeepRawTokenStream - <*> const True - --- | Wrap GHC's 'Severity' to add 'Ord' instance. -newtype SeverityOrd = SeverityOrd Severity - -instance Eq SeverityOrd where - s1 == s2 = compare s1 s2 == EQ - -instance Ord SeverityOrd where - compare (SeverityOrd s1) (SeverityOrd s2) = - compare (f s1) (f s2) - where - f :: Severity -> Int - f SevOutput = 1 - f SevFatal = 2 - f SevInteractive = 3 - f SevDump = 4 - f SevInfo = 5 - f SevWarning = 6 - f SevError = 7 + parseState = GHC.initParserState (initParserOpts flags) buffer location ---------------------------------------------------------------------------- -- Helpers taken from HLint @@ -267,7 +250,11 @@ IO (Either String ([GHC.Warn], DynFlags)) parsePragmasIntoDynFlags flags extraOpts filepath str = catchErrors $ do - let fileOpts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath + let (_warnings, fileOpts) = + GHC.getOptions + (initParserOpts flags) + (GHC.stringToStringBuffer str) + filepath (flags', leftovers, warnings) <- parseDynamicFilePragma flags (extraOpts <> fileOpts) case NE.nonEmpty leftovers of diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -29,8 +29,8 @@ import qualified Data.Map.Lazy as M import Data.Maybe import qualified Data.Set as S +import qualified GHC.Data.Strict as Strict import GHC.Hs (HsModule) -import GHC.Hs.Decls (HsDecl (..), LDocDecl, LHsDecl) import GHC.Hs.Doc import GHC.Hs.Extension import GHC.Hs.ImpExp @@ -87,22 +87,15 @@ EpaComments cs -> cs EpaCommentsBalanced pcs fcs -> pcs <> fcs -- All spans of valid Haddock comments - -- (everywhere where we use p_hsDoc{String,Name}) validHaddockCommentSpans = S.fromList . mapMaybe srcSpanToRealSrcSpan . mconcat - [ fmap getLoc . listify (only @LHsDocString), - fmap getLocA . listify (only @(LDocDecl GhcPs)), - fmap getLocA . listify isDocD, + [ fmap getLoc . listify (only @(LHsDoc GhcPs)), fmap getLocA . listify isIEDocLike ] $ hsModule where - isDocD :: LHsDecl GhcPs -> Bool - isDocD = \case - L _ DocD {} -> True - _ -> False isIEDocLike :: LIE GhcPs -> Bool isIEDocLike = \case L _ IEGroup {} -> True @@ -231,8 +224,8 @@ (y : ys) -> let (ls', y') = mkComment ls y in if onTheSameLine - (RealSrcSpan (getRealSrcSpan x) Nothing) - (RealSrcSpan (getRealSrcSpan y) Nothing) + (RealSrcSpan (getRealSrcSpan x) Strict.Nothing) + (RealSrcSpan (getRealSrcSpan y) Strict.Nothing) then go' ls' [y'] ys else go' ls [] xs @@ -240,10 +233,13 @@ unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated String) unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) = case eck of - GHC.EpaDocCommentNext s -> haddock "|" s -- @-- |@ - GHC.EpaDocCommentPrev s -> haddock "^" s -- @-- ^@ - GHC.EpaDocCommentNamed s -> haddock "$" s -- @-- $@ - GHC.EpaDocSection k s -> haddock (replicate k '*') s -- @-- *@ + GHC.EpaDocComment s -> + let trigger = case s of + MultiLineDocString t _ -> Just t + NestedDocString t _ -> Just t + -- should not occur + GeneratedDocString _ -> Nothing + in haddock trigger (renderHsDocString s) GHC.EpaDocOptions s -> mkL s GHC.EpaLineComment s -> mkL $ case take 3 s of @@ -255,9 +251,15 @@ where mkL = Just . L anchor insertAt x xs n = take (n - 1) xs ++ x ++ drop (n - 1) xs - haddock trigger = + haddock mtrigger = mkL . dashPrefix . escapeHaddockTriggers . (trigger <>) <=< dropBlank where + trigger = case mtrigger of + Just HsDocStringNext -> "|" + Just HsDocStringPrevious -> "^" + Just (HsDocStringNamed n) -> "$" <> n + Just (HsDocStringGroup k) -> replicate k '*' + Nothing -> "" dashPrefix s = "--" <> spaceIfNecessary <> s where spaceIfNecessary = case s of diff --git a/src/Ormolu/Parser/Pragma.hs b/src/Ormolu/Parser/Pragma.hs --- a/src/Ormolu/Parser/Pragma.hs +++ b/src/Ormolu/Parser/Pragma.hs @@ -11,9 +11,10 @@ import Control.Monad import Data.Char (isSpace, toLower) import qualified Data.List as L -import qualified GHC.Data.EnumSet as ES import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.DynFlags (baseDynFlags) import qualified GHC.Parser.Lexer as L import GHC.Types.SrcLoc @@ -67,14 +68,7 @@ location = mkRealSrcLoc (mkFastString "") 1 1 buffer = stringToStringBuffer input parseState = L.initParserState parserOpts buffer location - parserOpts = - L.mkParserOpts - ES.empty - ES.empty - True - True - True - True + parserOpts = initParserOpts baseDynFlags -- | Haskell lexer. pLexer :: L.P [L.Token] diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -38,7 +38,6 @@ breakpoint, breakpoint', getPrinterOpt, - whenUnicodeOtherwise, -- ** Formatting lists sep, @@ -64,21 +63,21 @@ commaDel, commaDelImportExport, equals, - llarrowtail, - rrarrowtail, - darrow, - dcolon, - larrow, - larrowtail, - rarrow, - rarrowtail, - star, - forall, - oparenbar, - cparenbar, - openExpQuote, - closeQuote, - lolly, + token'Larrowtail, + token'Rarrowtail, + token'darrow, + token'dcolon, + token'larrow, + token'larrowtail, + token'rarrow, + token'rarrowtail, + token'star, + token'forall, + token'oparenbar, + token'cparenbar, + token'openExpQuote, + token'closeQuote, + token'lolly, -- ** Stateful markers SpanMark (..), @@ -96,6 +95,7 @@ import Control.Monad import Data.List (intersperse) import Data.Text (Text) +import qualified GHC.Data.Strict as Strict import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc import Ormolu.Config @@ -133,7 +133,7 @@ RealSrcSpan l _ -> do spitPrecedingComments l withEnclosingSpan l $ - switchLayout [RealSrcSpan l Nothing] (f a) + switchLayout [RealSrcSpan l Strict.Nothing] (f a) spitFollowingComments l -- | A version of 'located' with arguments flipped. @@ -183,17 +183,6 @@ breakpoint' :: R () breakpoint' = vlayout (return ()) newline --- | Write the one text or the other depending on whether Unicode is enabled. -whenUnicodeOtherwise :: Text -> Text -> R () -unicodeText `whenUnicodeOtherwise` asciiText = do - unicodePrinterOption <- getPrinterOpt poUnicode - unicodeExtensionIsEnabled <- isExtensionEnabled UnicodeSyntax - txt $ case unicodePrinterOption of - UnicodeDetect | unicodeExtensionIsEnabled -> unicodeText - UnicodeDetect | otherwise -> asciiText - UnicodeAlways -> unicodeText - UnicodeNever -> asciiText - ---------------------------------------------------------------------------- -- Formatting lists @@ -261,23 +250,23 @@ -- | Surround given entity by banana brackets (i.e., from arrow notation.) banana :: BracketStyle -> R () -> R () -banana = brackets_ True "(|" "|)" +banana = brackets_ True token'oparenbar token'cparenbar -- | Surround given entity by curly braces @{@ and @}@. braces :: BracketStyle -> R () -> R () -braces = brackets_ False "{" "}" +braces = brackets_ False (txt "{") (txt "}") -- | Surround given entity by square brackets @[@ and @]@. brackets :: BracketStyle -> R () -> R () -brackets = brackets_ False "[" "]" +brackets = brackets_ False (txt "[") (txt "]") -- | Surround given entity by parentheses @(@ and @)@. parens :: BracketStyle -> R () -> R () -parens = brackets_ False "(" ")" +parens = brackets_ False (txt "(") (txt ")") -- | Surround given entity by @(# @ and @ #)@. parensHash :: BracketStyle -> R () -> R () -parensHash = brackets_ True "(#" "#)" +parensHash = brackets_ True (txt "(#") (txt "#)") -- | Braces as used for pragmas: @{\-#@ and @#-\}@. pragmaBraces :: R () -> R () @@ -305,9 +294,9 @@ -- | Insert breakpoints around brackets Bool -> -- | Opening bracket - Text -> + R () -> -- | Closing bracket - Text -> + R () -> -- | Bracket style BracketStyle -> -- | Inner expression @@ -316,13 +305,13 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine) where singleLine = do - txt open + open when needBreaks space m when needBreaks space - txt close + close multiLine = do - txt open + open commaStyle <- getPrinterOpt poCommaStyle case commaStyle of Leading -> @@ -334,7 +323,7 @@ then newline >> inci m else space >> sitcc m newline - inciIf (style == S) (txt close) + inciIf (style == S) close ---------------------------------------------------------------------------- -- Literals @@ -365,70 +354,80 @@ equals :: R () equals = interferingTxt "=" +---------------------------------------------------------------------------- +-- Token literals -- The names of the following literals are from GHC's -- @compiler/GHC/Parser/Lexer.x@. -llarrowtail, - rrarrowtail, - darrow, - dcolon, - larrow, - larrowtail, - rarrow, - rarrowtail, - star, - forall, - oparenbar, - cparenbar, - openExpQuote, - closeQuote, - lolly :: - R () - -- | Print @⤛@ or @-<<@ as appropriate. -llarrowtail = "⤛" `whenUnicodeOtherwise` "-<<" +token'Larrowtail :: R () +token'Larrowtail = "⤛" `whenUnicodeOtherwise` "-<<" -- | Print @⤜@ or @>>-@ as appropriate. -rrarrowtail = "⤜" `whenUnicodeOtherwise` ">>-" +token'Rarrowtail :: R () +token'Rarrowtail = "⤜" `whenUnicodeOtherwise` ">>-" -- | Print @⇒@ or @=>@ as appropriate. -darrow = "⇒" `whenUnicodeOtherwise` "=>" +token'darrow :: R () +token'darrow = "⇒" `whenUnicodeOtherwise` "=>" -- | Print @∷@ or @::@ as appropriate. -dcolon = "∷" `whenUnicodeOtherwise` "::" +token'dcolon :: R () +token'dcolon = "∷" `whenUnicodeOtherwise` "::" -- | Print @←@ or @<-@ as appropriate. -larrow = "←" `whenUnicodeOtherwise` "<-" +token'larrow :: R () +token'larrow = "←" `whenUnicodeOtherwise` "<-" -- | Print @⤙@ or @-<@ as appropriate. -larrowtail = "⤙" `whenUnicodeOtherwise` "-<" +token'larrowtail :: R () +token'larrowtail = "⤙" `whenUnicodeOtherwise` "-<" -- | Print @→@ or @->@ as appropriate. -rarrow = "→" `whenUnicodeOtherwise` "->" +token'rarrow :: R () +token'rarrow = "→" `whenUnicodeOtherwise` "->" -- | Print @⤚@ or @>-@ as appropriate. -rarrowtail = "⤚" `whenUnicodeOtherwise` ">-" +token'rarrowtail :: R () +token'rarrowtail = "⤚" `whenUnicodeOtherwise` ">-" -- | Print @★@ or @*@ as appropriate. -star = "★" `whenUnicodeOtherwise` "*" +token'star :: R () +token'star = "★" `whenUnicodeOtherwise` "*" -- | Print @∀@ or @forall@ as appropriate. -forall = "∀" `whenUnicodeOtherwise` "forall" +token'forall :: R () +token'forall = "∀" `whenUnicodeOtherwise` "forall" -- | Print @⦇@ or @(|@ as appropriate. -oparenbar = "⦇" `whenUnicodeOtherwise` "(|" +token'oparenbar :: R () +token'oparenbar = "⦇" `whenUnicodeOtherwise` "(|" -- | Print @⦈@ or @|)@ as appropriate. -cparenbar = "⦈" `whenUnicodeOtherwise` "|)" +token'cparenbar :: R () +token'cparenbar = "⦈" `whenUnicodeOtherwise` "|)" -- | Print @⟦@ or @[|@ as appropriate. -openExpQuote = "⟦" `whenUnicodeOtherwise` "[|" +token'openExpQuote :: R () +token'openExpQuote = "⟦" `whenUnicodeOtherwise` "[|" -- | Print @⟧@ or @|]@ as appropriate. -closeQuote = "⟧" `whenUnicodeOtherwise` "|]" +token'closeQuote :: R () +token'closeQuote = "⟧" `whenUnicodeOtherwise` "|]" -- | Print @⊸@ or @%1 ->@ as appropriate. -lolly = "⊸" `whenUnicodeOtherwise` "%1 ->" +token'lolly :: R () +token'lolly = "⊸" `whenUnicodeOtherwise` "%1 ->" + +-- | Write the one text or the other depending on whether Unicode is enabled. +whenUnicodeOtherwise :: Text -> Text -> R () +unicodeText `whenUnicodeOtherwise` asciiText = do + unicodePrinterOption <- getPrinterOpt poUnicode + unicodeExtensionIsEnabled <- isExtensionEnabled UnicodeSyntax + txt $ case unicodePrinterOption of + UnicodeDetect -> if unicodeExtensionIsEnabled then unicodeText else asciiText + UnicodeAlways -> unicodeText + UnicodeNever -> asciiText ---------------------------------------------------------------------------- -- Placement diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -10,16 +10,17 @@ p_rdrName, p_qualName, p_infixDefHelper, - p_hsDocString, + p_hsDoc, + p_hsDoc', p_sourceText, ) where import Control.Monad import Data.Foldable (traverse_) -import Data.List (intersperse) import qualified Data.Text as T import GHC.Hs.Doc +import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp import GHC.Parser.Annotation import GHC.Types.Name.Occurrence (OccName (..)) @@ -132,15 +133,30 @@ inciIf indentArgs $ sitcc (sep breakpoint sitcc args) -- | Print a Haddock. -p_hsDocString :: +p_hsDoc :: -- | Haddock style HaddockStyle -> -- | Finish the doc string with a newline Bool -> - -- | The doc string to render - LHsDocString -> + -- | The 'LHsDoc' to render + LHsDoc GhcPs -> R () -p_hsDocString hstyle needsNewline (L l str) = do +p_hsDoc hstyle needsNewline lstr = do + poHStyle <- getPrinterOpt poHaddockStyle + p_hsDoc' poHStyle hstyle needsNewline lstr + +-- | Print a Haddock. +p_hsDoc' :: + -- | 'haddock-style' configuration option + HaddockPrintStyle -> + -- | Haddock style + HaddockStyle -> + -- | Finish the doc string with a newline + Bool -> + -- | The 'LHsDoc' to render + LHsDoc GhcPs -> + R () +p_hsDoc' poHStyle hstyle needsNewline (L l str) = do let isCommentSpan = \case HaddockSpan _ _ -> True CommentSpan _ -> True @@ -149,28 +165,36 @@ -- Make sure the Haddock is separated by a newline from other comments. when goesAfterComment newline + let docStringLines = splitDocString $ hsDocString str + mSrcSpan <- getSrcSpan l - printStyle <- getPrinterOpt poHaddockStyle let useSingleLineComments = or - [ printStyle == HaddockSingleLine, - length docLines <= 1, + [ poHStyle == HaddockSingleLine, + length docStringLines <= 1, -- Use multiple single-line comments when the whole comment is indented maybe False ((> 1) . srcSpanStartCol) mSrcSpan ] - let txt' x = unless (T.null x) (txt x) - body s = sequence_ $ intersperse s $ map txt' docLines + let body sep' = + forM_ (zip docStringLines (True : repeat False)) $ \(x, isFirst) -> do + if isFirst + then do + -- prevent trailing space in multi-line comments + unless (not useSingleLineComments && T.null x) space + else do + sep' + unless (T.null x) (txt x) if useSingleLineComments then do txt $ "-- " <> haddockDelim - body $ newline >> txt "--" + body $ newline >> txt "--" >> space else do txt . T.concat $ [ "{-", - case (hstyle, printStyle) of + case (hstyle, poHStyle) of (Pipe, HaddockMultiLineCompact) -> "" _ -> " ", haddockDelim @@ -190,7 +214,6 @@ when needsNewline newline traverse_ (setSpanMark . HaddockSpan hstyle) mSrcSpan where - docLines = splitDocString str haddockDelim = case hstyle of Pipe -> "|" diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -125,10 +125,10 @@ SpliceD _ x -> p_spliceDecl x DocD _ docDecl -> case docDecl of - DocCommentNext str -> p_hsDocString Pipe False (noLoc str) - DocCommentPrev str -> p_hsDocString Caret False (noLoc str) - DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str) - DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str) + DocCommentNext str -> p_hsDoc Pipe False str + DocCommentPrev str -> p_hsDoc Caret False str + DocCommentNamed name str -> p_hsDoc (Named name) False str + DocGroup n str -> p_hsDoc (Asterisk n) False str RoleAnnotD _ x -> p_roleAnnot x KindSigD _ s -> p_standaloneKindSig s @@ -314,7 +314,7 @@ 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 (SumPat _ (L _ p) _ _) = patBindNames p diff --git a/src/Ormolu/Printer/Meat/Declaration/Class.hs b/src/Ormolu/Printer/Meat/Declaration/Class.hs --- a/src/Ormolu/Printer/Meat/Declaration/Class.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Class.hs @@ -78,7 +78,7 @@ p_classContext ctx = unless (null (unLoc ctx)) $ do located ctx p_hsContext space - darrow + token'darrow breakpoint p_classFundeps :: [LHsFunDep GhcPs] -> R () @@ -97,7 +97,7 @@ p_funDep (FunDep _ before after) = do sep space p_rdrName before space - rarrow + token'rarrow space sep space p_rdrName after diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -14,6 +14,7 @@ import Data.Maybe (isJust, maybeToList) import qualified Data.Text as Text import Data.Void +import qualified GHC.Data.Strict as Strict import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall @@ -23,6 +24,7 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type +import Ormolu.Utils (matchAddEpAnn) p_dataDecl :: -- | Whether to format as data family @@ -66,7 +68,7 @@ (p_lhsTypeArg <$> tpats) forM_ dd_kindSig $ \k -> do space - dcolon + token'dcolon breakpoint inci $ located k p_hsType let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons @@ -107,7 +109,7 @@ R () p_conDecl singleConstRec = \case ConDeclGADT {..} -> do - mapM_ (p_hsDocString Pipe True) con_doc + mapM_ (p_hsDoc Pipe True) con_doc let conDeclSpn = fmap getLocA con_names <> [getLocA con_bndrs] @@ -116,7 +118,7 @@ where conArgsSpans = case con_g_args of PrefixConGADT xs -> getLocA . hsScaledThing <$> xs - RecConGADT x -> [getLocA x] + RecConGADT x _ -> [getLocA x] switchLayout conDeclSpn $ do case con_names of [] -> return () @@ -130,26 +132,28 @@ PrefixConGADT xs -> let go (HsScaled a b) t = addCLocAA t b (HsFunTy EpAnnNotUsed a b t) in foldr go con_res_ty xs - RecConGADT r -> + RecConGADT r _ -> addCLocAA r con_res_ty $ HsFunTy EpAnnNotUsed - (HsUnrestrictedArrow NormalSyntax) + (HsUnrestrictedArrow noHsUniTok) (la2la $ HsRecTy EpAnnNotUsed <$> r) con_res_ty qualTy = case con_mb_cxt of Nothing -> conTy Just qs -> addCLocAA qs conTy $ - HsQualTy NoExtField (Just qs) conTy + HsQualTy NoExtField qs conTy quantifiedTy = addCLocAA con_bndrs qualTy $ hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy startTypeAnnotationDecl quantifiedTy id p_hsType ConDeclH98 {..} -> do - mapM_ (p_hsDocString Pipe True) con_doc + mapM_ (p_hsDoc Pipe True) con_doc let conDeclWithContextSpn = - [RealSrcSpan real Nothing | AddEpAnn AnnForall (EpaSpan real) <- epAnnAnns con_ext] + [ RealSrcSpan real Strict.Nothing + | Just (EpaSpan real) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext + ] <> fmap getLocA con_ex_tvs <> maybeToList (fmap getLocA con_mb_cxt) <> conDeclSpn @@ -193,7 +197,7 @@ ctx -> do located ctx p_hsContext space - darrow + token'darrow breakpoint isGadt :: ConDecl GhcPs -> Bool diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -70,7 +70,7 @@ ) <$> cid_tyfam_insts dataFamInsts = - ( getLocA &&& fmap (InstD NoExtField . DataFamInstD EpAnnNotUsed) + ( getLocA &&& fmap (InstD NoExtField . DataFamInstD NoExtField) ) <$> cid_datafam_insts allDecls = diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -229,7 +229,7 @@ -- | Convert a LHsType containing an operator tree to the 'OpTree' -- intermediate representation. tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName) -tyOpTree (L _ (HsOpTy NoExtField l op r)) = +tyOpTree (L _ (HsOpTy _ _ l op r)) = OpBranches [tyOpTree l, tyOpTree r] [op] tyOpTree n = OpNode n diff --git a/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs b/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs --- a/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +++ b/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs @@ -11,14 +11,13 @@ import GHC.Core.Coercion.Axiom import GHC.Hs hiding (anns) import GHC.Types.Name.Reader -import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common p_roleAnnot :: RoleAnnotDecl GhcPs -> R () p_roleAnnot (RoleAnnotDecl _ l_name anns) = p_roleAnnot' l_name anns -p_roleAnnot' :: LocatedN RdrName -> [Located (Maybe Role)] -> R () +p_roleAnnot' :: LocatedN RdrName -> [XRec GhcPs (Maybe Role)] -> R () p_roleAnnot' l_name anns = do txt "type role" breakpoint diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -36,7 +36,7 @@ -- in the input or no forall at all. We do not want to add redundant -- foralls, so let's just skip the empty ones. unless (null ruleBndrs) $ - p_forallBndrs ForAllInvis p_ruleBndr (reLocA <$> ruleBndrs) + p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs breakpoint inci $ do located lhs p_hsExpr diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -133,15 +133,16 @@ space p_rdrName name space - dcolon + token'dcolon breakpoint inci $ sep commaDel (located' p_hsSigType) ts p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case - Inline -> txt "INLINE" - Inlinable -> txt "INLINEABLE" - NoInline -> txt "NOINLINE" + Inline _ -> txt "INLINE" + Inlinable _ -> txt "INLINEABLE" + NoInline _ -> txt "NOINLINE" + Opaque _ -> txt "OPAQUE" NoUserInlinePrag -> return () p_activation :: Activation -> R () @@ -203,11 +204,11 @@ sep commaDel p_rdrName cs forM_ mty $ \ty -> do space - dcolon + token'dcolon breakpoint inci (p_rdrName ty) -p_sccSig :: LocatedN RdrName -> Maybe (Located StringLiteral) -> R () +p_sccSig :: LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> R () p_sccSig loc literal = pragma "SCC" . inci $ do p_rdrName loc forM_ literal $ \x -> do diff --git a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs --- a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +++ b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs @@ -28,7 +28,7 @@ Associated -> mempty Free -> " family" let headerSpns = getLocA fdLName : (getLocA <$> hsq_explicit) - headerAndSigSpns = getLoc fdResultSig : headerSpns + headerAndSigSpns = getLocA fdResultSig : headerSpns inci . switchLayout headerAndSigSpns $ do breakpoint switchLayout headerSpns $ do @@ -58,7 +58,7 @@ inci (sep newline (located' p_tyFamInstEqn) eqs) p_familyResultSigL :: - Located (FamilyResultSig GhcPs) -> + LFamilyResultSig GhcPs -> Maybe (R ()) p_familyResultSigL (L _ a) = case a of NoSig NoExtField -> Nothing @@ -75,7 +75,7 @@ space p_rdrName a space - rarrow + token'rarrow space sep space p_rdrName bs diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Printer.Meat.Declaration.Value @@ -35,6 +38,7 @@ import Data.Void import GHC.Data.Bag (bagToList) import GHC.Data.FastString (FastString, lengthFS) +import qualified GHC.Data.Strict as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) import GHC.Parser.CharClass (is_space) @@ -67,12 +71,11 @@ = EqualSign | RightArrow -p_valDecl :: HsBindLR GhcPs GhcPs -> R () +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 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker - AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker PatSynBind _ psb -> p_patSynBind psb p_funBind :: @@ -88,7 +91,7 @@ p_matchGroup = p_matchGroup' exprPlacement p_hsExpr p_matchGroup' :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan, + ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => -- | How to get body placement @@ -157,7 +160,7 @@ p_match = p_match' exprPlacement p_hsExpr p_match' :: - (Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan) => + (Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns) => -- | How to get body placement (body -> Placement) -> -- | How to print body @@ -245,7 +248,7 @@ || not (onTheSameLine spn grhssSpan) -> Normal _ -> blockPlacement placer grhssGRHSs - guardNeedsLineBreak :: Located (GRHS GhcPs body) -> Bool + guardNeedsLineBreak :: XRec GhcPs (GRHS GhcPs body) -> Bool guardNeedsLineBreak (L _ (GRHS _ guardLStmts _)) = case guardLStmts of [] -> False [g] -> not . isOneLineSpan . getLocA $ g @@ -257,7 +260,7 @@ else EqualSign sep breakpoint - (located' (p_grhs' placement placer render groupStyle) . reLocA) + (located' (p_grhs' placement placer render groupStyle)) grhssGRHSs p_where = do unless (eqEmptyLocalBinds grhssLocalBinds) $ do @@ -273,7 +276,7 @@ Function _ -> space >> inci equals PatternBind -> space >> inci equals s | isCase s && hasGuards -> return () - _ -> space >> rarrow + _ -> space >> token'rarrow switchLayout [patGrhssSpan] $ placeHanging placement p_body inci p_where @@ -301,7 +304,7 @@ space inci $ case style of EqualSign -> equals - RightArrow -> rarrow + RightArrow -> token'rarrow -- If we have a sequence of guards and it is placed in the normal way, -- then we indent one level more for readability. Otherwise (all -- guards are on the same line) we do not need to indent, as it would @@ -333,10 +336,10 @@ breakpoint inci $ do case (arrType, rightToLeft) of - (HsFirstOrderApp, True) -> larrowtail - (HsHigherOrderApp, True) -> llarrowtail - (HsFirstOrderApp, False) -> rarrowtail - (HsHigherOrderApp, False) -> rrarrowtail + (HsFirstOrderApp, True) -> token'larrowtail + (HsHigherOrderApp, True) -> token'Larrowtail + (HsFirstOrderApp, False) -> token'rarrowtail + (HsHigherOrderApp, False) -> token'Rarrowtail placeHanging (exprPlacement (unLoc input)) $ located r p_hsExpr HsCmdArrForm _ form Prefix _ cmds -> banana s $ do @@ -357,15 +360,15 @@ space located expr p_hsExpr HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup - HsCmdPar _ c -> parens N $ sitcc $ located c p_hsCmd + HsCmdPar _ _ c _ -> parens N $ sitcc $ located c p_hsCmd HsCmdCase _ e mgroup -> p_case cmdPlacement p_hsCmd e mgroup - HsCmdLamCase _ mgroup -> - p_lamcase cmdPlacement p_hsCmd mgroup + HsCmdLamCase _ variant mgroup -> + p_lamcase variant cmdPlacement p_hsCmd mgroup HsCmdIf _ _ if' then' else' -> p_if cmdPlacement p_hsCmd if' then' else' - HsCmdLet epAnnLet localBinds c -> - p_let (s == S) p_hsCmd epAnnLet localBinds c + HsCmdLet _ letToken localBinds _ c -> + p_let (s == S) p_hsCmd letToken localBinds c HsCmdDo _ es -> do txt "do" p_stmts cmdPlacement (p_hsCmd' S) es @@ -422,7 +425,7 @@ BindStmt _ p f@(getLocA -> l) -> do located p p_pat space - larrow + token'larrow let loc = getLocA p placement | isOneLineSpan (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l)) = placer (unLoc f) @@ -530,16 +533,12 @@ sitcc $ sepSemi p_item' (attachRelativePos binds) HsValBinds _ _ -> notImplemented "HsValBinds" HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do - -- Second argument of IPBind is always Left before type-checking. - let p_ipBind (IPBind _ (Left name) expr) = do - atom name + let p_ipBind (IPBind _ (L _ name) expr) = do + atom @HsIPName name space equals breakpoint useBraces $ inci $ located expr p_hsExpr - p_ipBind (IPBind _ (Right _) _) = - -- Should only occur after the type checker - notImplemented "IPBind _ (Right _) _" sepSemi (located' p_ipBind) xs EmptyLocalBinds _ -> return () where @@ -548,13 +547,13 @@ -- depend on the layout being correctly set. pseudoLocated = \case EpAnn {anns = AnnList {al_anchor = Just Anchor {anchor}}} -> - located (L (RealSrcSpan anchor Nothing) ()) . const + located (L (RealSrcSpan anchor Strict.Nothing) ()) . const _ -> id -p_lhsFieldLabel :: Located (HsFieldLabel GhcPs) -> R () -p_lhsFieldLabel = located' $ p_lFieldLabelString . hflLabel +p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R () +p_ldotFieldOcc = located' $ p_lFieldLabelString . dfoLabel where - p_lFieldLabelString (L s fs) = parensIfOp . atom @FastString $ fs + p_lFieldLabelString (L (locA -> s) fs) = parensIfOp . atom @FastString $ fs where -- HACK For OverloadedRecordUpdate: -- In operator field updates (i.e. `f {(+) = 1}`), we don't have @@ -568,24 +567,27 @@ parens N | otherwise = id -p_fieldLabels :: [Located (HsFieldLabel GhcPs)] -> R () -p_fieldLabels flss = - sep (txt ".") p_lhsFieldLabel flss +p_ldotFieldOccs :: [XRec GhcPs (DotFieldOcc GhcPs)] -> R () +p_ldotFieldOccs = sep (txt ".") p_ldotFieldOcc -p_hsRecField :: - (id -> R ()) -> - HsRecField' id (LHsExpr GhcPs) -> +p_fieldOcc :: FieldOcc GhcPs -> R () +p_fieldOcc FieldOcc {..} = p_rdrName foLabel + +p_hsFieldBind :: + (lhs ~ GenLocated l a, HasSrcSpan l) => + (lhs -> R ()) -> + HsFieldBind lhs (LHsExpr GhcPs) -> R () -p_hsRecField p_lbl HsRecField {..} = do - located hsRecFieldLbl p_lbl - unless hsRecPun $ do +p_hsFieldBind p_lhs HsFieldBind {..} = do + p_lhs hfbLHS + unless hfbPun $ do space equals let placement = - if onTheSameLine (getLoc hsRecFieldLbl) (getLocA hsRecFieldArg) - then exprPlacement (unLoc hsRecFieldArg) + if onTheSameLine (getLoc' hfbLHS) (getLocA hfbRHS) + then exprPlacement (unLoc hfbRHS) else Normal - placeHanging placement (located hsRecFieldArg p_hsExpr) + placeHanging placement (located hfbRHS p_hsExpr) p_hsExpr :: HsExpr GhcPs -> R () p_hsExpr = p_hsExpr' N @@ -594,11 +596,7 @@ p_hsExpr' s = \case HsVar _ name -> p_rdrName name HsUnboundVar _ occ -> atom occ - HsConLikeOut _ _ -> notImplemented "HsConLikeOut" - HsRecFld _ x -> - case x of - Unambiguous _ name -> p_rdrName name - Ambiguous _ name -> p_rdrName name + HsRecSel _ fldOcc -> p_fieldOcc fldOcc HsOverLabel _ v -> do txt "#" atom v @@ -613,8 +611,8 @@ r -> atom r HsLam _ mgroup -> p_matchGroup Lambda mgroup - HsLamCase _ mgroup -> - p_lamcase exprPlacement p_hsExpr mgroup + HsLamCase _ variant mgroup -> + p_lamcase 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 @@ -706,7 +704,7 @@ -- negated literals, as `- 1` and `-1` have differing AST. when (negativeLiterals && isLiteral) space located e p_hsExpr - HsPar _ e -> + HsPar _ _ e _ -> parens s $ sitcc (located e (dontUseBraces . p_hsExpr)) SectionL _ x op -> do located x p_hsExpr @@ -729,7 +727,9 @@ case boxity of Boxed -> parens Unboxed -> parensHash - enclSpan <- fmap (flip RealSrcSpan Nothing) . maybeToList <$> getEnclosingSpan (const True) + enclSpan <- + fmap (flip RealSrcSpan Strict.Nothing) . maybeToList + <$> getEnclosingSpan (const True) if isSection then switchLayout [] . parens' s $ @@ -747,9 +747,9 @@ txt "if" breakpoint inci . inci $ sep newline (located' (p_grhs RightArrow)) guards - HsLet epAnnLet localBinds e -> - p_let (s == S) p_hsExpr epAnnLet localBinds e - HsDo _ ctx es -> do + HsLet _ letToken localBinds _ e -> + p_let (s == S) p_hsExpr letToken localBinds e + HsDo _ doFlavor es -> do let doBody moduleName header = do forM_ moduleName $ \m -> atom m *> txt "." txt header @@ -772,52 +772,48 @@ txt "|" space p_parBody lists - case ctx of + case doFlavor of DoExpr moduleName -> doBody moduleName "do" MDoExpr moduleName -> doBody moduleName "mdo" ListComp -> compBody MonadComp -> compBody - ArrowExpr -> notImplemented "ArrowExpr" GhciStmtCtxt -> notImplemented "GhciStmtCtxt" - PatGuard _ -> notImplemented "PatGuard" - ParStmtCtxt _ -> notImplemented "ParStmtCtxt" - TransStmtCtxt _ -> notImplemented "TransStmtCtxt" ExplicitList _ xs -> brackets s $ sep commaDel (sitcc . located' p_hsExprListItem) xs RecordCon {..} -> do - located rcon_con atom + p_rdrName rcon_con breakpointPreRecordBrace let HsRecFields {..} = rcon_flds - p_lbl = p_rdrName . rdrNameFieldOcc - fields = located' (p_hsRecField p_lbl) <$> rec_flds - dotdot = - case rec_dotdot of - Just {} -> [txt ".."] - Nothing -> [] + p_lhs = located' $ p_rdrName . foLabel + fields = located' (p_hsFieldBind p_lhs) <$> rec_flds + dotdot = case rec_dotdot of + Just {} -> [txt ".."] + Nothing -> [] inci . braces N $ sep commaDel sitcc (fields <> dotdot) RecordUpd {..} -> do located rupd_expr p_hsExpr breakpointPreRecordBrace let p_updLbl = - p_rdrName . \case - Unambiguous NoExtField n -> n - Ambiguous NoExtField n -> n + located' $ + p_rdrName . \case + (Unambiguous NoExtField n :: AmbiguousFieldOcc GhcPs) -> n + Ambiguous NoExtField n -> n p_recFields p_lbl = - sep commaDel (sitcc . located' (p_hsRecField p_lbl)) + sep commaDel (sitcc . located' (p_hsFieldBind p_lbl)) inci . braces N $ either (p_recFields p_updLbl) - (p_recFields (p_fieldLabels . coerce)) + (p_recFields $ located' $ coerce p_ldotFieldOccs) rupd_flds HsGetField {..} -> do located gf_expr p_hsExpr txt "." - p_lhsFieldLabel gf_field + p_ldotFieldOcc gf_field HsProjection {..} -> parens N $ do txt "." - p_fieldLabels (NE.toList proj_flds) + p_ldotFieldOccs (NE.toList proj_flds) ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do located x p_hsExpr inci $ startTypeAnnotation hswc_body p_hsSigType @@ -843,9 +839,13 @@ txt ".." space located to p_hsExpr - HsBracket epAnn x -> p_hsBracket epAnn x - HsRnBracketOut {} -> notImplemented "HsRnBracketOut" - HsTcBracketOut {} -> notImplemented "HsTcBracketOut" + HsTypedBracket _ expr -> do + txt "[||" + breakpoint' + located expr p_hsExpr + breakpoint' + txt "||]" + HsUntypedBracket epAnn x -> p_hsQuote epAnn x HsSpliceE _ splice -> p_hsSplice splice HsProc _ p e -> do txt "proc" @@ -853,22 +853,21 @@ breakpoint inci (p_pat x) breakpoint - rarrow + token'rarrow placeHanging (cmdTopPlacement (unLoc e)) $ located e (p_hsCmdTop N) HsStatic _ e -> do txt "static" breakpoint inci (located e p_hsExpr) - HsTick {} -> notImplemented "HsTick" - HsBinTick {} -> notImplemented "HsBinTick" HsPragE _ prag x -> case prag of HsPragSCC _ _ name -> do txt "{-# SCC " atom name txt " #-}" breakpoint - located x p_hsExpr + let inciIfS = case s of N -> id; S -> inci + inciIfS $ located x p_hsExpr p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do @@ -878,7 +877,7 @@ case psb_dir of Unidirectional -> switchLayout pattern_def_spans $ do - larrow + token'larrow breakpoint located psb_def p_pat ImplicitBidirectional -> @@ -888,7 +887,7 @@ located psb_def p_pat ExplicitBidirectional mgroup -> do switchLayout pattern_def_spans $ do - larrow + token'larrow breakpoint located psb_def p_pat breakpoint @@ -930,7 +929,7 @@ inci (rhs conSpans) p_case :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan, + ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => -- | Placer @@ -952,9 +951,11 @@ inci (p_matchGroup' placer render Case mgroup) p_lamcase :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan, + ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => + -- | Variant (@\\case@ or @\\cases@) + LamCaseVariant -> -- | Placer (body -> Placement) -> -- | Render @@ -962,8 +963,10 @@ -- | Expression MatchGroup GhcPs (LocatedA body) -> R () -p_lamcase placer render mgroup = do - txt "\\case" +p_lamcase variant placer render mgroup = do + txt $ case variant of + LamCase -> "\\case" + LamCases -> "\\cases" breakpoint inci (p_matchGroup' placer render LambdaCase mgroup) @@ -1001,16 +1004,16 @@ -- | Render (body -> R ()) -> -- | Annotation for the `let` block - EpAnn AnnsLet -> + LHsToken "let" GhcPs -> HsLocalBinds GhcPs -> LocatedA body -> R () -p_let inDo render epAnnLet localBinds e = p_let' inDo letLoc localBinds $ Just (located e render) +p_let inDo render letToken localBinds e = p_let' inDo letLoc localBinds $ Just (located e render) where letLoc = - case epAnnLet of - EpAnn {anns} -> Just (alLet anns) - EpAnnNotUsed -> Nothing + case getLoc letToken of + TokenLoc loc -> Just loc + NoTokenLoc -> Nothing p_let' :: -- | True if in do-block @@ -1026,9 +1029,9 @@ letStyle <- getPrinterOpt poLetStyle inStyle <- getPrinterOpt poInStyle layout <- getLayout - -- isAllInline = True if whole "let ... in ..." is one line - let isAllInline = not inDo && layout == SingleLine - -- isBlockInline = True if each "let ..." + "in ..." block is one line + -- isAllInline = True if whole "let ... in ..." should be one line + let isAllInline = layout == SingleLine && (not inDo || isJust mBody) + -- isBlockInline = True if each "let ..." + "in ..." block should be one line let isBlockInline = case letStyle of _ | isAllInline -> True @@ -1046,7 +1049,7 @@ LetInline -> True LetNewline -> False LetMixed -> numLocalBinds <= 1 - -- isInShifted = True if "in" is right-aligned with "let" + -- isInShifted = True if "in" should be right-aligned with "let" let isInShifted = inDo || inStyle == InRightAlign -- helpers @@ -1099,7 +1102,7 @@ p_rdrName name txt "@" located pat p_pat - ParPat _ pat -> + ParPat _ _ pat _ -> located pat (parens S . sitcc . p_pat) BangPat _ pat -> do txt "!" @@ -1116,19 +1119,18 @@ p_unboxedSum S tag arity (located pat p_pat) ConPat _ pat details -> case details of - PrefixCon [] xs -> sitcc $ do + PrefixCon tys xs -> sitcc $ do p_rdrName pat - unless (null xs) $ do - breakpoint - inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs - -- The first field of PrefixCon is filled in later stages - PrefixCon {} -> notImplemented "Unexpected types in constructor pattern" + unless (null tys && null xs) breakpoint + inci . sitcc $ + sep breakpoint (sitcc . either p_hsPatSigType (located' p_pat)) $ + (Left <$> tys) <> (Right <$> xs) RecCon (HsRecFields fields dotdot) -> do p_rdrName pat breakpointPreRecordBrace let f = \case Nothing -> txt ".." - Just x -> located x p_pat_hsRecField + Just x -> located x p_pat_hsFieldBind inci . braces N . sep commaDel f $ case dotdot of Nothing -> Just <$> fields @@ -1144,7 +1146,7 @@ ViewPat _ expr pat -> sitcc $ do located expr p_hsExpr space - rarrow + token'rarrow breakpoint inci (located pat p_pat) SplicePat _ splice -> p_hsSplice splice @@ -1166,14 +1168,17 @@ located pat p_pat p_typeAscription (lhsTypeToSigType hsps_body) -p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () -p_pat_hsRecField HsRecField {..} = do - located hsRecFieldLbl $ p_rdrName . rdrNameFieldOcc - unless hsRecPun $ do +p_hsPatSigType :: HsPatSigType GhcPs -> R () +p_hsPatSigType (HsPS _ ty) = txt "@" *> located ty p_hsType + +p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () +p_pat_hsFieldBind HsFieldBind {..} = do + located hfbLHS p_fieldOcc + unless hfbPun $ do space equals breakpoint - inci (located hsRecFieldArg p_pat) + inci (located hfbRHS p_pat) p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R () p_unboxedSum s tag arity m = do @@ -1221,11 +1226,11 @@ where decoSymbol = if isTyped then "$$" else "$" -p_hsBracket :: EpAnn [AddEpAnn] -> HsBracket GhcPs -> R () -p_hsBracket epAnn = \case +p_hsQuote :: EpAnn [AddEpAnn] -> HsQuote GhcPs -> R () +p_hsQuote epAnn = \case ExpBr _ expr -> do let name - | or [True | AddEpAnn AnnOpenEQ _ <- epAnnAnns epAnn] = "" + | any isJust (matchAddEpAnn AnnOpenEQ <$> epAnnAnns epAnn) = "" | otherwise = "e" quote name (located expr p_hsExpr) PatBr _ pat -> located pat (quote "p" . p_pat) @@ -1235,23 +1240,19 @@ VarBr _ isSingleQuote name -> do txt (bool "''" "'" isSingleQuote) p_rdrName name - TExpBr _ expr -> do - txt "[||" - breakpoint' - located expr p_hsExpr - breakpoint' - txt "||]" where quote :: Text -> R () -> R () quote name body = do - txt "[" - txt name - txt "|" + let (startQuote, endQuote) = + if Text.null name + then (token'openExpQuote, token'closeQuote) + else (txt "[" >> txt name >> txt "|", txt "|]") + startQuote breakpoint' inci $ do dontUseBraces body breakpoint' - txt "|]" + endQuote -- With StarIsType, type and declaration brackets might end with a *, -- so we have to insert a space in the end to prevent the (mis)parsing -- of an (*|) operator. @@ -1346,7 +1347,7 @@ cmdPlacement = \case HsCmdLam _ _ -> Hanging HsCmdCase _ _ _ -> Hanging - HsCmdLamCase _ _ -> Hanging + HsCmdLamCase _ _ _ -> Hanging HsCmdDo _ _ -> Hanging _ -> Normal @@ -1363,7 +1364,7 @@ | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> Hanging _ -> Normal - HsLamCase _ _ -> Hanging + HsLamCase _ _ _ -> 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 --- a/src/Ormolu/Printer/Meat/Declaration/Warning.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Warning.hs @@ -25,12 +25,12 @@ p_warnDecl (Warning _ functions warningTxt) = p_topLevelWarning functions warningTxt -p_moduleWarning :: WarningTxt -> R () +p_moduleWarning :: WarningTxt GhcPs -> R () p_moduleWarning wtxt = do let (pragmaText, lits) = warningText wtxt inci $ pragma pragmaText $ inci $ p_lits lits -p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt -> R () +p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt GhcPs -> R () p_topLevelWarning fnames wtxt = do let (pragmaText, lits) = warningText wtxt switchLayout (fmap getLocA fnames ++ fmap getLoc lits) $ @@ -39,10 +39,10 @@ breakpoint p_lits lits -warningText :: WarningTxt -> (Text, [Located StringLiteral]) +warningText :: WarningTxt GhcPs -> (Text, [Located StringLiteral]) warningText = \case - WarningTxt _ lits -> ("WARNING", lits) - DeprecatedTxt _ lits -> ("DEPRECATED", lits) + WarningTxt _ lits -> ("WARNING", fmap hsDocString <$> lits) + DeprecatedTxt _ lits -> ("DEPRECATED", fmap hsDocString <$> lits) p_lits :: [Located StringLiteral] -> R () p_lits = \case diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -13,6 +13,7 @@ import qualified Data.Text as T import GHC.Hs import GHC.LanguageExtensions.Type +import GHC.Types.PkgQual import GHC.Types.SrcLoc import GHC.Unit.Types import Ormolu.Config @@ -47,8 +48,8 @@ (txt "qualified") space case ideclPkgQual of - Nothing -> return () - Just slit -> atom slit + NoRawPkgQual -> return () + RawPkgQual slit -> atom slit space inci $ do located ideclName atom @@ -112,10 +113,10 @@ MiddlePos -> newline LastPos -> newline FirstAfterDocPos -> newline - indentDoc $ p_hsDocString (Asterisk n) False (noLoc str) + indentDoc $ p_hsDoc (Asterisk n) False str IEDoc NoExtField str -> indentDoc $ - p_hsDocString Pipe False (noLoc str) + p_hsDoc Pipe False str IEDocNamed NoExtField str -> indentDoc $ txt $ "-- $" <> T.pack str where -- Add a comma to a import-export list element diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -61,7 +61,11 @@ p_hsModuleHeader :: HsModule -> LocatedA ModuleName -> R () p_hsModuleHeader HsModule {..} moduleName = do located moduleName $ \name -> do - forM_ hsmodHaddockModHeader (p_hsDocString Pipe True) + poHStyle <- + getPrinterOpt poHaddockStyleModule >>= \case + PrintStyleInherit -> getPrinterOpt poHaddockStyle + PrintStyleOverride style -> pure style + forM_ hsmodHaddockModHeader (p_hsDoc' poHStyle Pipe True) p_hsmodName name forM_ hsmodDeprecMessage $ \w -> do diff --git a/src/Ormolu/Printer/Meat/Pragma.hs b/src/Ormolu/Printer/Meat/Pragma.hs --- a/src/Ormolu/Printer/Meat/Pragma.hs +++ b/src/Ormolu/Printer/Meat/Pragma.hs @@ -11,7 +11,10 @@ import Data.Char (isUpper) import qualified Data.List as L import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Text as T +import GHC.Driver.Flags (Language) import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma (Pragma (..)) @@ -37,7 +40,9 @@ -- -- See also: data LanguagePragmaClass - = -- | All other extensions + = -- | A pack of extensions like @GHC2021@ or @Haskell2010@ + ExtensionPack + | -- | All other extensions Normal | -- | Extensions starting with "No" Disabling @@ -76,6 +81,7 @@ -- | Classify a 'LanguagePragma'. classifyLanguagePragma :: String -> LanguagePragmaClass classifyLanguagePragma = \case + str | str `Set.member` extensionPacks -> ExtensionPack "ImplicitPrelude" -> Final "CUSKs" -> Final str -> @@ -88,3 +94,8 @@ then Disabling else Normal _ -> Normal + +-- | Extension packs, like @GHC2021@ and @Haskell2010@. +extensionPacks :: Set String +extensionPacks = + Set.fromList $ show <$> [minBound :: Language .. maxBound] diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -25,7 +25,6 @@ where import Control.Monad -import Data.Foldable (for_) import GHC.Hs import GHC.Types.Basic hiding (isPromoted) import GHC.Types.SourceText @@ -46,6 +45,7 @@ getPrinterOpt poFunctionArrows >>= \case TrailingArrows -> pure PipeStyle LeadingArrows -> pure CaretStyle + LeadingArgsArrows -> pure CaretStyle layout <- getLayout p_hsType' (hasDocStrings t || layout == MultiLine) s t @@ -68,12 +68,12 @@ LeadingArrows | multilineArgs -> interArgBreak >> txt " " >> p_forallBndrsEnd vis _ -> p_forallBndrsEnd vis >> interArgBreak p_hsTypeR (unLoc t) - HsQualTy _ qs' t -> do - for_ qs' $ \qs -> do - located qs p_hsContext - getPrinterOpt poFunctionArrows >>= \case - LeadingArrows -> interArgBreak >> darrow >> space - TrailingArrows -> space >> darrow >> interArgBreak + HsQualTy _ qs t -> do + located qs p_hsContext + getPrinterOpt poFunctionArrows >>= \case + LeadingArrows -> interArgBreak >> token'darrow >> space + TrailingArrows -> space >> token'darrow >> interArgBreak + LeadingArgsArrows -> space >> token'darrow >> interArgBreak case unLoc t of HsQualTy {} -> p_hsTypeR (unLoc t) HsFunTy {} -> p_hsTypeR (unLoc t) @@ -113,17 +113,18 @@ HsFunTy _ arrow x y -> do let p_arrow = case arrow of - HsUnrestrictedArrow _ -> rarrow - HsLinearArrow _ _ -> lolly - HsExplicitMult _ _ mult -> do + HsUnrestrictedArrow _ -> token'rarrow + HsLinearArrow _ -> token'lolly + HsExplicitMult _ mult _ -> do txt "%" p_hsTypeR (unLoc mult) space - rarrow + token'rarrow located x p_hsType getPrinterOpt poFunctionArrows >>= \case LeadingArrows -> interArgBreak >> located y (\y' -> p_arrow >> space >> p_hsTypeR y') TrailingArrows -> space >> p_arrow >> interArgBreak >> located y p_hsTypeR + LeadingArgsArrows -> interArgBreak >> located y (\y' -> p_arrow >> space >> p_hsTypeR y') HsListTy _ t -> located t (brackets N . p_hsType) HsTupleTy _ tsort xs -> @@ -135,7 +136,7 @@ HsSumTy _ xs -> parensHash N $ sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs - HsOpTy _ x op y -> do + HsOpTy _ _ x op y -> do fixityOverrides <- askFixityOverrides fixityMap <- askFixityMap let opTree = OpBranches [tyOpTree x, tyOpTree y] [op] @@ -146,7 +147,7 @@ HsIParamTy _ n t -> sitcc $ do located n atom inci $ startTypeAnnotation t p_hsType - HsStarTy _ _ -> star + HsStarTy _ _ -> token'star HsKindSig _ t k -> sitcc $ do located t p_hsType inci $ startTypeAnnotation k p_hsType @@ -154,12 +155,12 @@ HsDocTy _ t str -> case docStyle of PipeStyle -> do - p_hsDocString Pipe True str + p_hsDoc Pipe True str located t p_hsType CaretStyle -> do located t p_hsType newline - p_hsDocString Caret False str + p_hsDoc Caret False str HsBangTy _ (HsSrcBang _ u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-}" >> space @@ -242,15 +243,20 @@ getPrinterOpt poFunctionArrows >>= \case TrailingArrows -> do space - dcolon + token'dcolon breakTrailing located lItem renderItem LeadingArrows -> do breakLeading located lItem $ \item -> do - dcolon + token'dcolon space renderItem item + LeadingArgsArrows -> do + space + token'dcolon + breakTrailing + located lItem renderItem -- | Return 'True' if at least one argument in 'HsType' has a doc string -- attached to it. @@ -290,23 +296,28 @@ data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables. -p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R () +p_forallBndrs :: + HasSrcSpan l => + ForAllVisibility -> + (a -> R ()) -> + [GenLocated l a] -> + R () p_forallBndrs vis p tyvars = do p_forallBndrsStart p tyvars p_forallBndrsEnd vis -p_forallBndrsStart :: (a -> R ()) -> [LocatedA a] -> R () -p_forallBndrsStart _ [] = forall +p_forallBndrsStart :: HasSrcSpan l => (a -> R ()) -> [GenLocated l a] -> R () +p_forallBndrsStart _ [] = token'forall p_forallBndrsStart p tyvars = do - switchLayout (getLocA <$> tyvars) $ do - forall + switchLayout (getLoc' <$> tyvars) $ do + token'forall breakpoint inci $ do sitcc $ sep breakpoint (sitcc . located' p) tyvars p_forallBndrsEnd :: ForAllVisibility -> R () p_forallBndrsEnd ForAllInvis = txt "." >> space -p_forallBndrsEnd ForAllVis = space >> rarrow +p_forallBndrsEnd ForAllVis = space >> token'rarrow p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields xs = @@ -316,25 +327,30 @@ p_conDeclField ConDeclField {..} = do commaStyle <- getPrinterOpt poCommaStyle when (commaStyle == Trailing) $ - mapM_ (p_hsDocString Pipe True) cd_fld_doc + mapM_ (p_hsDoc Pipe True) cd_fld_doc sitcc $ sep commaDel - (located' (p_rdrName . rdrNameFieldOcc)) + (located' (p_rdrName . foLabel)) cd_fld_names getPrinterOpt poFunctionArrows >>= \case LeadingArrows -> inci $ do breakpoint - dcolon + token'dcolon space p_hsType (unLoc cd_fld_type) TrailingArrows -> do space - dcolon + token'dcolon breakpoint sitcc . inci $ p_hsType (unLoc cd_fld_type) + LeadingArgsArrows -> do + space + token'dcolon + breakpoint + sitcc . inci $ p_hsType (unLoc cd_fld_type) when (commaStyle == Leading) $ - mapM_ (inciByFrac (-1) . (newline >>) . p_hsDocString Caret False) cd_fld_doc + mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret False) cd_fld_doc p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -17,6 +17,7 @@ groupBy', HasSrcSpan (..), getLoc', + matchAddEpAnn, ) where @@ -26,6 +27,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified GHC.Data.Strict as Strict import GHC.Driver.Ppr import GHC.DynFlags (baseDynFlags) import GHC.Hs @@ -74,10 +76,11 @@ where r = fmap (escapeLeadingDollar . escapeCommentBraces) + . dropPaddingSpace . dropWhileEnd T.null . fmap (T.stripEnd . T.pack) . lines - $ unpackHDS docStr + $ renderHsDocString docStr -- We cannot have the first character to be a dollar because in that -- case it'll be a parse error (apparently collides with named docs -- syntax @-- $name@ somehow). @@ -85,6 +88,20 @@ case T.uncons txt of Just ('$', _) -> T.cons '\\' txt _ -> txt + dropPaddingSpace xs = + case dropWhile T.null xs of + [] -> [] + (x : _) -> + let leadingSpace txt = case T.uncons txt of + Just (' ', _) -> True + _ -> False + dropSpace txt = + if leadingSpace txt + then T.drop 1 txt + else txt + in if leadingSpace x + then dropSpace <$> xs + else xs escapeCommentBraces = T.replace "{-" "{\\-" . T.replace "-}" "-\\}" -- | Increment line number in a 'SrcSpan'. @@ -98,7 +115,7 @@ line = srcLocLine x col = srcLocCol x in mkRealSrcLoc file (line + i) col - in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end)) Nothing + in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end)) Strict.Nothing UnhelpfulSpan x -> UnhelpfulSpan x -- | Do two declarations have a blank between them? @@ -139,3 +156,10 @@ 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 +matchAddEpAnn annId (AddEpAnn annId' loc) + | annId == annId' || unicodeAnn annId == annId' = Just loc + | otherwise = Nothing diff --git a/tests/Ormolu/CabalInfoSpec.hs b/tests/Ormolu/CabalInfoSpec.hs --- a/tests/Ormolu/CabalInfoSpec.hs +++ b/tests/Ormolu/CabalInfoSpec.hs @@ -38,7 +38,7 @@ ciDynOpts `shouldBe` [DynOption "-XHaskell2010"] it "extracts correct dependencies from fourmolu.cabal (src/Ormolu/Config.hs)" $ do CabalInfo {..} <- parseCabalInfo "fourmolu.cabal" "src/Ormolu/Config.hs" - ciDependencies `shouldBe` Set.fromList ["Cabal", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "bytestring", "containers", "directory", "dlist", "exceptions", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "template-haskell", "text", "th-lift-instances", "yaml"] + ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "bytestring", "containers", "directory", "dlist", "exceptions", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "template-haskell", "text", "th-lift-instances", "yaml"] it "extracts correct dependencies from fourmolu.cabal (tests/Ormolu/PrinterSpec.hs)" $ do CabalInfo {..} <- parseCabalInfo "fourmolu.cabal" "tests/Ormolu/PrinterSpec.hs" ciDependencies `shouldBe` Set.fromList ["Diff", "QuickCheck", "base", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "megaparsec", "fourmolu", "path", "path-io", "pretty", "process", "temporary", "text"] diff --git a/tests/Ormolu/Config/PrinterOptsSpec.hs b/tests/Ormolu/Config/PrinterOptsSpec.hs --- a/tests/Ormolu/Config/PrinterOptsSpec.hs +++ b/tests/Ormolu/Config/PrinterOptsSpec.hs @@ -28,6 +28,7 @@ detectSourceType, ormolu, ) +import Ormolu.Config (HaddockPrintStyleModule (..)) import Ormolu.Exception (OrmoluException, printOrmoluException) import Ormolu.Terminal (ColorMode (..), runTerm) import Ormolu.Utils.IO (readFileUtf8, writeFileUtf8) @@ -130,10 +131,24 @@ }, TestGroup { label = "haddock-style", - testCases = allOptions, - updateConfig = \haddockStyle opts -> opts {poHaddockStyle = pure haddockStyle}, - showTestCase = show, - testCaseSuffix = suffix1 + testCases = (,) <$> allOptions <*> (PrintStyleInherit : map PrintStyleOverride allOptions), + updateConfig = \(haddockStyle, haddockStyleModule) opts -> + opts + { poHaddockStyle = pure haddockStyle, + poHaddockStyleModule = pure haddockStyleModule + }, + showTestCase = \(haddockStyle, haddockStyleModule) -> + show haddockStyle + ++ case haddockStyleModule of + PrintStyleInherit -> "" + PrintStyleOverride style -> " + module=" ++ show style, + testCaseSuffix = \(haddockStyle, haddockStyleModule) -> + suffixWith + [ show haddockStyle, + case haddockStyleModule of + PrintStyleInherit -> "" + PrintStyleOverride style -> "module=" ++ show style + ] }, TestGroup { label = "let-style",