diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,22 @@ +## Fourmolu 0.17.0.0 + +* Add new `import-grouping` option to group imports with grouping rules specified in configuration ([#403](https://github.com/fourmolu/fourmolu/pull/403)) + +* Add new `sort-constraints` option to sort constraints alphabetically ([#433](https://github.com/fourmolu/fourmolu/pull/433)) + +* Add new `sort-derived-classes` option to sort classes in deriving clauses ([#434](https://github.com/fourmolu/fourmolu/pull/434)) + +* Add new `sort-derived-clauses` option to sort classes deriving clauses ([#434](https://github.com/fourmolu/fourmolu/pull/434)) + +* Add new `trailing-section-operators` option to disable trailing "section" operators (those that are `infixr 0`, such as `$`) ([#444](https://github.com/fourmolu/fourmolu/pull/444)) + +* Fix issue where `single-constraint-parens: never` would drop parentheses around implicit parameters ([#446](https://github.com/fourmolu/fourmolu/issues/446)) + +* Fix indentation for parenthesized expressions that start off the indentation column ([#428](https://github.com/fourmolu/fourmolu/issues/428)) + +* Allow multiline comments in indented contexts ([#65](https://github.com/fourmolu/fourmolu/issues/65)) + + ## Fourmolu 0.16.2.0 ### Upstream changes: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,6 +18,7 @@ * [Troubleshooting](#troubleshooting) * [Operators are being formatted weirdly!](#operators-are-being-formatted-weirdly) * [Limitations](#limitations) +* [Breaking changes policy](#breaking-changes-policy) * [Contributing](#contributing) * [License](#license) @@ -244,7 +245,7 @@ * If this is a custom operator, see the instructions in the [Language extensions, dependencies, and fixities](#language-extensions-dependencies-and-fixities) section to - specify the correct fixities in a `.ormolu` file. + specify the correct fixities in a `fourmolu.yaml` file. * If this is a third-party operator (e.g. from `base` or some other package from Hackage), Ormolu probably doesn't recognize that the operator is the @@ -256,7 +257,7 @@ * You might have `-XNoImplicitPrelude` turned on If any of these are true, make sure to specify the reexports correctly in - a `.ormolu` file. + a `fourmolu.yaml` file. You can see how Ormolu decides the fixity of operators if you use `--debug`. @@ -268,7 +269,18 @@ declarations. See the [CPP](https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp) section in the design notes for a discussion of the dangers. * 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`. + +## Breaking changes policy + +Fourmolu is still in a relatively early stage of development, but it is in wide enough use that stability is a desirable property. Fourmolu aims to uphold the following principles: + +1. It will always be possible to replicate Ormolu's formatting with a suitable `fourmolu.yaml` + +1. Breaking changes will be avoided where possible, but may still occur in the following circumstances: + + * Fourmolu inherits a breaking change from Ormolu + * The change reverts a prior breaking change, which caused a regression + * Other exceptional situations, on a case-by-case basis ## Contributing diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -474,6 +474,12 @@ ] ) <*> pure defaultPrinterOpts -- unused; overwritten in resolveConfig + <*> (fmap Set.fromList . many . strOption . mconcat) + [ long "local-modules", + short 'm', + metavar "LOCAL_MODULES", + help "Modules Fourmolu should consider as local by the current Cabal package" + ] sourceTypeParser :: Parser (Maybe SourceType) sourceTypeParser = diff --git a/data/examples/declaration/data/infix-haddocks-four-out.hs b/data/examples/declaration/data/infix-haddocks-four-out.hs --- a/data/examples/declaration/data/infix-haddocks-four-out.hs +++ b/data/examples/declaration/data/infix-haddocks-four-out.hs @@ -23,9 +23,10 @@ right data DocPartial - = Left -- ^ left docs - -- on multiple - -- lines + = Left {- ^ left docs + on multiple + lines + -} :*: Right | -- | op diff --git a/data/examples/declaration/data/operators-four-out.hs b/data/examples/declaration/data/operators-four-out.hs --- a/data/examples/declaration/data/operators-four-out.hs +++ b/data/examples/declaration/data/operators-four-out.hs @@ -1,12 +1,15 @@ data ErrorMessage' s = -- | Show the text as is. Text s - | -- | Pretty print the type. - -- @ShowType :: k -> ErrorMessage@ + | {- | Pretty print the type. + @ShowType :: k -> ErrorMessage@ + -} forall t. ShowType t - | -- | Put two pieces of error message next - -- to each other. + | {- | Put two pieces of error message next + to each other. + -} ErrorMessage' s :<>: ErrorMessage' s - | -- | Stack two pieces of error message on top - -- of each other. + | {- | Stack two pieces of error message on top + of each other. + -} ErrorMessage' s :$$: ErrorMessage' s diff --git a/data/examples/declaration/data/single-constructor-with-haddock-four-out.hs b/data/examples/declaration/data/single-constructor-with-haddock-four-out.hs --- a/data/examples/declaration/data/single-constructor-with-haddock-four-out.hs +++ b/data/examples/declaration/data/single-constructor-with-haddock-four-out.hs @@ -1,6 +1,7 @@ data FutureSumType - = -- | This is what the documentation for this type looks like. - -- It is pretty awkward that the @--@s aren't aligned. + = {- | This is what the documentation for this type looks like. + It is pretty awkward that the @--@s aren't aligned. + -} SingleConstructor { someRecordField :: Bool , someOtherRecordField :: Int diff --git a/data/examples/declaration/splice/bracket-declaration-out.hs b/data/examples/declaration/splice/bracket-declaration-out.hs --- a/data/examples/declaration/splice/bracket-declaration-out.hs +++ b/data/examples/declaration/splice/bracket-declaration-out.hs @@ -19,10 +19,10 @@ $(singletons [d|data T = T deriving (Eq, Ord, Enum, Bounded, Show)|]) $( singletons - [d| - data T = T - deriving (Eq, Ord, Enum, Bounded, Show) - |] + [d| + data T = T + deriving (Eq, Ord, Enum, Bounded, Show) + |] ) foo = [d| type X = * |] diff --git a/data/examples/declaration/splice/untyped-splice-out.hs b/data/examples/declaration/splice/untyped-splice-out.hs --- a/data/examples/declaration/splice/untyped-splice-out.hs +++ b/data/examples/declaration/splice/untyped-splice-out.hs @@ -4,7 +4,7 @@ x = $( foo - bar + bar ) x = $foo diff --git a/data/examples/declaration/value/function/infix/esqueleto-1-out.hs b/data/examples/declaration/value/function/infix/esqueleto-1-out.hs --- a/data/examples/declaration/value/function/infix/esqueleto-1-out.hs +++ b/data/examples/declaration/value/function/infix/esqueleto-1-out.hs @@ -5,5 +5,5 @@ E.table `E.innerJoin` E.table `E.on` ( \(a :& b) -> - a E.^. AField E.==. b E.^. BField + a E.^. AField E.==. b E.^. BField ) diff --git a/data/examples/declaration/value/function/let-multi-line-out.hs b/data/examples/declaration/value/function/let-multi-line-out.hs --- a/data/examples/declaration/value/function/let-multi-line-out.hs +++ b/data/examples/declaration/value/function/let-multi-line-out.hs @@ -14,7 +14,7 @@ inlineComment :: Int -> Int inlineComment = let {- join -} go = case () of - () -> undefined + () -> undefined in go implicitParams :: (HasCallStack) => Int diff --git a/data/examples/declaration/value/function/operators-6-out.hs b/data/examples/declaration/value/function/operators-6-out.hs --- a/data/examples/declaration/value/function/operators-6-out.hs +++ b/data/examples/declaration/value/function/operators-6-out.hs @@ -3,9 +3,9 @@ type PermuteRef = "a" :> ( "b" :> "c" :> End - :<|> "c" :> "b" :> End + :<|> "c" :> "b" :> End ) :<|> "b" :> ( "a" :> "c" :> End - :<|> "c" :> "a" :> End + :<|> "c" :> "a" :> End ) diff --git a/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs b/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs --- a/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs +++ b/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs @@ -4,5 +4,5 @@ :<|> restartNodeR ) :<|> ( getUtxoR - :<|> getConfirmedProposalsR - ) = client nodeV1Api + :<|> getConfirmedProposalsR + ) = client nodeV1Api diff --git a/data/examples/declaration/value/function/pattern/splice-pattern-out.hs b/data/examples/declaration/value/function/pattern/splice-pattern-out.hs --- a/data/examples/declaration/value/function/pattern/splice-pattern-out.hs +++ b/data/examples/declaration/value/function/pattern/splice-pattern-out.hs @@ -6,8 +6,8 @@ multiline = case () of $( x - + y + + y ) -> () $( y - "something" + "something" ) -> () diff --git a/data/examples/declaration/value/function/required-type-arguments-out.hs b/data/examples/declaration/value/function/required-type-arguments-out.hs --- a/data/examples/declaration/value/function/required-type-arguments-out.hs +++ b/data/examples/declaration/value/function/required-type-arguments-out.hs @@ -16,6 +16,6 @@ foo = f ( type ( Maybe - Int + Int ) ) diff --git a/data/examples/fourmolu/multiline-haddocks-four-out.hs b/data/examples/fourmolu/multiline-haddocks-four-out.hs --- a/data/examples/fourmolu/multiline-haddocks-four-out.hs +++ b/data/examples/fourmolu/multiline-haddocks-four-out.hs @@ -1,12 +1,14 @@ -- https://github.com/fourmolu/fourmolu/pull/64 module Foo ( - -- | Multiline comment - -- in header + {- | Multiline comment + in header + -} foo, ) where class Foo a where - -- | Multiline haddock - -- in class + {- | Multiline haddock + in class + -} multiline :: a diff --git a/data/examples/import/docstrings-after-exports-four-out.hs b/data/examples/import/docstrings-after-exports-four-out.hs --- a/data/examples/import/docstrings-after-exports-four-out.hs +++ b/data/examples/import/docstrings-after-exports-four-out.hs @@ -5,7 +5,8 @@ SinceType (..), -- ^ @since 4.0 SinceClass (..), -- ^ @since 5.0 Multi (..), - -- ^ since 6.0 - -- multi - -- line + {- ^ since 6.0 + multi + line + -} ) where diff --git a/data/fourmolu/import-export/output-ImportExportDiffFriendly.hs b/data/fourmolu/import-export/output-ImportExportDiffFriendly.hs --- a/data/fourmolu/import-export/output-ImportExportDiffFriendly.hs +++ b/data/fourmolu/import-export/output-ImportExportDiffFriendly.hs @@ -3,8 +3,9 @@ -- * Something bar, - -- | A multiline - -- comment here + {- | A multiline + comment here + -} baz, -- * Another thing @@ -61,7 +62,8 @@ SinceType (..), -- ^ @since 4.0 SinceClass (..), -- ^ @since 5.0 Multi (..), - -- ^ since 6.0 - -- multi - -- line + {- ^ since 6.0 + multi + line + -} ) where diff --git a/data/fourmolu/import-export/output-ImportExportLeading.hs b/data/fourmolu/import-export/output-ImportExportLeading.hs --- a/data/fourmolu/import-export/output-ImportExportLeading.hs +++ b/data/fourmolu/import-export/output-ImportExportLeading.hs @@ -3,8 +3,9 @@ -- * Something , bar - -- | A multiline - -- comment here + {- | A multiline + comment here + -} , baz -- * Another thing @@ -61,7 +62,8 @@ , SinceType (..) -- ^ @since 4.0 , SinceClass (..) -- ^ @since 5.0 , Multi (..) - -- ^ since 6.0 - -- multi - -- line + {- ^ since 6.0 + multi + line + -} ) where diff --git a/data/fourmolu/import-export/output-ImportExportTrailing.hs b/data/fourmolu/import-export/output-ImportExportTrailing.hs --- a/data/fourmolu/import-export/output-ImportExportTrailing.hs +++ b/data/fourmolu/import-export/output-ImportExportTrailing.hs @@ -3,8 +3,9 @@ -- * Something bar, - -- | A multiline - -- comment here + {- | A multiline + comment here + -} baz, -- * Another thing @@ -61,7 +62,8 @@ SinceType (..), -- ^ @since 4.0 SinceClass (..), -- ^ @since 5.0 Multi (..), - -- ^ since 6.0 - -- multi - -- line + {- ^ since 6.0 + multi + line + -} ) where diff --git a/data/fourmolu/import-grouping/input.hs b/data/fourmolu/import-grouping/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/input.hs @@ -0,0 +1,13 @@ +module Main where + +import Data.Text (Text) +import Data.Maybe (maybe) + +import qualified Data.Text +import Control.Monad (Monad (..)) + +import qualified System.IO as SIO +import SomeInternal.Module1 (anotherDefinition, someDefinition) +import qualified SomeInternal.Module2 as Mod2 +import Text.Printf (printf) +import qualified SomeModule diff --git a/data/fourmolu/import-grouping/output-ImportGroupByQualified.hs b/data/fourmolu/import-grouping/output-ImportGroupByQualified.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/output-ImportGroupByQualified.hs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad (Monad (..)) +import Data.Maybe (maybe) +import Data.Text (Text) +import SomeInternal.Module1 (anotherDefinition, someDefinition) +import Text.Printf (printf) + +import qualified Data.Text +import qualified SomeInternal.Module2 as Mod2 +import qualified SomeModule +import qualified System.IO as SIO diff --git a/data/fourmolu/import-grouping/output-ImportGroupByScope.hs b/data/fourmolu/import-grouping/output-ImportGroupByScope.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/output-ImportGroupByScope.hs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad (Monad (..)) +import Data.Maybe (maybe) +import Data.Text (Text) +import qualified Data.Text +import qualified SomeModule +import qualified System.IO as SIO +import Text.Printf (printf) + +import SomeInternal.Module1 (anotherDefinition, someDefinition) +import qualified SomeInternal.Module2 as Mod2 diff --git a/data/fourmolu/import-grouping/output-ImportGroupByScopeThenQualified.hs b/data/fourmolu/import-grouping/output-ImportGroupByScopeThenQualified.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/output-ImportGroupByScopeThenQualified.hs @@ -0,0 +1,14 @@ +module Main where + +import Control.Monad (Monad (..)) +import Data.Maybe (maybe) +import Data.Text (Text) +import Text.Printf (printf) + +import qualified Data.Text +import qualified SomeModule +import qualified System.IO as SIO + +import SomeInternal.Module1 (anotherDefinition, someDefinition) + +import qualified SomeInternal.Module2 as Mod2 diff --git a/data/fourmolu/import-grouping/output-ImportGroupPreserve.hs b/data/fourmolu/import-grouping/output-ImportGroupPreserve.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/output-ImportGroupPreserve.hs @@ -0,0 +1,13 @@ +module Main where + +import Data.Maybe (maybe) +import Data.Text (Text) + +import Control.Monad (Monad (..)) +import qualified Data.Text + +import SomeInternal.Module1 (anotherDefinition, someDefinition) +import qualified SomeInternal.Module2 as Mod2 +import qualified SomeModule +import qualified System.IO as SIO +import Text.Printf (printf) diff --git a/data/fourmolu/import-grouping/output-ImportGroupSingle.hs b/data/fourmolu/import-grouping/output-ImportGroupSingle.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/output-ImportGroupSingle.hs @@ -0,0 +1,11 @@ +module Main where + +import Control.Monad (Monad (..)) +import Data.Maybe (maybe) +import Data.Text (Text) +import qualified Data.Text +import SomeInternal.Module1 (anotherDefinition, someDefinition) +import qualified SomeInternal.Module2 as Mod2 +import qualified SomeModule +import qualified System.IO as SIO +import Text.Printf (printf) diff --git a/data/fourmolu/import-grouping/output-custom.hs b/data/fourmolu/import-grouping/output-custom.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/import-grouping/output-custom.hs @@ -0,0 +1,14 @@ +module Main where + +import Data.Text (Text) +import qualified Data.Text + +import Control.Monad (Monad (..)) +import Data.Maybe (maybe) +import Text.Printf (printf) + +import qualified SomeInternal.Module2 as Mod2 + +import SomeInternal.Module1 (anotherDefinition, someDefinition) +import qualified SomeModule +import qualified System.IO as SIO diff --git a/data/fourmolu/single-constraint-parens/input.hs b/data/fourmolu/single-constraint-parens/input.hs --- a/data/fourmolu/single-constraint-parens/input.hs +++ b/data/fourmolu/single-constraint-parens/input.hs @@ -9,3 +9,6 @@ -- https://github.com/fourmolu/fourmolu/issues/374 nestedConstraint :: ((c a, c b) => c (f a b)) => Is c a -> Is c b -> Is c (f a b) + +-- https://github.com/fourmolu/fourmolu/issues/446 +implicitParam :: (?a :: Int) => Int diff --git a/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs b/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs --- a/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs +++ b/data/fourmolu/single-constraint-parens/output-ConstraintAlways.hs @@ -7,3 +7,5 @@ quantifiedConstraint :: (forall a. (Show a) => Show (f a)) => f Int -- https://github.com/fourmolu/fourmolu/issues/374 nestedConstraint :: ((c a, c b) => c (f a b)) => Is c a -> Is c b -> Is c (f a b) +-- https://github.com/fourmolu/fourmolu/issues/446 +implicitParam :: (?a :: Int) => Int diff --git a/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs b/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs --- a/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs +++ b/data/fourmolu/single-constraint-parens/output-ConstraintAuto.hs @@ -7,3 +7,5 @@ quantifiedConstraint :: (forall a. Show a => Show (f a)) => f Int -- https://github.com/fourmolu/fourmolu/issues/374 nestedConstraint :: ((c a, c b) => c (f a b)) => Is c a -> Is c b -> Is c (f a b) +-- https://github.com/fourmolu/fourmolu/issues/446 +implicitParam :: (?a :: Int) => Int diff --git a/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs b/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs --- a/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs +++ b/data/fourmolu/single-constraint-parens/output-ConstraintNever.hs @@ -7,3 +7,5 @@ quantifiedConstraint :: (forall a. Show a => Show (f a)) => f Int -- https://github.com/fourmolu/fourmolu/issues/374 nestedConstraint :: ((c a, c b) => c (f a b)) => Is c a -> Is c b -> Is c (f a b) +-- https://github.com/fourmolu/fourmolu/issues/446 +implicitParam :: (?a :: Int) => Int diff --git a/data/fourmolu/sort-constraints/input.hs b/data/fourmolu/sort-constraints/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-constraints/input.hs @@ -0,0 +1,43 @@ +module Main where + +f1 :: (Show a, Eq a) => a +f1 a = a + +f2 :: + (Show a + , Eq a) + => a +f2 a = a + +-- We don't currently realise that the inner tuple type +-- is a constraint tuple. +f3 :: + ( Generic a + , (Show a, Num a) + , Eq a) + => a +f3 a = a + +f4 :: + (Show a, Num a) + => + Eq a + => a +f4 a = a + +f5 :: + (Show a + -- an interloping comment + , Eq a) + => a +f5 a = a + +class (Show a, Eq a) => Class1 a where + +data (Generic a, (Show a, Eq a)) => A a + +deriving instance (Show a, Eq a) => Class1 Int + +-- We can't know this is a constraint tuple type rather than a normal +-- tuple type without type information +type MyConstraints a = (Show a, Eq a) diff --git a/data/fourmolu/sort-constraints/output-False.hs b/data/fourmolu/sort-constraints/output-False.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-constraints/output-False.hs @@ -0,0 +1,45 @@ +module Main where + +f1 :: (Show a, Eq a) => a +f1 a = a + +f2 :: + ( Show a + , Eq a + ) => + a +f2 a = a + +-- We don't currently realise that the inner tuple type +-- is a constraint tuple. +f3 :: + ( Generic a + , (Show a, Num a) + , Eq a + ) => + a +f3 a = a + +f4 :: + (Show a, Num a) => + (Eq a) => + a +f4 a = a + +f5 :: + ( Show a + , -- an interloping comment + Eq a + ) => + a +f5 a = a + +class (Show a, Eq a) => Class1 a + +data (Generic a, (Show a, Eq a)) => A a + +deriving instance (Show a, Eq a) => Class1 Int + +-- We can't know this is a constraint tuple type rather than a normal +-- tuple type without type information +type MyConstraints a = (Show a, Eq a) diff --git a/data/fourmolu/sort-constraints/output-True.hs b/data/fourmolu/sort-constraints/output-True.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-constraints/output-True.hs @@ -0,0 +1,45 @@ +module Main where + +f1 :: (Eq a, Show a) => a +f1 a = a + +f2 :: + ( Eq a + , Show a + ) => + a +f2 a = a + +-- We don't currently realise that the inner tuple type +-- is a constraint tuple. +f3 :: + ( (Show a, Num a) + , Eq a + , Generic a + ) => + a +f3 a = a + +f4 :: + (Num a, Show a) => + (Eq a) => + a +f4 a = a + +f5 :: + ( -- an interloping comment + Eq a + , Show a + ) => + a +f5 a = a + +class (Eq a, Show a) => Class1 a + +data ((Show a, Eq a), Generic a) => A a + +deriving instance (Eq a, Show a) => Class1 Int + +-- We can't know this is a constraint tuple type rather than a normal +-- tuple type without type information +type MyConstraints a = (Show a, Eq a) diff --git a/data/fourmolu/sort-derived-classes/input.hs b/data/fourmolu/sort-derived-classes/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-derived-classes/input.hs @@ -0,0 +1,18 @@ +module Main where + +data A + deriving (Show, Eq, Ord) + +newtype B = B Int + deriving newtype (Num) + deriving stock (Show, Eq, Generic) + deriving (Semigroup, Monoid) via (Generically B) + deriving stock (Ord, Generic) + deriving (ToJSON) + +data C + deriving + (Show + , Eq + -- A comment that will end up in an odd place + , Ord) diff --git a/data/fourmolu/sort-derived-classes/output-False.hs b/data/fourmolu/sort-derived-classes/output-False.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-derived-classes/output-False.hs @@ -0,0 +1,19 @@ +module Main where + +data A + deriving (Show, Eq, Ord) + +newtype B = B Int + deriving newtype (Num) + deriving stock (Show, Eq, Generic) + deriving (Semigroup, Monoid) via (Generically B) + deriving stock (Ord, Generic) + deriving (ToJSON) + +data C + deriving + ( Show + , Eq + , -- A comment that will end up in an odd place + Ord + ) diff --git a/data/fourmolu/sort-derived-classes/output-True.hs b/data/fourmolu/sort-derived-classes/output-True.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-derived-classes/output-True.hs @@ -0,0 +1,19 @@ +module Main where + +data A + deriving (Eq, Ord, Show) + +newtype B = B Int + deriving newtype (Num) + deriving stock (Eq, Generic, Show) + deriving (Monoid, Semigroup) via (Generically B) + deriving stock (Generic, Ord) + deriving (ToJSON) + +data C + deriving + ( Eq + , -- A comment that will end up in an odd place + Ord + , Show + ) diff --git a/data/fourmolu/sort-deriving-clauses/input.hs b/data/fourmolu/sort-deriving-clauses/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-deriving-clauses/input.hs @@ -0,0 +1,12 @@ +module Main where + +newtype A = A Int + deriving newtype (Num) + deriving stock (Show, Eq) + deriving stock (Ord, Generic) + deriving (ToJSON) + +data B + -- A comment that will end up in an odd place + deriving stock (Show) + deriving (Eq) diff --git a/data/fourmolu/sort-deriving-clauses/output-False.hs b/data/fourmolu/sort-deriving-clauses/output-False.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-deriving-clauses/output-False.hs @@ -0,0 +1,12 @@ +module Main where + +newtype A = A Int + deriving newtype (Num) + deriving stock (Show, Eq) + deriving stock (Ord, Generic) + deriving (ToJSON) + +data B + -- A comment that will end up in an odd place + deriving stock (Show) + deriving (Eq) diff --git a/data/fourmolu/sort-deriving-clauses/output-True.hs b/data/fourmolu/sort-deriving-clauses/output-True.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/sort-deriving-clauses/output-True.hs @@ -0,0 +1,13 @@ +module Main where + +newtype A = A Int + deriving (ToJSON) + deriving stock (Show, Eq) + deriving stock (Ord, Generic) + deriving newtype (Num) + +data B + -- A comment that will end up in an odd place + + deriving (Eq) + deriving stock (Show) diff --git a/data/fourmolu/trailing-section-operators/input.hs b/data/fourmolu/trailing-section-operators/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/trailing-section-operators/input.hs @@ -0,0 +1,18 @@ +someShortFunction $ someShortFunction x + +someShortFunction $ someShortFunction $ \x -> do + putStrLn x + +someLongFunction $ someLongFunction + $ someLongFunction + $ someLongFunction $ someLongFunction x + +someLongFunction + $ someLongFunction + $ someLongFunction $ someLongFunction $ \x -> do + putStrLn x + +someLongFunction $ someLongFunction $ someLongFunction $ someLongFunction $ \x -> putStrLn x + +someLongFunction $ someLongFunction $ someLongFunction $ someLongFunction $ \x -> do + putStrLn x diff --git a/data/fourmolu/trailing-section-operators/output-False.hs b/data/fourmolu/trailing-section-operators/output-False.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/trailing-section-operators/output-False.hs @@ -0,0 +1,22 @@ +someShortFunction $ someShortFunction x + +someShortFunction $ someShortFunction $ \x -> do + putStrLn x + +someLongFunction + $ someLongFunction + $ someLongFunction + $ someLongFunction + $ someLongFunction x + +someLongFunction + $ someLongFunction + $ someLongFunction + $ someLongFunction + $ \x -> do + putStrLn x + +someLongFunction $ someLongFunction $ someLongFunction $ someLongFunction $ \x -> putStrLn x + +someLongFunction $ someLongFunction $ someLongFunction $ someLongFunction $ \x -> do + putStrLn x diff --git a/data/fourmolu/trailing-section-operators/output-True.hs b/data/fourmolu/trailing-section-operators/output-True.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/trailing-section-operators/output-True.hs @@ -0,0 +1,21 @@ +someShortFunction $ someShortFunction x + +someShortFunction $ someShortFunction $ \x -> do + putStrLn x + +someLongFunction $ + someLongFunction $ + someLongFunction $ + someLongFunction $ + someLongFunction x + +someLongFunction $ + someLongFunction $ + someLongFunction $ + someLongFunction $ \x -> do + putStrLn x + +someLongFunction $ someLongFunction $ someLongFunction $ someLongFunction $ \x -> putStrLn x + +someLongFunction $ someLongFunction $ someLongFunction $ someLongFunction $ \x -> do + putStrLn x diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: fourmolu -version: 0.16.2.0 +version: 0.17.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: @@ -52,6 +52,7 @@ Ormolu.Diff.Text Ormolu.Exception Ormolu.Imports + Ormolu.Imports.Grouping Ormolu.Parser Ormolu.Parser.CommentStream Ormolu.Parser.Pragma @@ -96,17 +97,21 @@ Ormolu.Utils Ormolu.Utils.Cabal Ormolu.Utils.Fixity + Ormolu.Utils.Glob Ormolu.Utils.IO Paths_fourmolu other-modules: Ormolu.Config.Gen + Ormolu.Config.Types + autogen-modules: + Paths_fourmolu hs-source-dirs: src other-modules: GHC.DynFlags default-language: GHC2021 build-depends: Cabal-syntax >=3.12 && <3.13, - Diff >=0.4 && <1, + Diff >=0.4 && <2, MemoTrie >=0.6 && <0.7, ansi-terminal >=0.10 && <1.2, array >=0.5 && <0.6, @@ -214,9 +219,10 @@ Ormolu.Integration.FixitySpec Ormolu.Integration.RegionSpec Ormolu.Integration.Utils + Ormolu.Utils.GlobSpec build-depends: bytestring, - Diff >=0.3 && <1, + Diff >=1 && <2, pretty >=1.0 && <2.0, process >=1.6 && <2.0, yaml, diff --git a/fourmolu.yaml b/fourmolu.yaml --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -6,6 +6,7 @@ function-arrows: trailing comma-style: trailing import-export-style: trailing +import-grouping: legacy indent-wheres: true record-brace-space: true newlines-between-decls: 1 @@ -15,7 +16,12 @@ in-style: right-align single-constraint-parens: always single-deriving-parens: always +sort-constraints: false +sort-derived-classes: false +sort-deriving-clauses: false +trailing-section-operators: true unicode: never respectful: false fixities: [] reexports: [] +local-modules: [] diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -221,7 +221,10 @@ ], cfgDependencies = Set.union (cfgDependencies rawConfig) depsFromCabal, - cfgSourceType = sourceType + cfgSourceType = sourceType, + cfgLocalModules = + cfgLocalModules rawConfig + <> maybe Set.empty (Set.fromList . CabalUtils.ciModules) mcabalInfo } where fixityOverrides = fromMaybe defaultFixityOverrides mfixityOverrides diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -39,6 +39,15 @@ HaddockPrintStyle (..), HaddockPrintStyleModule (..), ImportExportStyle (..), + ImportGrouping (..), + ImportGroup (..), + ImportGroupRule (..), + ImportModuleMatcher (..), + ImportRulePriority (..), + matchAllRulePriority, + matchLocalRulePriority, + defaultImportRulePriority, + QualifiedImportMatcher (..), LetStyle (..), InStyle (..), Unicode (..), @@ -65,10 +74,12 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.String (fromString) +import Distribution.ModuleName (ModuleName) import Distribution.Types.PackageName (PackageName) import GHC.Generics (Generic) import GHC.Types.SrcLoc qualified as GHC import Ormolu.Config.Gen +import Ormolu.Config.Types import Ormolu.Fixity import Ormolu.Terminal (ColorMode (..)) import Ormolu.Utils.Fixity (parseFixityDeclarationStr, parseModuleReexportDeclarationStr) @@ -113,7 +124,8 @@ cfgColorMode :: !ColorMode, -- | Region selection cfgRegion :: !region, - cfgPrinterOpts :: !PrinterOptsTotal + cfgPrinterOpts :: !PrinterOptsTotal, + cfgLocalModules :: !(Set ModuleName) } deriving (Eq, Show, Functor, Generic) @@ -154,7 +166,8 @@ { regionStartLine = Nothing, regionEndLine = Nothing }, - cfgPrinterOpts = defaultPrinterOpts + cfgPrinterOpts = defaultPrinterOpts, + cfgLocalModules = Set.empty } -- | Return all dependencies of the module. This includes both the declared 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 @@ -19,6 +19,7 @@ , SingleConstraintParens (..) , ColumnLimit (..) , SingleDerivingParens (..) + , ImportGrouping (..) , emptyPrinterOpts , defaultPrinterOpts , defaultPrinterOptsYaml @@ -32,9 +33,11 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import Data.Functor.Identity (Identity) +import Data.List.NonEmpty (NonEmpty) import Data.Scientific (floatingOrInteger) import qualified Data.Text as Text import GHC.Generics (Generic) +import qualified Ormolu.Config.Types as CT import Text.Read (readEither, readMaybe) -- | Options controlling formatting output. @@ -50,6 +53,8 @@ poCommaStyle :: f CommaStyle , -- | Styling of import/export lists poImportExportStyle :: f ImportExportStyle + , -- | Rules for grouping import declarations + poImportGrouping :: f ImportGrouping , -- | Whether to full-indent or half-indent 'where' bindings past the preceding body poIndentWheres :: f Bool , -- | Whether to leave a space before an opening record brace @@ -68,6 +73,14 @@ poSingleConstraintParens :: f SingleConstraintParens , -- | Whether to put parentheses around a single deriving class poSingleDerivingParens :: f SingleDerivingParens + , -- | Whether to sort constraints + poSortConstraints :: f Bool + , -- | Whether to sort derived classes + poSortDerivedClasses :: f Bool + , -- | Whether to sort deriving clauses + poSortDerivingClauses :: f Bool + , -- | Whether to place section operators (those that are infixr 0, such as $) in trailing position, continuing the expression indented below + poTrailingSectionOperators :: f Bool , -- | Output Unicode syntax poUnicode :: f Unicode , -- | Give the programmer more choice on where to insert blank lines @@ -83,6 +96,7 @@ , poFunctionArrows = Nothing , poCommaStyle = Nothing , poImportExportStyle = Nothing + , poImportGrouping = Nothing , poIndentWheres = Nothing , poRecordBraceSpace = Nothing , poNewlinesBetweenDecls = Nothing @@ -92,6 +106,10 @@ , poInStyle = Nothing , poSingleConstraintParens = Nothing , poSingleDerivingParens = Nothing + , poSortConstraints = Nothing + , poSortDerivedClasses = Nothing + , poSortDerivingClauses = Nothing + , poTrailingSectionOperators = Nothing , poUnicode = Nothing , poRespectful = Nothing } @@ -104,6 +122,7 @@ , poFunctionArrows = pure TrailingArrows , poCommaStyle = pure Leading , poImportExportStyle = pure ImportExportDiffFriendly + , poImportGrouping = pure ImportGroupLegacy , poIndentWheres = pure False , poRecordBraceSpace = pure False , poNewlinesBetweenDecls = pure 1 @@ -113,6 +132,10 @@ , poInStyle = pure InRightAlign , poSingleConstraintParens = pure ConstraintAlways , poSingleDerivingParens = pure DerivingAlways + , poSortConstraints = pure False + , poSortDerivedClasses = pure False + , poSortDerivingClauses = pure False + , poTrailingSectionOperators = pure True , poUnicode = pure UnicodeNever , poRespectful = pure True } @@ -132,6 +155,7 @@ , poFunctionArrows = maybe (poFunctionArrows p2) pure (poFunctionArrows p1) , poCommaStyle = maybe (poCommaStyle p2) pure (poCommaStyle p1) , poImportExportStyle = maybe (poImportExportStyle p2) pure (poImportExportStyle p1) + , poImportGrouping = maybe (poImportGrouping p2) pure (poImportGrouping p1) , poIndentWheres = maybe (poIndentWheres p2) pure (poIndentWheres p1) , poRecordBraceSpace = maybe (poRecordBraceSpace p2) pure (poRecordBraceSpace p1) , poNewlinesBetweenDecls = maybe (poNewlinesBetweenDecls p2) pure (poNewlinesBetweenDecls p1) @@ -141,6 +165,10 @@ , poInStyle = maybe (poInStyle p2) pure (poInStyle p1) , poSingleConstraintParens = maybe (poSingleConstraintParens p2) pure (poSingleConstraintParens p1) , poSingleDerivingParens = maybe (poSingleDerivingParens p2) pure (poSingleDerivingParens p1) + , poSortConstraints = maybe (poSortConstraints p2) pure (poSortConstraints p1) + , poSortDerivedClasses = maybe (poSortDerivedClasses p2) pure (poSortDerivedClasses p1) + , poSortDerivingClauses = maybe (poSortDerivingClauses p2) pure (poSortDerivingClauses p1) + , poTrailingSectionOperators = maybe (poTrailingSectionOperators p2) pure (poTrailingSectionOperators p1) , poUnicode = maybe (poUnicode p2) pure (poUnicode p1) , poRespectful = maybe (poRespectful p2) pure (poRespectful p1) } @@ -172,6 +200,10 @@ "Styling of import/export lists (choices: \"leading\", \"trailing\", or \"diff-friendly\") (default: diff-friendly)" "OPTION" <*> f + "import-grouping" + "Rules for grouping import declarations (default: legacy)" + "OPTION" + <*> f "indent-wheres" "Whether to full-indent or half-indent 'where' bindings past the preceding body (default: false)" "BOOL" @@ -208,6 +240,22 @@ "Whether to put parentheses around a single deriving class (choices: \"auto\", \"always\", or \"never\") (default: always)" "OPTION" <*> f + "sort-constraints" + "Whether to sort constraints (default: false)" + "BOOL" + <*> f + "sort-derived-classes" + "Whether to sort derived classes (default: false)" + "BOOL" + <*> f + "sort-deriving-clauses" + "Whether to sort deriving clauses (default: false)" + "BOOL" + <*> f + "trailing-section-operators" + "Whether to place section operators (those that are infixr 0, such as $) in trailing position, continuing the expression indented below (default: true)" + "BOOL" + <*> f "unicode" "Output Unicode syntax (choices: \"detect\", \"always\", or \"never\") (default: never)" "OPTION" @@ -227,6 +275,7 @@ <*> f "function-arrows" <*> f "comma-style" <*> f "import-export-style" + <*> f "import-grouping" <*> f "indent-wheres" <*> f "record-brace-space" <*> f "newlines-between-decls" @@ -236,6 +285,10 @@ <*> f "in-style" <*> f "single-constraint-parens" <*> f "single-deriving-parens" + <*> f "sort-constraints" + <*> f "sort-derived-classes" + <*> f "sort-deriving-clauses" + <*> f "trailing-section-operators" <*> f "unicode" <*> f "respectful" @@ -322,6 +375,16 @@ | DerivingNever deriving (Eq, Show, Enum, Bounded) +data ImportGrouping + = ImportGroupLegacy + | ImportGroupPreserve + | ImportGroupSingle + | ImportGroupByScope + | ImportGroupByQualified + | ImportGroupByScopeThenQualified + | ImportGroupCustom (NonEmpty CT.ImportGroup) + deriving (Eq, Show) + instance Aeson.FromJSON CommaStyle where parseJSON = Aeson.withText "CommaStyle" $ \s -> @@ -525,6 +588,37 @@ , "Valid values are: \"auto\", \"always\", or \"never\"" ] +instance Aeson.FromJSON ImportGrouping where + parseJSON = + \case + Aeson.String "legacy" -> pure ImportGroupLegacy + Aeson.String "preserve" -> pure ImportGroupPreserve + Aeson.String "single" -> pure ImportGroupSingle + Aeson.String "by-qualified" -> pure ImportGroupByQualified + Aeson.String "by-scope" -> pure ImportGroupByScope + Aeson.String "by-scope-then-qualified" -> pure ImportGroupByScopeThenQualified + arr@(Aeson.Array _) -> ImportGroupCustom <$> Aeson.parseJSON arr + other -> + fail . unlines $ + [ "unknown strategy value: " <> show other, + "Valid values are: \"legacy\", \"preserve\", \"single\", \"by-qualified\", \"by-scope\", \"by-scope-then-qualified\" or a valid YAML configuration for import groups" + ] + +instance PrinterOptsFieldType ImportGrouping where + parsePrinterOptType = + \case + "legacy" -> Right ImportGroupLegacy + "preserve" -> Right ImportGroupPreserve + "single" -> Right ImportGroupSingle + "by-qualified" -> Right ImportGroupByQualified + "by-scope" -> Right ImportGroupByScope + "by-scope-then-qualified" -> Right ImportGroupByScopeThenQualified + s -> + Left . unlines $ + [ "unknown value: " <> show s + , "Valid values are: \"legacy\", \"preserve\", \"single\", \"by-qualified\", \"by-scope\", \"by-scope-then-qualified\" or a valid YAML configuration for import groups (see fourmolu.yaml)" + ] + defaultPrinterOptsYaml :: String defaultPrinterOptsYaml = unlines @@ -543,6 +637,9 @@ , "# Styling of import/export lists (choices: leading, trailing, or diff-friendly)" , "import-export-style: diff-friendly" , "" + , "# Rules for grouping import declarations" + , "import-grouping: legacy" + , "" , "# Whether to full-indent or half-indent 'where' bindings past the preceding body" , "indent-wheres: false" , "" @@ -570,6 +667,18 @@ , "# Whether to put parentheses around a single deriving class (choices: auto, always, or never)" , "single-deriving-parens: always" , "" + , "# Whether to sort constraints" + , "sort-constraints: false" + , "" + , "# Whether to sort derived classes" + , "sort-derived-classes: false" + , "" + , "# Whether to sort deriving clauses" + , "sort-deriving-clauses: false" + , "" + , "# Whether to place section operators (those that are infixr 0, such as $) in trailing position, continuing the expression indented below" + , "trailing-section-operators: true" + , "" , "# Output Unicode syntax (choices: detect, always, or never)" , "unicode: never" , "" @@ -581,4 +690,7 @@ , "" , "# Module reexports Fourmolu should know about" , "reexports: []" + , "" + , "# Modules defined by the current Cabal package for import grouping" + , "local-modules: []" ] diff --git a/src/Ormolu/Config/Types.hs b/src/Ormolu/Config/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Config/Types.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ormolu.Config.Types + ( ImportGroup (..), + ImportGroupRule (..), + ImportModuleMatcher (..), + ImportRulePriority (..), + matchAllRulePriority, + matchLocalRulePriority, + defaultImportRulePriority, + QualifiedImportMatcher (..), + ) +where + +import Control.Applicative (Alternative (..), asum) +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson +import Data.List.NonEmpty (NonEmpty) +import Data.Word (Word8) +import Ormolu.Utils.Glob (Glob, mkGlob) + +data ImportGroup = ImportGroup + { igName :: !(Maybe String), + igRules :: !(NonEmpty ImportGroupRule) + } + deriving (Eq, Show) + +instance Aeson.FromJSON ImportGroup where + parseJSON = Aeson.withObject "ImportGroup" $ \o -> + ImportGroup + <$> Aeson.parseFieldMaybe o "name" + <*> Aeson.parseField o "rules" + +data ImportGroupRule = ImportGroupRule + { igrModuleMatcher :: !ImportModuleMatcher, + igrQualifiedMatcher :: !QualifiedImportMatcher, + igrPriority :: !ImportRulePriority + } + deriving (Eq, Show) + +instance Aeson.FromJSON ImportGroupRule where + parseJSON = Aeson.withObject "rule" $ \o -> do + let parseModuleMatcher = Aeson.parseJSON (Aeson.Object o) + failUnknownModuleMatcher = Aeson.parseFail "Unknown or invalid module matcher" + attemptParseModuleMatcher = parseModuleMatcher <|> failUnknownModuleMatcher + igrModuleMatcher <- attemptParseModuleMatcher + + qualified <- o .:? "qualified" + igrQualifiedMatcher <- case qualified of + Just True -> pure MatchQualifiedOnly + Just False -> pure MatchUnqualifiedOnly + Nothing -> pure MatchBothQualifiedAndUnqualified + + let defaultPriority + | MatchAllModules <- igrModuleMatcher = matchAllRulePriority + | otherwise = defaultImportRulePriority + igrPriority <- o .:? "priority" .!= defaultPriority + + pure ImportGroupRule {..} + +newtype ImportRulePriority = ImportRulePriority Word8 + deriving (Eq, Ord, Show, Bounded) + +instance Aeson.FromJSON ImportRulePriority where + parseJSON = fmap ImportRulePriority . Aeson.parseJSON + +matchAllRulePriority :: ImportRulePriority +matchAllRulePriority = ImportRulePriority 100 + +matchLocalRulePriority :: ImportRulePriority +matchLocalRulePriority = ImportRulePriority 60 -- Lower priority than "all" but higher than the default. + +defaultImportRulePriority :: ImportRulePriority +defaultImportRulePriority = ImportRulePriority 50 + +data QualifiedImportMatcher + = MatchQualifiedOnly + | MatchUnqualifiedOnly + | MatchBothQualifiedAndUnqualified + deriving (Eq, Show) + +data ImportModuleMatcher + = MatchAllModules + | MatchLocalModules + | MatchGlob !Glob + deriving (Eq, Show) + +instance Aeson.FromJSON ImportModuleMatcher where + parseJSON v = + asum + [ parseMatchModuleMatcher v, + parseGlobModuleMatcher v + ] + where + parseMatchModuleMatcher :: Aeson.Value -> Aeson.Parser ImportModuleMatcher + parseMatchModuleMatcher = Aeson.withObject "ImportModuleMatcher" $ \o -> do + c <- Aeson.parseField @String o "match" + case c of + "all" -> pure MatchAllModules + "local-modules" -> pure MatchLocalModules + other -> Aeson.parseFail $ "Unknown matcher: " <> other + + parseGlobModuleMatcher :: Aeson.Value -> Aeson.Parser ImportModuleMatcher + parseGlobModuleMatcher = Aeson.withObject "ImportModuleMatcher" $ \o -> do + rawGlob <- o .: "glob" + let glob = mkGlob rawGlob + pure (MatchGlob glob) 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 @@ -12,12 +12,16 @@ where import Data.ByteString (ByteString) +import Data.Char (isSpace) import Data.Foldable import Data.Function import Data.Generics +import Data.List (sortOn) +import Data.Text qualified as T import GHC.Hs import GHC.Types.SourceText import GHC.Types.SrcLoc +import Ormolu.Config.Gen (ImportGrouping (ImportGroupSingle)) import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result @@ -55,8 +59,8 @@ } = diffCommentStream cstream0 cstream1 <> diffHsModule - hs0 {hsmodImports = concat . normalizeImports False $ hsmodImports hs0} - hs1 {hsmodImports = concat . normalizeImports False $ hsmodImports hs1} + hs0 {hsmodImports = concat . normalizeImports False mempty ImportGroupSingle $ hsmodImports hs0} + hs1 {hsmodImports = concat . normalizeImports False mempty ImportGroupSingle $ hsmodImports hs1} diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff diffCommentStream (CommentStream cs) (CommentStream cs') @@ -98,7 +102,9 @@ `extQ` hsDocStringEq `extQ` importDeclQualifiedStyleEq `extQ` classDeclCtxEq - `extQ` derivedTyClsParensEq + `extQ` derivedTyClsEq + `extQ` qualTyCtxEq + `extQ` dataDeclEq `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token `extQ` considerEqual @EpaLocation @@ -142,7 +148,7 @@ f x x' = x == x' hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff - hsDocStringEq = considerEqualVia' ((==) `on` splitDocString True) + hsDocStringEq = considerEqualVia' ((==) `on` (map (T.dropWhile isSpace) . splitDocString True)) forLocated :: (Data e0, Data e1) => @@ -163,15 +169,53 @@ UnhelpfulSpan _ -> d appendSpan _ d = d + -- The order of contexts doesn't matter + normalizeContext :: HsContext GhcPs -> HsContext GhcPs + normalizeContext = sortOn showOutputable + + normalizeMContext :: Maybe (LHsContext GhcPs) -> Maybe (LHsContext GhcPs) + normalizeMContext Nothing = Nothing + normalizeMContext (Just (L _ [])) = Nothing + normalizeMContext (Just (L ann ctx)) = Just (L ann $ normalizeContext ctx) + + qualTyCtxEq :: HsType GhcPs -> GenericQ ParseResultDiff + qualTyCtxEq = considerEqualVia $ \lt rt -> genericQuery (normalizeQualTy lt) (normalizeQualTy rt) + where + normalizeQualTy :: HsType GhcPs -> HsType GhcPs + normalizeQualTy (HsQualTy ann ctx body) = HsQualTy ann (fmap normalizeContext ctx) body + normalizeQualTy ty = ty + classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff - classDeclCtxEq ClassDecl {tcdCtxt = Just (L _ []), ..} tc' = genericQuery ClassDecl {tcdCtxt = Nothing, ..} tc' - classDeclCtxEq tc tc' = genericQuery tc tc' + classDeclCtxEq = considerEqualVia $ \lc rc -> genericQuery (normalizeClassDecl lc) (normalizeClassDecl rc) + where + normalizeClassDecl ClassDecl {tcdCtxt, ..} = ClassDecl {tcdCtxt = normalizeMContext tcdCtxt, ..} + normalizeClassDecl d = d - derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff - derivedTyClsParensEq = considerEqualVia $ curry $ \case - (DctSingle _ ty, DctMulti _ [ty']) -> genericQuery ty ty' - (DctMulti _ [ty], DctSingle _ ty') -> genericQuery ty ty' - (x, y) -> genericQuery x y + dataDeclEq :: HsDataDefn GhcPs -> GenericQ ParseResultDiff + dataDeclEq = considerEqualVia $ \dd dd' -> genericQuery (normalizeDataDecl dd) (normalizeDataDecl dd') + + normalizeDataDecl :: HsDataDefn GhcPs -> HsDataDefn GhcPs + normalizeDataDecl HsDataDefn {dd_ctxt, dd_derivs, ..} = + HsDataDefn + { -- The order of classes in the context doesn't matter + dd_ctxt = normalizeMContext dd_ctxt, + -- The order of deriving clauses doesn't matter. Note: need to normalize before sorting, otherwise + -- we'll get a different sort order! + dd_derivs = sortOn showOutputable ((fmap . fmap) normalizeDerivingClause dd_derivs), + .. + } + + normalizeDerivingClause :: HsDerivingClause GhcPs -> HsDerivingClause GhcPs + normalizeDerivingClause HsDerivingClause {deriv_clause_tys, ..} = + HsDerivingClause {deriv_clause_tys = fmap normalizeDerivClauseTys deriv_clause_tys, ..} + + normalizeDerivClauseTys :: DerivClauseTys GhcPs -> DerivClauseTys GhcPs + normalizeDerivClauseTys (DctSingle ann ty) = DctMulti ann [ty] + -- The order of types in deriving clauses doesn't matter + normalizeDerivClauseTys (DctMulti ann tys) = DctMulti ann (sortOn showOutputable tys) + + derivedTyClsEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff + derivedTyClsEq = considerEqualVia $ \lc rc -> genericQuery (normalizeDerivClauseTys lc) (normalizeDerivClauseTys rc) compareAnnKeywordId x y = let go = curry $ \case diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -13,11 +13,12 @@ import Data.Bifunctor import Data.Char (isAlphaNum) -import Data.Foldable (toList) import Data.Function (on) import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as M +import Data.Set (Set) +import Distribution.ModuleName qualified as Cabal import GHC.Data.FastString import GHC.Hs import GHC.Hs.ImpExp as GHC @@ -25,7 +26,9 @@ import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc -import Ormolu.Utils (groupBy', notImplemented, separatedByBlank, showOutputable) +import Ormolu.Config (ImportGrouping) +import Ormolu.Imports.Grouping (Import (..), groupImports, prepareExistingGroups) +import Ormolu.Utils (notImplemented, showOutputable) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif @@ -35,18 +38,20 @@ -- Assumes input list is sorted by source location. Output list is not necessarily -- sorted by source location, so this function should be called at most once on a -- given input list. -normalizeImports :: Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] -normalizeImports preserveGroups = - map - ( fmap snd - . M.toAscList - . M.fromListWith combineImports - . fmap (\x -> (importId x, g x)) - ) - . if preserveGroups - then map toList . groupBy' (\x y -> not $ separatedByBlank getLocA x y) - else pure +normalizeImports :: Bool -> Set Cabal.ModuleName -> ImportGrouping -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] +normalizeImports respectful localModules importGrouping = + map (fmap snd) + . concatMap + ( groupImports importGrouping localModules toImport + . M.toAscList + . M.fromListWith combineImports + . fmap (\x -> (importId x, g x)) + ) + . prepareExistingGroups importGrouping respectful where + toImport :: (ImportId, x) -> Import + toImport (ImportId {..}, _) = Import {importName = importIdName, importQualified} + g :: LImportDecl GhcPs -> LImportDecl GhcPs g (L l ImportDecl {..}) = L diff --git a/src/Ormolu/Imports/Grouping.hs b/src/Ormolu/Imports/Grouping.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Imports/Grouping.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Ormolu.Imports.Grouping + ( Import (..), + prepareExistingGroups, + groupImports, + ) +where + +import Data.Bifunctor (Bifunctor (..)) +import Data.Foldable (toList) +import Data.Function (on) +import Data.List (groupBy, minimumBy, sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set +import Distribution.ModuleName qualified as Cabal +import GHC.Hs (GhcPs, getLocA) +import Language.Haskell.Syntax (LImportDecl, ModuleName, moduleNameString) +import Ormolu.Config (ImportGroup (..), ImportGroupRule (..), ImportGrouping (..), ImportModuleMatcher (..)) +import Ormolu.Config qualified as Config +import Ormolu.Utils (ghcModuleNameToCabal, groupBy', separatedByBlank) +import Ormolu.Utils.Glob (matchesGlob) + +newtype ImportGroups = ImportGroups (NonEmpty ImportGroup) + +data Import = Import + { importName :: ModuleName, + importQualified :: Bool + } + +importGroupSingleStrategy :: ImportGroups +importGroupSingleStrategy = + ImportGroups $ + pure + ImportGroup + { igName = Nothing, + igRules = pure matchAllImportRule + } + +importGroupByQualifiedStrategy :: ImportGroups +importGroupByQualifiedStrategy = + ImportGroups $ + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = pure $ withUnqualifiedOnly matchAllImportRule + }, + ImportGroup + { igName = Nothing, + igRules = pure $ withQualifiedOnly matchAllImportRule + } + ] + +importGroupByScopeStrategy :: ImportGroups +importGroupByScopeStrategy = + ImportGroups $ + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = pure matchAllImportRule + }, + ImportGroup + { igName = Nothing, + igRules = pure matchLocalModulesRule + } + ] + +importGroupByScopeThenQualifiedStrategy :: ImportGroups +importGroupByScopeThenQualifiedStrategy = + ImportGroups $ + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = pure $ withQualified matchModule + } + | matchModule <- [matchAllImportRule, matchLocalModulesRule], + withQualified <- [withUnqualifiedOnly, withQualifiedOnly] + ] + +groupsFromConfig :: Config.ImportGrouping -> ImportGroups +groupsFromConfig = + \case + Config.ImportGroupLegacy -> importGroupSingleStrategy + Config.ImportGroupPreserve -> importGroupSingleStrategy + Config.ImportGroupSingle -> importGroupSingleStrategy + Config.ImportGroupByQualified -> importGroupByQualifiedStrategy + Config.ImportGroupByScope -> importGroupByScopeStrategy + Config.ImportGroupByScopeThenQualified -> importGroupByScopeThenQualifiedStrategy + Config.ImportGroupCustom igs -> ImportGroups igs + +matchAllImportRule :: ImportGroupRule +matchAllImportRule = + ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = Config.MatchBothQualifiedAndUnqualified, + igrPriority = Config.matchAllRulePriority + } + +matchLocalModulesRule :: ImportGroupRule +matchLocalModulesRule = + ImportGroupRule + { igrModuleMatcher = MatchLocalModules, + igrQualifiedMatcher = Config.MatchBothQualifiedAndUnqualified, + igrPriority = Config.matchLocalRulePriority + } + +withQualifiedOnly :: ImportGroupRule -> ImportGroupRule +withQualifiedOnly ImportGroupRule {..} = + ImportGroupRule + { igrQualifiedMatcher = Config.MatchQualifiedOnly, + .. + } + +withUnqualifiedOnly :: ImportGroupRule -> ImportGroupRule +withUnqualifiedOnly ImportGroupRule {..} = + ImportGroupRule + { igrQualifiedMatcher = Config.MatchUnqualifiedOnly, + .. + } + +matchesRule :: Set Cabal.ModuleName -> Import -> ImportGroupRule -> Bool +matchesRule localMods Import {..} ImportGroupRule {..} = matchesModules && matchesQualified + where + matchesModules = case igrModuleMatcher of + MatchAllModules -> True + MatchLocalModules -> ghcModuleNameToCabal importName `Set.member` localMods + MatchGlob gl -> moduleNameString importName `matchesGlob` gl + matchesQualified = case igrQualifiedMatcher of + Config.MatchQualifiedOnly -> importQualified + Config.MatchUnqualifiedOnly -> not importQualified + Config.MatchBothQualifiedAndUnqualified -> True + +prepareExistingGroups :: ImportGrouping -> Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] +prepareExistingGroups ig respectful = + case ig of + ImportGroupPreserve -> preserveGroups + ImportGroupLegacy | respectful -> preserveGroups + _ -> flattenGroups + where + preserveGroups = map toList . groupBy' (\x y -> not $ separatedByBlank getLocA x y) + flattenGroups = pure + +groupImports :: forall x. ImportGrouping -> Set Cabal.ModuleName -> (x -> Import) -> [x] -> [[x]] +groupImports ig localModules fToImport = regroup . fmap (breakTies . matchRules) + where + ImportGroups igs = groupsFromConfig ig + + indexedGroupRules :: [(Int, [ImportGroupRule])] + indexedGroupRules = zip [0 ..] (toList . igRules <$> toList igs) + + matchRules :: x -> ([(Int, [ImportGroupRule])], x) + matchRules x = + let imp = fToImport x + testRule (_, rules) = any (matchesRule localModules imp) rules + in (filter testRule indexedGroupRules, x) + + breakTies :: ([(Int, [ImportGroupRule])], x) -> (Int, x) + breakTies ([], x) = + (maxBound, x) -- Any non-matched imports will be in the last group + breakTies (matches, x) = + (fst . minimumBy (compare `on` snd) $ second (minimum . fmap igrPriority) <$> matches, x) + + regroup :: [(Int, x)] -> [[x]] + regroup = fmap (fmap snd) . groupBy ((==) `on` fst) . sortOn fst diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -168,7 +168,8 @@ prCommentStream = comments, prExtensions = GHC.extensionFlags dynFlags, prModuleFixityMap = modFixityMap, - prIndent = indent + prIndent = indent, + prLocalModules = cfgLocalModules } return r @@ -216,6 +217,7 @@ [x@(L _ (HsParTy _ inner))] | L _ HsForAllTy {} <- inner -> [x] | L _ HsQualTy {} <- inner -> [x] + | L _ HsIParamTy {} <- inner -> [x] | ConstraintNever <- constraintParens -> [inner] | otherwise -> [x] [x@(L lx _)] 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 @@ -5,9 +5,11 @@ ) where +import Data.Set (Set) import Data.Text (Text) +import Distribution.ModuleName (ModuleName) import GHC.Data.EnumSet (EnumSet) -import GHC.Hs +import GHC.Hs (GhcPs, HsModule) import GHC.LanguageExtensions.Type import Ormolu.Config (SourceType) import Ormolu.Fixity (ModuleFixityMap) @@ -34,5 +36,7 @@ -- | Fixity map for operators prModuleFixityMap :: ModuleFixityMap, -- | Indentation level, can be non-zero in case of region formatting - prIndent :: Int + prIndent :: Int, + -- | Local modules + prLocalModules :: Set ModuleName } diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -40,6 +40,7 @@ (mkSpanStream prParsedSource) prCommentStream printerOpts + prLocalModules prSourceType prExtensions prModuleFixityMap 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 @@ -18,10 +18,12 @@ -- ** Basic txt, + txtStripIndent, atom, space, newline, declNewline, + multilineCommentNewline, inci, inciBy, inciIf, @@ -41,6 +43,7 @@ breakpoint, breakpoint', getPrinterOpt, + getLocalModules, -- ** Formatting lists sep, 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 @@ -230,17 +230,17 @@ let startColumn = srcLocCol . realSrcSpanStart in startColumn espn > startColumn ref || ( abs (startColumn espn - startColumn l) - >= abs (startColumn ref - startColumn l) + >= abs (startColumn ref - startColumn l) ) continuation = -- A comment is a continuation when it doesn't have non-whitespace -- lexemes in front of it and goes right after the previous comment. not (hasAtomsBefore comment) && ( case mlastMark of - Just (HaddockSpan _ _) -> False - Just (CommentSpan spn) -> - srcSpanEndLine spn + 1 == srcSpanStartLine l - _ -> False + Just (HaddockSpan _ _) -> False + Just (CommentSpan spn) -> + srcSpanEndLine spn + 1 == srcSpanStartLine l + _ -> False ) lastInEnclosing = case meSpn of 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 @@ -13,11 +13,13 @@ -- * Internal functions txt, + txtStripIndent, interferingTxt, atom, space, newline, declNewline, + multilineCommentNewline, askSourceType, askModuleFixityMap, askDebug, @@ -31,6 +33,7 @@ vlayout, getLayout, getPrinterOpt, + getLocalModules, -- * Helpers for braces useBraces, @@ -65,6 +68,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Bool (bool) +import Data.Char (isSpace) import Data.Choice (Choice) import Data.Choice qualified as Choice import Data.Coerce @@ -72,10 +76,12 @@ import Data.Functor.Identity (runIdentity) import Data.List (find) import Data.Maybe (listToMaybe) +import Data.Set (Set) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder +import Distribution.ModuleName (ModuleName) import GHC.Data.EnumSet (EnumSet) import GHC.Data.EnumSet qualified as EnumSet import GHC.LanguageExtensions.Type @@ -108,6 +114,7 @@ -- | Whether the last expression in the layout can use braces rcCanUseBraces :: Bool, rcPrinterOpts :: PrinterOptsTotal, + rcLocalModules :: Set ModuleName, -- | Enabled extensions rcExtensions :: EnumSet Extension, -- | Whether the source is a signature or a regular module @@ -180,6 +187,7 @@ -- | Comment stream CommentStream -> PrinterOptsTotal -> + Set ModuleName -> -- | Whether the source is a signature or a regular module SourceType -> -- | Enabled extensions @@ -189,7 +197,7 @@ -- | Resulting rendition Bool -> Text -runR (R m) sstream cstream printerOpts sourceType extensions moduleFixityMap debug = +runR (R m) sstream cstream printerOpts localModules sourceType extensions moduleFixityMap debug = TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc where rc = @@ -199,6 +207,7 @@ rcEnclosingSpans = [], rcCanUseBraces = False, rcPrinterOpts = printerOpts, + rcLocalModules = localModules, rcExtensions = extensions, rcSourceType = sourceType, rcModuleFixityMap = moduleFixityMap, @@ -250,6 +259,15 @@ R () txt = spit SimpleText +-- | Same as 'txt', except strip leading whitespace equal to the current +-- indentation level. Useful for multiline comments, where the AST contains +-- the full leading whitespace. +txtStripIndent :: Text -> R () +txtStripIndent s = do + indent <- R (asks rcIndent) + let (leadingSpaces, s') = T.span isSpace s + txt $ T.drop indent leadingSpaces <> s' + -- | Similar to 'txt' but the text inserted this way is assumed to break the -- “link” between the preceding atom and its pending comments. interferingTxt :: @@ -342,6 +360,23 @@ declNewline :: R () declNewline = newlineRawN =<< getPrinterOpt poNewlinesBetweenDecls +-- | Add a newline in a multiline comment. +-- +-- Can't use 'newline' because it avoids adding multiple consecutive newlines. +-- Single-line comments don't have this issue because each line has at least "--". +multilineCommentNewline :: R () +multilineCommentNewline = + -- inlining part of rawNewline here because rawNewline still swallows newlines + -- when called consecutively + R . modify $ \sc -> + sc + { scBuilder = scBuilder sc <> "\n", + scColumn = 0, + scIndent = 0, + scThisLineSpans = [], + scRequestedDelimiter = AfterNewline + } + -- | Output a newline. First time 'newline' is used after some non-'newline' -- output it gets inserted immediately. Second use of 'newline' does not -- output anything but makes sure that the next non-white space output will @@ -422,7 +457,37 @@ where modRC rc = rc - { rcIndent = roundDownToNearest step (rcIndent rc) + step + { rcIndent = + -- Currently, in parenthesized expressions, we keep expressions aligned on + -- the left, and increase indentation from that point. But this means that + -- all subsequent indentation levels will be misaligned with the indentation, + -- assuming the parentheses starts on the indentation column: + -- + -- ( Maybe + -- Int -> + -- String + -- ) + -- ^^^^ 'Int' is 4 spaces from indentation start + -- ^^^^^^ but 6 spaces from start of column + -- + -- To fix this, we mitigated the symptom by rounding down the indentation to + -- the indentation first before incrementing. + -- https://github.com/fourmolu/fourmolu/pull/37#discussion_r497904191 + -- + -- But this causes a regression with 2 space indentation, where a wrapped line + -- isn't indented enough if the parentheses does NOT start on the indentation + -- column. + -- https://github.com/fourmolu/fourmolu/issues/428 + -- + -- Ideally, we'd rather indicate that the "current" indentation is shifted, + -- while the "next" indentation should increase from the parentheses. However, + -- that would probably be a lot of reworking the rcIndent machinery. Instead, + -- we'll just restrict this patch to only apply on indentation > 2. + let modifyIndent = + if poIndentation (rcPrinterOpts rc) > 2 + then roundDownToNearest step + else id + in modifyIndent (rcIndent rc) + step } roundDownToNearest r n = (n `div` r) * r @@ -492,6 +557,9 @@ -- | Get a particular 'PrinterOpts' field from the environment. getPrinterOpt :: (forall f. PrinterOpts f -> f a) -> R a getPrinterOpt f = R $ asks $ runIdentity . f . rcPrinterOpts + +getLocalModules :: R (Set ModuleName) +getLocalModules = R $ asks rcLocalModules ---------------------------------------------------------------------------- -- Special helpers for comment placement diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -191,30 +191,11 @@ HaddockMultiLineCompact -> True let docStringLines = splitDocString shouldEscapeCommentBraces $ hsDocString str - mSrcSpan <- getSrcSpan l - - let useSingleLineComments = - or - [ poHStyle == HaddockSingleLine, - length docStringLines <= 1, - -- Use multiple single-line comments when the whole comment is indented - maybe False ((> 1) . srcSpanStartCol) mSrcSpan - ] - - let body sep' = - forM_ (zip docStringLines (True : repeat False)) $ \(x, isFirst) -> do - if isFirst - then do - -- prevent trailing space in multi-line comments - unless (not useSingleLineComments && T.null x) space - else do - sep' - unless (T.null x) (txt x) - - if useSingleLineComments + if poHStyle == HaddockSingleLine || length docStringLines <= 1 then do txt $ "-- " <> haddockDelim - body $ newline >> txt "--" >> space + space + sep (newline >> txt "--" >> space) txt docStringLines else do txt . T.concat $ [ "{-", @@ -223,20 +204,13 @@ _ -> " ", haddockDelim ] - -- 'newline' doesn't allow multiple blank newlines, which changes the comment - -- if the user writes a comment with multiple newlines. So we have to do this - -- to force the printer to output a newline. The HaddockSingleLine branch - -- doesn't have this problem because each newline has at least "--". - -- - -- 'newline' also takes indentation into account, but since multiline comments - -- are never used in an indented context (see useSingleLineComments), this is - -- safe - body $ txt "\n" + space + sep multilineCommentNewline txtStripIndent docStringLines newline txt "-}" when (Choice.isTrue needsNewline) newline - traverse_ (setSpanMark . HaddockSpan hstyle) mSrcSpan + traverse_ (setSpanMark . HaddockSpan hstyle) =<< getSrcSpan l where haddockDelim = case hstyle of 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 @@ -16,6 +16,7 @@ import Control.Monad import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With) import Data.Choice qualified as Choice +import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList) @@ -133,8 +134,26 @@ else id sep s (sitcc' . located' (p_conDecl singleRecCon)) dd_cons' unless (null dd_derivs) breakpoint - inci $ sep newline (located' p_hsDerivingClause) dd_derivs + sortDerivingClauses <- getPrinterOpt poSortDerivingClauses + let sortedDeriving = if sortDerivingClauses then sortOn (derivingStrategyKey . fmap unLoc . deriv_clause_strategy . unLoc) dd_derivs else dd_derivs + inci $ sep newline (located' p_hsDerivingClause) sortedDeriving + where + derivingStrategyKey Nothing = ClauseNoStrategy + derivingStrategyKey (Just strategy) = case strategy of + StockStrategy _ -> ClauseStockStrategy + NewtypeStrategy _ -> ClauseNewtypeStrategy + AnyclassStrategy _ -> ClauseAnyclassStrategy + ViaStrategy ty -> ClauseViaStrategy (showOutputable ty) + +data DerivingClauseSortKey + = ClauseNoStrategy + | ClauseStockStrategy + | ClauseNewtypeStrategy + | ClauseAnyclassStrategy + | ClauseViaStrategy String + deriving (Eq, Ord) + p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R () p_conDecl _ ConDeclGADT {..} = do mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc @@ -286,12 +305,14 @@ | [sigTy] <- sigTys, DerivingNever <- singleDerivingParens -> located sigTy p_hsSigType - | otherwise -> + | otherwise -> do + sortDerivedClasses <- getPrinterOpt poSortDerivedClasses + let sort = if sortDerivedClasses then sortOn showOutputable else id parens N $ sep commaDel (sitcc . located' p_hsSigType) - sigTys + (sort sigTys) space case deriv_clause_strategy of Nothing -> do 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 @@ -22,7 +22,7 @@ import GHC.Types.Name (occNameString) import GHC.Types.Name.Reader (RdrName, rdrNameOcc) import GHC.Types.SrcLoc -import Ormolu.Config (poIndentation) +import Ormolu.Config (poIndentation, poTrailingSectionOperators) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common (p_rdrName) import Ormolu.Printer.Meat.Declaration.Value @@ -96,6 +96,8 @@ R () p_exprOpTree s (OpNode x) = located x (p_hsExpr' NotApplicand s) p_exprOpTree s t@(OpBranches exprs@(firstExpr :| otherExprs) ops) = do + trailingSectionOperators <- getPrinterOpt poTrailingSectionOperators + let placement = opBranchPlacement exprPlacement @@ -113,9 +115,11 @@ -- Whether we could place the operator in a trailing position, -- followed by a breakpoint before the RHS couldBeTrailing (prevExpr, opi) = - -- An operator with fixity InfixR 0, like seq, $, and $ variants, - -- is required - isHardSplitterOp (opiFixityApproximation opi) + -- Enabled by config + trailingSectionOperators + -- An operator with fixity InfixR 0, like seq, $, and $ variants, + -- is required + && isHardSplitterOp (opiFixityApproximation opi) -- the LHS must be single-line && isOneLineSpan (opTreeLoc prevExpr) -- can only happen when a breakpoint would have been added anyway 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 @@ -50,8 +50,10 @@ newline mapM_ (p_hsModuleHeader hsmod) hsmodName newline - preserveGroups <- getPrinterOpt poRespectful - forM_ (normalizeImports preserveGroups hsmodImports) $ \importGroup -> do + respectful <- getPrinterOpt poRespectful + localModules <- getLocalModules + importGrouping <- getPrinterOpt poImportGrouping + forM_ (normalizeImports respectful localModules importGrouping hsmodImports) $ \importGroup -> do forM_ importGroup (located' p_hsmodImport) newline declNewline 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 @@ -26,6 +26,7 @@ import Control.Monad import Data.Choice (pattern With, pattern Without) import Data.Functor ((<&>)) +import Data.List (sortOn) import GHC.Data.Strict qualified as Strict import GHC.Hs hiding (isPromoted) import GHC.Types.SourceText @@ -268,7 +269,10 @@ p_hsContext = \case [] -> txt "()" [x] -> located x p_hsType - xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs + xs -> do + shouldSort <- getPrinterOpt poSortConstraints + let sort = if shouldSort then sortOn showOutputable else id + parens N $ sep commaDel (sitcc . located' p_hsType) (sort xs) class IsTyVarBndrFlag flag where isInferred :: flag -> Bool 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 @@ -20,6 +20,7 @@ import Data.Maybe (maybeToList) import Data.Set (Set) import Data.Set qualified as Set +import Distribution.ModuleName (ModuleName) import Distribution.ModuleName qualified as ModuleName import Distribution.PackageDescription import Distribution.PackageDescription.Parsec @@ -56,7 +57,9 @@ -- | Direct dependencies ciDependencies :: !(Set PackageName), -- | Absolute path to the cabal file - ciCabalFilePath :: !FilePath + ciCabalFilePath :: !FilePath, + -- | Local modules + ciModules :: ![ModuleName] } deriving (Eq, Show) @@ -96,7 +99,9 @@ genericPackageDescription :: GenericPackageDescription, -- | Map from Haskell source file paths (without any extensions) to the -- corresponding 'DynOption's and dependencies. - extensionsAndDeps :: Map FilePath ([DynOption], [PackageName]) + extensionsAndDeps :: Map FilePath ([DynOption], [PackageName]), + -- | Modules defined in the cabal file + localModules :: [ModuleName] } deriving (Show) @@ -125,6 +130,7 @@ throwIO . OrmoluCabalFileParsingFailed cabalFile . snd let extensionsAndDeps = getExtensionAndDepsMap cabalFile genericPackageDescription + localModules = getLocalModules genericPackageDescription pure CachedCabalFile {..} let (dynOpts, dependencies, mentioned) = case M.lookup (dropExtensions sourceFileAbs) extensionsAndDeps of @@ -137,12 +143,45 @@ { ciPackageName = pkgName (package pdesc), ciDynOpts = dynOpts, ciDependencies = Set.fromList dependencies, - ciCabalFilePath = cabalFile + ciCabalFilePath = cabalFile, + ciModules = localModules } ) where whenLeft :: (Applicative f) => Either e a -> (e -> f a) -> f a whenLeft eitha ma = either ma pure eitha + +getLocalModules :: GenericPackageDescription -> [ModuleName] +getLocalModules = extractPackageModules + where + extractPackageModules :: GenericPackageDescription -> [ModuleName] + extractPackageModules GenericPackageDescription {..} = + mconcat + [ maybe [] (extractLibraryModules . condTreeData) condLibrary, + extractLibraryModules . condTreeData . snd =<< condSubLibraries, + extractForeignLibraryModules . condTreeData . snd =<< condForeignLibs, + extractExecutableModules . condTreeData . snd =<< condExecutables, + extractTestSuiteModules . condTreeData . snd =<< condTestSuites, + extractBenchmarkModules . condTreeData . snd =<< condBenchmarks + ] + + extractLibraryModules :: Library -> [ModuleName] + extractLibraryModules Library {..} = mconcat [exposedModules, extractBuildInfoModules libBuildInfo] + + extractForeignLibraryModules :: ForeignLib -> [ModuleName] + extractForeignLibraryModules = extractBuildInfoModules . foreignLibBuildInfo + + extractExecutableModules :: Executable -> [ModuleName] + extractExecutableModules = extractBuildInfoModules . buildInfo + + extractTestSuiteModules :: TestSuite -> [ModuleName] + extractTestSuiteModules = extractBuildInfoModules . testBuildInfo + + extractBenchmarkModules :: Benchmark -> [ModuleName] + extractBenchmarkModules = extractBuildInfoModules . benchmarkBuildInfo + + extractBuildInfoModules :: BuildInfo -> [ModuleName] + extractBuildInfoModules BuildInfo {..} = mconcat [otherModules, virtualModules, autogenModules] -- | Get a map from Haskell source file paths (without any extensions) to -- the corresponding 'DynOption's and dependencies. diff --git a/src/Ormolu/Utils/Glob.hs b/src/Ormolu/Utils/Glob.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Utils/Glob.hs @@ -0,0 +1,50 @@ +module Ormolu.Utils.Glob + ( Glob, + mkGlob, + matchesGlob, + ) +where + +import Data.List (elemIndex, stripPrefix) +import Data.Maybe (fromMaybe) + +newtype Glob = Glob [GlobPart] + deriving (Eq, Show) + +data GlobPart + = MatchExactly !String + | SingleWildcard + | DoubleWildcard + deriving (Eq, Show) + +mkGlob :: String -> Glob +mkGlob = Glob . parsePart + where + parsePart :: String -> [GlobPart] + parsePart s = case s of + [] -> + [] + '*' : '*' : t -> + DoubleWildcard : parsePart t + '*' : t -> + SingleWildcard : parsePart t + t -> + let (m, t') = break (== '*') t + in MatchExactly m : parsePart t' + +matchesGlob :: String -> Glob -> Bool +matchesGlob s (Glob ps) = s `matchesGlobParts` ps + +matchesGlobParts :: String -> [GlobPart] -> Bool +matchesGlobParts s g = case g of + [] -> + null s + MatchExactly p : g' -> + case stripPrefix p s of + Nothing -> False + Just s' -> s' `matchesGlobParts` g' + SingleWildcard : g' -> + let l = fromMaybe (length s) (elemIndex '.' s) + in or [s' `matchesGlobParts` g' | i <- [0 .. l], let s' = drop i s] + DoubleWildcard : g' -> + or [s' `matchesGlobParts` g' | i <- [0 .. length s], let s' = drop i s] 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 @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -- | Tests for Fourmolu configuration options. Similar to PrinterSpec.hs @@ -12,25 +11,22 @@ import Control.Exception (catch) import Control.Monad (forM_, when) -import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff) +import Data.Algorithm.DiffContext qualified as Diff import Data.Char (isSpace) +import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (isJust) +import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO.Utf8 qualified as T.Utf8 +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName (mkPackageName) import GHC.Stack (withFrozenCallStack) -import Ormolu - ( Config (..), - PrinterOpts (..), - PrinterOptsTotal, - defaultConfig, - defaultPrinterOpts, - detectSourceType, - ormolu, - ) -import Ormolu.Config (ColumnLimit (..), HaddockPrintStyleModule (..)) +import Ormolu (detectSourceType, ormolu) +import Ormolu.Config import Ormolu.Exception (OrmoluException, printOrmoluException) -import Ormolu.Terminal (ColorMode (..), runTerm) +import Ormolu.Terminal (runTerm) +import Ormolu.Utils.Glob (mkGlob) import Path ( File, Path, @@ -129,6 +125,80 @@ checkIdempotence = True }, TestGroup + { label = "import-grouping", + isMulti = False, + testCases = + [ ImportGroupPreserve, + ImportGroupSingle, + ImportGroupByQualified, + ImportGroupByScope, + ImportGroupByScopeThenQualified, + ImportGroupCustom . NonEmpty.fromList $ + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Data.Text"), + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = defaultImportRulePriority + } + ] + }, + ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = ImportRulePriority 100 + } + ] + }, + ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "SomeInternal.**"), + igrQualifiedMatcher = MatchQualifiedOnly, + igrPriority = defaultImportRulePriority + }, + ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Unknown.**"), + igrQualifiedMatcher = MatchUnqualifiedOnly, + igrPriority = defaultImportRulePriority + } + ] + }, + ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchLocalModules, + igrQualifiedMatcher = MatchUnqualifiedOnly, + igrPriority = defaultImportRulePriority + }, + ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = MatchQualifiedOnly, + igrPriority = defaultImportRulePriority + } + ] + } + ] + ], + updateConfig = \igs opts -> + opts + { poImportGrouping = pure igs + }, + showTestCase = showStrategy, + testCaseSuffix = \igs -> suffixWith [showStrategy igs], + checkIdempotence = True + }, + TestGroup { label = "record-brace-space", isMulti = False, testCases = allOptions, @@ -210,6 +280,42 @@ checkIdempotence = True }, TestGroup + { label = "sort-constraints", + isMulti = False, + testCases = allOptions, + updateConfig = \sortConstraints options -> options {poSortConstraints = pure sortConstraints}, + showTestCase = show, + testCaseSuffix = suffix1, + checkIdempotence = True + }, + TestGroup + { label = "sort-derived-classes", + isMulti = False, + testCases = allOptions, + updateConfig = \sortDerivedClasses opts -> opts {poSortDerivedClasses = pure sortDerivedClasses}, + showTestCase = show, + testCaseSuffix = suffix1, + checkIdempotence = True + }, + TestGroup + { label = "sort-deriving-clauses", + isMulti = False, + testCases = allOptions, + updateConfig = \sortDerivingClauses opts -> opts {poSortDerivingClauses = pure sortDerivingClauses}, + showTestCase = show, + testCaseSuffix = suffix1, + checkIdempotence = True + }, + TestGroup + { label = "trailing-section-operators", + isMulti = False, + testCases = allOptions, + updateConfig = \trailingSectionOperators opts -> opts {poTrailingSectionOperators = pure trailingSectionOperators}, + showTestCase = show, + testCaseSuffix = suffix1, + checkIdempotence = True + }, + TestGroup { label = "unicode-syntax", isMulti = False, testCases = allOptions, @@ -281,7 +387,15 @@ defaultConfig { cfgPrinterOpts = opts, cfgSourceType = detectSourceType inputPath, - cfgCheckIdempotence = checkIdempotence + cfgCheckIdempotence = checkIdempotence, + cfgDependencies = S.fromList [mkPackageName "base"], + cfgLocalModules = + S.fromList $ + ModuleName.fromString + <$> [ "SomeInternal.Module1", + "SomeInternal.Module1.SubModuleA", + "SomeInternal.Module2" + ] } checkResult :: Path Rel File -> Text -> Expectation @@ -332,8 +446,8 @@ getDiff :: (String, Text) -> (String, Text) -> Text getDiff (s1Name, s1) (s2Name, s2) = T.pack . Doc.render $ - prettyContextDiff (Doc.text s1Name) (Doc.text s2Name) (Doc.text . T.unpack) $ - getContextDiff 2 (T.lines s1) (T.lines s2) + Diff.prettyContextDiff (Doc.text s1Name) (Doc.text s2Name) (Doc.text . T.unpack . Diff.unnumber) $ + Diff.getContextDiff (Just 2) (T.lines s1) (T.lines s2) renderOrmoluException :: OrmoluException -> IO String renderOrmoluException e = @@ -360,3 +474,8 @@ spanEnd f xs = let xs' = reverse xs in (reverse $ dropWhile f xs', reverse $ takeWhile f xs') + +showStrategy :: ImportGrouping -> String +showStrategy igs = case igs of + ImportGroupCustom _ -> "custom" + _ -> show igs diff --git a/tests/Ormolu/ConfigSpec.hs b/tests/Ormolu/ConfigSpec.hs --- a/tests/Ormolu/ConfigSpec.hs +++ b/tests/Ormolu/ConfigSpec.hs @@ -4,11 +4,13 @@ module Ormolu.ConfigSpec (spec) where import Data.ByteString.Char8 qualified as Char8 +import Data.List (isInfixOf) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.Yaml qualified as Yaml -import Ormolu.Config (FourmoluConfig (..), poIndentation, resolvePrinterOpts) +import Ormolu.Config (FourmoluConfig (..), ImportGroup (..), ImportGroupRule (..), ImportGrouping (..), ImportModuleMatcher (..), ImportRulePriority (ImportRulePriority), PrinterOpts (..), QualifiedImportMatcher (MatchBothQualifiedAndUnqualified, MatchQualifiedOnly, MatchUnqualifiedOnly), defaultImportRulePriority, matchAllRulePriority, resolvePrinterOpts) import Ormolu.Fixity (ModuleReexports (..)) +import Ormolu.Utils.Glob (mkGlob) import Test.Hspec spec :: Spec @@ -31,3 +33,308 @@ opts2 = mempty {poIndentation = Just 4} configs = [opts1, opts2] poIndentation (resolvePrinterOpts configs) `shouldBe` 4 + + context "when using an import grouping configuration" $ do + it "parses 'legacy' as the 'ImportGroupLegacy' import grouping strategy" $ do + config <- Yaml.decodeThrow "import-grouping: legacy" + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + actualStrategy `shouldBe` Just ImportGroupLegacy + it "parses 'preserve' as the 'ImportGroupPreserve' import grouping strategy" $ do + config <- Yaml.decodeThrow "import-grouping: preserve" + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + actualStrategy `shouldBe` Just ImportGroupPreserve + it "parses 'single' as the 'ImportGroupSingle' import grouping strategy" $ do + config <- Yaml.decodeThrow "import-grouping: single" + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + actualStrategy `shouldBe` Just ImportGroupSingle + it "parses 'by-qualified' as the 'ImportGroupByQualified' import grouping strategy" $ do + config <- Yaml.decodeThrow "import-grouping: by-qualified" + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + actualStrategy `shouldBe` Just ImportGroupByQualified + it "parses 'by-scope' as the 'ImportGroupByScope' import grouping strategy" $ do + config <- Yaml.decodeThrow "import-grouping: by-scope" + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + actualStrategy `shouldBe` Just ImportGroupByScope + it "parses 'by-scope-then-qualified' as the 'ImportGroupByScopeThenQualified' import grouping strategy" $ do + config <- Yaml.decodeThrow "import-grouping: by-scope-then-qualified" + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + actualStrategy `shouldBe` Just ImportGroupByScopeThenQualified + it "fails when an unknown strategy is requested" $ do + let decodeResult = Yaml.decodeEither' @FourmoluConfig "import-grouping: fake-strategy" + isAnUnknownStrategyValue e = case e of + Left (Yaml.AesonException msg) -> "unknown strategy value" `isInfixOf` msg + _ -> False + decodeResult `shouldSatisfy` isAnUnknownStrategyValue + it "parses a grouping rule's name" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - name: Some name", + " rules:", + " - match: all" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Just "Some name", + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = matchAllRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "enables the 'qualified' rule option" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - glob: \"**\"", + " qualified: yes" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "**"), + igrQualifiedMatcher = MatchQualifiedOnly, + igrPriority = defaultImportRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "disables the 'qualified' rule option" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - glob: \"**\"", + " qualified: no" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "**"), + igrQualifiedMatcher = MatchUnqualifiedOnly, + igrPriority = defaultImportRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "decodes the 'priority' rule option" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - match: all", + " priority: 55" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = ImportRulePriority 55 + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "parses a 'glob' rule" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - glob: Data.Text.**" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Data.Text.**"), + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = defaultImportRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "parses a 'match' rule for local modules" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - match: local-modules" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchLocalModules, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = defaultImportRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "parses a 'match' rule for all modules" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - match: all" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Nothing, + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = matchAllRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "parses multiple group configurations and rules in their order of appearance in the configuration" $ do + config <- + Yaml.decodeThrow . Char8.pack . unlines $ + [ "import-grouping:", + " - name: Text modules", + " rules:", + " - glob: Data.Text", + " - name: The rest", + " rules:", + " - match: all", + " priority: 100", + " - name: My internals and monads unqualified", + " rules:", + " - match: local-modules", + " qualified: no", + " - glob: Control.Monad", + " qualified: no", + " - name: My internals and monads qualified", + " rules:", + " - match: local-modules", + " qualified: yes", + " - glob: Control.Monad", + " qualified: yes", + " - name: Specific monads", + " rules:", + " - glob: Control.Monad.**" + ] + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + expectedRules = + NonEmpty.fromList + [ ImportGroup + { igName = Just "Text modules", + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Data.Text"), + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = defaultImportRulePriority + } + ] + }, + ImportGroup + { igName = Just "The rest", + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchAllModules, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = ImportRulePriority 100 + } + ] + }, + ImportGroup + { igName = Just "My internals and monads unqualified", + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchLocalModules, + igrQualifiedMatcher = MatchUnqualifiedOnly, + igrPriority = defaultImportRulePriority + }, + ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad"), + igrQualifiedMatcher = MatchUnqualifiedOnly, + igrPriority = defaultImportRulePriority + } + ] + }, + ImportGroup + { igName = Just "My internals and monads qualified", + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchLocalModules, + igrQualifiedMatcher = MatchQualifiedOnly, + igrPriority = defaultImportRulePriority + }, + ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad"), + igrQualifiedMatcher = MatchQualifiedOnly, + igrPriority = defaultImportRulePriority + } + ] + }, + ImportGroup + { igName = Just "Specific monads", + igRules = + NonEmpty.fromList + [ ImportGroupRule + { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad.**"), + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrPriority = defaultImportRulePriority + } + ] + } + ] + actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + it "fails when a rule cannot be identified" $ do + let decodeResult = + Yaml.decodeEither' @FourmoluConfig . Char8.pack . unlines $ + [ "import-grouping:", + " - rules:", + " - some-unknown-rule-type: whatever" + ] + isAnUnknownModuleMatcher e = case e of + Left (Yaml.AesonException msg) -> "Unknown or invalid module matcher" `isInfixOf` msg + _ -> False + decodeResult `shouldSatisfy` isAnUnknownModuleMatcher diff --git a/tests/Ormolu/Utils/GlobSpec.hs b/tests/Ormolu/Utils/GlobSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/Utils/GlobSpec.hs @@ -0,0 +1,50 @@ +module Ormolu.Utils.GlobSpec (spec) where + +import Ormolu.Utils.Glob (matchesGlob, mkGlob) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (..), listOf, suchThat) + +newtype Wildcardless = Wildcardless String + deriving (Show) + +instance Arbitrary Wildcardless where + arbitrary = fmap Wildcardless $ listOf (arbitrary `suchThat` (/= '*')) + +newtype ModuleName = ModuleName String + deriving (Show) + +instance Arbitrary ModuleName where + arbitrary = fmap ModuleName $ listOf (arbitrary `suchThat` (/= '.')) `suchThat` (not . null) + +spec :: Spec +spec = + describe "glob" $ do + it "should match modules exactly" $ + "Hello.world" `matchesGlob` mkGlob "Hello.world" `shouldBe` True + it "should fail if case doesn't match" $ + "Some.thing" `matchesGlob` mkGlob "Some.Thing" `shouldBe` False + it "should allow * to match anything on the same level" $ + "Level1.Level2.Level3" `matchesGlob` mkGlob "Level1.Le*2.Level3" `shouldBe` True + it "should fail if input doesn't match glob even with wildcards" $ + "Control.Monad.Writer.Lazy" `matchesGlob` mkGlob "Data.Functor.*.Lazy" `shouldBe` False + it "should disallow * to match anything on different level" $ + "Level1.Level2.Level3.Level4" `matchesGlob` mkGlob "Level1.*.Level4" `shouldBe` False + it "should allow multiple *" $ + "Some.Fake.Path.With.Internals" `matchesGlob` mkGlob "Some.*.Path.*.Internals" `shouldBe` True + it "should allow * at the beginning" $ + "MyApp42.Control.Monad" `matchesGlob` mkGlob "*42.Control.Monad" `shouldBe` True + it "should allow * at the end" $ + "System.IO.Stuff" `matchesGlob` mkGlob "System.IO.*" `shouldBe` True + it "should allow ** to match anything on the same level" $ + "Level1.Level2.Level3" `matchesGlob` mkGlob "Level1.L**2.Level3" `shouldBe` True + it "should allow ** to match anything on multiple levels" $ + "Level1.Level2.Level3.Level4.Level5" `matchesGlob` mkGlob "Level1.L**4.Level5" `shouldBe` True + + describe "Properties" $ do + prop "should obey: s `matches` glob s with s being any string without '*'" $ + \(Wildcardless s) -> s `matchesGlob` mkGlob s + prop "should obey: (a <> b <> c) `matches` glob (a <> * <> c) with b being a module name" $ + \a (ModuleName b) c -> (a <> b <> c) `matchesGlob` mkGlob (a <> "*" <> c) + prop "should obey: (a <> b <> c) `matches` glob (a <> ** <> c)" $ + \a b c -> (a <> b <> c) `matchesGlob` mkGlob (a <> "**" <> c)