diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,19 @@ +## Ormolu 0.7.4.0 + +* Don't error when the `JavaScriptFFI` language pragma is present. [Issue + 1087](https://github.com/tweag/ormolu/issues/1087). +* Improve comment placement in if-then-else blocks. [Issue + 998](https://github.com/tweag/ormolu/issues/998). +* Now command line options for fixity overrides and module re-exports + overwrite information from `.ormolu` files. [Issue + 1030](https://github.com/tweag/ormolu/issues/1030). +* Respect newlines in data declarations in more cases. [Issue + 1077](https://github.com/tweag/ormolu/issues/1077) and [issue + 947](https://github.com/tweag/ormolu/issues/947). +* The `-d / --debug` command line option now makes Ormolu print out debug + information regarding operator fixity inference. [Issue + 1060](https://github.com/tweag/ormolu/issues/1060). + ## Ormolu 0.7.3.0 * Switched to `ghc-lib-parser-9.8`, with the following new syntactic features: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,6 +18,8 @@ * [Regions](#regions) * [Exit codes](#exit-codes) * [Using as a library](#using-as-a-library) +* [Troubleshooting](#troubleshooting) + * [Operators are being formatted weirdly!](#operators-are-being-formatted-weirdly) * [Limitations](#limitations) * [Running on Hackage](#running-on-hackage) * [Forks and modifications](#forks-and-modifications) @@ -271,6 +273,32 @@ For these purposes only the top `Ormolu` module should be considered stable. It follows [PVP](https://pvp.haskell.org/) starting from the version 0.5.3.0. Rely on other modules at your own risk. + +## Troubleshooting + +### Operators are being formatted weirdly! + +This can happen when Ormolu doesn't know or can't determine the fixity of an +operator. + +* 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. + +* 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 + same as the third-party one. + + Some reasons this might be the case: + + * You might have a custom Prelude that re-exports things from Prelude + * You might have `-XNoImplicitPrelude` turned on + + If any of these are true, make sure to specify the reexports correctly in + a `.ormolu` file. + +You can see how Ormolu decides the fixity of operators if you use `--debug`. ## Limitations diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -168,15 +168,17 @@ fromMaybe ModuleSource (reqSourceType <|> mdetectedSourceType) - let mfixityOverrides = fst <$> mdotOrmolu - mmoduleReexports = snd <$> mdotOrmolu return $ refineConfig sourceType mcabalInfo - mfixityOverrides - mmoduleReexports - rawConfig + (Just (cfgFixityOverrides rawConfig)) + (Just (cfgModuleReexports rawConfig)) + ( rawConfig + { cfgFixityOverrides = maybe defaultFixityOverrides fst mdotOrmolu, + cfgModuleReexports = maybe defaultModuleReexports snd mdotOrmolu + } + ) handleDiff originalInput formattedInput fileRepr = case diffText originalInput formattedInput fileRepr of Nothing -> return ExitSuccess diff --git a/data/examples/declaration/data/ctype-0-out.hs b/data/examples/declaration/data/ctype-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-0-out.hs @@ -0,0 +1,1 @@ +data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/ctype-0.hs b/data/examples/declaration/data/ctype-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-0.hs @@ -0,0 +1,1 @@ +data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/ctype-1-out.hs b/data/examples/declaration/data/ctype-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-1-out.hs @@ -0,0 +1,6 @@ +data + {-# CTYPE "header.h" "an-ffi-type-with-along-name" #-} + AnFFITypeWithAlongName = AnFFITypeWithAlongName + { a :: X, + b :: Y + } diff --git a/data/examples/declaration/data/ctype-1.hs b/data/examples/declaration/data/ctype-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-1.hs @@ -0,0 +1,6 @@ +data + {-# CTYPE "header.h" "an-ffi-type-with-along-name" #-} + AnFFITypeWithAlongName = AnFFITypeWithAlongName + { a :: X, + b :: Y + } diff --git a/data/examples/declaration/data/ctype-out.hs b/data/examples/declaration/data/ctype-out.hs deleted file mode 100644 --- a/data/examples/declaration/data/ctype-out.hs +++ /dev/null @@ -1,1 +0,0 @@ -data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/ctype.hs b/data/examples/declaration/data/ctype.hs deleted file mode 100644 --- a/data/examples/declaration/data/ctype.hs +++ /dev/null @@ -1,1 +0,0 @@ -data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/field-layout/record-0-out.hs b/data/examples/declaration/data/field-layout/record-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-0-out.hs @@ -0,0 +1,10 @@ +-- | Foo. +data Foo = Foo + { -- | Something + foo :: Foo Int Int, + -- | Something else + bar :: + Bar + Char + Char + } diff --git a/data/examples/declaration/data/field-layout/record-0.hs b/data/examples/declaration/data/field-layout/record-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-0.hs @@ -0,0 +1,9 @@ +-- | Foo. + +data Foo = Foo + { foo :: Foo Int Int + -- ^ Something + , bar :: Bar Char + Char + -- ^ Something else + } diff --git a/data/examples/declaration/data/field-layout/record-1-out.hs b/data/examples/declaration/data/field-layout/record-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-1-out.hs @@ -0,0 +1,11 @@ +-- | Foo. +data Foo + = Foo + { -- | Something + foo :: Foo Int Int, + -- | Something else + bar :: + Bar + Char + Char + } diff --git a/data/examples/declaration/data/field-layout/record-1.hs b/data/examples/declaration/data/field-layout/record-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-1.hs @@ -0,0 +1,10 @@ +-- | Foo. + +data Foo = + Foo + { foo :: Foo Int Int + -- ^ Something + , bar :: Bar Char + Char + -- ^ Something else + } diff --git a/data/examples/declaration/data/field-layout/record-2-out.hs b/data/examples/declaration/data/field-layout/record-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-2-out.hs @@ -0,0 +1,7 @@ +data IndexWithInfo schema + = forall x. + IndexWithInfo + { checkedIndex :: Index schema x, + checkedIndexName :: U.Variable, + checkedIndexType :: Type x + } diff --git a/data/examples/declaration/data/field-layout/record-2.hs b/data/examples/declaration/data/field-layout/record-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-2.hs @@ -0,0 +1,7 @@ +data IndexWithInfo schema = + forall x. + IndexWithInfo + { checkedIndex :: Index schema x + , checkedIndexName :: U.Variable + , checkedIndexType :: Type x + } diff --git a/data/examples/declaration/data/field-layout/record-out.hs b/data/examples/declaration/data/field-layout/record-out.hs deleted file mode 100644 --- a/data/examples/declaration/data/field-layout/record-out.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - --- | Foo. -data Foo = Foo - { -- | Something - foo :: Foo Int Int, - -- | Something else - bar :: - Bar - Char - Char - } diff --git a/data/examples/declaration/data/field-layout/record.hs b/data/examples/declaration/data/field-layout/record.hs deleted file mode 100644 --- a/data/examples/declaration/data/field-layout/record.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - --- | Foo. - -data Foo = Foo - { foo :: Foo Int Int - -- ^ Something - , bar :: Bar Char - Char - -- ^ Something else - } diff --git a/data/examples/declaration/data/record-fancy-existential-out.hs b/data/examples/declaration/data/record-fancy-existential-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-fancy-existential-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a b. (Show a, Eq b) => Bar + { foo :: a, + bars :: b + } diff --git a/data/examples/declaration/data/record-fancy-existential.hs b/data/examples/declaration/data/record-fancy-existential.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-fancy-existential.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExistentialQuantification #-} +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } diff --git a/data/examples/declaration/data/simple-broken-out.hs b/data/examples/declaration/data/simple-broken-out.hs --- a/data/examples/declaration/data/simple-broken-out.hs +++ b/data/examples/declaration/data/simple-broken-out.hs @@ -1,7 +1,8 @@ module Main where -- | Here we go. -data Foo = Foo {unFoo :: Int} +data Foo + = Foo {unFoo :: Int} deriving (Eq) -- | And once again. diff --git a/data/examples/declaration/value/function/if-single-line-functions-do-out.hs b/data/examples/declaration/value/function/if-single-line-functions-do-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions-do-out.hs @@ -0,0 +1,5 @@ +foo x = do + y <- quux + if x > 2 + then bar x + else baz y diff --git a/data/examples/declaration/value/function/if-single-line-functions-do.hs b/data/examples/declaration/value/function/if-single-line-functions-do.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions-do.hs @@ -0,0 +1,5 @@ +foo x = do + y <- quux + if x > 2 + then bar x + else baz y diff --git a/data/examples/declaration/value/function/if-single-line-functions-out.hs b/data/examples/declaration/value/function/if-single-line-functions-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions-out.hs @@ -0,0 +1,4 @@ +foo x = + if x > 2 + then bar x + else baz x diff --git a/data/examples/declaration/value/function/if-single-line-functions.hs b/data/examples/declaration/value/function/if-single-line-functions.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions.hs @@ -0,0 +1,4 @@ +foo x = + if x > 2 + then bar x + else baz x diff --git a/data/examples/declaration/value/function/if-with-comment-above-branches-out.hs b/data/examples/declaration/value/function/if-with-comment-above-branches-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-above-branches-out.hs @@ -0,0 +1,7 @@ +foo = + if undefined + -- then comment + then undefined + -- else comment + else do + undefined diff --git a/data/examples/declaration/value/function/if-with-comment-above-branches.hs b/data/examples/declaration/value/function/if-with-comment-above-branches.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-above-branches.hs @@ -0,0 +1,8 @@ +foo = + if undefined + -- then comment + then undefined + -- else comment + else + do + undefined diff --git a/data/examples/declaration/value/function/if-with-comment-before-do-blocks-out.hs b/data/examples/declaration/value/function/if-with-comment-before-do-blocks-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-before-do-blocks-out.hs @@ -0,0 +1,10 @@ +foo = + if something + -- then comment + then do + stuff + stuff + -- else comment + else do + stuff + stuff diff --git a/data/examples/declaration/value/function/if-with-comment-before-do-blocks.hs b/data/examples/declaration/value/function/if-with-comment-before-do-blocks.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-before-do-blocks.hs @@ -0,0 +1,10 @@ +foo = + if something + -- then comment + then do + stuff + stuff + -- else comment + else do + stuff + stuff diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches-out.hs b/data/examples/declaration/value/function/if-with-comment-in-branches-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches-out.hs @@ -0,0 +1,14 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + case a of + Just b -> _ + Nothing -> _ + else + -- comment 3 + -- comment 4 + case a of + Just b -> _ + Nothing -> _ diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions-out.hs b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions-out.hs @@ -0,0 +1,12 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + foo 1 2 3 + else + -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions.hs b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions.hs @@ -0,0 +1,12 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + foo 1 2 3 + else + -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches.hs b/data/examples/declaration/value/function/if-with-comment-in-branches.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches.hs @@ -0,0 +1,14 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + case a of + Just b -> _ + Nothing -> _ + else + -- comment 3 + -- comment 4 + case a of + Just b -> _ + Nothing -> _ diff --git a/data/examples/declaration/value/function/if-with-comment-next-to-keyword-out.hs b/data/examples/declaration/value/function/if-with-comment-next-to-keyword-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-next-to-keyword-out.hs @@ -0,0 +1,10 @@ +foo = + if x + then -- comment 1 + -- comment 2 + foo 1 2 3 + else -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-next-to-keyword.hs b/data/examples/declaration/value/function/if-with-comment-next-to-keyword.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-next-to-keyword.hs @@ -0,0 +1,10 @@ +foo = + if x + then -- comment 1 + -- comment 2 + foo 1 2 3 + else -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-out.hs b/data/examples/declaration/value/function/if-with-comment-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/if-with-comment-out.hs +++ /dev/null @@ -1,8 +0,0 @@ -foo = - if undefined - then -- then comment - undefined - else -- else comment - - do - undefined diff --git a/data/examples/declaration/value/function/if-with-comment.hs b/data/examples/declaration/value/function/if-with-comment.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/if-with-comment.hs +++ /dev/null @@ -1,8 +0,0 @@ -foo = - if undefined - -- then comment - then undefined - -- else comment - else - do - undefined diff --git a/data/examples/other/jsffi-out.hs b/data/examples/other/jsffi-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/jsffi-out.hs @@ -0,0 +1,1 @@ +{-# LANGUAGE JavaScriptFFI #-} diff --git a/data/examples/other/jsffi.hs b/data/examples/other/jsffi.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/jsffi.hs @@ -0,0 +1,1 @@ +{-# language JavaScriptFFI #-} diff --git a/ormolu.cabal b/ormolu.cabal --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ormolu -version: 0.7.3.0 +version: 0.7.4.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -26,7 +26,8 @@ Platform { platformArchOS = ArchOS - { archOS_arch = ArchUnknown, + { -- see https://github.com/tweag/ormolu/issues/1087 + archOS_arch = ArchJavaScript, archOS_OS = OSUnknown }, platformWordSize = PW8, diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -112,7 +112,7 @@ -- when we try to parse the rendered code back, inside of GHC monad -- wrapper which will lead to error messages presenting the exceptions as -- GHC bugs. - let !formattedText = printSnippets result0 + let !formattedText = printSnippets (cfgDebug cfg) result0 when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do -- Parse the result of pretty-printing again and make sure that AST -- is the same as AST of original snippet module span positions. @@ -138,7 +138,7 @@ -- Try re-formatting the formatted result to check if we get exactly -- the same output. when (cfgCheckIdempotence cfg) . liftIO $ - let reformattedText = printSnippets result1 + let reformattedText = printSnippets (cfgDebug cfg) result1 in case diffText formattedText reformattedText path of Nothing -> return () Just diff -> throwIO (OrmoluNonIdempotentOutput diff) diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs --- a/src/Ormolu/Fixity/Internal.hs +++ b/src/Ormolu/Fixity/Internal.hs @@ -42,6 +42,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T +import Debug.Trace (trace) import Distribution.ModuleName (ModuleName) import Distribution.Types.PackageName import GHC.Data.FastString (fs_sbs) @@ -256,24 +257,62 @@ deriving stock (Eq, Show) -- | Get a 'FixityApproximation' of an operator. -inferFixity :: RdrName -> ModuleFixityMap -> FixityApproximation -inferFixity rdrName (ModuleFixityMap m) = - case Map.lookup opName m of - Nothing -> defaultFixityApproximation - Just (Given fixityInfo) -> - fixityInfoToApproximation fixityInfo - Just (FromModuleImports xs) -> - let isMatching (provenance, _fixityInfo) = - case provenance of - UnqualifiedAndQualified mn -> - maybe True (== mn) moduleName - OnlyQualified mn -> - maybe False (== mn) moduleName - in fromMaybe defaultFixityApproximation - . foldMap (Just . fixityInfoToApproximation . snd) - $ NE.filter isMatching xs +inferFixity :: + -- | Whether to print debug info regarding fixity inference + Bool -> + -- | Operator name + RdrName -> + -- | Module fixity map + ModuleFixityMap -> + -- | The resulting fixity approximation + FixityApproximation +inferFixity debug rdrName (ModuleFixityMap m) = + if debug + then + trace + (renderFixityJustification opName moduleName m result) + result + else result where + result = + case Map.lookup opName m of + Nothing -> defaultFixityApproximation + Just (Given fixityInfo) -> + fixityInfoToApproximation fixityInfo + Just (FromModuleImports xs) -> + let isMatching (provenance, _fixityInfo) = + case provenance of + UnqualifiedAndQualified mn -> + maybe True (== mn) moduleName + OnlyQualified mn -> + maybe False (== mn) moduleName + in fromMaybe defaultFixityApproximation + . foldMap (Just . fixityInfoToApproximation . snd) + $ NE.filter isMatching xs opName = occOpName (rdrNameOcc rdrName) moduleName = case rdrName of Qual x _ -> Just (ghcModuleNameToCabal x) _ -> Nothing + +-- | Render a human-readable account of why a certain 'FixityApproximation' +-- was chosen for an operator. +renderFixityJustification :: + -- | Operator name + OpName -> + -- | Qualification of the operator name + Maybe ModuleName -> + -- | Module fixity map + Map OpName FixityProvenance -> + -- | The chosen fixity approximation + FixityApproximation -> + String +renderFixityJustification opName mqualification m approximation = + concat + [ "FIXITY analysis of ", + show opName, + case mqualification of + Nothing -> "" + Just mn -> " qualified in " ++ show mn, + "\n Provenance: " ++ show (Map.lookup opName m), + "\n Inferred: " ++ show approximation + ] diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -17,11 +17,13 @@ -- | Render several source snippets. printSnippets :: + -- | Whether to print out debug information during printing + Bool -> -- | Result of parsing [SourceSnippet] -> -- | Resulting rendition Text -printSnippets = T.concat . fmap printSnippet +printSnippets debug = T.concat . fmap printSnippet where printSnippet = \case ParsedSnippet ParseResult {..} -> @@ -37,4 +39,5 @@ prSourceType prExtensions prModuleFixityMap + debug RawSnippet r -> r 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 @@ -24,6 +24,7 @@ inciIf, askSourceType, askModuleFixityMap, + askDebug, located, encloseLocated, located', 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 @@ -18,6 +18,7 @@ newline, askSourceType, askModuleFixityMap, + askDebug, inci, sitcc, Layout (..), @@ -100,7 +101,9 @@ -- | Whether the source is a signature or a regular module rcSourceType :: SourceType, -- | Module fixity map - rcModuleFixityMap :: ModuleFixityMap + rcModuleFixityMap :: ModuleFixityMap, + -- | Whether to print out debug information during printing + rcDebug :: !Bool } -- | State context of 'R'. @@ -171,8 +174,9 @@ -- | Module fixity map ModuleFixityMap -> -- | Resulting rendition + Bool -> Text -runR (R m) sstream cstream sourceType extensions moduleFixityMap = +runR (R m) sstream cstream sourceType extensions moduleFixityMap debug = TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc where rc = @@ -183,7 +187,8 @@ rcCanUseBraces = False, rcExtensions = extensions, rcSourceType = sourceType, - rcModuleFixityMap = moduleFixityMap + rcModuleFixityMap = moduleFixityMap, + rcDebug = debug } sc = SC @@ -383,6 +388,11 @@ -- | Retrieve the module fixity map. askModuleFixityMap :: R ModuleFixityMap askModuleFixityMap = R (asks rcModuleFixityMap) + +-- | Retrieve whether we should print out certain debug information while +-- printing. +askDebug :: R Bool +askDebug = R (asks rcDebug) inciBy :: Int -> R () -> R () inciBy step (R m) = R (local modRC m) 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 @@ -50,74 +50,78 @@ txt $ case style of Associated -> mempty Free -> " instance" - case unLoc <$> dd_cType of - Nothing -> pure () - Just (CType prag header (type_, _)) -> do - space - p_sourceText prag - case header of - Nothing -> pure () - Just (Header h _) -> space *> p_sourceText h - space - p_sourceText type_ - txt " #-}" let constructorSpans = getLocA name : fmap getTyVarLoc tyVars sigSpans = maybeToList . fmap getLocA $ dd_kindSig + contextSpans = maybeToList . fmap getLocA $ dd_ctxt + ctypeSpans = maybeToList . fmap getLocA $ dd_cType declHeaderSpans = - maybeToList (getLocA <$> dd_ctxt) ++ constructorSpans ++ sigSpans - switchLayout declHeaderSpans $ do - breakpoint - inci $ do - case dd_ctxt of - Nothing -> pure () - Just ctxt -> do - located ctxt p_hsContext - space - txt "=>" - breakpoint - switchLayout constructorSpans $ - p_infixDefHelper - (isInfix fixity) - True - (p_rdrName name) - (p_tyVar <$> tyVars) - forM_ dd_kindSig $ \k -> do - space - txt "::" + constructorSpans ++ sigSpans ++ contextSpans ++ ctypeSpans + switchLayout declHeaderSpans . inci $ do + case unLoc <$> dd_cType of + Nothing -> pure () + Just (CType prag header (type_, _)) -> do breakpoint - inci $ located k p_hsType + p_sourceText prag + case header of + Nothing -> pure () + Just (Header h _) -> space *> p_sourceText h + space + p_sourceText type_ + txt " #-}" + breakpoint + forM_ dd_ctxt p_lhsContext + switchLayout constructorSpans $ + p_infixDefHelper + (isInfix fixity) + True + (p_rdrName name) + (p_tyVar <$> tyVars) + forM_ dd_kindSig $ \k -> do + space + txt "::" + breakpoint + inci $ located k p_hsType let dd_cons' = case dd_cons of NewTypeCon a -> [a] DataTypeCons _ as -> as gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons' - unless (null dd_cons') $ - if gadt - then inci $ do - switchLayout declHeaderSpans $ do + case dd_cons' of + [] -> pure () + first_dd_cons : _ -> + if gadt + then inci $ do + switchLayout declHeaderSpans $ do + breakpoint + txt "where" breakpoint - txt "where" - breakpoint - sepSemi (located' (p_conDecl False)) dd_cons' - else switchLayout (getLocA name : (getLocA <$> dd_cons')) . inci $ do - let singleConstRec = isSingleConstRec dd_cons' - if hasHaddocks dd_cons' - then newline - else - if singleConstRec - then space - else breakpoint - equals - space - layout <- getLayout - let s = - if layout == MultiLine || hasHaddocks dd_cons' - then newline >> txt "|" >> space - else space >> txt "|" >> space - sitcc' = - if hasHaddocks dd_cons' || not singleConstRec - then sitcc - else id - sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons' + sepSemi (located' (p_conDecl False)) dd_cons' + else switchLayout (getLocA name : (getLocA <$> dd_cons')) . inci $ do + let singleConstRec = isSingleConstRec dd_cons' + compactLayoutAroundEquals = + onTheSameLine + (getLocA name) + (combineSrcSpans' (conDeclConsSpans (unLoc first_dd_cons))) + conDeclConsSpans = \case + ConDeclGADT {..} -> getLocA <$> con_names + ConDeclH98 {..} -> getLocA con_name :| [] + if hasHaddocks dd_cons' + then newline + else + if singleConstRec && compactLayoutAroundEquals + then space + else breakpoint + equals + space + layout <- getLayout + let s = + if layout == MultiLine || hasHaddocks dd_cons' + then newline >> txt "|" >> space + else space >> txt "|" >> space + sitcc' = + if hasHaddocks dd_cons' || not singleConstRec + then sitcc + else id + sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons' unless (null dd_derivs) breakpoint inci $ sep newline (located' p_hsDerivingClause) dd_derivs @@ -171,46 +175,47 @@ located quantifiedTy p_hsType ConDeclH98 {..} -> do mapM_ (p_hsDoc Pipe True) con_doc - let conDeclWithContextSpn = + let conNameSpn = getLocA con_name + conNameWithContextSpn = [ RealSrcSpan real Strict.Nothing | Just (EpaSpan real _) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext ] <> fmap getLocA con_ex_tvs <> maybeToList (fmap getLocA con_mb_cxt) - <> conDeclSpn - conDeclSpn = getLocA con_name : conArgsSpans + <> [conNameSpn] + conDeclSpn = conNameSpn : conArgsSpans where conArgsSpans = case con_args of PrefixCon [] xs -> getLocA . hsScaledThing <$> xs PrefixCon (v : _) _ -> absurd v RecCon l -> [getLocA l] InfixCon x y -> getLocA . hsScaledThing <$> [x, y] - switchLayout conDeclWithContextSpn $ do + switchLayout conNameWithContextSpn $ do when con_forall $ do p_forallBndrs ForAllInvis p_hsTyVarBndr con_ex_tvs breakpoint forM_ con_mb_cxt p_lhsContext - switchLayout conDeclSpn $ case con_args of - PrefixCon [] xs -> do - p_rdrName con_name - let args = hsScaledThing <$> xs - argsHaveDocs = conArgsHaveHaddocks args - delimiter = if argsHaveDocs then newline else breakpoint - unless (null xs) delimiter - inci . sitcc $ - sep delimiter (sitcc . located' p_hsType) args - PrefixCon (v : _) _ -> absurd v - RecCon l -> do + switchLayout conDeclSpn $ case con_args of + PrefixCon [] xs -> do + p_rdrName con_name + let args = hsScaledThing <$> xs + argsHaveDocs = conArgsHaveHaddocks args + delimiter = if argsHaveDocs then newline else breakpoint + unless (null xs) delimiter + inci . sitcc $ + sep delimiter (sitcc . located' p_hsType) args + PrefixCon (v : _) _ -> absurd v + RecCon l -> do + p_rdrName con_name + breakpoint + inciIf (not singleConstRec) (located l p_conDeclFields) + InfixCon (HsScaled _ x) (HsScaled _ y) -> do + located x p_hsType + breakpoint + inci $ do p_rdrName con_name - breakpoint - inciIf (not singleConstRec) (located l p_conDeclFields) - InfixCon (HsScaled _ x) (HsScaled _ y) -> do - located x p_hsType - breakpoint - inci $ do - p_rdrName con_name - space - located y p_hsType + space + located y p_hsType p_lhsContext :: LHsContext GhcPs -> 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 @@ -348,10 +348,11 @@ inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds))) HsCmdArrForm _ form Infix _ [left, right] -> do modFixityMap <- askModuleFixityMap + debug <- askDebug let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right) p_cmdOpTree s - (reassociateOpTree (getOpName . unLoc) modFixityMap opTree) + (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree) HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm" HsCmdApp _ cmd expr -> do located cmd (p_hsCmd' Applicand s) @@ -363,8 +364,8 @@ p_case isApp cmdPlacement p_hsCmd e mgroup HsCmdLamCase _ variant mgroup -> p_lamcase isApp variant cmdPlacement p_hsCmd mgroup - HsCmdIf _ _ if' then' else' -> - p_if cmdPlacement p_hsCmd if' then' else' + HsCmdIf anns _ if' then' else' -> + p_if cmdPlacement p_hsCmd anns if' then' else' HsCmdLet _ _ localBinds _ c -> p_let p_hsCmd localBinds c HsCmdDo _ es -> do @@ -679,10 +680,11 @@ located (hswc_body a) p_hsType OpApp _ x op y -> do modFixityMap <- askModuleFixityMap + debug <- askDebug let opTree = BinaryOpBranches (exprOpTree x) op (exprOpTree y) p_exprOpTree s - (reassociateOpTree (getOpName . unLoc) modFixityMap opTree) + (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree) NegApp _ e _ -> do negativeLiterals <- isExtensionEnabled NegativeLiterals let isLiteral = case unLoc e of @@ -731,8 +733,8 @@ p_unboxedSum N tag arity (located e p_hsExpr) HsCase _ e mgroup -> p_case isApp exprPlacement p_hsExpr e mgroup - HsIf _ if' then' else' -> - p_if exprPlacement p_hsExpr if' then' else' + HsIf anns if' then' else' -> + p_if exprPlacement p_hsExpr anns if' then' else' HsMultiIf _ guards -> do txt "if" breakpoint @@ -971,6 +973,8 @@ (body -> Placement) -> -- | Render (body -> R ()) -> + -- | Annotations + EpAnn AnnsIf -> -- | If LHsExpr GhcPs -> -- | Then @@ -978,21 +982,47 @@ -- | Else LocatedA body -> R () -p_if placer render if' then' else' = do +p_if placer render epAnn if' then' else' = do txt "if" space located if' p_hsExpr breakpoint inci $ do - txt "then" + locatedToken thenSpan "then" space - located then' $ \x -> - placeHanging (placer x) (render x) + placeHangingLocated thenSpan then' breakpoint - txt "else" + locatedToken elseSpan "else" space - located else' $ \x -> - placeHanging (placer x) (render x) + placeHangingLocated elseSpan else' + where + (thenSpan, elseSpan, commentSpans) = + case epAnn of + EpAnn {anns = AnnsIf {aiThen, aiElse}, comments} -> + ( loc' $ epaLocationRealSrcSpan aiThen, + loc' $ epaLocationRealSrcSpan aiElse, + map (anchor . getLoc) $ + case comments of + EpaComments cs -> cs + EpaCommentsBalanced pre post -> pre <> post + ) + EpAnnNotUsed -> + (noSrcSpan, noSrcSpan, []) + + locatedToken tokenSpan token = + located (L tokenSpan ()) $ \_ -> txt token + + betweenSpans spanA spanB s = spanA < s && s < spanB + + placeHangingLocated tokenSpan bodyLoc@(L _ body) = do + let bodySpan = getLoc' bodyLoc + hasComments = fromMaybe False $ do + tokenRealSpan <- srcSpanToRealSrcSpan tokenSpan + bodyRealSpan <- srcSpanToRealSrcSpan bodySpan + pure $ any (betweenSpans tokenRealSpan bodyRealSpan) commentSpans + placement = if hasComments then Normal else placer body + switchLayout [tokenSpan, bodySpan] $ + placeHanging placement (located bodyLoc render) p_let :: -- | Render 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 @@ -110,9 +110,10 @@ sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs HsOpTy _ _ x op y -> do modFixityMap <- askModuleFixityMap + debug <- askDebug let opTree = BinaryOpBranches (tyOpTree x) op (tyOpTree y) p_tyOpTree - (reassociateOpTree (Just . unLoc) modFixityMap opTree) + (reassociateOpTree debug (Just . unLoc) modFixityMap opTree) HsParTy _ t -> parens N (located t p_hsType) HsIParamTy _ n t -> sitcc $ do diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -90,6 +90,8 @@ -- Users are expected to first construct an initial 'OpTree', then -- re-associate it using this function before printing. reassociateOpTree :: + -- | Whether to print debug info regarding fixity inference + Bool -> -- | How to get name of an operator (op -> Maybe RdrName) -> -- | Fixity Map @@ -98,14 +100,16 @@ OpTree ty op -> -- | Re-associated 'OpTree', with added context and info around operators OpTree ty (OpInfo op) -reassociateOpTree getOpName modFixityMap = +reassociateOpTree debug getOpName modFixityMap = reassociateFlatOpTree . makeFlatOpTree - . addFixityInfo modFixityMap getOpName + . addFixityInfo debug modFixityMap getOpName -- | Wrap every operator of the tree with 'OpInfo' to carry the information -- about its fixity (extracted from the specified fixity map). addFixityInfo :: + -- | Whether to print debug info regarding fixity inference + Bool -> -- | Fixity map for operators ModuleFixityMap -> -- | How to get the name of an operator @@ -114,10 +118,10 @@ OpTree ty op -> -- | 'OpTree', with fixity info wrapped around each operator OpTree ty (OpInfo op) -addFixityInfo _ _ (OpNode n) = OpNode n -addFixityInfo modFixityMap getOpName (OpBranches exprs ops) = +addFixityInfo _ _ _ (OpNode n) = OpNode n +addFixityInfo debug modFixityMap getOpName (OpBranches exprs ops) = OpBranches - (addFixityInfo modFixityMap getOpName <$> exprs) + (addFixityInfo debug modFixityMap getOpName <$> exprs) (toOpInfo <$> ops) where toOpInfo o = OpInfo o mrdrName fixityApproximation @@ -125,7 +129,7 @@ mrdrName = getOpName o fixityApproximation = case mrdrName of Nothing -> defaultFixityApproximation - Just rdrName -> inferFixity rdrName modFixityMap + Just rdrName -> inferFixity debug rdrName modFixityMap -- | Given a 'OpTree' of any shape, produce a flat 'OpTree', where every -- node and operator is directly connected to the root. diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -147,6 +147,9 @@ instance HasSrcSpan SrcSpan where loc' = id +instance HasSrcSpan RealSrcSpan where + loc' l = RealSrcSpan l Strict.Nothing + instance HasSrcSpan (SrcSpanAnn' ann) where loc' = locA diff --git a/tests/Ormolu/FixitySpec.hs b/tests/Ormolu/FixitySpec.hs --- a/tests/Ormolu/FixitySpec.hs +++ b/tests/Ormolu/FixitySpec.hs @@ -261,7 +261,7 @@ where actualResult = fmap - (\(k, _) -> (k, inferFixity k resultMap)) + (\(k, _) -> (k, inferFixity False k resultMap)) expectedResult resultMap = moduleFixityMap diff --git a/tests/Ormolu/OpTreeSpec.hs b/tests/Ormolu/OpTreeSpec.hs --- a/tests/Ormolu/OpTreeSpec.hs +++ b/tests/Ormolu/OpTreeSpec.hs @@ -31,7 +31,7 @@ removeOpInfo (OpNode x) = OpNode x removeOpInfo (OpBranches exprs ops) = OpBranches (removeOpInfo <$> exprs) (opiOp <$> ops) - actualOutputTree = reassociateOpTree convertName modFixityMap inputTree + actualOutputTree = reassociateOpTree False convertName modFixityMap inputTree modFixityMap = ModuleFixityMap (Map.map Given (Map.fromList fixities)) convertName = Just . mkRdrUnqual . mkOccName varName . T.unpack . unOpName