diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,25 @@ +## Fourmolu 0.14.0.0 + +* Provide `resolvePrinterOpts` instead of `fillMissingPrinterOpts` + +* Format configuration better in `--debug` output + +### Upstream changes: + +#### Ormolu 0.7.2.0 + +* Preserve necessary braces for final function arguments. [Issue + 1044](https://github.com/tweag/ormolu/issues/1044). + +* Put `"this"` `PackageImports` at the end. [Issue + 1048](https://github.com/tweag/ormolu/issues/1048). + +* Format parenthesized operators starting with a `#` correctly in the presence + of `UnboxedSums`. [Issue 1062](https://github.com/tweag/ormolu/issues/1062). + +* Fix false positives in AST diffing related to empty Haddock comments in data + declarations. [Issue 1065](https://github.com/tweag/ormolu/issues/1065). + ## Fourmolu 0.13.1.0 * Fix `single-constraint-parens: never` with `QuantifiedConstraints` ([#340](https://github.com/fourmolu/fourmolu/issues/340)) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -86,8 +86,8 @@ ```bash $ fourmolu --mode inplace $(git ls-files '*.hs') -# Or to avoid hitting command line length limits: -$ git ls-files -z '*.hs' | xargs -0 fourmolu --mode inplace +# Or to avoid hitting command line length limits and enable parallelism (12-way here): +$ git ls-files -z '*.hs' | xargs -P 12 -0 fourmolu --mode inplace ``` To check if files are already formatted (useful on CI): @@ -237,8 +237,6 @@ works only in simple cases when CPP conditionals surround top-level 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. -* Input modules should be parsable by Haddock, which is a bit stricter - criterion than just being valid Haskell modules. * Various minor idempotence issues, most of them are related to comments 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`. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -83,7 +83,7 @@ loadConfigFile path >>= \case ConfigLoaded f cfg -> do outputInfo $ "Loaded config from: " <> f - outputDebug $ show cfg + outputDebug $ unwords ["*** CONFIG FILE ***", show cfg] pure cfg ConfigParseError f e -> do outputError . unlines $ @@ -99,9 +99,10 @@ return $ cliConfig { cfgPrinterOpts = - fillMissingPrinterOpts cliPrinterOpts - . fillMissingPrinterOpts (cfgFilePrinterOpts fourmoluConfig) - $ defaultPrinterOpts, + resolvePrinterOpts + [ cliPrinterOpts, + cfgFilePrinterOpts fourmoluConfig + ], cfgFixityOverrides = FixityOverrides . mconcat . map unFixityOverrides $ [ cfgFixityOverrides cliConfig, diff --git a/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-four-out.hs b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedSums #-} + +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-out.hs b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedSums #-} + +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-with-unboxed-sums.hs b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedSums #-} + +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-four-out.hs b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-four-out.hs @@ -0,0 +1,6 @@ +module Foo ((#<|)) where + +(#<|) :: Int -> Int -> Int +(#<|) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-out.hs b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-out.hs @@ -0,0 +1,6 @@ +module Foo ((#<|)) where + +(#<|) :: Int -> Int -> Int +(#<|) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-without-unboxed-sums.hs b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums.hs @@ -0,0 +1,6 @@ +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/import/sorted-package-imports-four-out.hs b/data/examples/import/sorted-package-imports-four-out.hs --- a/data/examples/import/sorted-package-imports-four-out.hs +++ b/data/examples/import/sorted-package-imports-four-out.hs @@ -5,3 +5,6 @@ import "b" Aa import "b" Bb import "c" Ba + +import "zzzz" Z +import "this" Y diff --git a/data/examples/import/sorted-package-imports-out.hs b/data/examples/import/sorted-package-imports-out.hs --- a/data/examples/import/sorted-package-imports-out.hs +++ b/data/examples/import/sorted-package-imports-out.hs @@ -5,3 +5,5 @@ import "b" Aa import "b" Bb import "c" Ba +import "zzzz" Z +import "this" Y diff --git a/data/examples/import/sorted-package-imports.hs b/data/examples/import/sorted-package-imports.hs --- a/data/examples/import/sorted-package-imports.hs +++ b/data/examples/import/sorted-package-imports.hs @@ -5,3 +5,6 @@ import "c" Ba import D import "b" Bb + +import "this" Y +import "zzzz" Z diff --git a/data/examples/other/empty-haddock-four-out.hs b/data/examples/other/empty-haddock-four-out.hs --- a/data/examples/other/empty-haddock-four-out.hs +++ b/data/examples/other/empty-haddock-four-out.hs @@ -5,3 +5,5 @@ test :: test + +data T = T diff --git a/data/examples/other/empty-haddock-out.hs b/data/examples/other/empty-haddock-out.hs --- a/data/examples/other/empty-haddock-out.hs +++ b/data/examples/other/empty-haddock-out.hs @@ -5,3 +5,5 @@ test :: test + +data T = T diff --git a/data/examples/other/empty-haddock.hs b/data/examples/other/empty-haddock.hs --- a/data/examples/other/empty-haddock.hs +++ b/data/examples/other/empty-haddock.hs @@ -9,3 +9,5 @@ test :: -- | test + +data T = T {- ^ -} diff --git a/data/examples/other/necessary-brackets-four-out.hs b/data/examples/other/necessary-brackets-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/necessary-brackets-four-out.hs @@ -0,0 +1,3 @@ +insertEmDash = Text.concat . map \case { x | x == "--" -> "—"; x -> x } . Text.groupBy ((==) `on` Char.isSpace) + +foo f a b c = f do { a } + f do { b } + f do c diff --git a/data/examples/other/necessary-brackets-out.hs b/data/examples/other/necessary-brackets-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/necessary-brackets-out.hs @@ -0,0 +1,3 @@ +insertEmDash = Text.concat . map \case { x | x == "--" -> "—"; x -> x } . Text.groupBy ((==) `on` Char.isSpace) + +foo f a b c = f do { a } + f do { b } + f do c diff --git a/data/examples/other/necessary-brackets.hs b/data/examples/other/necessary-brackets.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/necessary-brackets.hs @@ -0,0 +1,3 @@ +insertEmDash = Text.concat . map \case{ x | x == "--" -> "—"; x -> x } . Text.groupBy ((==) `on` Char.isSpace) + +foo f a b c = f do {a} + f do {b} + f do {c} diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,13 +1,13 @@ cabal-version: 2.4 name: fourmolu -version: 0.13.1.0 +version: 0.14.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Matt Parsons George Thomas Brandon Chinn -tested-with: ghc ==9.2.7 ghc ==9.4.4 ghc ==9.6.1 +tested-with: ghc ==9.2.8 ghc ==9.4.5 ghc ==9.6.2 homepage: https://github.com/fourmolu/fourmolu bug-reports: https://github.com/fourmolu/fourmolu/issues synopsis: A formatter for Haskell source code @@ -112,9 +112,9 @@ array >=0.5 && <0.6, base >=4.14 && <5.0, binary >=0.8 && <0.9, - bytestring >=0.2 && <0.12, + bytestring >=0.2 && <0.13, containers >=0.5 && <0.7, - deepseq >=1.4 && <1.5, + deepseq >=1.4 && <1.6, directory ^>=1.3, file-embed >=0.0.15 && <0.1, filepath >=1.2 && <1.5, diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -25,7 +25,7 @@ loadConfigFile, ConfigFileLoadResult (..), configFileName, - fillMissingPrinterOpts, + resolvePrinterOpts, -- * Cabal info CabalUtils.CabalSearchResult (..), @@ -61,7 +61,7 @@ import Ormolu.Exception import Ormolu.Fixity import Ormolu.Parser -import Ormolu.Parser.CommentStream (showCommentStream) +import Ormolu.Parser.CommentStream (CommentStream (..)) import Ormolu.Parser.Result import Ormolu.Printer import Ormolu.Utils (showOutputable) @@ -97,13 +97,18 @@ fixityMap = packageFixityMap (overapproximatedDependencies cfg) -- memoized on the set of dependencies + when (cfgDebug cfg) $ do + traceM $ unwords ["*** CONFIG ***", show cfg] (warnings, result0) <- parseModule' cfg fixityMap OrmoluParsingFailed path originalInput when (cfgDebug cfg) $ do - traceM "warnings:\n" - traceM (concatMap showWarn warnings) + forM_ warnings $ \(GHC.Warn reason (L loc msg)) -> + traceM $ unwords ["*** WARNING ***", showOutputable loc, msg, showOutputable reason] forM_ result0 $ \case - ParsedSnippet r -> traceM . showCommentStream . prCommentStream $ r + ParsedSnippet r -> do + let CommentStream comments = prCommentStream r + forM_ comments $ \(L loc comment) -> + traceM $ unwords ["*** COMMENT ***", showOutputable loc, show comment] _ -> pure () -- We're forcing 'formattedText' here because otherwise errors (such as -- messages about not-yet-supported functionality) will be thrown later @@ -251,14 +256,6 @@ case r of Left (spn, err) -> liftIO $ throwIO (mkException spn err) Right x -> return (warnings, x) - --- | Pretty-print a 'GHC.Warn'. -showWarn :: GHC.Warn -> String -showWarn (GHC.Warn reason l) = - unlines - [ showOutputable reason, - unLoc l - ] -- | Detect 'SourceType' based on the file extension. detectSourceType :: FilePath -> SourceType diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -32,6 +32,7 @@ defaultPrinterOpts, defaultPrinterOptsYaml, fillMissingPrinterOpts, + resolvePrinterOpts, CommaStyle (..), FunctionArrowsStyle (..), HaddockPrintStyle (..), @@ -226,6 +227,10 @@ deriving instance Eq PrinterOptsTotal deriving instance Show PrinterOptsTotal + +-- | Apply the given configuration in order (later options override earlier). +resolvePrinterOpts :: [PrinterOptsPartial] -> PrinterOptsTotal +resolvePrinterOpts = foldr fillMissingPrinterOpts defaultPrinterOpts ---------------------------------------------------------------------------- -- Loading Fourmolu configuration diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | Manipulations on import lists. module Ormolu.Imports @@ -73,7 +74,7 @@ -- the same 'ImportId' they can be merged. data ImportId = ImportId { importIsPrelude :: Bool, - importPkgQual :: Maybe LexicalFastString, + importPkgQual :: ImportPkgQual, importIdName :: ModuleName, importSource :: IsBootInterface, importSafe :: Bool, @@ -83,6 +84,23 @@ } deriving (Eq, Ord) +data ImportPkgQual + = -- | The import is not qualified by a package name. + NoImportPkgQual + | -- | The import is qualified by an external package name. + ImportPkgQual LexicalFastString + | -- | The import is qualified by the current package being built, using the + -- special @this@ package name. + ImportPkgQualThis + deriving stock (Eq, Ord) + +mkImportPkgQual :: RawPkgQual -> ImportPkgQual +mkImportPkgQual = \case + NoRawPkgQual -> NoImportPkgQual + RawPkgQual (sl_fs -> fs) + | fs == mkFastString "this" -> ImportPkgQualThis + | otherwise -> ImportPkgQual (LexicalFastString fs) + -- | 'ImportListInterpretation' does not have an 'Ord' instance. newtype ImportListInterpretationOrd = ImportListInterpretationOrd { unImportListInterpretationOrd :: ImportListInterpretation @@ -101,7 +119,7 @@ ImportId { importIsPrelude = isPrelude, importIdName = moduleName, - importPkgQual = rawPkgQualToLFS ideclPkgQual, + importPkgQual = mkImportPkgQual ideclPkgQual, importSource = ideclSource, importSafe = ideclSafe, importQualified = case ideclQualified of @@ -114,9 +132,6 @@ where isPrelude = moduleNameString moduleName == "Prelude" moduleName = unLoc ideclName - rawPkgQualToLFS = \case - RawPkgQual fs -> Just . LexicalFastString . sl_fs $ fs - NoRawPkgQual -> Nothing -- | Normalize a collection of import\/export items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -179,7 +179,7 @@ normalizeModule :: Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs normalizeModule Config {..} hsmod = everywhere - (extT (mkT dropBlankTypeHaddocks) patchContext) + (mkT dropBlankTypeHaddocks `extT` dropBlankDataDeclHaddocks `extT` patchContext) hsmod { hsmodImports = hsmodImports hsmod, @@ -206,6 +206,13 @@ L _ (HsDocTy _ ty s) :: LHsType GhcPs | isBlankDocString s -> ty a -> a + dropBlankDataDeclHaddocks = \case + ConDeclGADT {con_doc = Just s, ..} :: ConDecl GhcPs + | isBlankDocString s -> ConDeclGADT {con_doc = Nothing, ..} + ConDeclH98 {con_doc = Just s, ..} :: ConDecl GhcPs + | isBlankDocString s -> ConDeclH98 {con_doc = Nothing, ..} + a -> a + patchContext :: LHsContext GhcPs -> LHsContext GhcPs patchContext = fmap $ \case [x@(L _ (HsParTy _ inner))] diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -7,7 +7,6 @@ ( -- * Comment stream CommentStream (..), mkCommentStream, - showCommentStream, -- * Comment LComment, @@ -38,7 +37,7 @@ import GHC.Parser.Annotation qualified as GHC import GHC.Types.SrcLoc import Ormolu.Parser.Pragma -import Ormolu.Utils (onTheSameLine, showOutputable) +import Ormolu.Utils (onTheSameLine) ---------------------------------------------------------------------------- -- Comment stream @@ -104,14 +103,6 @@ _ -> False only :: a -> Bool only _ = True - --- | Pretty-print a 'CommentStream'. -showCommentStream :: CommentStream -> String -showCommentStream (CommentStream xs) = - unlines $ - showComment <$> xs - where - showComment (L l str) = showOutputable l ++ " " ++ show str ---------------------------------------------------------------------------- -- Comment diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- | Rendering of commonly useful bits. module Ormolu.Printer.Meat.Common @@ -21,8 +22,9 @@ import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp +import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Parser.Annotation -import GHC.Types.Name.Occurrence (OccName (..)) +import GHC.Types.Name.Occurrence (OccName (..), occNameString) import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc @@ -63,15 +65,27 @@ -- | Render a @'LocatedN' 'RdrName'@. p_rdrName :: LocatedN RdrName -> R () p_rdrName l = located l $ \x -> do + unboxedSums <- isExtensionEnabled UnboxedSums let wrapper = \case EpAnn {anns} -> case anns of NameAnnQuote {nann_quoted} -> tickPrefix . wrapper (ann nann_quoted) - NameAnn {nann_adornment = NameParens} -> parens N + NameAnn {nann_adornment = NameParens} -> + parens N . handleUnboxedSumsAndHashInteraction NameAnn {nann_adornment = NameBackquotes} -> backticks -- special case for unboxed unit tuples NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)" _ -> id EpAnnNotUsed -> id + + -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to + -- insert spaces when we have a parenthesized operator starting with `#`. + handleUnboxedSumsAndHashInteraction + | unboxedSums, + -- Qualified names do not start wth a `#`. + Unqual (occNameString -> '#' : _) <- x = + \y -> space *> y <* space + | otherwise = id + wrapper (ann . getLoc $ l) $ case x of Unqual occName -> atom occName diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -497,9 +497,18 @@ p_stmts isApp placer render es = do breakpoint ub <- layoutToBraces <$> getLayout + let p_stmtExt (relPos, stmt) = + ub' $ withSpacing (p_stmt' placer render) stmt + where + -- We need to set brace usage information for all but the last + -- statement (e.g.in the case of nested do blocks). + ub' = case relPos of + FirstPos -> ub + MiddlePos -> ub + LastPos -> id + SinglePos -> id inciApplicand isApp . located es $ - sepSemi - (ub . withSpacing (p_stmt' placer render)) + sepSemi p_stmtExt . attachRelativePos gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]] gatherStmt (L _ (ParStmt _ block _ _)) = @@ -675,7 +684,7 @@ located func (p_hsExpr' Applicand s) breakpoint sep breakpoint (located' p_hsExpr) initp - placeHanging placement . dontUseBraces $ + placeHanging placement $ located lastp p_hsExpr HsAppType _ e _ a -> do located e p_hsExpr diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -31,12 +31,12 @@ loadConfigFile "fourmolu.yaml" >>= \case ConfigLoaded _ cfg -> pure cfg result -> error $ "Could not load config file: " ++ show result - let fourmoluConfig = emptyConfig + let ormoluPrinterOpts = resolvePrinterOpts [cfgFilePrinterOpts ormoluConfig] es <- runIO locateExamples sequence_ $ checkExample - <$> [(ormoluConfig, "ormolu", "-out"), (fourmoluConfig, "fourmolu", "-four-out")] + <$> [(ormoluPrinterOpts, "ormolu", "-out"), (defaultPrinterOpts, "fourmolu", "-four-out")] <*> es -- | Fixity overrides that are to be used with the test examples. @@ -50,19 +50,15 @@ ) -- | Check a single given example. -checkExample :: (FourmoluConfig, String, String) -> Path Rel File -> Spec -checkExample (cfg, label, suffix) srcPath' = it (fromRelFile srcPath' ++ " works (" ++ label ++ ")") . withNiceExceptions $ do +checkExample :: (PrinterOptsTotal, String, String) -> Path Rel File -> Spec +checkExample (printerOpts, label, suffix) srcPath' = it (fromRelFile srcPath' ++ " works (" ++ label ++ ")") . withNiceExceptions $ do let srcPath = examplesDir srcPath' inputPath = fromRelFile srcPath config = defaultConfig - { cfgPrinterOpts = fillMissingPrinterOpts (cfgFilePrinterOpts cfg) defaultPrinterOpts, + { cfgPrinterOpts = printerOpts, cfgSourceType = detectSourceType inputPath, - cfgFixityOverrides = - FixityOverrides . mconcat . map unFixityOverrides $ - [ testsuiteOverrides, - cfgFileFixities cfg - ], + cfgFixityOverrides = testsuiteOverrides, cfgDependencies = Set.fromList [ "base",