fourmolu 0.9.0.0 → 0.10.0.0
raw patch · 102 files changed
+1286/−417 lines, 102 filesdep +Cabal-syntaxdep −Cabaldep ~ghc-lib-parserPVP ok
version bump matches the API change (PVP)
Dependencies added: Cabal-syntax
Dependencies removed: Cabal
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
- Ormolu.Parser: instance GHC.Classes.Eq Ormolu.Parser.SeverityOrd
- Ormolu.Parser: instance GHC.Classes.Ord Ormolu.Parser.SeverityOrd
- Ormolu.Printer.Combinators: closeQuote :: R ()
- Ormolu.Printer.Combinators: cparenbar :: R ()
- Ormolu.Printer.Combinators: darrow :: R ()
- Ormolu.Printer.Combinators: dcolon :: R ()
- Ormolu.Printer.Combinators: forall :: R ()
- Ormolu.Printer.Combinators: larrow :: R ()
- Ormolu.Printer.Combinators: larrowtail :: R ()
- Ormolu.Printer.Combinators: llarrowtail :: R ()
- Ormolu.Printer.Combinators: lolly :: R ()
- Ormolu.Printer.Combinators: oparenbar :: R ()
- Ormolu.Printer.Combinators: openExpQuote :: R ()
- Ormolu.Printer.Combinators: rarrow :: R ()
- Ormolu.Printer.Combinators: rarrowtail :: R ()
- Ormolu.Printer.Combinators: rrarrowtail :: R ()
- Ormolu.Printer.Combinators: star :: R ()
- Ormolu.Printer.Combinators: whenUnicodeOtherwise :: Text -> Text -> R ()
- Ormolu.Printer.Meat.Common: p_hsDocString :: HaddockStyle -> Bool -> LHsDocString -> R ()
+ Ormolu: [poHaddockStyleModule] :: PrinterOpts f -> f HaddockPrintStyleModule
+ Ormolu.Config: PrintStyleInherit :: HaddockPrintStyleModule
+ Ormolu.Config: PrintStyleOverride :: HaddockPrintStyle -> HaddockPrintStyleModule
+ Ormolu.Config: [poHaddockStyleModule] :: PrinterOpts f -> f HaddockPrintStyleModule
+ Ormolu.Config: data HaddockPrintStyleModule
+ Ormolu.Config: instance Ormolu.Config.PrinterOptsFieldType Ormolu.Config.Types.HaddockPrintStyleModule
+ Ormolu.Printer: [poHaddockStyleModule] :: PrinterOpts f -> f HaddockPrintStyleModule
+ Ormolu.Printer.Combinators: token'Larrowtail :: R ()
+ Ormolu.Printer.Combinators: token'Rarrowtail :: R ()
+ Ormolu.Printer.Combinators: token'closeQuote :: R ()
+ Ormolu.Printer.Combinators: token'cparenbar :: R ()
+ Ormolu.Printer.Combinators: token'darrow :: R ()
+ Ormolu.Printer.Combinators: token'dcolon :: R ()
+ Ormolu.Printer.Combinators: token'forall :: R ()
+ Ormolu.Printer.Combinators: token'larrow :: R ()
+ Ormolu.Printer.Combinators: token'larrowtail :: R ()
+ Ormolu.Printer.Combinators: token'lolly :: R ()
+ Ormolu.Printer.Combinators: token'oparenbar :: R ()
+ Ormolu.Printer.Combinators: token'openExpQuote :: R ()
+ Ormolu.Printer.Combinators: token'rarrow :: R ()
+ Ormolu.Printer.Combinators: token'rarrowtail :: R ()
+ Ormolu.Printer.Combinators: token'star :: R ()
+ Ormolu.Printer.Meat.Common: p_hsDoc :: HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
+ Ormolu.Printer.Meat.Common: p_hsDoc' :: HaddockPrintStyle -> HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
+ Ormolu.Utils: matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation
- Ormolu: PrinterOpts :: f Int -> f FunctionArrowsStyle -> f CommaStyle -> f ImportExportStyle -> f Bool -> f Bool -> f Int -> f HaddockPrintStyle -> f LetStyle -> f InStyle -> f Unicode -> f Bool -> PrinterOpts f
+ Ormolu: PrinterOpts :: f Int -> f FunctionArrowsStyle -> f CommaStyle -> f ImportExportStyle -> f Bool -> f Bool -> f Int -> f HaddockPrintStyle -> f HaddockPrintStyleModule -> f LetStyle -> f InStyle -> f Unicode -> f Bool -> PrinterOpts f
- Ormolu.Config: PrinterOpts :: f Int -> f FunctionArrowsStyle -> f CommaStyle -> f ImportExportStyle -> f Bool -> f Bool -> f Int -> f HaddockPrintStyle -> f LetStyle -> f InStyle -> f Unicode -> f Bool -> PrinterOpts f
+ Ormolu.Config: PrinterOpts :: f Int -> f FunctionArrowsStyle -> f CommaStyle -> f ImportExportStyle -> f Bool -> f Bool -> f Int -> f HaddockPrintStyle -> f HaddockPrintStyleModule -> f LetStyle -> f InStyle -> f Unicode -> f Bool -> PrinterOpts f
- Ormolu.Printer: PrinterOpts :: f Int -> f FunctionArrowsStyle -> f CommaStyle -> f ImportExportStyle -> f Bool -> f Bool -> f Int -> f HaddockPrintStyle -> f LetStyle -> f InStyle -> f Unicode -> f Bool -> PrinterOpts f
+ Ormolu.Printer: PrinterOpts :: f Int -> f FunctionArrowsStyle -> f CommaStyle -> f ImportExportStyle -> f Bool -> f Bool -> f Int -> f HaddockPrintStyle -> f HaddockPrintStyleModule -> f LetStyle -> f InStyle -> f Unicode -> f Bool -> PrinterOpts f
- Ormolu.Printer.Meat.Declaration.Value: p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
+ Ormolu.Printer.Meat.Declaration.Value: p_valDecl :: HsBind GhcPs -> R ()
- Ormolu.Printer.Meat.Declaration.Warning: p_moduleWarning :: WarningTxt -> R ()
+ Ormolu.Printer.Meat.Declaration.Warning: p_moduleWarning :: WarningTxt GhcPs -> R ()
- Ormolu.Printer.Meat.Type: p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
+ Ormolu.Printer.Meat.Type: p_forallBndrs :: HasSrcSpan l => ForAllVisibility -> (a -> R ()) -> [GenLocated l a] -> R ()
Files
- CHANGELOG.md +48/−1
- README.md +11/−11
- data/examples/declaration/data/existential-unicode-four-out.hs +9/−0
- data/examples/declaration/data/existential-unicode-out.hs +9/−0
- data/examples/declaration/data/existential-unicode.hs +7/−0
- data/examples/declaration/signature/inline/noinline-four-out.hs +4/−0
- data/examples/declaration/signature/inline/noinline-out.hs +4/−0
- data/examples/declaration/signature/inline/noinline.hs +4/−0
- data/examples/declaration/splice/bracket-unicode-four-out.hs +6/−0
- data/examples/declaration/splice/bracket-unicode-out.hs +6/−0
- data/examples/declaration/splice/bracket-unicode.hs +6/−0
- data/examples/declaration/value/function/lambda-case-four-out.hs +8/−0
- data/examples/declaration/value/function/lambda-case-out.hs +8/−0
- data/examples/declaration/value/function/lambda-case.hs +8/−0
- data/examples/declaration/value/function/pragmas-four-out.hs +5/−0
- data/examples/declaration/value/function/pragmas-out.hs +5/−0
- data/examples/declaration/value/function/pragmas.hs +4/−0
- data/examples/declaration/value/function/type-applications-four-out.hs +8/−0
- data/examples/declaration/value/function/type-applications-out.hs +8/−0
- data/examples/declaration/value/function/type-applications.hs +6/−0
- data/examples/declaration/value/function/unboxed-sums-four-out.hs +2/−0
- data/examples/declaration/value/function/unboxed-sums-out.hs +2/−0
- data/examples/declaration/value/function/unboxed-sums.hs +2/−0
- data/examples/import/sorted-package-imports-four-out.hs +7/−0
- data/examples/import/sorted-package-imports-out.hs +7/−0
- data/examples/import/sorted-package-imports.hs +7/−0
- data/examples/module-header/leading-empty-line-four-out.hs +8/−8
- data/examples/module-header/named-section-four-out.hs +1/−1
- data/examples/other/comment-spacing-four-out.hs +3/−3
- data/examples/other/comment-spacing-out.hs +3/−3
- data/examples/other/comment-style-transform-out.hs +10/−10
- data/examples/other/following-comment-last-3-four-out.hs +1/−1
- data/examples/other/haddock-sections-four-out.hs +2/−2
- data/examples/other/invalid-haddock-weird-four-out.hs +3/−1
- data/examples/other/invalid-haddock-weird-out.hs +3/−1
- data/examples/other/pragma-sorting-four-out.hs +2/−0
- data/examples/other/pragma-sorting-out.hs +2/−0
- data/examples/other/pragma-sorting.hs +2/−0
- data/fourmolu/function-arrows/output-LeadingArgsArrows.hs +129/−0
- data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLine.hs +31/−0
- data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLineCompact.hs +31/−0
- data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockSingleLine.hs +30/−0
- data/fourmolu/haddock-style/output-HaddockMultiLine.hs +4/−4
- data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLine.hs +31/−0
- data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLineCompact.hs +31/−0
- data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockSingleLine.hs +30/−0
- data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs +4/−4
- data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLine.hs +28/−0
- data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLineCompact.hs +28/−0
- data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockSingleLine.hs +27/−0
- data/fourmolu/haddock-style/output-HaddockSingleLine.hs +2/−2
- data/fourmolu/let-style/input.hs +7/−0
- data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=2.hs +9/−0
- data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=4.hs +9/−0
- data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=2.hs +9/−0
- data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=4.hs +9/−0
- data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=2.hs +7/−0
- data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=4.hs +7/−0
- data/fourmolu/let-style/output-LetInline-InRightAlign-indent=2.hs +7/−0
- data/fourmolu/let-style/output-LetInline-InRightAlign-indent=4.hs +7/−0
- data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=2.hs +7/−0
- data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=4.hs +7/−0
- data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=2.hs +7/−0
- data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=4.hs +7/−0
- data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=2.hs +9/−0
- data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=4.hs +9/−0
- data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=2.hs +9/−0
- data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=4.hs +9/−0
- data/fourmolu/unicode-syntax/input.hs +4/−0
- data/fourmolu/unicode-syntax/output-UnicodeAlways.hs +5/−1
- data/fourmolu/unicode-syntax/output-UnicodeDetect.hs +5/−1
- data/fourmolu/unicode-syntax/output-UnicodeNever.hs +4/−0
- fourmolu.cabal +9/−9
- fourmolu.yaml +1/−0
- src/GHC/DynFlags.hs +1/−0
- src/Ormolu/Config.hs +24/−1
- src/Ormolu/Config/Types.hs +9/−0
- src/Ormolu/Diff/ParseResult.hs +7/−3
- src/Ormolu/Imports.hs +6/−2
- src/Ormolu/Parser.hs +27/−40
- src/Ormolu/Parser/CommentStream.hs +18/−16
- src/Ormolu/Parser/Pragma.hs +3/−9
- src/Ormolu/Printer/Combinators.hs +70/−71
- src/Ormolu/Printer/Meat/Common.hs +37/−14
- src/Ormolu/Printer/Meat/Declaration.hs +5/−5
- src/Ormolu/Printer/Meat/Declaration/Class.hs +2/−2
- src/Ormolu/Printer/Meat/Declaration/Data.hs +13/−9
- src/Ormolu/Printer/Meat/Declaration/Instance.hs +1/−1
- src/Ormolu/Printer/Meat/Declaration/OpTree.hs +1/−1
- src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +1/−2
- src/Ormolu/Printer/Meat/Declaration/Rule.hs +1/−1
- src/Ormolu/Printer/Meat/Declaration/Signature.hs +7/−6
- src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +3/−3
- src/Ormolu/Printer/Meat/Declaration/Value.hs +123/−122
- src/Ormolu/Printer/Meat/Declaration/Warning.hs +5/−5
- src/Ormolu/Printer/Meat/ImportExport.hs +5/−4
- src/Ormolu/Printer/Meat/Module.hs +5/−1
- src/Ormolu/Printer/Meat/Pragma.hs +12/−1
- src/Ormolu/Printer/Meat/Type.hs +44/−28
- src/Ormolu/Utils.hs +26/−2
- tests/Ormolu/CabalInfoSpec.hs +1/−1
- tests/Ormolu/Config/PrinterOptsSpec.hs +19/−4
CHANGELOG.md view
@@ -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:
README.md view
@@ -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:
+ data/examples/declaration/data/existential-unicode-four-out.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE UnicodeSyntax #-}++data Foo+ = forall a.+ Foo++data Bar+ = forall a.+ Bar
+ data/examples/declaration/data/existential-unicode-out.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE UnicodeSyntax #-}++data Foo+ = forall a.+ Foo++data Bar+ = forall a.+ Bar
+ data/examples/declaration/data/existential-unicode.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE UnicodeSyntax #-}++data Foo = forall+ a. Foo++data Bar = ∀+ a. Bar
data/examples/declaration/signature/inline/noinline-four-out.hs view
@@ -9,3 +9,7 @@ baz :: Int -> Int baz = id {-# NOINLINE [~2] baz #-}++blub :: Int -> Int+blub = baz+{-# OPAQUE blub #-}
data/examples/declaration/signature/inline/noinline-out.hs view
@@ -9,3 +9,7 @@ baz :: Int -> Int baz = id {-# NOINLINE [~2] baz #-}++blub :: Int -> Int+blub = baz+{-# OPAQUE blub #-}
data/examples/declaration/signature/inline/noinline.hs view
@@ -11,3 +11,7 @@ baz = id {-# NOINLINE [~2] baz #-}++blub :: Int -> Int+blub = baz+{-# opaque blub #-}
+ data/examples/declaration/splice/bracket-unicode-four-out.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++ascii = [|x|]++unicode = [|x|]
+ data/examples/declaration/splice/bracket-unicode-out.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++ascii = [|x|]++unicode = [|x|]
+ data/examples/declaration/splice/bracket-unicode.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++ascii = [|x|]++unicode = ⟦x⟧
data/examples/declaration/value/function/lambda-case-four-out.hs view
@@ -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
data/examples/declaration/value/function/lambda-case-out.hs view
@@ -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
data/examples/declaration/value/function/lambda-case.hs view
@@ -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
data/examples/declaration/value/function/pragmas-four-out.hs view
@@ -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
data/examples/declaration/value/function/pragmas-out.hs view
@@ -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
data/examples/declaration/value/function/pragmas.hs view
@@ -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
data/examples/declaration/value/function/type-applications-four-out.hs view
@@ -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 ->+ ""
data/examples/declaration/value/function/type-applications-out.hs view
@@ -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 ->+ ""
data/examples/declaration/value/function/type-applications.hs view
@@ -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+ -> ""
data/examples/declaration/value/function/unboxed-sums-four-out.hs view
@@ -22,3 +22,5 @@ (# | | | 10 | | | | | #)++type UbxPair = (# | #)
data/examples/declaration/value/function/unboxed-sums-out.hs view
@@ -22,3 +22,5 @@ (# | | | 10 | | | | | #)++type UbxPair = (# | #)
data/examples/declaration/value/function/unboxed-sums.hs view
@@ -12,3 +12,5 @@ baz = (# | | | 10 | | | | | #)++type UbxPair = (# | #)
+ data/examples/import/sorted-package-imports-four-out.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}++import D+import "a" Ab+import "b" Aa+import "b" Bb+import "c" Ba
+ data/examples/import/sorted-package-imports-out.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}++import D+import "a" Ab+import "b" Aa+import "b" Bb+import "c" Ba
+ data/examples/import/sorted-package-imports.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}++import "b" Aa+import "a" Ab+import "c" Ba+import D+import "b" Bb
data/examples/module-header/leading-empty-line-four-out.hs view
@@ -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 <markkarpov92@gmail.com>- Stability : experimental- Portability : portable+Maintainer : Mark Karpov <markkarpov92@gmail.com>+Stability : experimental+Portability : portable -} module Main where
data/examples/module-header/named-section-four-out.hs view
@@ -10,5 +10,5 @@ {- $explanation - Here it goes.+Here it goes. -}
data/examples/other/comment-spacing-four-out.hs view
@@ -1,7 +1,7 @@--- |Something.+-- | Something. foo ::- -- |Foo.+ -- | Foo. Int ->- -- |Bar.+ -- | Bar. IO () foo _ = pure () -- comment
data/examples/other/comment-spacing-out.hs view
@@ -1,7 +1,7 @@--- |Something.+-- | Something. foo ::- -- |Foo.+ -- | Foo. Int ->- -- |Bar.+ -- | Bar. IO () foo _ = pure () -- comment
data/examples/other/comment-style-transform-out.hs view
@@ -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
data/examples/other/following-comment-last-3-four-out.hs view
@@ -3,5 +3,5 @@ -- | Another datatype... data D' {- ^ ...with two docstrings.- even on second line+even on second line -}
data/examples/other/haddock-sections-four-out.hs view
@@ -1,9 +1,9 @@ {- $weird #anchor# - Section 1+Section 1 -} {- $normal - Section 2+Section 2 -}
data/examples/other/invalid-haddock-weird-four-out.hs view
@@ -1,3 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo -- \|# ${+foo = foo++-- \|# ${
data/examples/other/invalid-haddock-weird-out.hs view
@@ -1,3 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo -- \|# ${+foo = foo++-- \|# ${
data/examples/other/pragma-sorting-four-out.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}
data/examples/other/pragma-sorting-out.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}
data/examples/other/pragma-sorting.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GHC2021 #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NondecreasingIndentation #-}
+ data/fourmolu/function-arrows/output-LeadingArgsArrows.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLine.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockMultiLineCompact.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockMultiLine-module=HaddockSingleLine.hs view
@@ -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
data/fourmolu/haddock-style/output-HaddockMultiLine.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLine.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockMultiLineCompact.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockMultiLineCompact-module=HaddockSingleLine.hs view
@@ -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
data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLine.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockMultiLineCompact.hs view
@@ -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
+ data/fourmolu/haddock-style/output-HaddockSingleLine-module=HaddockSingleLine.hs view
@@ -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
data/fourmolu/haddock-style/output-HaddockSingleLine.hs view
@@ -13,8 +13,8 @@ multi1 :: Int -- |---This is a multiline---function haddock+-- This is a multiline+-- function haddock multi2 :: Int -- | This is a haddock
data/fourmolu/let-style/input.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetAuto-InLeftAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetAuto-InRightAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetInline-InLeftAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetInline-InRightAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetInline-InRightAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetMixed-InLeftAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetMixed-InRightAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetNewline-InLeftAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=2.hs view
@@ -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 --}
data/fourmolu/let-style/output-LetNewline-InRightAlign-indent=4.hs view
@@ -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 --}
data/fourmolu/unicode-syntax/input.hs view
@@ -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
data/fourmolu/unicode-syntax/output-UnicodeAlways.hs view
@@ -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
data/fourmolu/unicode-syntax/output-UnicodeDetect.hs view
@@ -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
data/fourmolu/unicode-syntax/output-UnicodeNever.hs view
@@ -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
fourmolu.cabal view
@@ -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 <parsonsmatt@gmail.com> George Thomas <georgefsthomas@gmail.com> Brandon Chinn <brandonchinn178@gmail.com>-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,
fourmolu.yaml view
@@ -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
src/GHC/DynFlags.hs view
@@ -38,6 +38,7 @@ platformIsCrossCompiling = False, platformLeadingUnderscore = False, platformTablesNextToCode = False,+ platformHasLibm = False, platform_constants = Nothing }, sPlatformMisc = PlatformMisc {},
src/Ormolu/Config.hs view
@@ -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"
src/Ormolu/Config/Types.hs view
@@ -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
src/Ormolu/Diff/ParseResult.hs view
@@ -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)
src/Ormolu/Imports.hs view
@@ -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]
src/Ormolu/Parser.hs view
@@ -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
src/Ormolu/Parser/CommentStream.hs view
@@ -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
src/Ormolu/Parser/Pragma.hs view
@@ -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]
src/Ormolu/Printer/Combinators.hs view
@@ -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
src/Ormolu/Printer/Meat/Common.hs view
@@ -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 -> "|"
src/Ormolu/Printer/Meat/Declaration.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Class.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Data.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Instance.hs view
@@ -70,7 +70,7 @@ ) <$> cid_tyfam_insts dataFamInsts =- ( getLocA &&& fmap (InstD NoExtField . DataFamInstD EpAnnNotUsed)+ ( getLocA &&& fmap (InstD NoExtField . DataFamInstD NoExtField) ) <$> cid_datafam_insts allDecls =
src/Ormolu/Printer/Meat/Declaration/OpTree.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Rule.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Signature.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Value.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Warning.hs view
@@ -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
src/Ormolu/Printer/Meat/ImportExport.hs view
@@ -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
src/Ormolu/Printer/Meat/Module.hs view
@@ -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
src/Ormolu/Printer/Meat/Pragma.hs view
@@ -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: <https://github.com/tweag/ormolu/issues/404> 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]
src/Ormolu/Printer/Meat/Type.hs view
@@ -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
src/Ormolu/Utils.hs view
@@ -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
tests/Ormolu/CabalInfoSpec.hs view
@@ -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"]
tests/Ormolu/Config/PrinterOptsSpec.hs view
@@ -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",