diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,48 @@ +## Fourmolu 0.12.0.0 + +* Add `single-constraint-parens` option for controlling parenthesis around constraints in type + signatures. See [issue 288](https://github.com/fourmolu/fourmolu/pull/304) + +* Add `column-limit` option to try to insert line breaks when lines exceed a certain length. + May break idempotence in some particularly painful cases. + See [issue 71](https://github.com/fourmolu/fourmolu/pull/305) + +* Add a new CLI flag `--print-defaults` which makes fourmolu print default options to stdout. + This can be used to generate default config which can be further tweaked by user `fourmolu --print-defaults > fourmolu.yaml`. + See [issue 307](https://github.com/fourmolu/fourmolu/pull/308) + +### Upstream changes: + +#### Ormolu 0.6.0.1 + +* Fix false positives in AST diffing related to `UnicodeSyntax`. [PR + 1009](https://github.com/tweag/ormolu/pull/1009). + +#### Ormolu 0.6.0.0 + +* Haddocks attached to arguments of a data constructor are now formatted in + the pipe style (rather than the caret style), consistent with everything + else. As a consequence, now Ormolu's output will be deemed invalid by the + Haddock shipped with GHC <9.0. [Issue + 844](https://github.com/tweag/ormolu/issues/844) and [issue + 828](https://github.com/tweag/ormolu/issues/828). + +* Insert space before char literals in ticked promoted constructs when + necessary. [Issue 1000](https://github.com/tweag/ormolu/issues/1000). + +* Switched to `ghc-lib-parser-9.6`: + * Extended `OverloadedLabels`: `#Foo`, `#3`, `#"Hello there"`. + + Also, it is now disabled by default, as it causes e.g. `a#b` to be parsed + differently. + * New extension: `TypeData`, enabled by default. + * Parse errors now include error codes, cf. https://errors.haskell.org. + +* Updated to `Cabal-syntax-3.10`. + +* Now whenever Ormolu fails to parse a `.cabal` file it also explains why. + [PR 999](https://github.com/tweag/ormolu/pull/999). + ## Fourmolu 0.11.0.0 * Added the `no-space` value for the `in-style` option. See [issue diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,6 +8,7 @@ * [Installation](#installation) * [Building from source](#building-from-source) * [Usage](#usage) + * [Fourmolu Live](#fourmolu-live) * [Editor integration](#editor-integration) * [Language extensions, dependencies, and fixities](#language-extensions-dependencies-and-fixities) * [Magic comments](#magic-comments) @@ -18,7 +19,7 @@ * [Contributing](#contributing) * [License](#license) -Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/tweag/ormolu), with the intention to continue to merge upstream improvements. +Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/tweag/ormolu), with upstream improvements continually merged. We share all bar one of Ormolu's goals: @@ -41,72 +42,7 @@ ## Configuration -### Available options - -Defaults are in bold. - -| Configuration option | Valid options | Description -|--------------------------|-------------------------------------------------------|------------- -| `indentation` | any non-negative integer (**`4`**) | How many spaces to use as an indent -| `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`**, `no-space` | How to align the `in` keyword with respect to `let` (`left-align` produces in  ..., `right-align` produces  in ..., `no-space` produces in ...) -| `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 - -For examples of each of these options, see the [test files](https://github.com/fourmolu/fourmolu/tree/main/data/fourmolu/). - -### Specifying configuration - -Configuration options may be specified in either a `fourmolu.yaml` file or via command-line options. Fourmolu looks for a `fourmolu.yaml` file in all parents of the current directory, followed by [the XDG config directory](https://hackage.haskell.org/package/directory/docs/System-Directory.html#v:XdgConfig). - -A complete configuration file, corresponding to Fourmolu's default options, looks like: - -```yaml -indentation: 4 -function-arrows: trailing -comma-style: leading -import-export-style: diff-friendly -indent-wheres: false -record-brace-space: false -newlines-between-decls: 1 -haddock-style: multi-line -haddock-style-module: -let-style: auto -in-style: right-align -respectful: true -fixities: [] -unicode: never -``` - -The configuration that most closely matches Ormolu's styling is: - -```yaml -indentation: 2 -function-arrows: trailing -comma-style: trailing -import-export-style: trailing -indent-wheres: true -record-brace-space: true -newlines-between-decls: 1 -haddock-style: single-line -haddock-style-module: -let-style: inline -in-style: right-align -respectful: false -fixities: [] -unicode: never -``` - -Command-line options override options in a configuration file. Run `fourmolu --help` to see all options. +See https://fourmolu.github.io/config/ ## Installation @@ -154,7 +90,7 @@ $ git ls-files -z '*.hs' | xargs -0 fourmolu --mode inplace ``` -To check if files are are already formatted (useful on CI): +To check if files are already formatted (useful on CI): ```console $ fourmolu --mode check src @@ -168,6 +104,10 @@ https://www.git-scm.com/docs/git-config#Documentation/git-config.txt-coreautocrlf) to `false`. +### Web app + +See https://fourmolu.github.io/ to try Fourmolu in your browser. This is re-deployed on every new commit to `main`, so will use the latest version of Fourmolu, potentially including unreleased changes. + ### Editor integration Fourmolu can be integrated with your editor via the [Haskell Language Server](https://haskell-language-server.readthedocs.io/en/latest/index.html). Just set `haskell.formattingProvider` to `fourmolu` ([instructions](https://haskell-language-server.readthedocs.io/en/latest/configuration.html#language-specific-server-options)). @@ -274,7 +214,7 @@ discussion of the dangers. * Input modules should be parsable by Haddock, which is a bit stricter criterion than just being valid Haskell modules. -* Various minor idempotence issues, most of them are related to comments. +* Various minor idempotence issues, most of them are related to comments or column limits. * Fourmolu is in a fairly early stage of development. The implementation should be as stable as Ormolu, as it only makes minimal changes, and is extensively tested. But the default configuration style may change in some minor ways in the near future, as we make more options available. It will always be possible to replicate the old default behaviour with a suitable `fourmolu.yaml`. ## Contributing diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} module Main (main) where @@ -14,12 +11,12 @@ import Control.Monad import Data.Bool (bool) import Data.List (intercalate, isSuffixOf, sort) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, mapMaybe, maybeToList) -import qualified Data.Set as Set -import qualified Data.Text.IO as TIO +import Data.Set qualified as Set +import Data.Text.IO qualified as TIO import Data.Version (showVersion) -import qualified Data.Yaml as Yaml +import Data.Yaml qualified as Yaml import Language.Haskell.TH.Env (envQ) import Options.Applicative import Ormolu @@ -34,7 +31,7 @@ import Paths_fourmolu (version) import System.Directory import System.Exit (ExitCode (..), exitWith) -import qualified System.FilePath as FP +import System.FilePath qualified as FP import System.IO (hPutStrLn, stderr) -- | Entry point of the program. @@ -282,7 +279,7 @@ optsParserInfo :: ParserInfo Opts optsParserInfo = - info (helper <*> ver <*> exts <*> optsParser) . mconcat $ + info (helper <*> ver <*> exts <*> printDefaults <*> optsParser) . mconcat $ [fullDesc] where ver :: Parser (a -> a) @@ -307,6 +304,13 @@ help "Display extensions that need to be enabled manually" ] displayExts = unlines $ sort (showOutputable <$> manualExts) + + printDefaults :: Parser (a -> a) + printDefaults = + infoOption defaultPrinterOptsYaml . mconcat $ + [ long "print-defaults", + help "Print default configuration options that can be used in fourmolu.yaml" + ] optsParser :: Parser Opts optsParser = diff --git a/data/examples/declaration/data/gadt/unicode-four-out.hs b/data/examples/declaration/data/gadt/unicode-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/unicode-four-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo :: Type -> Type where + Foo :: a -> Foo a diff --git a/data/examples/declaration/data/gadt/unicode-out.hs b/data/examples/declaration/data/gadt/unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/unicode-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo :: Type -> Type where + Foo :: a -> Foo a diff --git a/data/examples/declaration/data/gadt/unicode.hs b/data/examples/declaration/data/gadt/unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/unicode.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo ∷ Type → Type where + Foo ∷ a → Foo a diff --git a/data/examples/declaration/data/type-data-four-out.hs b/data/examples/declaration/data/type-data-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/type-data-four-out.hs @@ -0,0 +1,8 @@ +type data Universe = Character | Number | Boolean + +type data Maybe a + = Just a + | Nothing + +type data P :: Type -> Type -> Type where + MkP :: (a ~ Natural, b ~~ Char) => P a b diff --git a/data/examples/declaration/data/type-data-out.hs b/data/examples/declaration/data/type-data-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/type-data-out.hs @@ -0,0 +1,8 @@ +type data Universe = Character | Number | Boolean + +type data Maybe a + = Just a + | Nothing + +type data P :: Type -> Type -> Type where + MkP :: (a ~ Natural, b ~~ Char) => P a b diff --git a/data/examples/declaration/data/type-data.hs b/data/examples/declaration/data/type-data.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/type-data.hs @@ -0,0 +1,7 @@ +type data Universe = Character | Number | Boolean + +type data Maybe a = Just a + | Nothing + +type data P :: Type -> Type -> Type where + MkP :: (a ~ Natural, b ~~ Char) => P a b diff --git a/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs b/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs --- a/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs +++ b/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs @@ -1,7 +1,7 @@ data Foo = -- | Bar Bar + -- | Field 1 Field1 - -- ^ Field 1 + -- | Field 2 Field2 - -- ^ Field 2 diff --git a/data/examples/declaration/data/unnamed-field-comment-0-out.hs b/data/examples/declaration/data/unnamed-field-comment-0-out.hs --- a/data/examples/declaration/data/unnamed-field-comment-0-out.hs +++ b/data/examples/declaration/data/unnamed-field-comment-0-out.hs @@ -1,7 +1,7 @@ data Foo = -- | Bar Bar + -- | Field 1 Field1 - -- ^ Field 1 + -- | Field 2 Field2 - -- ^ Field 2 diff --git a/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs b/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs --- a/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs +++ b/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs @@ -1,5 +1,5 @@ data X = B + -- | y !Int - -- ^ y C diff --git a/data/examples/declaration/data/unnamed-field-comment-1-out.hs b/data/examples/declaration/data/unnamed-field-comment-1-out.hs --- a/data/examples/declaration/data/unnamed-field-comment-1-out.hs +++ b/data/examples/declaration/data/unnamed-field-comment-1-out.hs @@ -1,5 +1,5 @@ data X = B + -- | y !Int - -- ^ y C diff --git a/data/examples/declaration/data/unnamed-field-comment-2-four-out.hs b/data/examples/declaration/data/unnamed-field-comment-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-2-four-out.hs @@ -0,0 +1,11 @@ +-- | Describes what sort of dictionary to generate for type class instances +data Evidence + = -- | An existing named instance + NamedInstance (Qualified Ident) + | -- | Computed instances + WarnInstance + -- | Warn type class with a user-defined warning message + SourceType + | -- | The IsSymbol type class for a given Symbol literal + IsSymbolInstance PSString + deriving (Show, Eq) diff --git a/data/examples/declaration/data/unnamed-field-comment-2-out.hs b/data/examples/declaration/data/unnamed-field-comment-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-2-out.hs @@ -0,0 +1,11 @@ +-- | Describes what sort of dictionary to generate for type class instances +data Evidence + = -- | An existing named instance + NamedInstance (Qualified Ident) + | -- | Computed instances + WarnInstance + -- | Warn type class with a user-defined warning message + SourceType + | -- | The IsSymbol type class for a given Symbol literal + IsSymbolInstance PSString + deriving (Show, Eq) diff --git a/data/examples/declaration/data/unnamed-field-comment-2.hs b/data/examples/declaration/data/unnamed-field-comment-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-2.hs @@ -0,0 +1,9 @@ +-- | Describes what sort of dictionary to generate for type class instances +data Evidence + -- | An existing named instance + = NamedInstance (Qualified Ident) + + -- | Computed instances + | WarnInstance SourceType -- ^ Warn type class with a user-defined warning message + | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal + deriving (Show, Eq) diff --git a/data/examples/declaration/data/unnamed-field-comment-3-four-out.hs b/data/examples/declaration/data/unnamed-field-comment-3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-3-four-out.hs @@ -0,0 +1,5 @@ +data A + = A + -- | a number + Int + Bool diff --git a/data/examples/declaration/data/unnamed-field-comment-3-out.hs b/data/examples/declaration/data/unnamed-field-comment-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-3-out.hs @@ -0,0 +1,5 @@ +data A + = A + -- | a number + Int + Bool diff --git a/data/examples/declaration/data/unnamed-field-comment-3.hs b/data/examples/declaration/data/unnamed-field-comment-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-3.hs @@ -0,0 +1,1 @@ +data A = A {- | a number -} Int Bool diff --git a/data/examples/declaration/type-families/closed-type-family/promotion-four-out.hs b/data/examples/declaration/type-families/closed-type-family/promotion-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/promotion-four-out.hs @@ -0,0 +1,2 @@ +type family Foo a where + Foo '( 'x', a) = a diff --git a/data/examples/declaration/type-families/closed-type-family/promotion-out.hs b/data/examples/declaration/type-families/closed-type-family/promotion-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/promotion-out.hs @@ -0,0 +1,2 @@ +type family Foo a where + Foo '( 'x', a) = a diff --git a/data/examples/declaration/type-families/closed-type-family/promotion.hs b/data/examples/declaration/type-families/closed-type-family/promotion.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/promotion.hs @@ -0,0 +1,2 @@ +type family Foo a where + Foo '( 'x', a) = a diff --git a/data/examples/declaration/type/promotion-1-four-out.hs b/data/examples/declaration/type/promotion-1-four-out.hs --- a/data/examples/declaration/type/promotion-1-four-out.hs +++ b/data/examples/declaration/type/promotion-1-four-out.hs @@ -9,3 +9,5 @@ type G = '[ '( 'Just, 'Bool)] type X = () '`PromotedInfix` () + +type A = '[ 'a'] diff --git a/data/examples/declaration/type/promotion-1-out.hs b/data/examples/declaration/type/promotion-1-out.hs --- a/data/examples/declaration/type/promotion-1-out.hs +++ b/data/examples/declaration/type/promotion-1-out.hs @@ -15,3 +15,5 @@ type G = '[ '( 'Just, 'Bool)] type X = () '`PromotedInfix` () + +type A = '[ 'a'] diff --git a/data/examples/declaration/type/promotion-1.hs b/data/examples/declaration/type/promotion-1.hs --- a/data/examples/declaration/type/promotion-1.hs +++ b/data/examples/declaration/type/promotion-1.hs @@ -9,3 +9,5 @@ type G = '[ '( 'Just, 'Bool) ] type X = () '`PromotedInfix` () + +type A = '[ 'a' ] diff --git a/data/examples/declaration/value/function/overloaded-labels-four-out.hs b/data/examples/declaration/value/function/overloaded-labels-four-out.hs --- a/data/examples/declaration/value/function/overloaded-labels-four-out.hs +++ b/data/examples/declaration/value/function/overloaded-labels-four-out.hs @@ -2,3 +2,35 @@ foo = #field bar = (#this) (#that) +baz = #Foo #"Hello world!" #"\"" #3 #"\n" + +-- from https://gitlab.haskell.org/ghc/ghc/-/blob/ghc-9.6.1-alpha3/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs +-- unnecessary once https://github.com/tweag/ormolu/issues/821 lands +main = + traverse_ + putStrLn + [ #a + , #number17 + , #do + , #type + , #Foo + , #3 + , #"199.4" + , #17a23b + , #f'a' + , #'a' + , #' + , #''notTHSplice + , #"..." + , #привет + , #こんにちは + , #"3" + , #":" + , #"Foo" + , #"The quick brown fox" + , #"\"" + , (++) #hello #world + , (++) #"hello" #"world" + , #"hello" # 1 -- equivalent to `(fromLabel @"hello") # 1` + , f "hello" #2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/data/examples/declaration/value/function/overloaded-labels-out.hs b/data/examples/declaration/value/function/overloaded-labels-out.hs --- a/data/examples/declaration/value/function/overloaded-labels-out.hs +++ b/data/examples/declaration/value/function/overloaded-labels-out.hs @@ -3,3 +3,36 @@ foo = #field bar = (#this) (#that) + +baz = #Foo #"Hello world!" #"\"" #3 #"\n" + +-- from https://gitlab.haskell.org/ghc/ghc/-/blob/ghc-9.6.1-alpha3/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs +-- unnecessary once https://github.com/tweag/ormolu/issues/821 lands +main = + traverse_ + putStrLn + [ #a, + #number17, + #do, + #type, + #Foo, + #3, + #"199.4", + #17a23b, + #f'a', + #'a', + #', + #''notTHSplice, + #"...", + #привет, + #こんにちは, + #"3", + #":", + #"Foo", + #"The quick brown fox", + #"\"", + (++) #hello #world, + (++) #"hello" #"world", + #"hello" # 1, -- equivalent to `(fromLabel @"hello") # 1` + f "hello" #2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/data/examples/declaration/value/function/overloaded-labels.hs b/data/examples/declaration/value/function/overloaded-labels.hs --- a/data/examples/declaration/value/function/overloaded-labels.hs +++ b/data/examples/declaration/value/function/overloaded-labels.hs @@ -2,3 +2,33 @@ foo = #field bar = (#this ) ( #that) +baz = #Foo #"Hello world!" #"\"" #3 #"\n" + +-- from https://gitlab.haskell.org/ghc/ghc/-/blob/ghc-9.6.1-alpha3/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs +-- unnecessary once https://github.com/tweag/ormolu/issues/821 lands +main = traverse_ putStrLn + [ #a + , #number17 + , #do + , #type + , #Foo + , #3 + , #"199.4" + , #17a23b + , #f'a' + , #'a' + , #' + , #''notTHSplice + , #"..." + , #привет + , #こんにちは + , #"3" + , #":" + , #"Foo" + , #"The quick brown fox" + , #"\"" + , (++) #hello#world + , (++) #"hello"#"world" + , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1` + , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/data/fourmolu/column-limit/input.hs b/data/fourmolu/column-limit/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/column-limit/input.hs @@ -0,0 +1,82 @@ +module ColumnLimitTest where + +-- Less than 80 characters +import Data.List (isPrefixOf, head, tail) + +-- Over 80 characters, should break this line when column-limit is set to 80. +import Data.Maybe (maybe, fromMaybe, fromJust, catMaybe, mapMaybe, isJust, isNothing, listToMaybe, maybeToList) + +-- For reference, this line had exactly 80 characters -------------------------| + +oneVeryLongLine :: [String] +oneVeryLongLine = ["akjsndjklansdsad"] ++ ["jkanskdjnajsndjnasd"] ++ ["jknasdljknasdlnasdn"] ++ ["lajndljnasdlnasds"] + +oneVeryLongList :: [String] +oneVeryLongList = ["akjsndjklansdsad", "jkanskdjnajsndjnasd", "jknasdljknasdlnasdn", "lajndljnasdlnasds"] + + +data NewDataType = NewDataType {field1 :: String, field2 :: String, field3 :: String, field4 :: String} + +-- Test if the current line breaking still works normally, i.e. if the user +-- breaks the line, fourmolu breaks and aligns the rest. +data SecondDataType = SecondDataType {field1 :: String + , field2 :: String, field3 :: String, field4 :: String} + +data DataTypeWithAVeryLongName = DataTypeWithAVeryLongName String String String String String + + +-- Long function signatures + +-- For reference, this line had exactly 80 characters -------------------------| + +longFunction0 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String -> [String] +longFunction0 veryLongArg1 a b c d e f = ["a list", "of strings", "that will break the", "column limit"] + +longFunction1 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction1 + veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 veryLongArg6 = undefined + +longFunction12 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 +longFunction12 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String -> String + veryLongArg6 veryLongArg6 = undefined + + +longFunction2 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction2 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 a veryLongArg6 = + let aVeryLongLine = ["list one", "list one", "list one", "list one", "list one", "list one"] + in undefined + +longFunction3 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction3 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 veryLongArg6 = undefined + + +-- For reference, this line had exactly 80 characters -------------------------| + +-- ---------------- Known limitation: idempotence is broken ---------------- + +-- With the column-limit option set, fourmolu will not be idempotent in some +-- cases. An example can be seen below, where the long line ends with a `do`. + +-- Original code +testFund :: Maybe Int +testFund = + firstTest oneFunctionArgument abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde $ do + result <- aRandomResult + +-- Will become this when formatted with column-limit set to 80. +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde $ do + result <- aRandomResult + + +-- Which, if formatted again, will become this: +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult diff --git a/data/fourmolu/column-limit/output-limit=100.hs b/data/fourmolu/column-limit/output-limit=100.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/column-limit/output-limit=100.hs @@ -0,0 +1,108 @@ +module ColumnLimitTest where + +-- Less than 80 characters +import Data.List (head, isPrefixOf, tail) + +-- Over 80 characters, should break this line when column-limit is set to 80. +import Data.Maybe ( + catMaybe, + fromJust, + fromMaybe, + isJust, + isNothing, + listToMaybe, + mapMaybe, + maybe, + maybeToList, + ) + +-- For reference, this line had exactly 80 characters -------------------------| + +oneVeryLongLine :: [String] +oneVeryLongLine = + ["akjsndjklansdsad"] ++ ["jkanskdjnajsndjnasd"] ++ ["jknasdljknasdlnasdn"] ++ ["lajndljnasdlnasds"] + +oneVeryLongList :: [String] +oneVeryLongList = ["akjsndjklansdsad", "jkanskdjnajsndjnasd", "jknasdljknasdlnasdn", "lajndljnasdlnasds"] + +data NewDataType = NewDataType {field1 :: String, field2 :: String, field3 :: String, field4 :: String} + +-- Test if the current line breaking still works normally, i.e. if the user +-- breaks the line, fourmolu breaks and aligns the rest. +data SecondDataType = SecondDataType + { field1 :: String + , field2 :: String + , field3 :: String + , field4 :: String + } + +data DataTypeWithAVeryLongName = DataTypeWithAVeryLongName String String String String String + +-- Long function signatures + +-- For reference, this line had exactly 80 characters -------------------------| + +longFunction0 :: + String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String -> [String] +longFunction0 veryLongArg1 a b c d e f = ["a list", "of strings", "that will break the", "column limit"] + +longFunction1 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction1 + veryLongArg1 + veryLongArg2 + veryLongArg3 + veryLongArg4 + veryLongArgument5 + veryLongArg6 = undefined + +longFunction12 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 +longFunction12 :: + String -> + String -> + String -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + String -> + String + veryLongArg6 + veryLongArg6 = undefined + +longFunction2 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction2 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 a veryLongArg6 = + let aVeryLongLine = ["list one", "list one", "list one", "list one", "list one", "list one"] + in undefined + +longFunction3 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction3 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 veryLongArg6 = undefined + +-- For reference, this line had exactly 80 characters -------------------------| + +-- ---------------- Known limitation: idempotence is broken ---------------- + +-- With the column-limit option set, fourmolu will not be idempotent in some +-- cases. An example can be seen below, where the long line ends with a `do`. + +-- Original code +testFund :: Maybe Int +testFund = + firstTest oneFunctionArgument abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde $ do + result <- aRandomResult + +-- Will become this when formatted with column-limit set to 80. +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult + +-- Which, if formatted again, will become this: +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult diff --git a/data/fourmolu/column-limit/output-limit=80.hs b/data/fourmolu/column-limit/output-limit=80.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/column-limit/output-limit=80.hs @@ -0,0 +1,135 @@ +module ColumnLimitTest where + +-- Less than 80 characters +import Data.List (head, isPrefixOf, tail) + +-- Over 80 characters, should break this line when column-limit is set to 80. +import Data.Maybe ( + catMaybe, + fromJust, + fromMaybe, + isJust, + isNothing, + listToMaybe, + mapMaybe, + maybe, + maybeToList, + ) + +-- For reference, this line had exactly 80 characters -------------------------| + +oneVeryLongLine :: [String] +oneVeryLongLine = + ["akjsndjklansdsad"] + ++ ["jkanskdjnajsndjnasd"] + ++ ["jknasdljknasdlnasdn"] + ++ ["lajndljnasdlnasds"] + +oneVeryLongList :: [String] +oneVeryLongList = + [ "akjsndjklansdsad" + , "jkanskdjnajsndjnasd" + , "jknasdljknasdlnasdn" + , "lajndljnasdlnasds" + ] + +data NewDataType = NewDataType + {field1 :: String, field2 :: String, field3 :: String, field4 :: String} + +-- Test if the current line breaking still works normally, i.e. if the user +-- breaks the line, fourmolu breaks and aligns the rest. +data SecondDataType = SecondDataType + { field1 :: String + , field2 :: String + , field3 :: String + , field4 :: String + } + +data DataTypeWithAVeryLongName + = DataTypeWithAVeryLongName String String String String String + +-- Long function signatures + +-- For reference, this line had exactly 80 characters -------------------------| + +longFunction0 :: + String -> + String -> + String -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + String -> + [String] +longFunction0 veryLongArg1 a b c d e f = ["a list", "of strings", "that will break the", "column limit"] + +longFunction1 :: + String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction1 + veryLongArg1 + veryLongArg2 + veryLongArg3 + veryLongArg4 + veryLongArgument5 + veryLongArg6 = undefined + +longFunction12 + veryLongArg1 + veryLongArg2 + veryLongArg3 + veryLongArg4 + veryLongArgument5 +longFunction12 :: + String -> + String -> + String -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + String -> + String + veryLongArg6 + veryLongArg6 = undefined + +longFunction2 :: + String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction2 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 a veryLongArg6 = + let aVeryLongLine = ["list one", "list one", "list one", "list one", "list one", "list one"] + in undefined + +longFunction3 :: + String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction3 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 veryLongArg6 = undefined + +-- For reference, this line had exactly 80 characters -------------------------| + +-- ---------------- Known limitation: idempotence is broken ---------------- + +-- With the column-limit option set, fourmolu will not be idempotent in some +-- cases. An example can be seen below, where the long line ends with a `do`. + +-- Original code +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde $ do + result <- aRandomResult + +-- Will become this when formatted with column-limit set to 80. +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult + +-- Which, if formatted again, will become this: +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult diff --git a/data/fourmolu/column-limit/output-limit=none.hs b/data/fourmolu/column-limit/output-limit=none.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/column-limit/output-limit=none.hs @@ -0,0 +1,96 @@ +module ColumnLimitTest where + +-- Less than 80 characters +import Data.List (head, isPrefixOf, tail) + +-- Over 80 characters, should break this line when column-limit is set to 80. +import Data.Maybe (catMaybe, fromJust, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybe, maybeToList) + +-- For reference, this line had exactly 80 characters -------------------------| + +oneVeryLongLine :: [String] +oneVeryLongLine = ["akjsndjklansdsad"] ++ ["jkanskdjnajsndjnasd"] ++ ["jknasdljknasdlnasdn"] ++ ["lajndljnasdlnasds"] + +oneVeryLongList :: [String] +oneVeryLongList = ["akjsndjklansdsad", "jkanskdjnajsndjnasd", "jknasdljknasdlnasdn", "lajndljnasdlnasds"] + +data NewDataType = NewDataType {field1 :: String, field2 :: String, field3 :: String, field4 :: String} + +-- Test if the current line breaking still works normally, i.e. if the user +-- breaks the line, fourmolu breaks and aligns the rest. +data SecondDataType = SecondDataType + { field1 :: String + , field2 :: String + , field3 :: String + , field4 :: String + } + +data DataTypeWithAVeryLongName = DataTypeWithAVeryLongName String String String String String + +-- Long function signatures + +-- For reference, this line had exactly 80 characters -------------------------| + +longFunction0 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String -> [String] +longFunction0 veryLongArg1 a b c d e f = ["a list", "of strings", "that will break the", "column limit"] + +longFunction1 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction1 + veryLongArg1 + veryLongArg2 + veryLongArg3 + veryLongArg4 + veryLongArgument5 + veryLongArg6 = undefined + +longFunction12 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 +longFunction12 :: + String -> + String -> + String -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + String -> + String + veryLongArg6 + veryLongArg6 = undefined + +longFunction2 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction2 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 a veryLongArg6 = + let aVeryLongLine = ["list one", "list one", "list one", "list one", "list one", "list one"] + in undefined + +longFunction3 :: String -> String -> String -> Maybe Int -> Maybe Int -> Maybe Int -> String +longFunction3 veryLongArg1 veryLongArg2 veryLongArg3 veryLongArg4 veryLongArgument5 veryLongArg6 = undefined + +-- For reference, this line had exactly 80 characters -------------------------| + +-- ---------------- Known limitation: idempotence is broken ---------------- + +-- With the column-limit option set, fourmolu will not be idempotent in some +-- cases. An example can be seen below, where the long line ends with a `do`. + +-- Original code +testFund :: Maybe Int +testFund = + firstTest oneFunctionArgument abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde $ do + result <- aRandomResult + +-- Will become this when formatted with column-limit set to 80. +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult + +-- Which, if formatted again, will become this: +testFund :: Maybe Int +testFund = + firstTest + oneFunctionArgument + abcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcdeabcde + $ do + result <- aRandomResult diff --git a/data/fourmolu/single-constraint-parens/input.hs b/data/fourmolu/single-constraint-parens/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/single-constraint-parens/input.hs @@ -0,0 +1,5 @@ +module Main where + +functionName :: (C a) => a +functionName1 :: C a => a +functionName2 :: (C a, D a) => a diff --git a/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs b/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs @@ -0,0 +1,5 @@ +module Main where + +functionName :: (C a) => a +functionName1 :: (C a) => a +functionName2 :: (C a, D a) => a diff --git a/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs b/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs @@ -0,0 +1,5 @@ +module Main where + +functionName :: (C a) => a +functionName1 :: C a => a +functionName2 :: (C a, D a) => a diff --git a/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs b/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs @@ -0,0 +1,5 @@ +module Main where + +functionName :: C a => a +functionName1 :: C a => a +functionName2 :: (C a, D a) => a diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,13 +1,13 @@ cabal-version: 2.4 name: fourmolu -version: 0.11.0.0 +version: 0.12.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Matt Parsons George Thomas Brandon Chinn -tested-with: ghc ==9.0.2 ghc ==9.2.5 +tested-with: ghc ==9.2.7 ghc ==9.4.4 ghc ==9.6.1 homepage: https://github.com/fourmolu/fourmolu bug-reports: https://github.com/fourmolu/fourmolu/issues synopsis: A formatter for Haskell source code @@ -91,18 +91,20 @@ Ormolu.Processing.Cpp Ormolu.Processing.Preprocess Ormolu.Terminal + Ormolu.Terminal.QualifiedDo Ormolu.Utils Ormolu.Utils.Cabal Ormolu.Utils.Fixity Ormolu.Utils.IO + Paths_fourmolu other-modules: Ormolu.Config.Gen hs-source-dirs: src other-modules: GHC.DynFlags - default-language: Haskell2010 + default-language: GHC2021 build-depends: - Cabal-syntax >=3.8 && <3.9, + Cabal-syntax >=3.10 && <3.11, Diff >=0.4 && <1.0, MemoTrie >=0.6 && <0.7, ansi-terminal >=0.10 && <1.0, @@ -111,24 +113,24 @@ binary >=0.8 && <0.9, bytestring >=0.2 && <0.12, containers >=0.5 && <0.7, + deepseq >=1.4 && <1.5, directory ^>=1.3, - dlist >=0.8 && <2.0, file-embed >=0.0.15 && <0.1, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.4 && <9.5, + ghc-lib-parser >=9.6 && <9.7, megaparsec >=9.0, mtl >=2.0 && <3.0, syb >=0.7 && <0.8, text >=2.0 && <3.0, -- fourmolu-only deps aeson >=1.0 && <3.0, + scientific >=0.3.2 && <1, yaml >=0.11.6.0 && <1 if flag(dev) ghc-options: - -Wall -Werror -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wno-missing-home-modules -Wunused-packages + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages else ghc-options: -O2 -Wall @@ -141,13 +143,13 @@ hs-source-dirs: app other-modules: Paths_fourmolu autogen-modules: Paths_fourmolu - default-language: Haskell2010 + default-language: GHC2021 build-depends: base >=4.12 && <5.0, containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.4 && <9.5, + ghc-lib-parser >=9.6 && <9.7, th-env >=0.1.1 && <0.2, optparse-applicative >=0.14 && <0.18, text >=2.0 && <3.0, @@ -158,10 +160,8 @@ if flag(dev) ghc-options: - -Wall -Werror -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -optP-Wno-nonportable-include-path -Wunused-packages - -Wwarn=unused-packages + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages -Wwarn=unused-packages else ghc-options: -O2 -Wall -rtsopts @@ -192,15 +192,15 @@ Ormolu.Parser.PragmaSpec Ormolu.PrinterSpec - default-language: Haskell2010 + default-language: GHC2021 build-depends: - Cabal-syntax >=3.8 && <3.9, + Cabal-syntax >=3.10 && <3.11, QuickCheck >=2.14, base >=4.14 && <5.0, containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.4 && <9.5, + ghc-lib-parser >=9.6 && <9.7, hspec >=2.0 && <3.0, hspec-megaparsec >=2.2, path >=0.6 && <0.10, @@ -218,7 +218,9 @@ fourmolu if flag(dev) - ghc-options: -Wall -Werror -Wunused-packages + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages else ghc-options: -O2 -Wall diff --git a/fourmolu.yaml b/fourmolu.yaml --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -2,6 +2,7 @@ # Options should imitate Ormolu's style indentation: 2 +column-limit: none function-arrows: trailing comma-style: trailing import-export-style: trailing @@ -12,6 +13,7 @@ haddock-style-module: null let-style: inline in-style: right-align +single-constraint-parens: always unicode: never respectful: false fixities: [] diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -49,8 +49,5 @@ } } -fakeLlvmConfig :: LlvmConfig -fakeLlvmConfig = LlvmConfig [] [] - baseDynFlags :: DynFlags -baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig +baseDynFlags = defaultDynFlags fakeSettings diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -46,13 +45,13 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Debug.Trace -import qualified GHC.Driver.CmdLine as GHC -import qualified GHC.Types.SrcLoc as GHC +import GHC.Driver.CmdLine qualified as GHC +import GHC.Types.SrcLoc import Ormolu.Config import Ormolu.Diff.ParseResult import Ormolu.Diff.Text @@ -63,7 +62,7 @@ import Ormolu.Parser.Result import Ormolu.Printer import Ormolu.Utils (showOutputable) -import qualified Ormolu.Utils.Cabal as CabalUtils +import Ormolu.Utils.Cabal qualified as CabalUtils import Ormolu.Utils.Fixity (getFixityOverridesForSourceFile) import Ormolu.Utils.IO import System.FilePath @@ -228,7 +227,7 @@ -- | Fixity Map for operators LazyFixityMap -> -- | How to obtain 'OrmoluException' to throw when parsing fails - (GHC.SrcSpan -> String -> OrmoluException) -> + (SrcSpan -> String -> OrmoluException) -> -- | File name to use in errors FilePath -> -- | Actual input for the parser @@ -245,7 +244,7 @@ showWarn (GHC.Warn reason l) = unlines [ showOutputable reason, - showOutputable l + unLoc l ] -- | Detect 'SourceType' based on the file extension. diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -1,7 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -31,6 +29,7 @@ PrinterOptsPartial, PrinterOptsTotal, defaultPrinterOpts, + defaultPrinterOptsYaml, fillMissingPrinterOpts, CommaStyle (..), FunctionArrowsStyle (..), @@ -40,6 +39,7 @@ LetStyle (..), InStyle (..), Unicode (..), + ColumnLimit (..), parsePrinterOptsCLI, parsePrinterOptType, @@ -54,17 +54,17 @@ import Control.Monad (forM) import Data.Aeson ((.!=), (.:?)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson import Data.Functor.Identity (Identity (..)) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.String (fromString) -import qualified Data.Yaml as Yaml +import Data.Yaml qualified as Yaml import Distribution.Types.PackageName (PackageName) import GHC.Generics (Generic) -import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.SrcLoc qualified as GHC import Ormolu.Config.Gen import Ormolu.Fixity (FixityMap) import Ormolu.Fixity.Parser (parseFixityDeclaration) diff --git a/src/Ormolu/Config/Gen.hs b/src/Ormolu/Config/Gen.hs --- a/src/Ormolu/Config/Gen.hs +++ b/src/Ormolu/Config/Gen.hs @@ -2,6 +2,7 @@ {- ***** DO NOT EDIT: This module is autogenerated ***** -} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -15,8 +16,11 @@ , LetStyle (..) , InStyle (..) , Unicode (..) + , SingleConstraintParens (..) + , ColumnLimit (..) , emptyPrinterOpts , defaultPrinterOpts + , defaultPrinterOptsYaml , fillMissingPrinterOpts , parsePrinterOptsCLI , parsePrinterOptsJSON @@ -27,15 +31,18 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import Data.Functor.Identity (Identity) +import Data.Scientific (floatingOrInteger) import qualified Data.Text as Text import GHC.Generics (Generic) -import Text.Read (readEither) +import Text.Read (readEither, readMaybe) -- | Options controlling formatting output. data PrinterOpts f = PrinterOpts { -- | Number of spaces per indentation step poIndentation :: f Int + , -- | Max line length for automatic line breaking + poColumnLimit :: f ColumnLimit , -- | Styling of arrows in type signatures poFunctionArrows :: f FunctionArrowsStyle , -- | How to place commas in multi-line lists, records, etc. @@ -56,6 +63,8 @@ poLetStyle :: f LetStyle , -- | How to align the 'in' keyword with respect to the 'let' keyword poInStyle :: f InStyle + , -- | Whether to put parentheses around a single constraint + poSingleConstraintParens :: f SingleConstraintParens , -- | Output Unicode syntax poUnicode :: f Unicode , -- | Give the programmer more choice on where to insert blank lines @@ -67,6 +76,7 @@ emptyPrinterOpts = PrinterOpts { poIndentation = Nothing + , poColumnLimit = Nothing , poFunctionArrows = Nothing , poCommaStyle = Nothing , poImportExportStyle = Nothing @@ -77,6 +87,7 @@ , poHaddockStyleModule = Nothing , poLetStyle = Nothing , poInStyle = Nothing + , poSingleConstraintParens = Nothing , poUnicode = Nothing , poRespectful = Nothing } @@ -85,6 +96,7 @@ defaultPrinterOpts = PrinterOpts { poIndentation = pure 4 + , poColumnLimit = pure NoLimit , poFunctionArrows = pure TrailingArrows , poCommaStyle = pure Leading , poImportExportStyle = pure ImportExportDiffFriendly @@ -95,6 +107,7 @@ , poHaddockStyleModule = pure PrintStyleInherit , poLetStyle = pure LetAuto , poInStyle = pure InRightAlign + , poSingleConstraintParens = pure ConstraintAlways , poUnicode = pure UnicodeNever , poRespectful = pure True } @@ -110,6 +123,7 @@ fillMissingPrinterOpts p1 p2 = PrinterOpts { poIndentation = maybe (poIndentation p2) pure (poIndentation p1) + , poColumnLimit = maybe (poColumnLimit p2) pure (poColumnLimit p1) , poFunctionArrows = maybe (poFunctionArrows p2) pure (poFunctionArrows p1) , poCommaStyle = maybe (poCommaStyle p2) pure (poCommaStyle p1) , poImportExportStyle = maybe (poImportExportStyle p2) pure (poImportExportStyle p1) @@ -120,6 +134,7 @@ , poHaddockStyleModule = maybe (poHaddockStyleModule p2) pure (poHaddockStyleModule p1) , poLetStyle = maybe (poLetStyle p2) pure (poLetStyle p1) , poInStyle = maybe (poInStyle p2) pure (poInStyle p1) + , poSingleConstraintParens = maybe (poSingleConstraintParens p2) pure (poSingleConstraintParens p1) , poUnicode = maybe (poUnicode p2) pure (poUnicode p1) , poRespectful = maybe (poRespectful p2) pure (poRespectful p1) } @@ -135,6 +150,10 @@ "Number of spaces per indentation step (default: 4)" "INT" <*> f + "column-limit" + "Max line length for automatic line breaking (default: none)" + "OPTION" + <*> f "function-arrows" "Styling of arrows in type signatures (choices: \"trailing\", \"leading\", or \"leading-args\") (default: trailing)" "OPTION" @@ -175,6 +194,10 @@ "How to align the 'in' keyword with respect to the 'let' keyword (choices: \"left-align\", \"right-align\", or \"no-space\") (default: right-align)" "OPTION" <*> f + "single-constraint-parens" + "Whether to put parentheses around a single constraint (choices: \"auto\", \"always\", or \"never\") (default: always)" + "OPTION" + <*> f "unicode" "Output Unicode syntax (choices: \"detect\", \"always\", or \"never\") (default: never)" "OPTION" @@ -190,6 +213,7 @@ parsePrinterOptsJSON f = pure PrinterOpts <*> f "indentation" + <*> f "column-limit" <*> f "function-arrows" <*> f "comma-style" <*> f "import-export-style" @@ -200,6 +224,7 @@ <*> f "haddock-style-module" <*> f "let-style" <*> f "in-style" + <*> f "single-constraint-parens" <*> f "unicode" <*> f "respectful" @@ -269,6 +294,17 @@ | UnicodeNever deriving (Eq, Show, Enum, Bounded) +data SingleConstraintParens + = ConstraintAuto + | ConstraintAlways + | ConstraintNever + deriving (Eq, Show, Enum, Bounded) + +data ColumnLimit + = NoLimit + | ColumnLimit Int + deriving (Eq, Show) + instance Aeson.FromJSON CommaStyle where parseJSON = Aeson.withText "CommaStyle" $ \s -> @@ -407,3 +443,101 @@ [ "unknown value: " <> show s , "Valid values are: \"detect\", \"always\", or \"never\"" ] + +instance Aeson.FromJSON SingleConstraintParens where + parseJSON = + Aeson.withText "SingleConstraintParens" $ \s -> + either Aeson.parseFail pure $ + parsePrinterOptType (Text.unpack s) + +instance PrinterOptsFieldType SingleConstraintParens where + parsePrinterOptType s = + case s of + "auto" -> Right ConstraintAuto + "always" -> Right ConstraintAlways + "never" -> Right ConstraintNever + _ -> + Left . unlines $ + [ "unknown value: " <> show s + , "Valid values are: \"auto\", \"always\", or \"never\"" + ] + +instance Aeson.FromJSON ColumnLimit where + parseJSON = + \case + Aeson.String "none" -> + pure NoLimit + Aeson.Number x + | Right x' <- (floatingOrInteger x :: Either Double Int) -> + pure $ ColumnLimit x' + s -> + fail . unlines $ + [ "unknown value: " <> show s, + "Valid values are: \"none\", or an integer" + ] + +instance PrinterOptsFieldType ColumnLimit where + parsePrinterOptType = + \s -> + case s of + "none" -> Right NoLimit + _ + | Just someInt <- readMaybe s -> + Right . ColumnLimit $ someInt + _ -> + Left . unlines $ + [ "unknown value: " <> show s, + "Valid values are: \"none\", or an integer" + ] + +defaultPrinterOptsYaml :: String +defaultPrinterOptsYaml = + unlines + [ "# Number of spaces per indentation step" + , "indentation: 4" + , "" + , "# Max line length for automatic line breaking" + , "column-limit: none" + , "" + , "# Styling of arrows in type signatures (choices: trailing, leading, or leading-args)" + , "function-arrows: trailing" + , "" + , "# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)" + , "comma-style: leading" + , "" + , "# Styling of import/export lists (choices: leading, trailing, or diff-friendly)" + , "import-export-style: diff-friendly" + , "" + , "# Whether to full-indent or half-indent 'where' bindings past the preceding body" + , "indent-wheres: false" + , "" + , "# Whether to leave a space before an opening record brace" + , "record-brace-space: false" + , "" + , "# Number of spaces between top-level declarations" + , "newlines-between-decls: 1" + , "" + , "# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)" + , "haddock-style: multi-line" + , "" + , "# How to print module docstring" + , "haddock-style-module: null" + , "" + , "# Styling of let blocks (choices: auto, inline, newline, or mixed)" + , "let-style: auto" + , "" + , "# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space)" + , "in-style: right-align" + , "" + , "# Whether to put parentheses around a single constraint (choices: auto, always, or never)" + , "single-constraint-parens: always" + , "" + , "# Output Unicode syntax (choices: detect, always, or never)" + , "unicode: never" + , "" + , "# Give the programmer more choice on where to insert blank lines" + , "respectful: true" + , "" + , "# Fixity information for operators" + , "fixities: []" + ] diff --git a/src/Ormolu/Diff/ParseResult.hs b/src/Ormolu/Diff/ParseResult.hs --- a/src/Ormolu/Diff/ParseResult.hs +++ b/src/Ormolu/Diff/ParseResult.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeepSubsumption #-} {-# 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 @@ -18,6 +12,7 @@ import Data.ByteString (ByteString) import Data.Foldable +import Data.Function import Data.Generics import GHC.Hs import GHC.Types.SourceText @@ -58,7 +53,7 @@ prParsedSource = hs1 } = diffCommentStream cstream0 cstream1 - <> matchIgnoringSrcSpans + <> diffHsModule hs0 {hsmodImports = concat . normalizeImports False $ hsmodImports hs0} hs1 {hsmodImports = concat . normalizeImports False $ hsmodImports hs1} @@ -69,16 +64,18 @@ where commentLines = concatMap (toList . unComment . unLoc) --- | Compare two values for equality disregarding the following aspects: +-- | Compare two modules for equality disregarding the following aspects: -- -- * 'SrcSpan's -- * ordering of import lists --- * style (ASCII vs Unicode) of arrows +-- * style (ASCII vs Unicode) of arrows, colons -- * LayoutInfo (brace style) in extension fields -- * Empty contexts in type classes -- * Parens around derived type classes -matchIgnoringSrcSpans :: (Data a) => a -> a -> ParseResultDiff -matchIgnoringSrcSpans a = genericQuery a +-- * 'TokenLocation' (in 'LHsToken'/'LHsUniToken') +-- * 'EpaLocation' +diffHsModule :: HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff +diffHsModule = genericQuery where genericQuery :: GenericQ (GenericQ ParseResultDiff) genericQuery x y @@ -94,44 +91,54 @@ mconcat $ gzipWithQ ( genericQuery - `extQ` srcSpanEq + `extQ` considerEqual @SrcSpan `ext1Q` epAnnEq - `extQ` sourceTextEq + `extQ` considerEqual @SourceText `extQ` hsDocStringEq `extQ` importDeclQualifiedStyleEq - `extQ` unicodeArrowStyleEq - `extQ` layoutInfoEq + `extQ` considerEqual @(LayoutInfo GhcPs) `extQ` classDeclCtxEq `extQ` derivedTyClsParensEq - `extQ` epaCommentsEq + `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs + `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token + `extQ` considerEqual @EpaLocation `ext2Q` forLocated + -- unicode-related + `extQ` considerEqual @(HsUniToken "->" "→") + `extQ` considerEqual @(HsUniToken "::" "∷") + `extQ` considerEqual @(HsLinearArrowTokens GhcPs) ) x y | otherwise = Different [] - srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff - srcSpanEq _ _ = Same - epAnnEq :: EpAnn a -> GenericQ ParseResultDiff - epAnnEq _ _ = Same - sourceTextEq :: SourceText -> GenericQ ParseResultDiff - sourceTextEq _ _ = Same - importDeclQualifiedStyleEq :: - ImportDeclQualifiedStyle -> + + considerEqualVia :: + forall a. + (Typeable a) => + (a -> a -> ParseResultDiff) -> + a -> GenericQ ParseResultDiff - importDeclQualifiedStyleEq d0 d1' = - case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of - (x, Just x') | x == x' -> Same - (QualifiedPre, Just QualifiedPost) -> Same - (QualifiedPost, Just QualifiedPre) -> Same - _ -> Different [] + considerEqualVia f x (cast -> Just x') = f x x' + considerEqualVia _ _ _ = Different [] + + considerEqualVia' f = + considerEqualVia $ \x x' -> if f x x' then Same else Different [] + + considerEqual :: forall a. (Typeable a) => a -> GenericQ ParseResultDiff + considerEqual = considerEqualVia $ \_ _ -> Same + + epAnnEq :: EpAnn a -> b -> ParseResultDiff + epAnnEq _ _ = Same + + importDeclQualifiedStyleEq = considerEqualVia' f + where + f QualifiedPre QualifiedPost = True + f QualifiedPost QualifiedPre = True + f x x' = x == x' + hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff - hsDocStringEq str0 str1' = - case cast str1' :: Maybe HsDocString of - Nothing -> Different [] - Just str1 -> - if splitDocString True str0 == splitDocString True str1 - then Same - else Different [] + hsDocStringEq = considerEqualVia' ((==) `on` splitDocString True) + forLocated :: (Data e0, Data e1) => GenLocated e0 e1 -> @@ -147,25 +154,11 @@ else d UnhelpfulSpan _ -> d appendSpan _ d = d - -- 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 (HsExplicitMult _ _ t) (castArrow -> Just (HsExplicitMult _ _ t')) = genericQuery t t' - unicodeArrowStyleEq _ _ = Different [] - castArrow :: (Typeable a) => a -> Maybe (HsArrow GhcPs) - castArrow = cast - -- LayoutInfo ~ XClassDecl GhcPs tracks brace information - layoutInfoEq :: LayoutInfo -> GenericQ ParseResultDiff - layoutInfoEq _ (cast -> Just (_ :: LayoutInfo)) = Same - layoutInfoEq _ _ = Different [] + classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff classDeclCtxEq ClassDecl {tcdCtxt = Just (L _ []), ..} tc' = genericQuery ClassDecl {tcdCtxt = Nothing, ..} tc' classDeclCtxEq tc tc' = genericQuery tc tc' + derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff derivedTyClsParensEq (DctSingle NoExtField sigTy) dct' = genericQuery (DctMulti NoExtField [sigTy]) dct' derivedTyClsParensEq dct dct' = genericQuery dct dct' - -- EpAnnComments ~ XCGRHSs GhcPs - epaCommentsEq :: EpAnnComments -> GenericQ ParseResultDiff - epaCommentsEq _ (cast -> Just (_ :: EpAnnComments)) = Same - epaCommentsEq _ _ = Different [] diff --git a/src/Ormolu/Diff/Text.hs b/src/Ormolu/Diff/Text.hs --- a/src/Ormolu/Diff/Text.hs +++ b/src/Ormolu/Diff/Text.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE RecordWildCards #-} -- | This module allows us to diff two 'Text' values. @@ -13,16 +12,18 @@ ) where -import Control.Monad -import qualified Data.Algorithm.Diff as D +import Control.Monad (unless, when) +import Data.Algorithm.Diff qualified as D +import Data.Foldable (for_) import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import Data.IntSet qualified as IntSet import Data.List (foldl') import Data.Maybe (listToMaybe) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Types.SrcLoc import Ormolu.Terminal +import Ormolu.Terminal.QualifiedDo qualified as Term ---------------------------------------------------------------------------- -- Types @@ -103,39 +104,39 @@ -- | Print the given 'TextDiff' as a 'Term' action. This function tries to -- mimic the style of @git diff@. -printTextDiff :: TextDiff -> Term () -printTextDiff TextDiff {..} = do - (bold . putS) textDiffPath +printTextDiff :: TextDiff -> Term +printTextDiff TextDiff {..} = Term.do + (bold . put . T.pack) textDiffPath newline - forM_ (toHunks (assignLines textDiffDiffList)) $ \hunk@Hunk {..} -> - when (isSelectedLine textDiffSelectedLines hunk) $ do - cyan $ do + for_ (toHunks (assignLines textDiffDiffList)) $ \hunk@Hunk {..} -> + when (isSelectedLine textDiffSelectedLines hunk) $ Term.do + cyan $ Term.do put "@@ -" - putS (show hunkFirstStartLine) + putShow hunkFirstStartLine put "," - putS (show hunkFirstLength) + putShow hunkFirstLength put " +" - putS (show hunkSecondStartLine) + putShow hunkSecondStartLine put "," - putS (show hunkSecondLength) + putShow hunkSecondLength put " @@" newline - forM_ hunkDiff $ \case + for_ hunkDiff $ \case D.Both ys _ -> - forM_ ys $ \y -> do + for_ ys $ \y -> Term.do unless (T.null y) $ put " " put y newline D.First ys -> - forM_ ys $ \y -> red $ do + for_ ys $ \y -> red $ Term.do put "-" unless (T.null y) $ put " " put y newline D.Second ys -> - forM_ ys $ \y -> green $ do + for_ ys $ \y -> green $ Term.do put "+" unless (T.null y) $ put " " diff --git a/src/Ormolu/Exception.hs b/src/Ormolu/Exception.hs --- a/src/Ormolu/Exception.hs +++ b/src/Ormolu/Exception.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | 'OrmoluException' type and surrounding definitions. module Ormolu.Exception @@ -10,15 +11,17 @@ where import Control.Exception -import Control.Monad (forM_) +import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Void (Void) +import Distribution.Parsec.Error (PError, showPError) import GHC.Types.SrcLoc import Ormolu.Diff.Text (TextDiff, printTextDiff) import Ormolu.Terminal +import Ormolu.Terminal.QualifiedDo qualified as Term import System.Exit (ExitCode (..)) import System.IO import Text.Megaparsec (ParseErrorBundle, errorBundlePretty) @@ -36,74 +39,76 @@ | -- | Some GHC options were not recognized OrmoluUnrecognizedOpts (NonEmpty String) | -- | Cabal file parsing failed - OrmoluCabalFileParsingFailed FilePath + OrmoluCabalFileParsingFailed FilePath (NonEmpty PError) | -- | Missing input file path when using stdin input and -- accounting for .cabal files OrmoluMissingStdinInputFile | -- | A parse error in a fixity overrides file OrmoluFixityOverridesParseError (ParseErrorBundle Text Void) - deriving (Eq, Show) + deriving (Show) instance Exception OrmoluException -- | Print an 'OrmoluException'. printOrmoluException :: OrmoluException -> - Term () + Term printOrmoluException = \case - OrmoluParsingFailed s e -> do - bold (putSrcSpan s) + OrmoluParsingFailed s e -> Term.do + bold (putOutputable s) newline put " The GHC parser (in Haddock mode) failed:" newline put " " put (T.pack e) newline - OrmoluOutputParsingFailed s e -> do - bold (putSrcSpan s) + OrmoluOutputParsingFailed s e -> Term.do + bold (putOutputable s) newline put " Parsing of formatted code failed:" + newline put " " put (T.pack e) newline - OrmoluASTDiffers diff ss -> do + OrmoluASTDiffers diff ss -> Term.do printTextDiff diff newline put " AST of input and AST of formatted code differ." newline - forM_ ss $ \s -> do + for_ ss $ \s -> Term.do put " at " - putRealSrcSpan s + putOutputable s newline put " Please, consider reporting the bug." newline put " To format anyway, use --unsafe." newline - OrmoluNonIdempotentOutput diff -> do + OrmoluNonIdempotentOutput diff -> Term.do printTextDiff diff newline put " Formatting is not idempotent." newline put " Please, consider reporting the bug." newline - OrmoluUnrecognizedOpts opts -> do + OrmoluUnrecognizedOpts opts -> Term.do put "The following GHC options were not recognized:" newline put " " - (putS . unwords . NE.toList) opts + (put . T.unwords . map T.pack . NE.toList) opts newline - OrmoluCabalFileParsingFailed cabalFile -> do + OrmoluCabalFileParsingFailed cabalFile parseErrors -> Term.do put "Parsing this .cabal file failed:" newline - put $ " " <> T.pack cabalFile - newline - OrmoluMissingStdinInputFile -> do + for_ parseErrors $ \e -> Term.do + put . T.pack $ " " <> showPError cabalFile e + newline + OrmoluMissingStdinInputFile -> Term.do put "The --stdin-input-file option is necessary when using input" newline put "from stdin and accounting for .cabal files" newline - OrmoluFixityOverridesParseError errorBundle -> do - putS (errorBundlePretty errorBundle) + OrmoluFixityOverridesParseError errorBundle -> Term.do + put . T.pack . errorBundlePretty $ errorBundle newline -- | Inside this wrapper 'OrmoluException' will be caught and displayed diff --git a/src/Ormolu/Fixity.hs b/src/Ormolu/Fixity.hs --- a/src/Ormolu/Fixity.hs +++ b/src/Ormolu/Fixity.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -27,27 +26,25 @@ ) where -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary -import qualified Data.ByteString.Lazy as BL +import Data.Binary qualified as Binary +import Data.Binary.Get qualified as Binary +import Data.ByteString.Lazy qualified as BL import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.MemoTrie (memo) import Data.Semigroup (sconcat) import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName) import Ormolu.Fixity.Internal #if BUNDLE_FIXITIES import Data.FileEmbed (embedFile) #else -import qualified Data.ByteString.Unsafe as BU -import Foreign.Ptr -import System.Environment (getEnv) +import qualified Data.ByteString as B import System.IO.Unsafe (unsafePerformIO) #endif @@ -59,12 +56,10 @@ BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin") #else -- The GHC WASM backend does not yet support Template Haskell, so we instead --- pass in the encoded fixity DB at runtime by storing the pointer and length of --- the bytes in an environment variable. -HackageInfo packageToOps packageToPopularity = unsafePerformIO $ do - (ptr, len) <- read <$> getEnv "ORMOLU_HACKAGE_INFO" - Binary.runGet Binary.get . BL.fromStrict - <$> BU.unsafePackMallocCStringLen (intPtrToPtr $ IntPtr ptr, len) +-- pass in the encoded fixity DB via pre-initialization with Wizer. +HackageInfo packageToOps packageToPopularity = + unsafePerformIO $ + Binary.runGet Binary.get . BL.fromStrict <$> B.readFile "hackage-info.bin" {-# NOINLINE packageToOps #-} {-# NOINLINE packageToPopularity #-} #endif diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs --- a/src/Ormolu/Fixity/Internal.hs +++ b/src/Ormolu/Fixity/Internal.hs @@ -1,11 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Fixity.Internal @@ -24,16 +19,17 @@ ) where +import Control.DeepSeq (NFData) import Data.Binary (Binary) import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SBS +import Data.ByteString.Short qualified as SBS import Data.Foldable (asum) import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.String (IsString (..)) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Distribution.Types.PackageName (PackageName) import GHC.Data.FastString (fs_sbs) import GHC.Generics (Generic) @@ -45,7 +41,7 @@ | InfixR | InfixN deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (Binary) + deriving anyclass (Binary, NFData) -- | Fixity information about an infix operator that takes the uncertainty -- that can arise from conflicting definitions into account. @@ -60,7 +56,7 @@ fiMaxPrecedence :: Int } deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (Binary) + deriving anyclass (Binary, NFData) -- | The lowest level of information we can have about an operator. defaultFixityInfo :: FixityInfo @@ -100,7 +96,7 @@ { -- | Invariant: UTF-8 encoded getOpName :: ShortByteString } - deriving newtype (Eq, Ord, Binary) + deriving newtype (Eq, Ord, Binary, NFData) -- | Convert an 'OpName' to 'Text'. unOpName :: OpName -> Text @@ -140,9 +136,9 @@ -- each package, if available. data HackageInfo = HackageInfo + -- | Map from package name to a map from operator name to its fixity (Map PackageName FixityMap) - -- ^ Map from package name to a map from operator name to its fixity + -- | Map from package name to its 30-days download count from Hackage (Map PackageName Int) - -- ^ Map from package name to its 30-days download count from Hackage deriving stock (Generic) deriving anyclass (Binary) diff --git a/src/Ormolu/Fixity/Parser.hs b/src/Ormolu/Fixity/Parser.hs --- a/src/Ormolu/Fixity/Parser.hs +++ b/src/Ormolu/Fixity/Parser.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -- | Parser for fixity maps. module Ormolu.Fixity.Parser @@ -13,15 +12,15 @@ ) where -import qualified Data.Char as Char -import qualified Data.Map.Strict as Map +import Data.Char qualified as Char +import Data.Map.Strict qualified as Map import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Void (Void) import Ormolu.Fixity import Text.Megaparsec import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Char.Lexer qualified as L type Parser = Parsec Void Text diff --git a/src/Ormolu/Fixity/Printer.hs b/src/Ormolu/Fixity/Printer.hs --- a/src/Ormolu/Fixity/Printer.hs +++ b/src/Ormolu/Fixity/Printer.hs @@ -7,14 +7,14 @@ ) where -import qualified Data.Char as Char -import qualified Data.Map.Strict as Map +import Data.Char qualified as Char +import Data.Map.Strict qualified as Map import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Builder.Int as B +import Data.Text.Lazy.Builder qualified as B +import Data.Text.Lazy.Builder.Int qualified as B import Ormolu.Fixity -- | Print out a textual representation of a 'FixityMap'. diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -15,7 +15,7 @@ import Data.Function (on) import Data.List (foldl', nubBy, sortBy, sortOn) import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M +import Data.Map.Strict qualified as M import GHC.Data.FastString import GHC.Hs import GHC.Hs.ImpExp as GHC @@ -23,8 +23,6 @@ import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc -import GHC.Unit.Module.Name -import GHC.Unit.Types import Ormolu.Utils (groupBy', notImplemented, separatedByBlank, showOutputable) -- | Sort, group and normalize imports. @@ -49,7 +47,7 @@ L l ImportDecl - { ideclHiding = second (fmap normalizeLies) <$> ideclHiding, + { ideclImportList = second (fmap normalizeLies) <$> ideclImportList, .. } @@ -63,7 +61,7 @@ L lx ImportDecl - { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of + { ideclImportList = case (ideclImportList, GHC.ideclImportList y) of (Just (hiding, L l' xs), Just (_, L _ ys)) -> Just (hiding, (L l' (normalizeLies (xs ++ ys)))) _ -> Nothing, @@ -80,12 +78,23 @@ importSource :: IsBootInterface, importSafe :: Bool, importQualified :: Bool, - importImplicit :: Bool, importAs :: Maybe ModuleName, - importHiding :: Maybe Bool + importHiding :: Maybe ImportListInterpretationOrd } deriving (Eq, Ord) +-- | 'ImportListInterpretation' does not have an 'Ord' instance. +newtype ImportListInterpretationOrd = ImportListInterpretationOrd + { unImportListInterpretationOrd :: ImportListInterpretation + } + deriving stock (Eq) + +instance Ord ImportListInterpretationOrd where + compare = compare `on` toBool . unImportListInterpretationOrd + where + toBool Exactly = False + toBool EverythingBut = True + -- | Obtain an 'ImportId' for a given import. importId :: LImportDecl GhcPs -> ImportId importId (L _ ImportDecl {..}) = @@ -99,9 +108,8 @@ QualifiedPre -> True QualifiedPost -> True NotQualified -> False, - importImplicit = ideclImplicit, importAs = unLoc <$> ideclAs, - importHiding = fst <$> ideclHiding + importHiding = ImportListInterpretationOrd . fst <$> ideclImportList } where isPrelude = moduleNameString moduleName == "Prelude" @@ -163,15 +171,15 @@ in Just (f <$> old) in M.alter alter wname m --- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an +-- | A wrapper for @'IEWrappedName' 'GhcPs'@ that allows us to define an -- 'Ord' instance for it. -newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName) +newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName GhcPs) deriving (Eq) instance Ord IEWrappedNameOrd where compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y --- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@. +-- | Project @'IEWrappedName' 'GhcPs'@ from @'IE' 'GhcPs'@. getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case IEVar NoExtField x -> IEWrappedNameOrd (unLoc x) @@ -184,18 +192,18 @@ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" -- | Like 'compareIewn' for located wrapped names. -compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering +compareLIewn :: LIEWrappedName GhcPs -> LIEWrappedName GhcPs -> Ordering compareLIewn = compareIewn `on` unLoc --- | Compare two @'IEWrapppedName' 'RdrName'@ things. -compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering -compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y -compareIewn (IEName _) (IEPattern _ _) = LT -compareIewn (IEName _) (IEType _ _) = LT -compareIewn (IEPattern _ _) (IEName _) = GT +-- | Compare two @'IEWrapppedName' 'GhcPs'@ things. +compareIewn :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering +compareIewn (IEName _ x) (IEName _ y) = unLoc x `compareRdrName` unLoc y +compareIewn (IEName _ _) (IEPattern _ _) = LT +compareIewn (IEName _ _) (IEType _ _) = LT +compareIewn (IEPattern _ _) (IEName _ _) = GT compareIewn (IEPattern _ x) (IEPattern _ y) = unLoc x `compareRdrName` unLoc y compareIewn (IEPattern _ _) (IEType _ _) = LT -compareIewn (IEType _ _) (IEName _) = GT +compareIewn (IEType _ _) (IEName _ _) = GT compareIewn (IEType _ _) (IEPattern _ _) = GT compareIewn (IEType _ x) (IEType _ y) = unLoc x `compareRdrName` unLoc y diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -18,29 +19,31 @@ import Control.Monad.IO.Class import Data.Char (isSpace) import Data.Functor +import Data.Functor.Identity (Identity (..)) import Data.Generics -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE import Data.Text (Text) import GHC.Data.Bag (bagToList) -import qualified GHC.Data.EnumSet as EnumSet -import qualified GHC.Data.FastString as GHC -import qualified GHC.Driver.CmdLine as GHC +import GHC.Data.EnumSet qualified as EnumSet +import GHC.Data.FastString qualified as GHC +import GHC.Driver.CmdLine qualified 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 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.Parser qualified as GHC +import GHC.Parser.Header qualified as GHC +import GHC.Parser.Lexer qualified as GHC +import GHC.Types.Error (NoDiagnosticOpts (..), getMessages) +import GHC.Types.SourceError qualified as GHC (handleSourceError) import GHC.Types.SrcLoc import GHC.Utils.Error import GHC.Utils.Outputable (defaultSDocContext) -import qualified GHC.Utils.Panic as GHC +import GHC.Utils.Panic qualified as GHC import Ormolu.Config +import Ormolu.Config.Gen (SingleConstraintParens (..)) import Ormolu.Exception import Ormolu.Fixity (LazyFixityMap) import Ormolu.Parser.CommentStream @@ -98,7 +101,7 @@ FilePath -> Text -> m (Either (SrcSpan, String) ParseResult) -parseModuleSnippet Config {..} fixityMap dynFlags path rawInput = liftIO $ do +parseModuleSnippet config@Config {..} fixityMap dynFlags path rawInput = liftIO $ do let (input, indent) = removeIndentation . linesInRegion cfgRegion $ rawInput let pStateErrors pstate = let errs = bagToList . getMessages $ GHC.getPsErrorMessages pstate @@ -107,15 +110,19 @@ SevError -> 1 :: Int SevWarning -> 2 SevIgnore -> 3 - showErr = - showOutputable - . formatBulleted defaultSDocContext - . diagnosticMessage - . errMsgDiagnostic + showErr (errMsgDiagnostic -> err) = codeMsg <> msg + where + codeMsg = case diagnosticCode err of + Just code -> "[" <> showOutputable code <> "] " + Nothing -> "" + msg = + showOutputable + . formatBulleted defaultSDocContext + . diagnosticMessage NoDiagnosticOpts + $ err in case L.sortOn (rateSeverity . errMsgSeverity) errs of [] -> Nothing err : _ -> - -- Show instance returns a short error message Just (fixupErrSpan (errMsgSpan err), showErr err) parser = case cfgSourceType of ModuleSource -> GHC.parseModule @@ -125,7 +132,7 @@ case pStateErrors pstate of Just err -> Left err Nothing -> error "PFailed does not have an error" - GHC.POk pstate (L _ (normalizeModule -> hsModule)) -> + GHC.POk pstate (L _ (normalizeModule config -> hsModule)) -> case pStateErrors pstate of -- Some parse errors (pattern/arrow syntax in expr context) -- do not cause a parse error, but they are replaced with "_" @@ -151,8 +158,8 @@ -- | Normalize a 'HsModule' by sorting its export lists, dropping -- blank comments, etc. -normalizeModule :: HsModule -> HsModule -normalizeModule hsmod = +normalizeModule :: Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs +normalizeModule Config {..} hsmod = everywhere (extT (mkT dropBlankTypeHaddocks) patchContext) hsmod @@ -160,8 +167,11 @@ hsmodImports hsmod, hsmodDecls = filter (not . isBlankDocD . unLoc) (hsmodDecls hsmod), - hsmodHaddockModHeader = - mfilter (not . isBlankDocString) (hsmodHaddockModHeader hsmod), + hsmodExt = + (hsmodExt hsmod) + { hsmodHaddockModHeader = + mfilter (not . isBlankDocString) (hsmodHaddockModHeader (hsmodExt hsmod)) + }, hsmodExports = (fmap . fmap) (filter (not . isBlankDocIE . unLoc)) (hsmodExports hsmod) } @@ -179,10 +189,17 @@ | isBlankDocString s -> ty a -> a patchContext :: LHsContext GhcPs -> LHsContext GhcPs - patchContext = mapLoc $ \case - [x@(L _ (HsParTy _ _))] -> [x] - [x@(L lx _)] -> [L lx (HsParTy EpAnnNotUsed x)] + patchContext = fmap $ \case + [x@(L _ (HsParTy _ t))] -> unwrapParens x t + [x@(L _ _)] -> wrapParens x xs -> xs + constraintParens = runIdentity (poSingleConstraintParens cfgPrinterOpts) + unwrapParens outer inner = case constraintParens of + ConstraintNever -> [inner] + _ -> [outer] + wrapParens x@(L lx _) = case constraintParens of + ConstraintAlways -> [L lx (HsParTy EpAnnNotUsed x)] + _ -> [x] -- | Enable all language extensions that we think should be enabled by -- default for ease of use. @@ -220,7 +237,8 @@ LexicalNegation, -- implies NegativeLiterals LinearTypes, -- steals the (%) type operator in some cases OverloadedRecordDot, -- f.g parses differently - OverloadedRecordUpdate -- qualified fields are not supported + OverloadedRecordUpdate, -- qualified fields are not supported + OverloadedLabels -- a#b is parsed differently ] -- | Run a 'GHC.P' computation. diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -- | Functions for working with comment stream. @@ -26,19 +22,19 @@ import Data.Data (Data) import Data.Generics.Schemes import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Lazy as M +import Data.List.NonEmpty qualified as NE +import Data.Map.Lazy qualified as M import Data.Maybe -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T -import qualified GHC.Data.Strict as Strict +import Data.Text qualified as T +import GHC.Data.Strict qualified as Strict import GHC.Hs (HsModule) import GHC.Hs.Doc import GHC.Hs.Extension import GHC.Hs.ImpExp import GHC.Parser.Annotation (EpAnnComments (..), getLocA) -import qualified GHC.Parser.Annotation as GHC +import GHC.Parser.Annotation qualified as GHC import GHC.Types.SrcLoc import Ormolu.Parser.Pragma import Ormolu.Utils (onTheSameLine, showOutputable) @@ -57,7 +53,7 @@ -- | Original input Text -> -- | Module to use for comment extraction - HsModule -> + HsModule GhcPs -> -- | Stack header, pragmas, and comment stream ( Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)], diff --git a/src/Ormolu/Parser/Pragma.hs b/src/Ormolu/Parser/Pragma.hs --- a/src/Ormolu/Parser/Pragma.hs +++ b/src/Ormolu/Parser/Pragma.hs @@ -10,12 +10,12 @@ import Data.Char (isSpace) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import GHC.Data.FastString (bytesFS, mkFastString) import GHC.Driver.Config.Parser (initParserOpts) import GHC.DynFlags (baseDynFlags) -import qualified GHC.Parser.Lexer as L +import GHC.Parser.Lexer qualified as L import GHC.Types.SrcLoc import Ormolu.Utils (textToStringBuffer) diff --git a/src/Ormolu/Parser/Result.hs b/src/Ormolu/Parser/Result.hs --- a/src/Ormolu/Parser/Result.hs +++ b/src/Ormolu/Parser/Result.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- | A type for result of parsing. module Ormolu.Parser.Result ( SourceSnippet (..), @@ -23,7 +21,7 @@ -- | A collection of data that represents a parsed module in Ormolu. data ParseResult = ParseResult { -- | Parsed module or signature - prParsedSource :: HsModule, + prParsedSource :: HsModule GhcPs, -- | Either regular module or signature file prSourceType :: SourceType, -- | Stack header diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Pretty-printer for Haskell AST. @@ -10,7 +9,7 @@ where import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu.Config import Ormolu.Parser.Result import Ormolu.Printer.Combinators diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -32,6 +31,7 @@ located, located', switchLayout, + switchLayoutNoLimit, Layout (..), vlayout, getLayout, @@ -95,7 +95,7 @@ import Control.Monad import Data.List (intersperse) import Data.Text (Text) -import qualified GHC.Data.Strict as Strict +import GHC.Data.Strict qualified as Strict import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc import Ormolu.Config @@ -151,22 +151,48 @@ -- provided by GHC AST. It is relatively rare that this one is needed. -- -- Given empty list this function will set layout to single line. -switchLayout :: +switchLayout' :: + -- | Should enforce column limit, if one is set + Bool -> -- | Span that controls layout [SrcSpan] -> -- | Computation to run with changed layout R () -> R () -switchLayout spans' = enterLayout (spansLayout spans') +switchLayout' useColLimit spans' r = do + columnLimit <- + if useColLimit then getPrinterOpt poColumnLimit else pure NoLimit + enterLayout (spansLayout columnLimit spans') r +switchLayout :: [SrcSpan] -> R () -> R () +switchLayout = switchLayout' True + +-- | Switch layout version that disregards the column limit. +-- It should be used for the argument list in function definitions because +-- the column limit can't be enforced there without changing the AST. +switchLayoutNoLimit :: [SrcSpan] -> R () -> R () +switchLayoutNoLimit = switchLayout' False + -- | Which layout combined spans result in? -spansLayout :: [SrcSpan] -> Layout -spansLayout = \case +spansLayout :: ColumnLimit -> [SrcSpan] -> Layout +spansLayout colLimit = \case [] -> SingleLine (x : xs) -> - if isOneLineSpan (foldr combineSrcSpans x xs) + if isOneLineSpan combinedSpan && not (shouldBreakSingleLine combinedSpan) then SingleLine else MultiLine + where + combinedSpan = foldr combineSrcSpans x xs + + shouldBreakSingleLine :: SrcSpan -> Bool + shouldBreakSingleLine (RealSrcSpan rs _) = + case colLimit of + ColumnLimit maxLineLength -> + spanLineLength > fromIntegral maxLineLength + NoLimit -> False + where + spanLineLength = srcSpanEndCol rs - srcSpanStartCol rs + shouldBreakSingleLine _ = False -- | Insert a space if enclosing layout is single-line, or newline if it's -- multiline. diff --git a/src/Ormolu/Printer/Comments.hs b/src/Ormolu/Printer/Comments.hs --- a/src/Ormolu/Printer/Comments.hs +++ b/src/Ormolu/Printer/Comments.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Helpers for formatting of comments. This is low-level code, use @@ -13,7 +12,7 @@ where import Control.Monad -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (listToMaybe) import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -- | In most cases import "Ormolu.Printer.Combinators" instead, these -- functions are the low-level building blocks and should not be used on @@ -69,11 +67,11 @@ import Data.Functor.Identity (runIdentity) import Data.Maybe (listToMaybe) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder import GHC.Data.EnumSet (EnumSet) -import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.EnumSet qualified as EnumSet import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable) diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -- | Rendering of commonly useful bits. @@ -18,7 +17,7 @@ import Control.Monad import Data.Foldable (traverse_) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp @@ -27,7 +26,7 @@ import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc -import GHC.Unit.Module.Name +import Language.Haskell.Syntax.Module.Name import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Utils @@ -49,9 +48,9 @@ space atom mname -p_ieWrappedName :: IEWrappedName RdrName -> R () +p_ieWrappedName :: IEWrappedName GhcPs -> R () p_ieWrappedName = \case - IEName x -> p_rdrName x + IEName _ x -> p_rdrName x IEPattern _ x -> do txt "pattern" space @@ -235,4 +234,4 @@ p_sourceText :: SourceText -> R () p_sourceText = \case NoSourceText -> pure () - SourceText s -> space >> txt (T.pack s) + SourceText s -> txt (T.pack s) diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -13,7 +12,7 @@ import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..), (<|)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import GHC.Hs import GHC.Types.Name.Occurrence (occNameFS) import GHC.Types.Name.Reader @@ -254,12 +253,12 @@ RdrName -> HsDecl GhcPs pattern InlinePragma n <- SigD _ (InlineSig _ (L _ n) _) pattern SpecializePragma n <- SigD _ (SpecSig _ (L _ n) _ _) -pattern SCCPragma n <- SigD _ (SCCFunSig _ _ (L _ n) _) -pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ _ (TypeAnnProvenance (L _ n)) _) -pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ _ (ValueAnnProvenance (L _ n)) _) +pattern SCCPragma n <- SigD _ (SCCFunSig _ (L _ n) _) +pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ (TypeAnnProvenance (L _ n)) _) +pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _) pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _)) pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _) -pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _) +pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ _ (L _ n) _ _ _ _ _ _ _ _) pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) @@ -294,8 +293,8 @@ defSigRdrNames _ = Nothing funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -funRdrNames (ValD _ (FunBind _ (L _ n) _ _)) = Just [n] -funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n +funRdrNames (ValD _ (FunBind _ (L _ n) _)) = Just [n] +funRdrNames (ValD _ (PatBind _ (L _ n) _)) = Just $ patBindNames n funRdrNames _ = Nothing patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] @@ -303,7 +302,7 @@ patSigRdrNames _ = Nothing warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -warnSigRdrNames (WarningD _ (Warnings _ _ ws)) = Just $ +warnSigRdrNames (WarningD _ (Warnings _ ws)) = Just $ flip concatMap ws $ \(L _ (Warning _ ns _)) -> map unLoc ns warnSigRdrNames _ = Nothing @@ -316,7 +315,7 @@ patBindNames (BangPat _ (L _ p)) = patBindNames p patBindNames (ParPat _ _ (L _ p) _) = patBindNames p patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps -patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p +patBindNames (AsPat _ (L _ n) _ (L _ p)) = n : patBindNames p patBindNames (SumPat _ (L _ p) _ _) = patBindNames p patBindNames (ViewPat _ _ (L _ p)) = patBindNames p patBindNames (SplicePat _ _) = [] diff --git a/src/Ormolu/Printer/Meat/Declaration/Annotation.hs b/src/Ormolu/Printer/Meat/Declaration/Annotation.hs --- a/src/Ormolu/Printer/Meat/Declaration/Annotation.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Annotation.hs @@ -12,7 +12,7 @@ import Ormolu.Printer.Meat.Declaration.Value p_annDecl :: AnnDecl GhcPs -> R () -p_annDecl (HsAnnotation _ _ annProv expr) = +p_annDecl (HsAnnotation _ annProv expr) = pragma "ANN" . inci $ do p_annProv annProv breakpoint diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -11,10 +11,12 @@ where import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, maybeToList) -import qualified Data.Text as Text +import Data.Text qualified as Text import Data.Void -import qualified GHC.Data.Strict as Strict +import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall @@ -39,19 +41,22 @@ HsDataDefn GhcPs -> R () p_dataDecl style name tpats fixity HsDataDefn {..} = do - txt $ case dd_ND of - NewType -> "newtype" - DataType -> "data" + txt $ case dd_cons of + NewTypeCon _ -> "newtype" + DataTypeCons False _ -> "data" + DataTypeCons True _ -> "type data" txt $ case style of Associated -> mempty Free -> " instance" case unLoc <$> dd_cType of Nothing -> pure () Just (CType prag header (type_, _)) -> do + space p_sourceText prag case header of Nothing -> pure () Just (Header h _) -> space *> p_sourceText h + space p_sourceText type_ txt " #-}" let constructorSpans = getLocA name : fmap lhsTypeArgSrcSpan tpats @@ -71,18 +76,21 @@ token'dcolon breakpoint inci $ located k p_hsType - let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons - unless (null dd_cons) $ + let dd_cons' = case dd_cons of + NewTypeCon a -> [a] + DataTypeCons _ as -> as + gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons' + unless (null dd_cons') $ if gadt then inci $ do switchLayout declHeaderSpans $ do breakpoint txt "where" breakpoint - sepSemi (located' (p_conDecl False)) dd_cons - else switchLayout (getLocA name : (getLocA <$> dd_cons)) . inci $ do - let singleConstRec = isSingleConstRec dd_cons - if hasHaddocks dd_cons + sepSemi (located' (p_conDecl False)) dd_cons' + else switchLayout (getLocA name : (getLocA <$> dd_cons')) . inci $ do + let singleConstRec = isSingleConstRec dd_cons' + if hasHaddocks dd_cons' then newline else if singleConstRec @@ -92,14 +100,14 @@ space layout <- getLayout let s = - if layout == MultiLine || hasHaddocks dd_cons + if layout == MultiLine || hasHaddocks dd_cons' then newline >> txt "|" >> space else space >> txt "|" >> space sitcc' = - if hasHaddocks dd_cons || not singleConstRec + if hasHaddocks dd_cons' || not singleConstRec then sitcc else id - sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons + sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons' unless (null dd_derivs) breakpoint inci $ sep newline (located' p_hsDerivingClause) dd_derivs @@ -111,7 +119,7 @@ ConDeclGADT {..} -> do mapM_ (p_hsDoc Pipe True) con_doc let conDeclSpn = - fmap getLocA con_names + fmap getLocA (NE.toList con_names) <> [getLocA con_bndrs] <> maybeToList (fmap getLocA con_mb_cxt) <> conArgsSpans @@ -120,13 +128,11 @@ PrefixConGADT xs -> getLocA . hsScaledThing <$> xs RecConGADT x _ -> [getLocA x] switchLayout conDeclSpn $ do - case con_names of - [] -> return () - (c : cs) -> do - p_rdrName c - unless (null cs) . inci $ do - commaDel - sep commaDel p_rdrName cs + let c :| cs = con_names + p_rdrName c + unless (null cs) . inci $ do + commaDel + sep commaDel p_rdrName cs inci $ do let conTy = case con_g_args of PrefixConGADT xs -> @@ -152,7 +158,7 @@ mapM_ (p_hsDoc Pipe True) con_doc let conDeclWithContextSpn = [ RealSrcSpan real Strict.Nothing - | Just (EpaSpan real) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext + | Just (EpaSpan real _) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext ] <> fmap getLocA con_ex_tvs <> maybeToList (fmap getLocA con_mb_cxt) @@ -174,8 +180,12 @@ switchLayout conDeclSpn $ case con_args of PrefixCon [] xs -> do p_rdrName con_name - unless (null xs) breakpoint - inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) (hsScaledThing <$> xs) + let args = hsScaledThing <$> xs + argsHaveDocs = conArgsHaveHaddocks args + delimiter = if argsHaveDocs then newline else breakpoint + unless (null xs) delimiter + inci . sitcc $ + sep delimiter (sitcc . located' p_hsType) args PrefixCon (v : _) _ -> absurd v RecCon l -> do p_rdrName con_name @@ -263,5 +273,16 @@ hasHaddocks :: [LConDecl GhcPs] -> Bool hasHaddocks = any (f . unLoc) where - f ConDeclH98 {..} = isJust con_doc + f ConDeclH98 {..} = + isJust con_doc || case con_args of + PrefixCon [] xs -> + conArgsHaveHaddocks (hsScaledThing <$> xs) + _ -> False f _ = False + +conArgsHaveHaddocks :: [LBangType GhcPs] -> Bool +conArgsHaveHaddocks xs = + let hasDocs = \case + HsDocTy {} -> True + _ -> False + in any (hasDocs . unLoc) xs diff --git a/src/Ormolu/Printer/Meat/Declaration/Default.hs b/src/Ormolu/Printer/Meat/Declaration/Default.hs --- a/src/Ormolu/Printer/Meat/Declaration/Default.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Default.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Ormolu.Printer.Meat.Declaration.Default diff --git a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs --- a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Ormolu.Printer.Meat.Declaration.Foreign @@ -50,18 +49,20 @@ -- We also layout the identifier using the 'SourceText', because printing -- with the other two fields of 'CImport' is very complicated. See the -- 'Outputable' instance of 'ForeignImport' for details. -p_foreignImport :: ForeignImport -> R () -p_foreignImport (CImport cCallConv safety _ _ sourceText) = do +p_foreignImport :: ForeignImport GhcPs -> R () +p_foreignImport (CImport sourceText cCallConv safety _ _) = do txt "foreign import" space located cCallConv atom -- Need to check for 'noLoc' for the 'safe' annotation when (isGoodSrcSpan $ getLoc safety) (space >> atom safety) + space located sourceText p_sourceText -p_foreignExport :: ForeignExport -> R () -p_foreignExport (CExport (L loc (CExportStatic _ _ cCallConv)) sourceText) = do +p_foreignExport :: ForeignExport GhcPs -> R () +p_foreignExport (CExport sourceText (L loc (CExportStatic _ _ cCallConv))) = do txt "foreign export" space located (L loc cCallConv) atom + space located sourceText p_sourceText diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -- | Printing of operator trees. module Ormolu.Printer.Meat.Declaration.OpTree diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -18,7 +18,7 @@ import Ormolu.Printer.Meat.Type p_ruleDecls :: RuleDecls GhcPs -> R () -p_ruleDecls (HsRules _ _ xs) = +p_ruleDecls (HsRules _ xs) = pragma "RULES" $ sep breakpoint (sitcc . located' p_ruleDecl) xs p_ruleDecl :: RuleDecl GhcPs -> R () @@ -46,8 +46,8 @@ breakpoint located rhs p_hsExpr -p_ruleName :: (SourceText, RuleName) -> R () -p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs) +p_ruleName :: RuleName -> R () +p_ruleName name = atom (HsString NoSourceText name :: HsLit GhcPs) p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -32,11 +32,10 @@ FixSig _ sig -> p_fixSig sig InlineSig _ name inlinePragma -> p_inlineSig name inlinePragma SpecSig _ name ts inlinePragma -> p_specSig name ts inlinePragma - SpecInstSig _ _ sigType -> p_specInstSig sigType - MinimalSig _ _ booleanFormula -> p_minimalSig booleanFormula - CompleteMatchSig _ _sourceText cs ty -> p_completeSig cs ty - SCCFunSig _ _ name literal -> p_sccSig name literal - _ -> notImplemented "certain types of signature declarations" + SpecInstSig _ sigType -> p_specInstSig sigType + MinimalSig _ booleanFormula -> p_minimalSig booleanFormula + CompleteMatchSig _ cs ty -> p_completeSig cs ty + SCCFunSig _ name literal -> p_sccSig name literal p_typeSig :: -- | Should the tail of the names be indented diff --git a/src/Ormolu/Printer/Meat/Declaration/Splice.hs b/src/Ormolu/Printer/Meat/Declaration/Splice.hs --- a/src/Ormolu/Printer/Meat/Declaration/Splice.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Splice.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - module Ormolu.Printer.Meat.Declaration.Splice ( p_spliceDecl, ) @@ -7,8 +5,8 @@ import GHC.Hs import Ormolu.Printer.Combinators -import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice) +import Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice) p_spliceDecl :: SpliceDecl GhcPs -> R () -p_spliceDecl = \case - SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice +p_spliceDecl (SpliceDecl NoExtField splice deco) = + located splice $ p_hsUntypedSplice deco diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -1,19 +1,15 @@ {-# 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 ( p_valDecl, p_pat, p_hsExpr, - p_hsSplice, + p_hsUntypedSplice, p_stringLit, p_hsExpr', p_hsCmdTop, @@ -31,14 +27,13 @@ import Data.Generics.Schemes (everything) import Data.List (find, intersperse, sortBy) import Data.List.NonEmpty (NonEmpty (..), (<|)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import Data.Void import GHC.Data.Bag (bagToList) -import GHC.Data.FastString (FastString, lengthFS) -import qualified GHC.Data.Strict as Strict +import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) import GHC.Parser.CharClass (is_space) @@ -47,6 +42,7 @@ import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc +import Language.Haskell.Syntax.Basic import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Internal (sitccIfTrailing) @@ -73,8 +69,8 @@ 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 + 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 PatSynBind _ psb -> p_patSynBind psb @@ -199,7 +195,7 @@ _ -> patSpans patSpans = combineSrcSpans' (getLocA <$> ne_pats) indentBody = not (isOneLineSpan combinedSpans) - switchLayout [combinedSpans] $ do + switchLayoutNoLimit [combinedSpans] $ do let stdCase = sep breakpoint (located' p_pat) m_pats case style of Function name -> @@ -554,21 +550,8 @@ _ -> id p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R () -p_ldotFieldOcc = located' $ p_lFieldLabelString . dfoLabel - where - 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 - -- information whether parens are necessary. As a workaround, - -- we look if the RealSrcSpan is bigger than the string fs. - parensIfOp - | isOneLineSpan s, - Just realS <- srcSpanToRealSrcSpan s, - let spanLength = srcSpanEndCol realS - srcSpanStartCol realS, - lengthFS fs < spanLength = - parens N - | otherwise = id +p_ldotFieldOcc = + located' $ p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel p_ldotFieldOccs :: [XRec GhcPs (DotFieldOcc GhcPs)] -> R () p_ldotFieldOccs = sep (txt ".") p_ldotFieldOcc @@ -600,9 +583,9 @@ HsVar _ name -> p_rdrName name HsUnboundVar _ occ -> atom occ HsRecSel _ fldOcc -> p_fieldOcc fldOcc - HsOverLabel _ v -> do + HsOverLabel _ sourceText _ -> do txt "#" - atom v + p_sourceText sourceText HsIPVar _ (HsIPName name) -> do txt "?" atom name @@ -678,7 +661,7 @@ sep breakpoint (located' p_hsExpr) initp placeHanging placement . dontUseBraces $ located lastp p_hsExpr - HsAppType _ e a -> do + HsAppType _ e _ a -> do located e p_hsExpr breakpoint inci $ do @@ -849,7 +832,8 @@ breakpoint' txt "||]" HsUntypedBracket epAnn x -> p_hsQuote epAnn x - HsSpliceE _ splice -> p_hsSplice splice + HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice + HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice HsProc _ p e -> do txt "proc" located p $ \x -> do @@ -864,7 +848,7 @@ breakpoint inci (located e p_hsExpr) HsPragE _ prag x -> case prag of - HsPragSCC _ _ name -> do + HsPragSCC _ name -> do txt "{-# SCC " atom name txt " #-}" @@ -1103,7 +1087,7 @@ LazyPat _ pat -> do txt "~" located pat p_pat - AsPat _ name pat -> do + AsPat _ name _ pat -> do p_rdrName name txt "@" located pat p_pat @@ -1128,7 +1112,7 @@ p_rdrName pat unless (null tys && null xs) breakpoint inci . sitcc $ - sep breakpoint (sitcc . either p_hsPatSigType (located' p_pat)) $ + sep breakpoint (sitcc . either p_hsConPatTyArg (located' p_pat)) $ (Left <$> tys) <> (Right <$> xs) RecCon (HsRecFields fields dotdot) -> do p_rdrName pat @@ -1139,7 +1123,7 @@ inci . braces N . sep commaDel f $ case dotdot of Nothing -> Just <$> fields - Just (L _ n) -> (Just <$> take n fields) ++ [Nothing] + Just (L _ (RecFieldsDotDot n)) -> (Just <$> take n fields) ++ [Nothing] InfixCon l r -> do switchLayout [getLocA l, getLocA r] $ do located l p_pat @@ -1154,7 +1138,7 @@ token'rarrow breakpoint inci (located pat p_pat) - SplicePat _ splice -> p_hsSplice splice + SplicePat _ splice -> p_hsUntypedSplice DollarSplice splice LitPat _ p -> atom p NPat _ v (isJust -> isNegated) _ -> do when isNegated $ do @@ -1176,6 +1160,9 @@ p_hsPatSigType :: HsPatSigType GhcPs -> R () p_hsPatSigType (HsPS _ ty) = txt "@" *> located ty p_hsType +p_hsConPatTyArg :: HsConPatTyArg GhcPs -> R () +p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_hsPatSigType patSigTy + p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () p_pat_hsFieldBind HsFieldBind {..} = do located hfbLHS p_fieldOcc @@ -1200,11 +1187,10 @@ space parensHash s $ sep (txt "|") f args -p_hsSplice :: HsSplice GhcPs -> R () -p_hsSplice = \case - HsTypedSplice _ deco _ expr -> p_hsSpliceTH True expr deco - HsUntypedSplice _ deco _ expr -> p_hsSpliceTH False expr deco - HsQuasiQuote _ _ quoterName _ str -> do +p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () +p_hsUntypedSplice deco = \case + HsUntypedSpliceExpr _ expr -> p_hsSpliceTH False expr deco + HsQuasiQuote _ quoterName str -> do txt "[" p_rdrName (noLocA quoterName) txt "|" @@ -1212,7 +1198,6 @@ -- formatting here without potentially breaking someone's code. atom str txt "|]" - HsSpliced {} -> notImplemented "HsSpliced" p_hsSpliceTH :: -- | Typed splice? @@ -1365,7 +1350,7 @@ exprPlacement = \case -- Only hang lambdas with single line parameter lists HsLam _ mg -> case mg of - MG _ (L _ [L _ (Match _ _ (x : xs) _)]) _ + MG _ (L _ [L _ (Match _ _ (x : xs) _)]) | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> Hanging _ -> Normal diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot @@ -2,7 +2,7 @@ ( p_valDecl, p_pat, p_hsExpr, - p_hsSplice, + p_hsUntypedSplice, p_stringLit, p_hsExpr', p_hsCmdTop, @@ -11,16 +11,13 @@ ) where -import GHC.Hs.Binds -import GHC.Hs.Expr -import GHC.Hs.Extension -import GHC.Hs.Pat +import GHC.Hs import Ormolu.Printer.Combinators p_valDecl :: HsBindLR GhcPs GhcPs -> R () p_pat :: Pat GhcPs -> R () p_hsExpr :: HsExpr GhcPs -> R () -p_hsSplice :: HsSplice GhcPs -> R () +p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () p_stringLit :: String -> R () p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () diff --git a/src/Ormolu/Printer/Meat/Declaration/Warning.hs b/src/Ormolu/Printer/Meat/Declaration/Warning.hs --- a/src/Ormolu/Printer/Meat/Declaration/Warning.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Warning.hs @@ -18,7 +18,7 @@ import Ormolu.Printer.Meat.Common p_warnDecls :: WarnDecls GhcPs -> R () -p_warnDecls (Warnings _ _ warnings) = +p_warnDecls (Warnings _ warnings) = traverse_ (located' p_warnDecl) warnings p_warnDecl :: WarnDecl GhcPs -> R () diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -10,12 +10,11 @@ where import Control.Monad -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Hs import GHC.LanguageExtensions.Type import GHC.Types.PkgQual import GHC.Types.SrcLoc -import GHC.Unit.Types import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common @@ -64,13 +63,12 @@ space located l atom space - case ideclHiding of - Nothing -> return () - Just (hiding, _) -> - when hiding (txt "hiding") - case ideclHiding of + case ideclImportList of Nothing -> return () - Just (_, L _ xs) -> do + Just (hiding, L _ xs) -> do + case hiding of + Exactly -> pure () + EverythingBut -> txt "hiding" breakIfNotDiffFriendly parens' True $ do layout <- getLayout diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -11,7 +11,6 @@ import Control.Monad import GHC.Hs hiding (comment) import GHC.Types.SrcLoc -import GHC.Unit.Module.Name import GHC.Utils.Outputable (ppr, showSDocUnsafe) import Ormolu.Config import Ormolu.Imports (normalizeImports) @@ -33,10 +32,11 @@ -- | Pragmas and the associated comments [([RealLocated Comment], Pragma)] -> -- | AST to print - HsModule -> + HsModule GhcPs -> R () p_hsModule mstackHeader pragmas hsmod@HsModule {..} = do - let deprecSpan = maybe [] (pure . getLocA) hsmodDeprecMessage + let XModulePs {..} = hsmodExt + deprecSpan = maybe [] (pure . getLocA) hsmodDeprecMessage exportSpans = maybe [] (pure . getLocA) hsmodExports switchLayout (deprecSpan <> exportSpans) $ do forM_ mstackHeader $ \(L spn comment) -> do @@ -58,8 +58,8 @@ newline spitRemainingComments -p_hsModuleHeader :: HsModule -> LocatedA ModuleName -> R () -p_hsModuleHeader HsModule {..} moduleName = do +p_hsModuleHeader :: HsModule GhcPs -> LocatedA ModuleName -> R () +p_hsModuleHeader HsModule {hsmodExt = XModulePs {..}, ..} moduleName = do located moduleName $ \name -> do poHStyle <- getPrinterOpt poHaddockStyleModule >>= \case diff --git a/src/Ormolu/Printer/Meat/Pragma.hs b/src/Ormolu/Printer/Meat/Pragma.hs --- a/src/Ormolu/Printer/Meat/Pragma.hs +++ b/src/Ormolu/Printer/Meat/Pragma.hs @@ -9,11 +9,11 @@ import Control.Monad import Data.Char (isUpper) -import qualified Data.List as L +import Data.List qualified as L import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Driver.Flags (Language) import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -1,13 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -- | Rendering of types. module Ormolu.Printer.Meat.Type ( p_hsType, - p_hsTypePostDoc, startTypeAnnotation, startTypeAnnotationDecl, hasDocStrings, @@ -25,8 +23,8 @@ where import Control.Monad -import GHC.Hs -import GHC.Types.Basic hiding (isPromoted) +import Data.Functor ((<&>)) +import GHC.Hs hiding (isPromoted) import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var @@ -34,30 +32,17 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree) -import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit) +import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice, p_stringLit) import Ormolu.Printer.Operators import Ormolu.Utils p_hsType :: HsType GhcPs -> R () p_hsType t = do - s <- - getPrinterOpt poFunctionArrows >>= \case - TrailingArrows -> pure PipeStyle - LeadingArrows -> pure CaretStyle - LeadingArgsArrows -> pure CaretStyle layout <- getLayout - p_hsType' (hasDocStrings t || layout == MultiLine) s t - -p_hsTypePostDoc :: HsType GhcPs -> R () -p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t - --- | How to render Haddocks associated with a type. -data TypeDocStyle - = PipeStyle - | CaretStyle + p_hsType' (hasDocStrings t || layout == MultiLine) t -p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R () -p_hsType' multilineArgs docStyle = \case +p_hsType' :: Bool -> HsType GhcPs -> R () +p_hsType' multilineArgs = \case HsForAllTy _ tele t -> do vis <- case tele of @@ -150,13 +135,18 @@ HsKindSig _ t k -> sitcc $ do located t p_hsType inci $ startTypeAnnotation k p_hsType - HsSpliceTy _ splice -> p_hsSplice splice - HsDocTy _ t str -> - case docStyle of - PipeStyle -> do + HsSpliceTy _ splice -> p_hsUntypedSplice DollarSplice splice + HsDocTy _ t str -> do + usePipe <- + getPrinterOpt poFunctionArrows <&> \case + TrailingArrows -> True + LeadingArrows -> False + LeadingArgsArrows -> False + if usePipe + then do p_hsDoc Pipe True str located t p_hsType - CaretStyle -> do + else do located t p_hsType newline p_hsDoc Caret False str @@ -177,17 +167,17 @@ IsPromoted -> txt "'" NotPromoted -> return () brackets N $ do - -- If both this list itself and the first element is promoted, - -- we need to put a space in between or it fails to parse. + -- If this list is promoted and the first element starts with a single + -- quote, we need to put a space in between or it fails to parse. case (p, xs) of - (IsPromoted, L _ t : _) | isPromoted t -> space + (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space _ -> return () sep commaDel (sitcc . located' p_hsType) xs HsExplicitTupleTy _ xs -> do txt "'" parens N $ do case xs of - L _ t : _ | isPromoted t -> space + L _ t : _ | startsWithSingleQuote t -> space _ -> return () sep commaDel (located' p_hsType) xs HsTyLit _ t -> @@ -197,17 +187,18 @@ HsWildCardTy _ -> txt "_" XHsType t -> atom t where - isPromoted = \case - HsAppTy _ (L _ f) _ -> isPromoted f + startsWithSingleQuote = \case + HsAppTy _ (L _ f) _ -> startsWithSingleQuote f HsTyVar _ IsPromoted _ -> True HsExplicitTupleTy {} -> True HsExplicitListTy {} -> True + HsTyLit _ HsCharTy {} -> True _ -> False interArgBreak = if multilineArgs then newline else breakpoint - p_hsTypeR m = p_hsType' multilineArgs docStyle m + p_hsTypeR m = p_hsType' multilineArgs m startTypeAnnotation :: (HasSrcSpan l) => diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | This module helps handle operator chains composed of different -- operators that may have different precedence and fixities. @@ -13,8 +12,8 @@ where import Control.Applicative ((<|>)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import GHC.Types.Name.Reader import GHC.Types.SrcLoc diff --git a/src/Ormolu/Printer/SpanStream.hs b/src/Ormolu/Printer/SpanStream.hs --- a/src/Ormolu/Printer/SpanStream.hs +++ b/src/Ormolu/Printer/SpanStream.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- | Build span stream from AST. module Ormolu.Printer.SpanStream ( SpanStream (..), @@ -8,12 +5,13 @@ ) where -import Data.DList (DList) -import qualified Data.DList as D import Data.Data (Data) +import Data.Foldable (toList) import Data.Generics (everything, ext1Q, ext2Q) import Data.List (sortOn) import Data.Maybe (maybeToList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq import Data.Typeable (cast) import GHC.Parser.Annotation import GHC.Types.SrcLoc @@ -34,16 +32,16 @@ mkSpanStream a = SpanStream . sortOn realSrcSpanStart - . D.toList + . toList $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` querySrcSpanAnn) a where queryLocated :: (Data e0) => GenLocated e0 e1 -> - DList RealSrcSpan + Seq RealSrcSpan queryLocated (L mspn _) = - maybe mempty srcSpanToRealSrcSpanDList (cast mspn :: Maybe SrcSpan) - querySrcSpanAnn :: SrcSpanAnn' a -> DList RealSrcSpan - querySrcSpanAnn = srcSpanToRealSrcSpanDList . locA - srcSpanToRealSrcSpanDList = - D.fromList . maybeToList . srcSpanToRealSrcSpan + maybe mempty srcSpanToRealSrcSpanSeq (cast mspn :: Maybe SrcSpan) + querySrcSpanAnn :: SrcSpanAnn' a -> Seq RealSrcSpan + querySrcSpanAnn = srcSpanToRealSrcSpanSeq . locA + srcSpanToRealSrcSpanSeq = + Seq.fromList . maybeToList . srcSpanToRealSrcSpan diff --git a/src/Ormolu/Processing/Common.hs b/src/Ormolu/Processing/Common.hs --- a/src/Ormolu/Processing/Common.hs +++ b/src/Ormolu/Processing/Common.hs @@ -13,9 +13,9 @@ import Data.Char (isSpace) import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import Data.IntSet qualified as IntSet import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu.Config -- | Remove indentation from a given 'Text'. Return the input with indentation diff --git a/src/Ormolu/Processing/Cpp.hs b/src/Ormolu/Processing/Cpp.hs --- a/src/Ormolu/Processing/Cpp.hs +++ b/src/Ormolu/Processing/Cpp.hs @@ -7,10 +7,10 @@ where import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import Data.IntSet qualified as IntSet import Data.Maybe (isJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T -- | State of the CPP processor. data State diff --git a/src/Ormolu/Processing/Preprocess.hs b/src/Ormolu/Processing/Preprocess.hs --- a/src/Ormolu/Processing/Preprocess.hs +++ b/src/Ormolu/Processing/Preprocess.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -15,13 +14,13 @@ import Data.Char (isSpace) import Data.Function ((&)) import Data.IntMap (IntMap) -import qualified Data.IntMap.Strict as IntMap +import Data.IntMap.Strict qualified as IntMap import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import qualified Data.List as L +import Data.IntSet qualified as IntSet +import Data.List qualified as L import Data.Maybe (isJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu.Config (RegionDeltas (..)) import Ormolu.Processing.Common import Ormolu.Processing.Cpp diff --git a/src/Ormolu/Terminal.hs b/src/Ormolu/Terminal.hs --- a/src/Ormolu/Terminal.hs +++ b/src/Ormolu/Terminal.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -- | An abstraction for colorful output in terminal. module Ormolu.Terminal - ( -- * The 'Term' monad + ( -- * The 'Term' abstraction Term, ColorMode (..), runTerm, + runTermPure, -- * Styling bold, @@ -17,114 +17,114 @@ -- * Printing put, - putS, - putSrcSpan, - putRealSrcSpan, + putShow, + putOutputable, newline, ) where -import Control.Monad.Reader +import Control.Applicative (Const (..)) +import Control.Monad (forM_) +import Data.Foldable (toList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq import Data.Text (Text) -import qualified Data.Text.IO as T -import GHC.Types.SrcLoc +import Data.Text qualified as T +import Data.Text.IO qualified as T +import GHC.Utils.Outputable (Outputable) import Ormolu.Utils (showOutputable) import System.Console.ANSI -import System.IO (Handle, hFlush, hPutStr) +import System.IO (Handle, hFlush) ---------------------------------------------------------------------------- --- The 'Term' monad +-- The 'Term' abstraction --- | Terminal monad. -newtype Term a = Term (ReaderT RC IO a) - deriving (Functor, Applicative, Monad) +type Term = TermOutput () --- | Reader context of 'Term'. -data RC = RC - { -- | Whether to use colors - rcUseColor :: Bool, - -- | Handle to print to - rcHandle :: Handle - } +newtype TermOutput a = TermOutput (Const (Seq TermOutputNode) a) + deriving (Semigroup, Monoid, Functor, Applicative) +data TermOutputNode + = OutputText Text + | WithColor Color Term + | WithBold Term + +singleTerm :: TermOutputNode -> Term +singleTerm = TermOutput . Const . Seq.singleton + -- | Whether to use colors and other features of ANSI terminals. data ColorMode = Never | Always | Auto deriving (Eq, Show, Enum, Bounded) -- | Run 'Term' monad. runTerm :: - -- | Monad to run - Term a -> + Term -> -- | Color mode ColorMode -> -- | Handle to print to Handle -> - IO a -runTerm (Term m) colorMode rcHandle = do - rcUseColor <- case colorMode of + IO () +runTerm term0 colorMode handle = do + useSGR <- case colorMode of Never -> return False Always -> return True - Auto -> hSupportsANSI rcHandle - x <- runReaderT m RC {..} - hFlush rcHandle - return x + Auto -> hSupportsANSI handle + runTerm' useSGR term0 + hFlush handle + where + runTerm' useSGR = go + where + go (TermOutput (Const nodes)) = + forM_ nodes $ \case + OutputText s -> T.hPutStr handle s + WithColor color term -> withSGR [SetColor Foreground Dull color] (go term) + WithBold term -> withSGR [SetConsoleIntensity BoldIntensity] (go term) + withSGR sgrs m + | useSGR = hSetSGR handle sgrs >> m >> hSetSGR handle [Reset] + | otherwise = m + +runTermPure :: Term -> Text +runTermPure (TermOutput (Const nodes)) = + T.concat . toList . flip fmap nodes $ \case + OutputText s -> s + WithColor _ term -> runTermPure term + WithBold term -> runTermPure term + ---------------------------------------------------------------------------- -- Styling --- | Make the inner computation output bold text. -bold :: Term a -> Term a -bold = withSGR [SetConsoleIntensity BoldIntensity] - --- | Make the inner computation output cyan text. -cyan :: Term a -> Term a -cyan = withSGR [SetColor Foreground Dull Cyan] +-- | Make the output bold text. +bold :: Term -> Term +bold = singleTerm . WithBold --- | Make the inner computation output green text. -green :: Term a -> Term a -green = withSGR [SetColor Foreground Dull Green] +-- | Make the output cyan text. +cyan :: Term -> Term +cyan = singleTerm . WithColor Cyan --- | Make the inner computation output red text. -red :: Term a -> Term a -red = withSGR [SetColor Foreground Dull Red] +-- | Make the output green text. +green :: Term -> Term +green = singleTerm . WithColor Green --- | Alter 'SGR' for inner computation. -withSGR :: [SGR] -> Term a -> Term a -withSGR sgrs (Term m) = Term $ do - RC {..} <- ask - if rcUseColor - then do - liftIO $ hSetSGR rcHandle sgrs - x <- m - liftIO $ hSetSGR rcHandle [Reset] - return x - else m +-- | Make the output red text. +red :: Term -> Term +red = singleTerm . WithColor Red ---------------------------------------------------------------------------- -- Printing -- | Output 'Text'. -put :: Text -> Term () -put txt = Term $ do - RC {..} <- ask - liftIO $ T.hPutStr rcHandle txt - --- | Output 'String'. -putS :: String -> Term () -putS str = Term $ do - RC {..} <- ask - liftIO $ hPutStr rcHandle str +put :: Text -> Term +put = singleTerm . OutputText --- | Output a 'GHC.SrcSpan'. -putSrcSpan :: SrcSpan -> Term () -putSrcSpan = putS . showOutputable +-- | Output a 'Show' value. +putShow :: (Show a) => a -> Term +putShow = put . T.pack . show --- | Output a 'GHC.RealSrcSpan'. -putRealSrcSpan :: RealSrcSpan -> Term () -putRealSrcSpan = putS . showOutputable +-- | Output an 'Outputable' value. +putOutputable :: (Outputable a) => a -> Term +putOutputable = put . T.pack . showOutputable -- | Output a newline. -newline :: Term () -newline = Term $ do - RC {..} <- ask - liftIO $ T.hPutStr rcHandle "\n" +newline :: Term +newline = put "\n" diff --git a/src/Ormolu/Terminal/QualifiedDo.hs b/src/Ormolu/Terminal/QualifiedDo.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Terminal/QualifiedDo.hs @@ -0,0 +1,7 @@ +module Ormolu.Terminal.QualifiedDo ((>>)) where + +import Ormolu.Terminal +import Prelude hiding ((>>)) + +(>>) :: Term -> Term -> Term +(>>) = (<>) diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -1,7 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -- | Random utilities used by the code. module Ormolu.Utils @@ -25,13 +23,13 @@ import Data.List (dropWhileEnd) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Foreign as TFFI +import Data.Text qualified as T +import Data.Text.Foreign qualified as TFFI import Foreign (pokeElemOff, withForeignPtr) -import qualified GHC.Data.Strict as Strict +import GHC.Data.Strict qualified as Strict import GHC.Data.StringBuffer (StringBuffer (..)) import GHC.Driver.Ppr import GHC.DynFlags (baseDynFlags) @@ -39,7 +37,7 @@ import GHC.Hs import GHC.IO.Unsafe (unsafePerformIO) import GHC.Types.SrcLoc -import GHC.Utils.Outputable +import GHC.Utils.Outputable (Outputable (..)) -- | Relative positions in a list. data RelativePos diff --git a/src/Ormolu/Utils/Cabal.hs b/src/Ormolu/Utils/Cabal.hs --- a/src/Ormolu/Utils/Cabal.hs +++ b/src/Ormolu/Utils/Cabal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Utils.Cabal @@ -15,17 +14,17 @@ import Control.Exception import Control.Monad.IO.Class -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.IORef import Data.Map.Lazy (Map) -import qualified Data.Map.Lazy as M +import Data.Map.Lazy qualified as M import Data.Maybe (maybeToList) import Data.Set (Set) -import qualified Data.Set as Set -import qualified Distribution.ModuleName as ModuleName +import Data.Set qualified as Set +import Distribution.ModuleName qualified as ModuleName import Distribution.PackageDescription import Distribution.PackageDescription.Parsec -import qualified Distribution.Types.CondTree as CT +import Distribution.Types.CondTree qualified as CT import Distribution.Utils.Path (getSymbolicPath) import Language.Haskell.Extension import Ormolu.Config @@ -141,8 +140,8 @@ CachedCabalFile {..} <- whenNothing (M.lookup cabalFile cabalCache) $ do cabalFileBs <- B.readFile cabalFile genericPackageDescription <- - whenNothing (parseGenericPackageDescriptionMaybe cabalFileBs) $ - throwIO (OrmoluCabalFileParsingFailed cabalFile) + whenLeft (snd . runParseResult $ parseGenericPackageDescription cabalFileBs) $ + throwIO . OrmoluCabalFileParsingFailed cabalFile . snd let extensionsAndDeps = getExtensionAndDepsMap cabalFile genericPackageDescription cachedCabalFile = CachedCabalFile {..} @@ -163,8 +162,10 @@ } ) where - whenNothing :: (Monad m) => Maybe a -> m a -> m a + whenNothing :: (Applicative f) => Maybe a -> f a -> f a whenNothing maya ma = maybe ma pure maya + whenLeft :: (Applicative f) => Either e a -> (e -> f a) -> f a + whenLeft eitha ma = either ma pure eitha -- | Get a map from Haskell source file paths (without any extensions) to -- the corresponding 'DynOption's and dependencies. diff --git a/src/Ormolu/Utils/Fixity.hs b/src/Ormolu/Utils/Fixity.hs --- a/src/Ormolu/Utils/Fixity.hs +++ b/src/Ormolu/Utils/Fixity.hs @@ -11,8 +11,8 @@ import Data.Bifunctor (first) import Data.IORef import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T +import Data.Map.Strict qualified as Map +import Data.Text qualified as T import Ormolu.Exception import Ormolu.Fixity import Ormolu.Fixity.Parser diff --git a/src/Ormolu/Utils/IO.hs b/src/Ormolu/Utils/IO.hs --- a/src/Ormolu/Utils/IO.hs +++ b/src/Ormolu/Utils/IO.hs @@ -10,9 +10,9 @@ import Control.Exception (throwIO) import Control.Monad.IO.Class import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.Text (Text) -import qualified Data.Text.Encoding as TE +import Data.Text.Encoding qualified as TE -- | Write a 'Text' to a file using UTF8 and ignoring native -- line ending conventions. diff --git a/tests/Ormolu/CabalInfoSpec.hs b/tests/Ormolu/CabalInfoSpec.hs --- a/tests/Ormolu/CabalInfoSpec.hs +++ b/tests/Ormolu/CabalInfoSpec.hs @@ -2,7 +2,7 @@ module Ormolu.CabalInfoSpec (spec) where -import qualified Data.Set as Set +import Data.Set qualified as Set import Distribution.Types.PackageName (unPackageName) import Ormolu.Config (DynOption (..)) import Ormolu.Utils.Cabal @@ -35,15 +35,15 @@ (mentioned, CabalInfo {..}) <- parseCabalInfo "fourmolu.cabal" "src/Ormolu/Config.hs" mentioned `shouldBe` True unPackageName ciPackageName `shouldBe` "fourmolu" - ciDynOpts `shouldBe` [DynOption "-XHaskell2010"] - Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "binary", "bytestring", "containers", "directory", "dlist", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "text", "yaml"] + ciDynOpts `shouldBe` [DynOption "-XGHC2021"] + Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "binary", "bytestring", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "scientific", "syb", "text", "yaml"] ciCabalFilePath `shouldSatisfy` isAbsolute makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "fourmolu.cabal" it "extracts correct cabal info from fourmolu.cabal for tests/Ormolu/PrinterSpec.hs" $ do (mentioned, CabalInfo {..}) <- parseCabalInfo "fourmolu.cabal" "tests/Ormolu/PrinterSpec.hs" mentioned `shouldBe` True unPackageName ciPackageName `shouldBe` "fourmolu" - ciDynOpts `shouldBe` [DynOption "-XHaskell2010"] + ciDynOpts `shouldBe` [DynOption "-XGHC2021"] Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "QuickCheck", "base", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "fourmolu", "path", "path-io", "pretty", "process", "temporary", "text"] ciCabalFilePath `shouldSatisfy` isAbsolute makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "fourmolu.cabal" diff --git a/tests/Ormolu/Config/OptionsSpec.hs b/tests/Ormolu/Config/OptionsSpec.hs --- a/tests/Ormolu/Config/OptionsSpec.hs +++ b/tests/Ormolu/Config/OptionsSpec.hs @@ -1,5 +1,6 @@ module Ormolu.Config.OptionsSpec (spec) where +import Data.List (isPrefixOf) import IntegrationUtils (getFourmoluExe, readProcess) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) @@ -44,6 +45,11 @@ withCLI <- readProcess fourmoluExe ["--indentation=4", hsFile] withCLI `shouldBe` indented4 + + it "prints defaults to stdout" $ \fourmoluExe -> do + stdOutput <- readProcess fourmoluExe ["--print-defaults"] + -- Only check prefix of the output, so we don't have to update the test with every new option added + stdOutput `shouldSatisfy` isPrefixOf "# Number of spaces per indentation step\nindentation: 4\n" where withTempDir = withSystemTempDirectory "fourmolu-cli-options-test" indented2 = diff --git a/tests/Ormolu/Config/PrinterOptsSpec.hs b/tests/Ormolu/Config/PrinterOptsSpec.hs --- a/tests/Ormolu/Config/PrinterOptsSpec.hs +++ b/tests/Ormolu/Config/PrinterOptsSpec.hs @@ -14,10 +14,10 @@ import Control.Monad (forM_, when) import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff) import Data.Char (isSpace) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Stack (withFrozenCallStack) import Ormolu ( Config (..), @@ -28,7 +28,7 @@ detectSourceType, ormolu, ) -import Ormolu.Config (HaddockPrintStyleModule (..)) +import Ormolu.Config (ColumnLimit (..), HaddockPrintStyleModule (..)) import Ormolu.Exception (OrmoluException, printOrmoluException) import Ormolu.Terminal (ColorMode (..), runTerm) import Ormolu.Utils.IO (readFileUtf8, writeFileUtf8) @@ -48,7 +48,7 @@ import System.IO.Temp (withSystemTempFile) import System.IO.Unsafe (unsafePerformIO) import Test.Hspec -import qualified Text.PrettyPrint as Doc +import Text.PrettyPrint qualified as Doc import Text.Printf (printf) data TestGroup = forall a. @@ -57,7 +57,8 @@ testCases :: [a], updateConfig :: a -> PrinterOptsTotal -> PrinterOptsTotal, showTestCase :: a -> String, - testCaseSuffix :: a -> String + testCaseSuffix :: a -> String, + checkIdempotence :: Bool } spec :: Spec @@ -84,22 +85,38 @@ showTestCase = \(indent, indentWheres) -> show indent ++ if indentWheres then " + indent wheres" else "", testCaseSuffix = \(indent, indentWheres) -> - suffixWith [show indent, if indentWheres then "indent_wheres" else ""] + suffixWith [show indent, if indentWheres then "indent_wheres" else ""], + checkIdempotence = True }, TestGroup + { label = "column-limit", + testCases = [NoLimit, ColumnLimit 80, ColumnLimit 100], + updateConfig = \columnLimit opts -> opts {poColumnLimit = pure columnLimit}, + showTestCase = show, + testCaseSuffix = \columnLimit -> + let limitStr = + case columnLimit of + NoLimit -> "none" + ColumnLimit x -> show x + in suffixWith ["limit=" ++ limitStr], + checkIdempotence = False + }, + TestGroup { label = "function-arrows", testCases = allOptions, updateConfig = \functionArrows opts -> opts {poFunctionArrows = pure functionArrows}, showTestCase = show, - testCaseSuffix = suffix1 + testCaseSuffix = suffix1, + checkIdempotence = True }, TestGroup { label = "comma-style", testCases = allOptions, updateConfig = \commaStyle opts -> opts {poCommaStyle = pure commaStyle}, showTestCase = show, - testCaseSuffix = suffix1 + testCaseSuffix = suffix1, + checkIdempotence = True }, TestGroup { label = "import-export", @@ -107,14 +124,16 @@ updateConfig = \commaStyle opts -> opts {poImportExportStyle = pure commaStyle}, showTestCase = show, - testCaseSuffix = suffix1 + testCaseSuffix = suffix1, + checkIdempotence = True }, TestGroup { label = "record-brace-space", testCases = allOptions, updateConfig = \recordBraceSpace opts -> opts {poRecordBraceSpace = pure recordBraceSpace}, showTestCase = show, - testCaseSuffix = suffix1 + testCaseSuffix = suffix1, + checkIdempotence = True }, TestGroup { label = "newlines-between-decls", @@ -127,7 +146,8 @@ showTestCase = \(newlines, respectful) -> show newlines ++ if respectful then " (respectful)" else "", testCaseSuffix = \(newlines, respectful) -> - suffixWith [show newlines, if respectful then "respectful" else ""] + suffixWith [show newlines, if respectful then "respectful" else ""], + checkIdempotence = True }, TestGroup { label = "haddock-style", @@ -148,7 +168,8 @@ case haddockStyleModule of PrintStyleInherit -> "" PrintStyleOverride style -> "module=" ++ show style - ] + ], + checkIdempotence = True }, TestGroup { label = "let-style", @@ -162,21 +183,32 @@ showTestCase = \(letStyle, inStyle, indent) -> printf "%s + %s (indent=%d)" (show letStyle) (show inStyle) indent, testCaseSuffix = \(letStyle, inStyle, indent) -> - suffixWith [show letStyle, show inStyle, "indent=" ++ show indent] + suffixWith [show letStyle, show inStyle, "indent=" ++ show indent], + checkIdempotence = True }, TestGroup + { label = "single-constraint-parens", + testCases = allOptions, + updateConfig = \parens opts -> opts {poSingleConstraintParens = pure parens}, + showTestCase = show, + testCaseSuffix = suffix1, + checkIdempotence = True + }, + TestGroup { label = "unicode-syntax", testCases = allOptions, updateConfig = \unicodePreference options -> options {poUnicode = pure unicodePreference}, showTestCase = show, - testCaseSuffix = suffix1 + testCaseSuffix = suffix1, + checkIdempotence = True }, TestGroup { label = "respectful", testCases = allOptions, updateConfig = \respectful opts -> opts {poRespectful = pure respectful}, showTestCase = show, - testCaseSuffix = suffix1 + testCaseSuffix = suffix1, + checkIdempotence = True } ] @@ -198,7 +230,8 @@ showTestCase = \(respectful, importExportStyle) -> (if respectful then "respectful" else "not respectful") ++ " + " ++ show importExportStyle, testCaseSuffix = \(respectful, importExportStyle) -> - suffixWith ["respectful=" ++ show respectful, show importExportStyle] + suffixWith ["respectful=" ++ show respectful, show importExportStyle], + checkIdempotence = True } ] @@ -215,8 +248,8 @@ input <- readFileUtf8 inputPath actual <- if isMulti - then overSectionsM (T.pack "{- // -}") (runOrmolu opts inputPath) input - else runOrmolu opts inputPath input + then overSectionsM (T.pack "{- // -}") (runOrmolu opts checkIdempotence inputPath) input + else runOrmolu opts checkIdempotence inputPath input checkResult outputFile actual where testDir = toRelDir $ "data/fourmolu/" ++ label @@ -229,8 +262,8 @@ Just path -> path Nothing -> error $ "Not a valid file name: " ++ show name -runOrmolu :: PrinterOptsTotal -> FilePath -> Text -> IO Text -runOrmolu opts inputPath input = +runOrmolu :: PrinterOptsTotal -> Bool -> FilePath -> Text -> IO Text +runOrmolu opts checkIdempotence inputPath input = ormolu config inputPath input `catch` \e -> do msg <- renderOrmoluException e expectationFailure' $ unlines ["Got ormolu exception:", "", msg] @@ -239,7 +272,7 @@ defaultConfig { cfgPrinterOpts = opts, cfgSourceType = detectSourceType inputPath, - cfgCheckIdempotence = True + cfgCheckIdempotence = checkIdempotence } checkResult :: Path Rel File -> Text -> Expectation diff --git a/tests/Ormolu/Diff/TextSpec.hs b/tests/Ormolu/Diff/TextSpec.hs --- a/tests/Ormolu/Diff/TextSpec.hs +++ b/tests/Ormolu/Diff/TextSpec.hs @@ -2,14 +2,11 @@ module Ormolu.Diff.TextSpec (spec) where -import Data.Text (Text) import Ormolu.Diff.Text import Ormolu.Terminal import Ormolu.Utils.IO import Path -import Path.IO -import qualified System.FilePath as FP -import System.IO (hClose) +import System.FilePath qualified as FP import Test.Hspec spec :: Spec @@ -48,16 +45,7 @@ parseRelFile expectedDiffPath >>= readFileUtf8 . toFilePath . (diffOutputsDir ) Just actualDiff <- pure $ diffText inputA inputB "TEST" - actualDiffText <- printDiff actualDiff - actualDiffText `shouldBe` expectedDiffText - --- | Print to a 'Text' value. -printDiff :: TextDiff -> IO Text -printDiff diff = - withSystemTempFile "ormolu-diff-test" $ \path h -> do - runTerm (printTextDiff diff) Never h - hClose h - readFileUtf8 (toFilePath path) + runTermPure (printTextDiff actualDiff) `shouldBe` expectedDiffText diffTestsDir :: Path Rel Dir diffTestsDir = $(mkRelDir "data/diff-tests") diff --git a/tests/Ormolu/Fixity/ParserSpec.hs b/tests/Ormolu/Fixity/ParserSpec.hs --- a/tests/Ormolu/Fixity/ParserSpec.hs +++ b/tests/Ormolu/Fixity/ParserSpec.hs @@ -2,9 +2,9 @@ module Ormolu.Fixity.ParserSpec (spec) where -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu.Fixity import Ormolu.Fixity.Parser import Test.Hspec diff --git a/tests/Ormolu/Fixity/PrinterSpec.hs b/tests/Ormolu/Fixity/PrinterSpec.hs --- a/tests/Ormolu/Fixity/PrinterSpec.hs +++ b/tests/Ormolu/Fixity/PrinterSpec.hs @@ -2,9 +2,9 @@ module Ormolu.Fixity.PrinterSpec (spec) where -import qualified Data.Char as Char -import qualified Data.Map.Strict as Map -import qualified Data.Text as T +import Data.Char qualified as Char +import Data.Map.Strict qualified as Map +import Data.Text qualified as T import Ormolu.Fixity import Ormolu.Fixity.Parser import Ormolu.Fixity.Printer diff --git a/tests/Ormolu/HackageInfoSpec.hs b/tests/Ormolu/HackageInfoSpec.hs --- a/tests/Ormolu/HackageInfoSpec.hs +++ b/tests/Ormolu/HackageInfoSpec.hs @@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} module Ormolu.HackageInfoSpec (spec) where -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) -import qualified Data.Set as Set +import Data.Set qualified as Set import Distribution.Types.PackageName (PackageName) import Ormolu.Fixity import Test.Hspec diff --git a/tests/Ormolu/OpTreeSpec.hs b/tests/Ormolu/OpTreeSpec.hs --- a/tests/Ormolu/OpTreeSpec.hs +++ b/tests/Ormolu/OpTreeSpec.hs @@ -2,10 +2,10 @@ module Ormolu.OpTreeSpec (spec) where -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Types.Name (mkOccName, varName) import GHC.Types.Name.Reader (mkRdrUnqual) import Ormolu.Fixity diff --git a/tests/Ormolu/Parser/OptionsSpec.hs b/tests/Ormolu/Parser/OptionsSpec.hs --- a/tests/Ormolu/Parser/OptionsSpec.hs +++ b/tests/Ormolu/Parser/OptionsSpec.hs @@ -3,7 +3,7 @@ module Ormolu.Parser.OptionsSpec (spec) where -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu import Test.Hspec diff --git a/tests/Ormolu/Parser/PragmaSpec.hs b/tests/Ormolu/Parser/PragmaSpec.hs --- a/tests/Ormolu/Parser/PragmaSpec.hs +++ b/tests/Ormolu/Parser/PragmaSpec.hs @@ -3,7 +3,7 @@ module Ormolu.Parser.PragmaSpec (spec) where import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu.Parser.Pragma import Test.Hspec diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -7,11 +7,11 @@ import Control.Exception import Control.Monad import Data.List (isSuffixOf) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Maybe (isJust) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T import Ormolu import Ormolu.Config import Ormolu.Fixity @@ -19,7 +19,7 @@ import Path import Path.IO import System.Environment (lookupEnv) -import qualified System.FilePath as F +import System.FilePath qualified as F import Test.Hspec spec :: Spec