diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,46 @@ +## Ormolu 0.1.0.0 + +* Fixed rendering of type signatures concerning several identifiers. [Issue + 566](https://github.com/tweag/ormolu/issues/566). + +* Fixed an idempotence issue with inline comments in tuples and parentheses. + [Issue 450](https://github.com/tweag/ormolu/issues/450). + +* Fixed an idempotence issue when certain comments where picked up as + “continuation” of a series of comments [Issue + 449](https://github.com/tweag/ormolu/issues/449). + +* Fixed an idempotence issue related to different indentation levels in a + comment series. [Issue 512](https://github.com/tweag/ormolu/issues/512). + +* Fixed an idempotence issue related to comments which may happen to be + separated from the elements they are attached to by the equality sign. + [Issue 340](https://github.com/tweag/ormolu/issues/340). + +* Fixed an idempotence issue with type synonym and data declarations where + the type has a Haddock. [Issue + 578](https://github.com/tweag/ormolu/issues/578). + +* Fix the false positive about AST differences in presence of comments with + multiple blank lines in a row. [Issue + 518](https://github.com/tweag/ormolu/issues/518). + +* Fixed rendering of comment around if expressions. [Issue + 458](https://github.com/tweag/ormolu/issues/458). + +* Unnamed fields of data constructors are now documented using the `-- ^` + syntax. [Issue 445](https://github.com/tweag/ormolu/issues/445) and [Issue + 428](https://github.com/tweag/ormolu/issues/428). + +* Fixed non-idempotent transformation of partly documented data definition. + [Issue 590](https://github.com/tweag/ormolu/issues/590). + +* Fixed an idempotence issue related to operators. [Issue + 522](https://github.com/tweag/ormolu/issues/522). + +* Renamed the `--check-idempotency` flag to `--check-idempotence`. + Apparently only the latter is correct. + ## Ormolu 0.0.5.0 * Grouping of statements in `do`-blocks is now preserved. [Issue diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,7 +30,7 @@ * The result of printing is parsed back again and the AST is compared to the AST obtained from the original file. They should match. * The output of printer is checked against the expected output. -* Idempotency property is verified: formatting already formatted code +* Idempotence property is verified: formatting already formatted code results in exactly the same output. Examples can be organized in sub-directories, see the existing ones for diff --git a/DESIGN.md b/DESIGN.md --- a/DESIGN.md +++ b/DESIGN.md @@ -24,7 +24,7 @@ We set for the following goals (mostly taken from [brittany](https://github.com/lspitzner/brittany)): -* Preserve the meaning of the formatted functions; +* Preserve the meaning of the formatted functions when no CPP is used; * Make reasonable use of screen space; * Use linear space and computation time on the size of the input; * Preserve comments; @@ -140,8 +140,10 @@ ### CPP -Formatting a module which uses CPP directives won't be supported. Instead, -we hope for a solution to replace CPP to do conditional compilation. +We allow CPP directives in the input, but we forgo the goal to preserve the +meaning of the formatted functions in that case. +Instead of supporting CPP better, we hope for a solution to replace CPP to +do conditional compilation. There are the following challenges when formatting a module with CPP: @@ -180,14 +182,15 @@ ``` At the time of this writing, formatting this program with Hindent -produces the same output we would get if the CPP directives were -considered comments: +or Ormolu produces the same output we would get if the CPP directives +were considered comments: ``` -$ hindent --version -hindent 5.2.7 +$ ormolu --version +ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115 +using ghc-lib-parser 8.10.1.20200412 -$ hindent test.hs +$ ormolu --mode inplace test.hs $ cat test.hs {-# LANGUAGE CPP #-} @@ -226,9 +229,6 @@ to parse Haskell modules. If CPP is replaced with some language extension or mechanism to do conditional compilation, all tools will benefit from it. - -Therefore, CPP won't be supported. If the CPP extension -is enabled, we should signal an error right away. ### Printing diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -91,6 +91,12 @@ $ ormolu --mode inplace Module.hs ``` +Use `find` to format a tree recursively: + +```console +$ ormolu --mode inplace $(find . -name '*.hs') +``` + ## Magic comments Ormolu understands two magic comments: @@ -116,8 +122,9 @@ * CPP support is experimental. CPP is virtually impossible to handle correctly, so we process them as a sort of unchangeable snippets. This - works only in simple cases when CPP conditionals are self-contained. Use - Ormolu with CPP at your own risk. + works only in simple cases when CPP conditionals surround top-level + declarations. See the [CPP][design-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. @@ -154,7 +161,7 @@ Copyright © 2018–present Tweag I/O -[design]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp +[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp [contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md [license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md [haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -167,17 +167,19 @@ help "Output information useful for debugging" ] <*> (switch . mconcat) - [ long "check-idempotency", + [ long "check-idempotence", short 'c', help "Fail if formatting is not idempotent" ] <*> ( RegionIndices <$> (optional . option auto . mconcat) [ long "start-line", - help "Start line of the region to format (lines start from 1)" + metavar "START", + help "Start line of the region to format (starts from 1)" ] <*> (optional . option auto . mconcat) [ long "end-line", + metavar "END", help "End line of the region to format (inclusive)" ] ) diff --git a/data/examples/declaration/data/gadt/multiline-out.hs b/data/examples/declaration/data/gadt/multiline-out.hs --- a/data/examples/declaration/data/gadt/multiline-out.hs +++ b/data/examples/declaration/data/gadt/multiline-out.hs @@ -8,7 +8,7 @@ Foo :: forall a b. (Show a, Eq b) => -- foo - -- bar + -- bar a -> b -> Foo 'Int diff --git a/data/examples/declaration/data/multiline-arg-parens-out.hs b/data/examples/declaration/data/multiline-arg-parens-out.hs --- a/data/examples/declaration/data/multiline-arg-parens-out.hs +++ b/data/examples/declaration/data/multiline-arg-parens-out.hs @@ -5,6 +5,6 @@ = Foo Bar (Set Baz) -- and here we go - -- and that's it + -- and that's it Text deriving (Eq) diff --git a/data/examples/declaration/data/partly-documented-out.hs b/data/examples/declaration/data/partly-documented-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/partly-documented-out.hs @@ -0,0 +1,5 @@ +data Optimisation + = PETransform + | -- | partial eval and associated transforms + GeneralisedNatHack + deriving (Show, Eq, Generic) diff --git a/data/examples/declaration/data/partly-documented.hs b/data/examples/declaration/data/partly-documented.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/partly-documented.hs @@ -0,0 +1,2 @@ +data Optimisation = PETransform | GeneralisedNatHack -- ^ partial eval and associated transforms + deriving (Show, Eq, Generic) diff --git a/data/examples/declaration/data/unnamed-field-comment-0-out.hs b/data/examples/declaration/data/unnamed-field-comment-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-0-out.hs @@ -0,0 +1,7 @@ +data Foo + = -- | Bar + Bar + Field1 + -- ^ Field 1 + Field2 + -- ^ Field 2 diff --git a/data/examples/declaration/data/unnamed-field-comment-0.hs b/data/examples/declaration/data/unnamed-field-comment-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-0.hs @@ -0,0 +1,5 @@ +data Foo + = -- | Bar + Bar + Field1 -- ^ Field 1 + Field2 -- ^ Field 2 diff --git a/data/examples/declaration/data/unnamed-field-comment-1-out.hs b/data/examples/declaration/data/unnamed-field-comment-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-1-out.hs @@ -0,0 +1,5 @@ +data X + = B + !Int + -- ^ y + C diff --git a/data/examples/declaration/data/unnamed-field-comment-1.hs b/data/examples/declaration/data/unnamed-field-comment-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-1.hs @@ -0,0 +1,4 @@ +data X + = B + !Int -- ^ y + C diff --git a/data/examples/declaration/data/with-comment-out.hs b/data/examples/declaration/data/with-comment-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/with-comment-out.hs @@ -0,0 +1,4 @@ +data A + = B -- C + | -- D + E diff --git a/data/examples/declaration/data/with-comment.hs b/data/examples/declaration/data/with-comment.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/with-comment.hs @@ -0,0 +1,5 @@ +data A = + B -- C + + -- D + | E diff --git a/data/examples/declaration/data/with-weird-haddock-out.hs b/data/examples/declaration/data/with-weird-haddock-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/with-weird-haddock-out.hs @@ -0,0 +1,4 @@ +data PlusLevel' t + = -- | @n + ℓ@. + Plus Integer (LevelAtom' t) + deriving (Show, Data) diff --git a/data/examples/declaration/data/with-weird-haddock.hs b/data/examples/declaration/data/with-weird-haddock.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/with-weird-haddock.hs @@ -0,0 +1,2 @@ +data PlusLevel' t = Plus Integer (LevelAtom' t) -- ^ @n + ℓ@. + deriving (Show, Data) diff --git a/data/examples/declaration/signature/type/multi-value-out.hs b/data/examples/declaration/signature/type/multi-value-out.hs --- a/data/examples/declaration/signature/type/multi-value-out.hs +++ b/data/examples/declaration/signature/type/multi-value-out.hs @@ -2,6 +2,11 @@ foo = 1 bar = 2 +a, b, c :: Int +a = 1 +b = 2 +c = 3 + foo, bar, baz :: diff --git a/data/examples/declaration/signature/type/multi-value.hs b/data/examples/declaration/signature/type/multi-value.hs --- a/data/examples/declaration/signature/type/multi-value.hs +++ b/data/examples/declaration/signature/type/multi-value.hs @@ -2,6 +2,11 @@ foo = 1 bar = 2 +a, b, c :: Int +a = 1 +b = 2 +c = 3 + foo, bar, baz :: Int diff --git a/data/examples/declaration/type-synonyms/with-weird-haddock-out.hs b/data/examples/declaration/type-synonyms/with-weird-haddock-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-synonyms/with-weird-haddock-out.hs @@ -0,0 +1,3 @@ +type Elims = + -- | eliminations ordered left-to-right. + [Elim] diff --git a/data/examples/declaration/type-synonyms/with-weird-haddock.hs b/data/examples/declaration/type-synonyms/with-weird-haddock.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-synonyms/with-weird-haddock.hs @@ -0,0 +1,1 @@ +type Elims = [Elim] -- ^ eliminations ordered left-to-right. diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs b/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs @@ -40,7 +40,7 @@ ) else do let u = x -- Let bindings bind expressions, not commands - -- Could pattern match directly on x + -- Could pattern match directly on x i <- case u of 0 -> (g . h -< u) n -> diff --git a/data/examples/declaration/value/function/awkward-comment-0-out.hs b/data/examples/declaration/value/function/awkward-comment-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/awkward-comment-0-out.hs @@ -0,0 +1,6 @@ +mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a +mergeErrorReply err1 reply -- XXX where to put it? + = + case reply of + Ok x state err2 -> Ok x state (mergeError err1 err2) + Error err2 -> Error (mergeError err1 err2) diff --git a/data/examples/declaration/value/function/awkward-comment-0.hs b/data/examples/declaration/value/function/awkward-comment-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/awkward-comment-0.hs @@ -0,0 +1,5 @@ +mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a +mergeErrorReply err1 reply -- XXX where to put it? + = case reply of + Ok x state err2 -> Ok x state (mergeError err1 err2) + Error err2 -> Error (mergeError err1 err2) diff --git a/data/examples/declaration/value/function/awkward-comment-1-out.hs b/data/examples/declaration/value/function/awkward-comment-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/awkward-comment-1-out.hs @@ -0,0 +1,9 @@ +doForeign :: Vars -> [Name] -> [Term] -> Idris LExp +doForeign x = x + where + splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits + = + do + let l' = toFDesc l + r' <- irTerm (sMN 0 "__foreignCall") vs env r + return (l', r') diff --git a/data/examples/declaration/value/function/awkward-comment-1.hs b/data/examples/declaration/value/function/awkward-comment-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/awkward-comment-1.hs @@ -0,0 +1,7 @@ +doForeign :: Vars -> [Name] -> [Term] -> Idris LExp +doForeign x = x + where + splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits + = do let l' = toFDesc l + r' <- irTerm (sMN 0 "__foreignCall") vs env r + return (l', r') diff --git a/data/examples/declaration/value/function/if-with-comment-out.hs b/data/examples/declaration/value/function/if-with-comment-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-out.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment.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/multi-way-if-out.hs b/data/examples/declaration/value/function/multi-way-if-out.hs --- a/data/examples/declaration/value/function/multi-way-if-out.hs +++ b/data/examples/declaration/value/function/multi-way-if-out.hs @@ -3,12 +3,14 @@ foo x = if | x == 5 -> 5 bar x y = - if | x > y -> x + if + | x > y -> x | x < y -> y | otherwise -> x baz = - if | p -> f + if + | p -> f | otherwise -> g x diff --git a/data/examples/declaration/value/function/operator-comments-2-out.hs b/data/examples/declaration/value/function/operator-comments-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-2-out.hs @@ -0,0 +1,5 @@ +x = + y + ++ f g -- commentA + -- commentB + -- commentC diff --git a/data/examples/declaration/value/function/operator-comments-2.hs b/data/examples/declaration/value/function/operator-comments-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-2.hs @@ -0,0 +1,4 @@ +x = + y ++ -- commentA +-- commentB + f g -- commentC diff --git a/data/examples/declaration/value/function/operators-0-out.hs b/data/examples/declaration/value/function/operators-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-0-out.hs @@ -0,0 +1,5 @@ +a = + b & c .~ d + & e + %~ f + g diff --git a/data/examples/declaration/value/function/operators-0.hs b/data/examples/declaration/value/function/operators-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-0.hs @@ -0,0 +1,4 @@ +a = + b & c .~ d + & e %~ f + g diff --git a/data/examples/declaration/value/function/operators-1-out.hs b/data/examples/declaration/value/function/operators-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-1-out.hs @@ -0,0 +1,4 @@ +foo = + f + . g + =<< h . i diff --git a/data/examples/declaration/value/function/operators-1.hs b/data/examples/declaration/value/function/operators-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-1.hs @@ -0,0 +1,3 @@ +foo = f + . g + =<< h . i diff --git a/data/examples/declaration/value/function/operators-2-out.hs b/data/examples/declaration/value/function/operators-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-2-out.hs @@ -0,0 +1,4 @@ +foo n + | x || y && z || n ** x + || x && n = + 42 diff --git a/data/examples/declaration/value/function/operators-2.hs b/data/examples/declaration/value/function/operators-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-2.hs @@ -0,0 +1,4 @@ +foo n + | x || y && z || n ** x + || x && n = + 42 diff --git a/data/examples/declaration/value/function/operators-3-out.hs b/data/examples/declaration/value/function/operators-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-3-out.hs @@ -0,0 +1,3 @@ +foo = + op <> n <+> colon <+> prettySe <+> text "=" + <+> prettySe <> text sc diff --git a/data/examples/declaration/value/function/operators-3.hs b/data/examples/declaration/value/function/operators-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-3.hs @@ -0,0 +1,3 @@ +foo = + op <> n <+> colon <+> prettySe <+> text "=" <+> + prettySe <> text sc diff --git a/data/examples/declaration/value/function/operators-4-out.hs b/data/examples/declaration/value/function/operators-4-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-4-out.hs @@ -0,0 +1,3 @@ +foo = + line <> bindingOf <+> text "=" <+> tPretty <+> colon + <+> align <> prettyPs diff --git a/data/examples/declaration/value/function/operators-4.hs b/data/examples/declaration/value/function/operators-4.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-4.hs @@ -0,0 +1,3 @@ +foo = + line <> bindingOf <+> text "=" <+> tPretty <+> colon <+> + align <> prettyPs diff --git a/data/examples/declaration/value/function/operators-5-out.hs b/data/examples/declaration/value/function/operators-5-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-5-out.hs @@ -0,0 +1,5 @@ +foo = + map bar $ + [ baz + ] + ++ quux diff --git a/data/examples/declaration/value/function/operators-5.hs b/data/examples/declaration/value/function/operators-5.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-5.hs @@ -0,0 +1,4 @@ +foo = + map bar $ + [ baz + ] ++ quux diff --git a/data/examples/declaration/value/function/operators-6-out.hs b/data/examples/declaration/value/function/operators-6-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-6-out.hs @@ -0,0 +1,9 @@ +type PermuteRef = + "a" + :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" + :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) diff --git a/data/examples/declaration/value/function/operators-6.hs b/data/examples/declaration/value/function/operators-6.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-6.hs @@ -0,0 +1,7 @@ +type PermuteRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) diff --git a/data/examples/declaration/value/function/operators-out.hs b/data/examples/declaration/value/function/operators-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/operators-out.hs +++ /dev/null @@ -1,5 +0,0 @@ -a = - b & c .~ d - & e - %~ f - g diff --git a/data/examples/declaration/value/function/operators.hs b/data/examples/declaration/value/function/operators.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/operators.hs +++ /dev/null @@ -1,4 +0,0 @@ -a = - b & c .~ d - & e %~ f - g diff --git a/data/examples/declaration/value/function/record-constructors-out.hs b/data/examples/declaration/value/function/record-constructors-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-constructors-out.hs +++ /dev/null @@ -1,31 +0,0 @@ -foo = Foo {a = 3} - -bar = - Bar - { abc = foo, - def = Foo {a = 10} - } - -baz = Baz {} - -sym = Foo {(+) = 3} - -aLongVariableName = - ALongRecordName - { short = baz, - aLongRecordFieldName = - YetAnotherLongRecordName - { yetAnotherLongRecordFieldName = "a long string" - }, - aLongRecordFieldName2 = - Just - YetAnotherLongRecordName - { yetAnotherLongRecordFieldName = "a long string", - yetAnotherLongRecordFieldName = - Just - "a long string" - }, - aLongRecordFieldName3 = do - foo - bar - } diff --git a/data/examples/declaration/value/function/record-constructors.hs b/data/examples/declaration/value/function/record-constructors.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-constructors.hs +++ /dev/null @@ -1,22 +0,0 @@ -foo = Foo { a = 3 } -bar = Bar { - abc = foo, - def = Foo {a = 10} -} -baz = Baz{ } -sym = Foo { (+) = 3 } -aLongVariableName = - ALongRecordName - { short = baz, - aLongRecordFieldName = YetAnotherLongRecordName - { yetAnotherLongRecordFieldName = "a long string" - }, - aLongRecordFieldName2 = Just YetAnotherLongRecordName - { yetAnotherLongRecordFieldName = "a long string", - yetAnotherLongRecordFieldName = Just - "a long string" - }, - aLongRecordFieldName3 = do - foo - bar - } diff --git a/data/examples/declaration/value/function/record-dot-out.hs b/data/examples/declaration/value/function/record-dot-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-dot-out.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -data Foo = Foo {bar :: Int} - -mfoo = fmap (.bar) $ Nothing - -bar = (Foo 1).bar - -fooplus f n = f{foo = f.bar + n} - -fooplus' f n = f {foo = f.bar + n} - -fooplus'' f n = f {foo = f.bar + n} - -fooplus''' f n = f {foo = f.bar + n} diff --git a/data/examples/declaration/value/function/record-dot.hs b/data/examples/declaration/value/function/record-dot.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-dot.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} -data Foo = Foo { bar :: Int } - -mfoo = fmap (.bar) $ Nothing - -bar = ( Foo 1).bar - -fooplus f n = f{foo = f.bar + n} - -fooplus' f n = f { foo = f.bar + n} - -fooplus'' f n = f {foo = f.bar + n} - -fooplus''' f n = f{ foo = f.bar + n} diff --git a/data/examples/declaration/value/function/record-inter-comments-out.hs b/data/examples/declaration/value/function/record-inter-comments-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-inter-comments-out.hs +++ /dev/null @@ -1,13 +0,0 @@ -x = - Just - -- comment - A - { x - } - -x = - Just - -- comment - a - { x - } diff --git a/data/examples/declaration/value/function/record-inter-comments.hs b/data/examples/declaration/value/function/record-inter-comments.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-inter-comments.hs +++ /dev/null @@ -1,11 +0,0 @@ -x = Just - -- comment - A - { x - } - -x = Just - -- comment - a - { x - } diff --git a/data/examples/declaration/value/function/record-updaters-out.hs b/data/examples/declaration/value/function/record-updaters-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-updaters-out.hs +++ /dev/null @@ -1,11 +0,0 @@ -foo x = x {a = 3} - -bar x = - x - { abc = foo, - def = Foo {a = 10} - } - -baz x = x {} - -sym x = x {(+) = 4} diff --git a/data/examples/declaration/value/function/record-updaters.hs b/data/examples/declaration/value/function/record-updaters.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-updaters.hs +++ /dev/null @@ -1,7 +0,0 @@ -foo x = x { a = 3 } -bar x = x { - abc = foo, - def = Foo {a = 10} -} -baz x = x{ } -sym x = x { (+) = 4 } diff --git a/data/examples/declaration/value/function/record-wildcards-out.hs b/data/examples/declaration/value/function/record-wildcards-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-wildcards-out.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -foo x y = Foo {x, y} - -bar x y z = - Bar - { x, - y, - z, - .. - } - -baz = Baz {..} diff --git a/data/examples/declaration/value/function/record-wildcards.hs b/data/examples/declaration/value/function/record-wildcards.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record-wildcards.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -foo x y = Foo { x, y } - -bar x y z = Bar { - x, - y, - z, - .. -} - -baz = Baz { .. } diff --git a/data/examples/other/comment-two-blocks-out.hs b/data/examples/other/comment-two-blocks-out.hs --- a/data/examples/other/comment-two-blocks-out.hs +++ b/data/examples/other/comment-two-blocks-out.hs @@ -2,7 +2,7 @@ newNames = let (*) = flip (,) in [ "Control" * "Monad" - -- Foo + -- Foo - -- Bar + -- Bar ] diff --git a/data/examples/other/inline-comment-0-out.hs b/data/examples/other/inline-comment-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/inline-comment-0-out.hs @@ -0,0 +1,3 @@ +x = ({-a-} b, c) + +y = ({-a-} b) diff --git a/data/examples/other/inline-comment-0.hs b/data/examples/other/inline-comment-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/inline-comment-0.hs @@ -0,0 +1,3 @@ +x = ({-a-}b, c) + +y = ({-a-}b) diff --git a/data/examples/other/inline-comment-1-out.hs b/data/examples/other/inline-comment-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/inline-comment-1-out.hs @@ -0,0 +1,12 @@ +showPs env ((n, _, Let _ t v) : bs) = + " " ++ show n ++ " : " + ++ showEnv env ({- normalise ctxt env -} t) + ++ " = " + ++ showEnv env ({- normalise ctxt env -} v) + ++ "\n" + ++ showPs env bs +showPs env ((n, _, b) : bs) = + " " ++ show n ++ " : " + ++ showEnv env ({- normalise ctxt env -} (binderTy b)) + ++ "\n" + ++ showPs env bs diff --git a/data/examples/other/inline-comment-1.hs b/data/examples/other/inline-comment-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/inline-comment-1.hs @@ -0,0 +1,9 @@ +showPs env ((n, _, Let _ t v):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} t) ++ " = " ++ + showEnv env ({- normalise ctxt env -} v) ++ + "\n" ++ showPs env bs +showPs env ((n, _, b):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} (binderTy b)) ++ + "\n" ++ showPs env bs diff --git a/data/examples/other/multiple-blank-line-comment-out.hs b/data/examples/other/multiple-blank-line-comment-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/multiple-blank-line-comment-out.hs @@ -0,0 +1,9 @@ +module A where + +a = + b + [ f + {-, + + -} + ] diff --git a/data/examples/other/multiple-blank-line-comment.hs b/data/examples/other/multiple-blank-line-comment.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/multiple-blank-line-comment.hs @@ -0,0 +1,10 @@ +module A where + +a = + b + [ f + {-, + + + -} + ] diff --git a/ormolu.cabal b/ormolu.cabal --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,170 +1,183 @@ -name: ormolu -version: 0.0.5.0 -cabal-version: 1.18 -tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 -license: BSD3 -license-file: LICENSE.md -maintainer: Mark Karpov -homepage: https://github.com/tweag/ormolu -bug-reports: https://github.com/tweag/ormolu/issues -category: Development, Formatting -synopsis: A formatter for Haskell source code -build-type: Simple -description: A formatter for Haskell source code. -extra-doc-files: CONTRIBUTING.md - , CHANGELOG.md - , DESIGN.md - , README.md -data-files: data/examples/declaration/annotation/*.hs - , data/examples/declaration/class/*.hs - , data/examples/declaration/data/*.hs - , data/examples/declaration/data/gadt/*.hs - , data/examples/declaration/default/*.hs - , data/examples/declaration/deriving/*.hs - , data/examples/declaration/foreign/*.hs - , data/examples/declaration/instance/*.hs - , data/examples/declaration/rewrite-rule/*.hs - , data/examples/declaration/role-annotation/*.hs - , data/examples/declaration/signature/complete/*.hs - , data/examples/declaration/signature/fixity/*.hs - , data/examples/declaration/signature/inline/*.hs - , data/examples/declaration/signature/minimal/*.hs - , data/examples/declaration/signature/pattern/*.hs - , data/examples/declaration/signature/set-cost-centre/*.hs - , data/examples/declaration/signature/specialize/*.hs - , data/examples/declaration/signature/type/*.hs - , data/examples/declaration/splice/*.hs - , data/examples/declaration/type-families/closed-type-family/*.hs - , data/examples/declaration/type-families/data-family/*.hs - , data/examples/declaration/type-families/type-family/*.hs - , data/examples/declaration/type-synonyms/*.hs - , data/examples/declaration/type/*.hs - , data/examples/declaration/value/function/*.hs - , data/examples/declaration/value/function/arrow/*.hs - , data/examples/declaration/value/function/comprehension/*.hs - , data/examples/declaration/value/function/do/*.hs - , data/examples/declaration/value/function/infix/*.hs - , data/examples/declaration/value/function/pattern/*.hs - , data/examples/declaration/value/other/*.hs - , data/examples/declaration/value/pattern-synonyms/*.hs - , data/examples/declaration/warning/*.hs - , data/examples/import/*.hs - , data/examples/module-header/*.hs - , data/examples/other/*.hs +cabal-version: 1.18 +name: ormolu +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE.md +maintainer: Mark Karpov +tested-with: ghc ==8.6.5 ghc ==8.8.3 ghc ==8.10.1 +homepage: https://github.com/tweag/ormolu +bug-reports: https://github.com/tweag/ormolu/issues +synopsis: A formatter for Haskell source code +description: A formatter for Haskell source code. +category: Development, Formatting +build-type: Simple +data-files: + data/examples/declaration/annotation/*.hs + data/examples/declaration/class/*.hs + data/examples/declaration/data/*.hs + data/examples/declaration/data/gadt/*.hs + data/examples/declaration/default/*.hs + data/examples/declaration/deriving/*.hs + data/examples/declaration/foreign/*.hs + data/examples/declaration/instance/*.hs + data/examples/declaration/rewrite-rule/*.hs + data/examples/declaration/role-annotation/*.hs + data/examples/declaration/signature/complete/*.hs + data/examples/declaration/signature/fixity/*.hs + data/examples/declaration/signature/inline/*.hs + data/examples/declaration/signature/minimal/*.hs + data/examples/declaration/signature/pattern/*.hs + data/examples/declaration/signature/set-cost-centre/*.hs + data/examples/declaration/signature/specialize/*.hs + data/examples/declaration/signature/type/*.hs + data/examples/declaration/splice/*.hs + data/examples/declaration/type-families/closed-type-family/*.hs + data/examples/declaration/type-families/data-family/*.hs + data/examples/declaration/type-families/type-family/*.hs + data/examples/declaration/type-synonyms/*.hs + data/examples/declaration/type/*.hs + data/examples/declaration/value/function/*.hs + data/examples/declaration/value/function/arrow/*.hs + data/examples/declaration/value/function/comprehension/*.hs + data/examples/declaration/value/function/do/*.hs + data/examples/declaration/value/function/infix/*.hs + data/examples/declaration/value/function/pattern/*.hs + data/examples/declaration/value/other/*.hs + data/examples/declaration/value/pattern-synonyms/*.hs + data/examples/declaration/warning/*.hs + data/examples/import/*.hs + data/examples/module-header/*.hs + data/examples/other/*.hs +extra-doc-files: + CONTRIBUTING.md + CHANGELOG.md + DESIGN.md + README.md + source-repository head - type: git - location: https://github.com/tweag/ormolu.git + type: git + location: https://github.com/tweag/ormolu.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - hs-source-dirs: src - build-depends: base >= 4.12 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.7 - , dlist >= 0.8 && < 0.9 - , exceptions >= 0.6 && < 0.11 - , ghc-lib-parser >= 8.10 && < 8.11 - , mtl >= 2.0 && < 3.0 - , syb >= 0.7 && < 0.8 - , text >= 0.2 && < 1.3 - exposed-modules: Ormolu - , Ormolu.Config - , Ormolu.Diff - , Ormolu.Exception - , Ormolu.Imports - , Ormolu.Parser - , Ormolu.Parser.Anns - , Ormolu.Parser.CommentStream - , Ormolu.Parser.Pragma - , Ormolu.Parser.Result - , Ormolu.Parser.Shebang - , Ormolu.Printer - , Ormolu.Printer.Combinators - , Ormolu.Printer.Comments - , Ormolu.Printer.Internal - , Ormolu.Printer.Meat.Common - , Ormolu.Printer.Meat.Declaration - , Ormolu.Printer.Meat.Declaration.Annotation - , Ormolu.Printer.Meat.Declaration.Class - , Ormolu.Printer.Meat.Declaration.Data - , Ormolu.Printer.Meat.Declaration.Default - , Ormolu.Printer.Meat.Declaration.Foreign - , Ormolu.Printer.Meat.Declaration.Instance - , Ormolu.Printer.Meat.Declaration.RoleAnnotation - , Ormolu.Printer.Meat.Declaration.Rule - , Ormolu.Printer.Meat.Declaration.Signature - , Ormolu.Printer.Meat.Declaration.Splice - , Ormolu.Printer.Meat.Declaration.Type - , Ormolu.Printer.Meat.Declaration.TypeFamily - , Ormolu.Printer.Meat.Declaration.Value - , Ormolu.Printer.Meat.Declaration.Warning - , Ormolu.Printer.Meat.ImportExport - , Ormolu.Printer.Meat.Module - , Ormolu.Printer.Meat.Pragma - , Ormolu.Printer.Meat.Type - , Ormolu.Printer.Operators - , Ormolu.Printer.SpanStream - , Ormolu.Processing.Common - , Ormolu.Processing.Cpp - , Ormolu.Processing.Postprocess - , Ormolu.Processing.Preprocess - , Ormolu.Utils - other-modules: GHC - , GHC.DynFlags - if flag(dev) - ghc-options: -Wall -Werror -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - -- https://github.com/haskell/haddock/issues/1116 - -Wno-missing-home-modules - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + exposed-modules: + Ormolu + Ormolu.Config + Ormolu.Diff + Ormolu.Exception + Ormolu.Imports + Ormolu.Parser + Ormolu.Parser.Anns + Ormolu.Parser.CommentStream + Ormolu.Parser.Pragma + Ormolu.Parser.Result + Ormolu.Parser.Shebang + Ormolu.Printer + Ormolu.Printer.Combinators + Ormolu.Printer.Comments + Ormolu.Printer.Internal + Ormolu.Printer.Meat.Common + Ormolu.Printer.Meat.Declaration + Ormolu.Printer.Meat.Declaration.Annotation + Ormolu.Printer.Meat.Declaration.Class + Ormolu.Printer.Meat.Declaration.Data + Ormolu.Printer.Meat.Declaration.Default + Ormolu.Printer.Meat.Declaration.Foreign + Ormolu.Printer.Meat.Declaration.Instance + Ormolu.Printer.Meat.Declaration.RoleAnnotation + Ormolu.Printer.Meat.Declaration.Rule + Ormolu.Printer.Meat.Declaration.Signature + Ormolu.Printer.Meat.Declaration.Splice + Ormolu.Printer.Meat.Declaration.Type + Ormolu.Printer.Meat.Declaration.TypeFamily + Ormolu.Printer.Meat.Declaration.Value + Ormolu.Printer.Meat.Declaration.Warning + Ormolu.Printer.Meat.ImportExport + Ormolu.Printer.Meat.Module + Ormolu.Printer.Meat.Pragma + Ormolu.Printer.Meat.Type + Ormolu.Printer.Operators + Ormolu.Printer.SpanStream + Ormolu.Processing.Common + Ormolu.Processing.Cpp + Ormolu.Processing.Postprocess + Ormolu.Processing.Preprocess + Ormolu.Utils -test-suite tests - main-is: Spec.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - build-depends: base >= 4.12 && < 5.0 - , containers >= 0.5 && < 0.7 - , filepath >= 1.2 && < 1.5 - , hspec >= 2.0 && < 3.0 - , ormolu - , path >= 0.6 && < 0.8 - , path-io >= 1.4.2 && < 2.0 - , text >= 0.2 && < 1.3 - build-tools: hspec-discover >= 2.0 && < 3.0 - other-modules: - Ormolu.Parser.PragmaSpec - , Ormolu.PrinterSpec + hs-source-dirs: src + other-modules: + GHC + GHC.DynFlags - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + default-language: Haskell2010 + build-depends: + base >=4.12 && <5.0, + bytestring >=0.2 && <0.11, + containers >=0.5 && <0.7, + dlist >=0.8 && <0.9, + exceptions >=0.6 && <0.11, + ghc-lib-parser >=8.10 && <8.11, + mtl >=2.0 && <3.0, + syb >=0.7 && <0.8, + text >=0.2 && <1.3 + if flag(dev) + ghc-options: + -Wall -Werror -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + -Wno-missing-home-modules + + else + ghc-options: -O2 -Wall + executable ormolu - main-is: Main.hs - hs-source-dirs: app - build-depends: base >= 4.12 && < 5.0 - , ghc-lib-parser >= 8.10 && < 8.11 - , gitrev >= 1.3 && < 1.4 - , optparse-applicative >= 0.14 && < 0.16 - , ormolu - , text >= 0.2 && < 1.3 - other-modules: Paths_ormolu - if flag(dev) - ghc-options: -Wall -Werror -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - else - ghc-options: -O2 -Wall -rtsopts - default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_ormolu + default-language: Haskell2010 + build-depends: + base >=4.12 && <5.0, + ghc-lib-parser >=8.10 && <8.11, + gitrev >=1.3 && <1.4, + optparse-applicative >=0.14 && <0.16, + ormolu -any, + text >=0.2 && <1.3 + + if flag(dev) + ghc-options: + -Wall -Werror -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + + else + ghc-options: -O2 -Wall -rtsopts + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tools: hspec-discover >=2.0 && <3.0 + hs-source-dirs: tests + other-modules: + Ormolu.Parser.PragmaSpec + Ormolu.PrinterSpec + + default-language: Haskell2010 + build-depends: + base >=4.12 && <5.0, + containers >=0.5 && <0.7, + filepath >=1.2 && <1.5, + hspec >=2.0 && <3.0, + ormolu -any, + path >=0.6 && <0.8, + path-io >=1.4.2 && <2.0, + text >=0.2 && <1.3 + + if flag(dev) + ghc-options: -Wall -Werror + + else + ghc-options: -O2 -Wall diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -1,6 +1,5 @@ module GHC ( module X, - ParsedSource, ) where @@ -11,5 +10,3 @@ import Module as X import RdrName as X import SrcLoc as X - -type ParsedSource = Located (HsModule GhcPs) diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -63,7 +63,7 @@ -- to parse the rendered code back, inside of GHC monad wrapper which will -- lead to error messages presenting the exceptions as GHC bugs. let !txt = printModule result0 - when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do + when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do let pathRendered = path ++ "" -- Parse the result of pretty-printing again and make sure that AST -- is the same as AST of original snippet module span positions. @@ -79,7 +79,7 @@ Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss) -- Try re-formatting the formatted result to check if we get exactly -- the same output. - when (cfgCheckIdempotency cfg) $ + when (cfgCheckIdempotence cfg) $ let txt2 = printModule result1 in case diffText txt txt2 pathRendered of Nothing -> return () diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -24,7 +24,7 @@ -- | Output information useful for debugging cfgDebug :: !Bool, -- | Checks if re-formatting the result is idempotent - cfgCheckIdempotency :: !Bool, + cfgCheckIdempotence :: !Bool, -- | Region selection cfgRegion :: !region } @@ -56,7 +56,7 @@ { cfgDynOptions = [], cfgUnsafe = False, cfgDebug = False, - cfgCheckIdempotency = False, + cfgCheckIdempotence = False, cfgRegion = RegionIndices { regionStartLine = Nothing, diff --git a/src/Ormolu/Diff.hs b/src/Ormolu/Diff.hs --- a/src/Ormolu/Diff.hs +++ b/src/Ormolu/Diff.hs @@ -15,6 +15,7 @@ import qualified FastString as GHC import GHC import Ormolu.Imports (sortImports) +import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils @@ -38,14 +39,16 @@ diffParseResult ParseResult { prCommentStream = cstream0, - prParsedSource = ps0 + prParsedSource = hs0 } ParseResult { prCommentStream = cstream1, - prParsedSource = ps1 + prParsedSource = hs1 } = matchIgnoringSrcSpans cstream0 cstream1 - <> matchIgnoringSrcSpans ps0 ps1 + <> matchIgnoringSrcSpans + hs0 {hsmodImports = sortImports (hsmodImports hs0)} + hs1 {hsmodImports = sortImports (hsmodImports hs1)} -- | Compare two values for equality disregarding differences in 'SrcSpan's -- and the ordering of import lists. @@ -67,7 +70,7 @@ gzipWithQ ( genericQuery `extQ` srcSpanEq - `extQ` hsModuleEq + `extQ` commentEq `extQ` sourceTextEq `extQ` hsDocStringEq `extQ` importDeclQualifiedStyleEq @@ -78,14 +81,14 @@ | otherwise = Different [] srcSpanEq :: SrcSpan -> GenericQ Diff srcSpanEq _ _ = Same - hsModuleEq :: HsModule GhcPs -> GenericQ Diff - hsModuleEq hs0 hs1' = - case cast hs1' :: Maybe (HsModule GhcPs) of + commentEq :: Comment -> GenericQ Diff + commentEq (Comment _ x) d = + case cast d :: Maybe Comment of Nothing -> Different [] - Just hs1 -> - matchIgnoringSrcSpans - hs0 {hsmodImports = sortImports (hsmodImports hs0)} - hs1 {hsmodImports = sortImports (hsmodImports hs1)} + Just (Comment _ y) -> + if x == y + then Same + else Different [] sourceTextEq :: SourceText -> GenericQ Diff sourceTextEq _ _ = Same importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -88,7 +88,7 @@ case pStateErrors pstate of Just err -> Left err Nothing -> error "PFailed does not have an error" - GHC.POk pstate pmod -> + GHC.POk pstate (L _ hsModule) -> case pStateErrors pstate of -- Some parse errors (pattern/arrow syntax in expr context) -- do not cause a parse error, but they are replaced with "_" @@ -97,10 +97,10 @@ Just err -> Left err Nothing -> let (stackHeader, shebangs, pragmas, comments) = - mkCommentStream extraComments pstate + mkCommentStream input extraComments pstate in Right ParseResult - { prParsedSource = pmod, + { prParsedSource = hsModule, prAnns = mkAnns pstate, prStackHeader = stackHeader, prShebangs = shebangs, 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 @@ -4,12 +4,16 @@ -- | Functions for working with comment stream. module Ormolu.Parser.CommentStream - ( CommentStream (..), - Comment (..), + ( -- * Comment stream + CommentStream (..), mkCommentStream, - isPrevHaddock, - isMultilineComment, showCommentStream, + + -- * Comment + Comment (..), + unComment, + hasAtomsBefore, + isMultilineComment, ) where @@ -26,20 +30,20 @@ import Ormolu.Utils (showOutputable) import SrcLoc +---------------------------------------------------------------------------- +-- Comment stream + -- | A stream of 'RealLocated' 'Comment's in ascending order with respect to -- beginning of corresponding spans. newtype CommentStream = CommentStream [RealLocated Comment] deriving (Eq, Data, Semigroup, Monoid) --- | A wrapper for a single comment. The 'NonEmpty' list inside contains --- lines of multiline comment @{- … -}@ or just single item\/line otherwise. -newtype Comment = Comment (NonEmpty String) - deriving (Eq, Show, Data) - -- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are -- removed from the 'CommentStream'. Shebangs are only extracted from the -- comments that come from the first argument. mkCommentStream :: + -- | Original input + String -> -- | Extra comments to include [Located String] -> -- | Parser state to use for comment extraction @@ -50,14 +54,14 @@ [([RealLocated Comment], Pragma)], CommentStream ) -mkCommentStream extraComments pstate = +mkCommentStream input extraComments pstate = ( mstackHeader, shebangs, pragmas, CommentStream comments ) where - (comments, pragmas) = extractPragmas rawComments1 + (comments, pragmas) = extractPragmas input rawComments1 (rawComments1, mstackHeader) = extractStackHeader rawComments0 rawComments0 = L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $ @@ -68,15 +72,6 @@ (GHC.annotations_comments pstate) (shebangs, otherExtraComments) = extractShebangs extraComments --- | Test whether a 'Comment' looks like a Haddock following a definition, --- i.e. something starting with @-- ^@. -isPrevHaddock :: Comment -> Bool -isPrevHaddock (Comment (x :| _)) = "-- ^" `L.isPrefixOf` x - --- | Is this comment multiline-style? -isMultilineComment :: Comment -> Bool -isMultilineComment (Comment (x :| _)) = "{-" `L.isPrefixOf` x - -- | Pretty-print a 'CommentStream'. showCommentStream :: CommentStream -> String showCommentStream (CommentStream xs) = @@ -86,49 +81,68 @@ showComment (GHC.L l str) = showOutputable l ++ " " ++ show str ---------------------------------------------------------------------------- --- Helpers +-- Comment +-- | A wrapper for a single comment. The 'Bool' indicates whether there were +-- atoms before beginning of the comment in the original input. The +-- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or +-- just single item\/line otherwise. +data Comment = Comment Bool (NonEmpty String) + deriving (Eq, Show, Data) + -- | Normalize comment string. Sometimes one multi-line comment is turned -- into several lines for subsequent outputting with correct indentation for -- each line. -mkComment :: RealLocated String -> RealLocated Comment -mkComment (L l s) = - L l . Comment . fmap dropTrailing $ - if "{-" `L.isPrefixOf` s - then case NE.nonEmpty (lines s) of - Nothing -> s :| [] - Just (x :| xs) -> - let getIndent y = - if all isSpace y - then startIndent - else length (takeWhile isSpace y) - n = minimum (startIndent : fmap getIndent xs) - in x :| (drop n <$> xs) - else s :| [] +mkComment :: + -- | Lines of original input with their indices + [(Int, String)] -> + -- | Raw comment string + RealLocated String -> + -- | Remaining lines of original input and the constructed 'Comment' + ([(Int, String)], RealLocated Comment) +mkComment ls (L l s) = (ls', comment) where + comment = + L l . Comment atomsBefore . removeConseqBlanks . fmap dropTrailing $ + if "{-" `L.isPrefixOf` s + then case NE.nonEmpty (lines s) of + Nothing -> s :| [] + Just (x :| xs) -> + let getIndent y = + if all isSpace y + then startIndent + else length (takeWhile isSpace y) + n = minimum (startIndent : fmap getIndent xs) + in x :| (drop n <$> xs) + else s :| [] + (atomsBefore, ls') = + case dropWhile ((< commentLine) . fst) ls of + [] -> (False, []) + ((_, i) : ls'') -> + case take 2 (dropWhile isSpace i) of + "--" -> (False, ls'') + "{-" -> (False, ls'') + _ -> (True, ls'') dropTrailing = L.dropWhileEnd isSpace startIndent = srcSpanStartCol l - 1 + commentLine = srcSpanStartLine l --- | Get a 'String' from 'GHC.AnnotationComment'. -unAnnotationComment :: GHC.AnnotationComment -> Maybe String -unAnnotationComment = \case - GHC.AnnDocCommentNext _ -> Nothing -- @-- |@ - GHC.AnnDocCommentPrev _ -> Nothing -- @-- ^@ - GHC.AnnDocCommentNamed _ -> Nothing -- @-- $@ - GHC.AnnDocSection _ _ -> Nothing -- @-- *@ - GHC.AnnDocOptions s -> Just s - GHC.AnnLineComment s -> Just s - GHC.AnnBlockComment s -> Just s +-- | Get a collection of lines from a 'Comment'. +unComment :: Comment -> NonEmpty String +unComment (Comment _ xs) = xs -liftMaybe :: Located (Maybe a) -> Maybe (Located a) -liftMaybe = \case - L _ Nothing -> Nothing - L l (Just a) -> Just (L l a) +-- | Check whether the 'Comment' had some non-whitespace atoms in front of +-- it in the original input. +hasAtomsBefore :: Comment -> Bool +hasAtomsBefore (Comment atomsBefore _) = atomsBefore -toRealSpan :: Located a -> Maybe (RealLocated a) -toRealSpan (L (RealSrcSpan l) a) = Just (L l a) -toRealSpan _ = Nothing +-- | Is this comment multiline-style? +isMultilineComment :: Comment -> Bool +isMultilineComment (Comment _ (x :| _)) = "{-" `L.isPrefixOf` x +---------------------------------------------------------------------------- +-- Helpers + -- | Detect and extract stack header if it is present. extractStackHeader :: [RealLocated String] -> @@ -136,25 +150,60 @@ extractStackHeader = \case [] -> ([], Nothing) (x : xs) -> - let comment = mkComment x + let comment = snd (mkComment [] x) in if isStackHeader (unRealSrcSpan comment) then (xs, Just comment) else (x : xs, Nothing) where - isStackHeader (Comment (x :| _)) = + isStackHeader (Comment _ (x :| _)) = "stack" `L.isPrefixOf` dropWhile isSpace (drop 2 x) -- | Extract pragmas and their associated comments. extractPragmas :: + String -> [RealLocated String] -> ([RealLocated Comment], [([RealLocated Comment], Pragma)]) -extractPragmas = go id id +extractPragmas input = go initialLs id id where - go csSoFar pragmasSoFar = \case + initialLs = zip [1 ..] (lines input) + go ls csSoFar pragmasSoFar = \case [] -> (csSoFar [], pragmasSoFar []) (x : xs) -> case parsePragma (unRealSrcSpan x) of - Nothing -> go (csSoFar . (mkComment x :)) pragmasSoFar xs + Nothing -> + let (ls', x') = mkComment ls x + in go ls' (csSoFar . (x' :)) pragmasSoFar xs Just pragma -> let combined = (csSoFar [], pragma) - in go id (pragmasSoFar . (combined :)) xs + in go ls id (pragmasSoFar . (combined :)) xs + +-- | Get a 'String' from 'GHC.AnnotationComment'. +unAnnotationComment :: GHC.AnnotationComment -> Maybe String +unAnnotationComment = \case + GHC.AnnDocCommentNext _ -> Nothing -- @-- |@ + GHC.AnnDocCommentPrev _ -> Nothing -- @-- ^@ + GHC.AnnDocCommentNamed _ -> Nothing -- @-- $@ + GHC.AnnDocSection _ _ -> Nothing -- @-- *@ + GHC.AnnDocOptions s -> Just s + GHC.AnnLineComment s -> Just s + GHC.AnnBlockComment s -> Just s + +liftMaybe :: Located (Maybe a) -> Maybe (Located a) +liftMaybe = \case + L _ Nothing -> Nothing + L l (Just a) -> Just (L l a) + +toRealSpan :: Located a -> Maybe (RealLocated a) +toRealSpan (L (RealSrcSpan l) a) = Just (L l a) +toRealSpan _ = Nothing + +-- | Remove consecutive blank lines. +removeConseqBlanks :: NonEmpty String -> NonEmpty String +removeConseqBlanks (x :| xs) = x :| go (null x) id xs + where + go seenBlank acc = \case + [] -> acc [] + (y : ys) -> + if seenBlank && null y + then go True acc ys + else go (null y) (acc . (y :)) ys 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 @@ -17,7 +17,7 @@ -- | A collection of data that represents a parsed module in Ormolu. data ParseResult = ParseResult { -- | 'ParsedSource' from GHC - prParsedSource :: ParsedSource, + prParsedSource :: HsModule GhcPs, -- | Ormolu-specfic representation of annotations prAnns :: Anns, -- | Stack header 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 @@ -51,6 +51,7 @@ -- ** Literals comma, + equals, -- ** Stateful markers SpanMark (..), @@ -62,12 +63,10 @@ where import Control.Monad -import Data.Data (Data) import Data.List (intersperse) import Data.Text (Text) import Ormolu.Printer.Comments import Ormolu.Printer.Internal -import Ormolu.Utils (isModule) import SrcLoc ---------------------------------------------------------------------------- @@ -79,31 +78,20 @@ -- 'Located' wrapper, it should be “discharged” with a corresponding -- 'located' invocation. located :: - Data a => -- | Thing to enter Located a -> -- | How to render inner value (a -> R ()) -> R () -located loc f = do - let withRealLocated (L l a) g = - case l of - UnhelpfulSpan _ -> return () - RealSrcSpan l' -> g (L l' a) - withRealLocated loc spitPrecedingComments - let setEnclosingSpan = - case getLoc loc of - UnhelpfulSpan _ -> id - RealSrcSpan orf -> - if isModule (unLoc loc) - then id - else withEnclosingSpan orf - setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc)) - withRealLocated loc spitFollowingComments +located (L (UnhelpfulSpan _) a) f = f a +located (L (RealSrcSpan l) a) f = do + spitPrecedingComments l + withEnclosingSpan l $ + switchLayout [RealSrcSpan l] (f a) + spitFollowingComments l -- | A version of 'located' with arguments flipped. located' :: - Data a => -- | How to render inner value (a -> R ()) -> -- | Thing to enter @@ -288,3 +276,7 @@ -- | Print @,@. comma :: R () comma = txt "," + +-- | Print @=@. Do not use @'txt' "="@. +equals :: R () +equals = interferingTxt "=" 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 @@ -13,13 +13,11 @@ where import Control.Monad -import Data.Coerce (coerce) -import Data.Data (Data) import qualified Data.List.NonEmpty as NE +import Data.Maybe (listToMaybe) import qualified Data.Text as T import Ormolu.Parser.CommentStream import Ormolu.Printer.Internal -import Ormolu.Utils (isModule) import SrcLoc ---------------------------------------------------------------------------- @@ -27,9 +25,8 @@ -- | Output all preceding comments for an element at given location. spitPrecedingComments :: - Data a => - -- | AST element to attach comments to - RealLocated a -> + -- | Span of the element to attach comments to + RealSrcSpan -> R () spitPrecedingComments ref = do gotSome <- handleCommentSeries (spitPrecedingComment ref) @@ -37,16 +34,15 @@ lastMark <- getSpanMark -- Insert a blank line between the preceding comments and the thing -- after them if there was a blank line in the input. - when (needsNewlineBefore (getRealSrcSpan ref) lastMark) newline + when (needsNewlineBefore ref lastMark) newline -- | Output all comments following an element at given location. spitFollowingComments :: - Data a => - -- | AST element of attach comments to - RealLocated a -> + -- | Span of the element to attach comments to + RealSrcSpan -> R () spitFollowingComments ref = do - trimSpanStream (getRealSrcSpan ref) + trimSpanStream ref void $ handleCommentSeries (spitFollowingComment ref) -- | Output all remaining comments in the comment stream. @@ -62,49 +58,41 @@ -- | Output a single preceding comment for an element at given location. spitPrecedingComment :: - Data a => - -- | AST element to attach comments to - RealLocated a -> - -- | Location of last comment in the series - Maybe SpanMark -> + -- | Span of the element to attach comments to + RealSrcSpan -> -- | Are we done? R Bool -spitPrecedingComment (L ref a) mlastMark = do +spitPrecedingComment ref = do + mlastMark <- getSpanMark let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref withPoppedComment p $ \l comment -> do - dirtyLine <- - case mlastMark of - -- When the current line is dirty it means that something that can - -- have comments attached to it is already on the line. To avoid - -- problems with idempotence we cannot output the first comment - -- immediately because it'll be attached to the previous element (on - -- the same line) on the next run, so we play safe here and output - -- an extra 'newline' in this case. - Nothing -> isLineDirty -- only for very first preceding comment - Just _ -> return False - when (dirtyLine || needsNewlineBefore l mlastMark) newline + lineSpans <- thisLineSpans + let thisCommentLine = srcLocLine (realSrcSpanStart l) + needsNewline = + case listToMaybe lineSpans of + Nothing -> False + Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine + when (needsNewline || needsNewlineBefore l mlastMark) newline spitCommentNow l comment - if theSameLinePre l ref && not (isModule a) + if theSameLinePre l ref then space else newline -- | Output a comment that follows element at given location immediately on -- the same line, if there is any. spitFollowingComment :: - Data a => -- | AST element to attach comments to - RealLocated a -> - -- | Location of last comment in the series - Maybe SpanMark -> + RealSrcSpan -> -- | Are we done? R Bool -spitFollowingComment (L ref a) mlastMark = do +spitFollowingComment ref = do + mlastMark <- getSpanMark mnSpn <- nextEltSpan -- Get first enclosing span that is not equal to reference span, i.e. it's -- truly something enclosing the AST element. meSpn <- getEnclosingSpan (/= ref) withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment -> - if theSameLinePost l ref && not (isModule a) + if theSameLinePost l ref then if isMultilineComment comment then space >> spitCommentNow l comment @@ -116,11 +104,10 @@ -- | Output a single remaining comment from the comment stream. spitRemainingComment :: - -- | Location of last comment in the series - Maybe SpanMark -> -- | Are we done? R Bool -spitRemainingComment mlastMark = +spitRemainingComment = do + mlastMark <- getSpanMark withPoppedComment (const True) $ \l comment -> do when (needsNewlineBefore l mlastMark) newline spitCommentNow l comment @@ -133,13 +120,13 @@ handleCommentSeries :: -- | Given location of previous comment, output the next comment -- returning 'True' if we're done - (Maybe SpanMark -> R Bool) -> + R Bool -> -- | Whether we printed any comments R Bool handleCommentSeries f = go False where go gotSome = do - done <- getSpanMark >>= f + done <- f if done then return gotSome else go True @@ -219,9 +206,8 @@ -- 2) The comment logically belongs to the element, four cases: logicallyFollows = theSameLinePost l ref -- a) it's on the same line - || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^ - || continuation -- c) it's a continuation of a comment block - || lastInEnclosing -- d) it's the last element in the enclosing construct + || continuation -- b) it's a continuation of a comment block + || lastInEnclosing -- c) it's the last element in the enclosing construct -- 3) There is no other AST element between this element and the comment: noEltBetween = @@ -248,12 +234,16 @@ >= abs (startColumn ref - startColumn l) ) continuation = - case mlastMark of - Just (HaddockSpan _ spn) -> - srcSpanEndLine spn + 1 == srcSpanStartLine l - Just (CommentSpan spn) -> - srcSpanEndLine spn + 1 == srcSpanStartLine l - _ -> False + -- 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 _ spn) -> + srcSpanEndLine spn + 1 == srcSpanStartLine l + Just (CommentSpan spn) -> + srcSpanEndLine spn + 1 == srcSpanStartLine l + _ -> False + ) lastInEnclosing = case meSpn of -- When there is no enclosing element, return false @@ -275,7 +265,7 @@ . sequence_ . NE.intersperse newline . fmap (txt . T.pack) - . coerce + . unComment $ comment setSpanMark (CommentSpan spn) @@ -291,6 +281,6 @@ . sequence_ . NE.toList . fmap (registerPendingCommentLine position . T.pack) - . coerce + . unComment $ comment setSpanMark (CommentSpan spn) 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 @@ -14,10 +14,10 @@ -- * Internal functions txt, + interferingTxt, atom, space, newline, - isLineDirty, useRecordDot, inci, sitcc, @@ -39,6 +39,7 @@ popComment, getEnclosingSpan, withEnclosingSpan, + thisLineSpans, -- * Stateful markers SpanMark (..), @@ -98,18 +99,19 @@ data SC = SC { -- | Index of the next column to render scColumn :: !Int, + -- | Indentation level that was used for the current line + scIndent :: !Int, -- | Rendered source code so far scBuilder :: Builder, -- | Span stream scSpanStream :: SpanStream, + -- | Spans of atoms that have been printed on the current line so far + scThisLineSpans :: [RealSrcSpan], -- | Comment stream scCommentStream :: CommentStream, -- | Pending comment lines (in reverse order) to be inserted before next -- newline, 'Int' is the indentation level - scPendingComments :: ![(CommentPosition, Int, Text)], - -- | Whether the current line is “dirty”, that is, already contains - -- atoms that can have comments attached to them - scDirtyLine :: !Bool, + scPendingComments :: ![(CommentPosition, Text)], -- | Whether to output a space before the next output scRequestedDelimiter :: !RequestedDelimiter, -- | An auxiliary marker for keeping track of last output element @@ -175,11 +177,12 @@ sc = SC { scColumn = 0, + scIndent = 0, scBuilder = mempty, scSpanStream = sstream, + scThisLineSpans = [], scCommentStream = cstream, scPendingComments = [], - scDirtyLine = False, scRequestedDelimiter = VeryBeginning, scSpanMark = Nothing } @@ -187,6 +190,23 @@ ---------------------------------------------------------------------------- -- Internal functions +-- | Type of the thing to output. Influences the primary low-level rendering +-- function 'spit'. +data SpitType + = -- | Simple opaque text that breaks comment series. + SimpleText + | -- | Like 'SimpleText', but assume that when this text is inserted it + -- will separate an 'Atom' and its pending comments, so insert an extra + -- 'newline' in that case to force the pending comments and continue on + -- a fresh line. + InterferingText + | -- | An atom that typically have span information in the AST and can + -- have comments attached to it. + Atom + | -- | Used for rendering comment lines. + CommentPart + deriving (Show, Eq) + -- | Output a fixed 'Text' fragment. The argument may not contain any line -- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like -- keywords and pipes @|@ in functional dependencies. @@ -198,8 +218,15 @@ -- | 'Text' to output Text -> R () -txt = spit False False +txt = spit SimpleText +-- | +interferingTxt :: + -- | 'Text' to output + Text -> + R () +interferingTxt = spit InterferingText + -- | Output 'Outputable' fragment of AST. This can be used to output numeric -- literals and similar. Everything that doesn't have inner structure but -- does have an 'Outputable' instance. @@ -207,47 +234,59 @@ Outputable a => a -> R () -atom = spit True False . T.pack . showOutputable +atom = spit Atom . T.pack . showOutputable -- | Low-level non-public helper to define 'txt' and 'atom'. spit :: - -- | Should we mark the line as dirty? - Bool -> - -- | Used during outputting of pending comments? - Bool -> + -- | Type of the thing to spit + SpitType -> -- | 'Text' to output Text -> R () -spit dirty printingComments txt' = do +spit stype text = do requestedDel <- R (gets scRequestedDelimiter) + pendingComments <- R (gets scPendingComments) + when (stype == InterferingText && not (null pendingComments)) newline case requestedDel of RequestedNewline -> do R . modify $ \sc -> sc { scRequestedDelimiter = RequestedNothing } - if printingComments - then newlineRaw - else newline + case stype of + CommentPart -> newlineRaw + _ -> newline _ -> return () R $ do i <- asks rcIndent c <- gets scColumn - let spaces = - if c < i - then T.replicate (i - c) " " - else bool mempty " " (requestedDel == RequestedSpace) - indentedTxt = spaces <> txt' + closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans + let indentedTxt = spaces <> text + spaces = T.replicate spacesN " " + spacesN = + if c == 0 + then i + else bool 0 1 (requestedDel == RequestedSpace) modify $ \sc -> sc { scBuilder = scBuilder sc <> fromText indentedTxt, scColumn = scColumn sc + T.length indentedTxt, - scDirtyLine = scDirtyLine sc || dirty, + scIndent = + if c == 0 + then i + else scIndent sc, + scThisLineSpans = + let xs = scThisLineSpans sc + in case stype of + Atom -> case closestEnclosing of + Nothing -> xs + Just x -> x : xs + _ -> xs, scRequestedDelimiter = RequestedNothing, scSpanMark = -- If there are pending comments, do not reset last comment -- location. - if printingComments || (not . null . scPendingComments) sc + if (stype == CommentPart) || (not . null . scPendingComments) sc then scSpanMark sc else Nothing } @@ -279,21 +318,22 @@ -- hard to output more than one blank newline in a row. newline :: R () newline = do + indent <- R (gets scIndent) cs <- reverse <$> R (gets scPendingComments) case cs of [] -> newlineRaw - ((position, _, _) : _) -> do + ((position, _) : _) -> do case position of OnTheSameLine -> space OnNextLine -> newlineRaw - R . forM_ cs $ \(_, indent, txt') -> + R . forM_ cs $ \(_, text) -> let modRC rc = rc { rcIndent = indent } R m = do - unless (T.null txt') $ - spit False True txt' + unless (T.null text) $ + spit CommentPart text newlineRaw in local modRC m R . modify $ \sc -> @@ -314,7 +354,8 @@ VeryBeginning -> builderSoFar _ -> builderSoFar <> "\n", scColumn = 0, - scDirtyLine = False, + scIndent = 0, + scThisLineSpans = [], scRequestedDelimiter = case scRequestedDelimiter sc of AfterNewline -> RequestedNewline RequestedNewline -> RequestedNewline @@ -322,14 +363,9 @@ _ -> AfterNewline } --- | Check if the current line is “dirty”, that is, there is something on it --- that can have comments attached to it. -isLineDirty :: R Bool -isLineDirty = R (gets scDirtyLine) - -- | Return 'True' if we should print record dot syntax. useRecordDot :: R Bool -useRecordDot = R $ asks rcUseRecDot +useRecordDot = R (asks rcUseRecDot) -- | Increase indentation level by one indentation step for the inner -- computation. 'inci' should be used when a part of code must be more @@ -346,8 +382,7 @@ -- | Set indentation level for the inner computation equal to current -- column. This makes sure that the entire inner block is uniformly --- \"shifted\" to the right. Only works (and makes sense) when enclosing --- layout is multi-line. +-- \"shifted\" to the right. sitcc :: R () -> R () sitcc (R m) = do requestedDel <- R (gets scRequestedDelimiter) @@ -355,16 +390,9 @@ c <- R (gets scColumn) let modRC rc = rc - { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace) + { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace)) } - vlayout (R m) . R $ do - modify $ \sc -> - sc - { scRequestedDelimiter = case requestedDel of - RequestedSpace -> RequestedNothing - other -> other - } - local modRC m + R (local modRC m) -- | Set 'Layout' for internal computation. enterLayout :: Layout -> R () -> R () @@ -405,11 +433,10 @@ -- | 'Text' to output Text -> R () -registerPendingCommentLine position txt' = R $ do - i <- asks rcIndent +registerPendingCommentLine position text = R $ do modify $ \sc -> sc - { scPendingComments = (position, i, txt') : scPendingComments sc + { scPendingComments = (position, text) : scPendingComments sc } -- | Drop elements that begin before or at the same place as given @@ -468,6 +495,10 @@ { rcEnclosingSpans = spn : rcEnclosingSpans rc } +-- | Get spans on this line so far. +thisLineSpans :: R [RealSrcSpan] +thisLineSpans = R (gets scThisLineSpans) + ---------------------------------------------------------------------------- -- Stateful markers @@ -477,15 +508,15 @@ HaddockSpan HaddockStyle RealSrcSpan | -- | Non-haddock comment CommentSpan RealSrcSpan - | -- | Non-comment span - OtherSpan RealSrcSpan + | -- | A statement in a do-block and such span + StatementSpan RealSrcSpan -- | Project 'RealSrcSpan' from 'SpanMark'. spanMarkSpan :: SpanMark -> RealSrcSpan spanMarkSpan = \case HaddockSpan _ s -> s CommentSpan s -> s - OtherSpan s -> s + StatementSpan s -> s -- | Haddock string style. data HaddockStyle @@ -534,7 +565,7 @@ -- | Return 'True' if we can use braces in this context. canUseBraces :: R Bool -canUseBraces = R $ asks rcCanUseBraces +canUseBraces = R (asks rcCanUseBraces) ---------------------------------------------------------------------------- -- Constants 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 @@ -154,10 +154,11 @@ LHsDocString -> R () p_hsDocString hstyle needsNewline (L l str) = do - goesAfterComment <- getSpanMark >>= \case - Just (HaddockSpan _ _) -> return True - Just (CommentSpan _) -> return True - _ -> return False + let isCommentSpan = \case + HaddockSpan _ _ -> True + CommentSpan _ -> True + _ -> False + goesAfterComment <- maybe False isCommentSpan <$> getSpanMark -- Make sure the Haddock is separated by a newline from other comments. when goesAfterComment newline forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do 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 @@ -66,13 +66,17 @@ let singleConstRec = isSingleConstRec dd_cons if singleConstRec then space - else breakpoint - txt "=" + else + if hasHaddocks dd_cons + then newline + else breakpoint + equals space + layout <- getLayout let s = - vlayout - (space >> txt "|" >> space) - (newline >> txt "|" >> space) + if layout == MultiLine || hasHaddocks dd_cons + then newline >> txt "|" >> space + else space >> txt "|" >> space sitcc' = if singleConstRec then id @@ -150,7 +154,7 @@ PrefixCon xs -> do p_rdrName con_name unless (null xs) breakpoint - inci . sitcc $ sep breakpoint (sitcc . located' p_hsType) xs + inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) xs RecCon l -> do p_rdrName con_name breakpoint @@ -256,3 +260,9 @@ RecCon _ -> True _ -> False isSingleConstRec _ = False + +hasHaddocks :: [LConDecl GhcPs] -> Bool +hasHaddocks = any (f . unLoc) + where + f ConDeclH98 {..} = isJust con_doc + f _ = False diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -43,7 +43,7 @@ inci $ do located lhs p_hsExpr space - txt "=" + equals inci $ do breakpoint located rhs p_hsExpr diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -48,11 +48,12 @@ p_rdrName n if null ns then p_typeAscription hswc - else bool id inci indentTail $ do + else do comma breakpoint - sep (comma >> breakpoint) p_rdrName ns - p_typeAscription hswc + bool id inci indentTail $ do + sep (comma >> breakpoint) p_rdrName ns + p_typeAscription hswc p_typeAscription :: LHsSigWcType GhcPs -> @@ -74,7 +75,11 @@ R () p_patSynSig names hsib = do txt "pattern" - let body = p_typeSig False names HsWC {hswc_ext = NoExtField, hswc_body = hsib} + let body = + p_typeSig + False + names + HsWC {hswc_ext = NoExtField, hswc_body = hsib} if length names > 1 then breakpoint >> inci body else space >> body diff --git a/src/Ormolu/Printer/Meat/Declaration/Type.hs b/src/Ormolu/Printer/Meat/Declaration/Type.hs --- a/src/Ormolu/Printer/Meat/Declaration/Type.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Type.hs @@ -32,7 +32,9 @@ (p_rdrName name) (map (located' p_hsTyVarBndr) hsq_explicit) space - txt "=" - breakpoint + equals + if hasDocStrings (unLoc t) + then newline + else breakpoint inci (located t p_hsType) p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x diff --git a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs --- a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +++ b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs @@ -69,7 +69,7 @@ breakpoint located k p_hsType TyVarSig NoExtField bndr -> Just $ do - txt "=" + equals breakpoint located bndr p_hsTyVarBndr XFamilyResultSig x -> @@ -101,7 +101,7 @@ (p_rdrName feqn_tycon) (located' p_hsType . typeArgToType <$> feqn_pats) space - txt "=" + equals breakpoint inci (located feqn_rhs p_hsType) p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x 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 @@ -217,35 +217,27 @@ -- about putting certain constructions in hanging positions. endOfPats = case NE.nonEmpty m_pats of Nothing -> case style of - Function name -> (Just . srcSpanEnd . getLoc) name + Function name -> Just (getLoc name) _ -> Nothing - Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats + Just pats -> (Just . getLoc . NE.last) pats isCase = \case Case -> True LambdaCase -> True _ -> False let hasGuards = withGuards grhssGRHSs - unless (length grhssGRHSs > 1) $ - case style of - Function _ | hasGuards -> return () - Function _ -> space >> txt "=" - PatternBind -> space >> txt "=" - s | isCase s && hasGuards -> return () - _ -> space >> txt "->" - let grhssSpan = + grhssSpan = combineSrcSpans' $ getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs patGrhssSpan = maybe grhssSpan - (combineSrcSpans grhssSpan . srcLocSpan) + (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd) endOfPats placement = case endOfPats of Nothing -> blockPlacement placer grhssGRHSs Just spn -> - if isOneLineSpan - (mkSrcSpan spn (srcSpanStart grhssSpan)) + if onTheSameLine spn grhssSpan then blockPlacement placer grhssGRHSs else Normal p_body = do @@ -262,6 +254,13 @@ unless whereIsEmpty breakpoint inci $ located grhssLocalBinds p_hsLocalBinds inci' $ do + unless (length grhssGRHSs > 1) $ + case style of + Function _ | hasGuards -> return () + Function _ -> space >> inci equals + PatternBind -> space >> inci equals + s | isCase s && hasGuards -> return () + _ -> space >> txt "->" switchLayout [patGrhssSpan] $ placeHanging placement p_body inci p_where @@ -287,22 +286,22 @@ space sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs) space - txt $ case style of - EqualSign -> "=" - RightArrow -> "->" + inci $ case style of + EqualSign -> equals + RightArrow -> txt "->" placeHanging placement p_body where placement = case endOfGuards of Nothing -> placer (unLoc body) Just spn -> - if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body))) + if onTheSameLine spn (getLoc body) then placer (unLoc body) else Normal endOfGuards = case NE.nonEmpty guards of Nothing -> Nothing - Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs + Just gs -> (Just . getLoc . NE.last) gs p_body = located body render p_grhs' _ _ _ (XGRHS x) = noExtCon x @@ -363,7 +362,7 @@ -- Spacing before comments will be handled by the code -- that prints comments, so we just have to deal with -- blank lines between statements here. - Just (OtherSpan lastSpn) -> + Just (StatementSpan lastSpn) -> if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1 then newline else return () @@ -374,7 +373,7 @@ getSpanMark >>= \case Just (HaddockSpan _ _) -> return () Just (CommentSpan _) -> return () - _ -> setSpanMark (OtherSpan currentSpn) + _ -> setSpanMark (StatementSpan currentSpn) p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R () p_stmt = p_stmt' exprPlacement p_hsExpr @@ -495,7 +494,7 @@ let p_ipBind (IPBind NoExtField (Left name) expr) = do atom name space - txt "=" + equals breakpoint useBraces $ inci $ located expr p_hsExpr p_ipBind (IPBind NoExtField (Right _) _) = @@ -514,9 +513,12 @@ p_rdrName hsRecFieldLbl unless hsRecPun $ do space - txt "=" - let placement = exprPlacement (unLoc hsRecFieldArg) - placeHanging placement $ located hsRecFieldArg p_hsExpr + equals + let placement = + if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg) + then exprPlacement (unLoc hsRecFieldArg) + else Normal + placeHanging placement (located hsRecFieldArg p_hsExpr) p_hsTupArg :: HsTupArg GhcPs -> R () p_hsTupArg = \case @@ -661,7 +663,8 @@ HsIf NoExtField _ if' then' else' -> p_if exprPlacement p_hsExpr if' then' else' HsMultiIf NoExtField guards -> do - txt "if " + txt "if" + breakpoint inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards HsLet NoExtField localBinds e -> p_let p_hsExpr localBinds e @@ -819,7 +822,7 @@ breakpoint located psb_def p_pat ImplicitBidirectional -> do - txt "=" + equals breakpoint located psb_def p_pat ExplicitBidirectional mgroup -> do @@ -901,10 +904,12 @@ breakpoint inci $ do txt "then" + space located then' $ \x -> placeHanging (placer x) (render x) breakpoint txt "else" + space located else' $ \x -> placeHanging (placer x) (render x) @@ -1004,7 +1009,7 @@ p_rdrName (rdrNameFieldOcc x) unless hsRecPun $ do space - txt "=" + equals breakpoint inci (located hsRecFieldArg p_pat) 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 @@ -34,9 +34,9 @@ -- | Whether to use postfix qualified imports Bool -> -- | AST to print - ParsedSource -> + HsModule GhcPs -> R () -p_hsModule mstackHeader shebangs pragmas qualifiedPost (L _ HsModule {..}) = do +p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports switchLayout (deprecSpan <> exportSpans) $ do 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 @@ -5,6 +5,7 @@ -- | Rendering of types. module Ormolu.Printer.Meat.Type ( p_hsType, + p_hsTypePostDoc, hasDocStrings, p_hsContext, p_hsTyVarBndr, @@ -23,14 +24,22 @@ import Ormolu.Utils p_hsType :: HsType GhcPs -> R () -p_hsType t = p_hsType' (hasDocStrings t) t +p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t -p_hsType' :: Bool -> HsType GhcPs -> R () -p_hsType' multilineArgs = \case +p_hsTypePostDoc :: HsType GhcPs -> R () +p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t + +-- | How to render Haddocks associated with a type. +data TypeDocStyle + = PipeStyle + | CaretStyle + +p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R () +p_hsType' multilineArgs docStyle = \case HsForAllTy NoExtField visibility bndrs t -> do p_forallBndrs visibility p_hsTyVarBndr bndrs interArgBreak - p_hsType' multilineArgs (unLoc t) + p_hsTypeR (unLoc t) HsQualTy NoExtField qs t -> do located qs p_hsContext space @@ -114,9 +123,15 @@ space inci (located k p_hsType) HsSpliceTy NoExtField splice -> p_hsSplice splice - HsDocTy NoExtField t str -> do - p_hsDocString Pipe True str - located t p_hsType + HsDocTy NoExtField t str -> + case docStyle of + PipeStyle -> do + p_hsDocString Pipe True str + located t p_hsType + CaretStyle -> do + located t p_hsType + newline + p_hsDocString Caret False str HsBangTy NoExtField (HsSrcBang _ u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-}" >> space @@ -156,14 +171,14 @@ where isPromoted = \case HsTyVar _ IsPromoted _ -> True - HsExplicitListTy {} -> True HsExplicitTupleTy {} -> True + HsExplicitListTy {} -> True _ -> False interArgBreak = if multilineArgs then newline else breakpoint - p_hsTypeR = p_hsType' multilineArgs + p_hsTypeR = p_hsType' multilineArgs docStyle -- | Return 'True' if at least one argument in 'HsType' has a doc string -- attached to it. 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 @@ -12,8 +12,9 @@ import Data.Function (on) import qualified Data.List as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, mapMaybe) -import Data.Ord (Down (Down), comparing) import GHC import OccName (mkVarOcc) import Ormolu.Utils (unSrcSpan) @@ -56,7 +57,7 @@ reassociateOpTreeWith :: forall ty op. -- | Fixity map for operators - [(RdrName, Fixity)] -> + Map RdrName Fixity -> -- | How to get the name of an operator (op -> Maybe RdrName) -> -- | Original 'OpTree' @@ -68,12 +69,12 @@ fixityOf :: op -> Fixity fixityOf op = fromMaybe defaultFixity $ do opName <- getOpName op - lookup opName fixityMap + M.lookup opName fixityMap -- Here, left branch is already associated and the root alongside with -- the right branch is right-associated. This function picks up one item -- from the right and inserts it correctly to the left. -- - -- Also, we are using the 'compareFixity' function which returns if the + -- Also, we are using the 'compareFixity' function which tells if the -- expression should associate to right. go :: OpTree ty op -> OpTree ty op -- base cases @@ -93,6 +94,16 @@ then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r' else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r' +-- | A score assigned to an operator. +data Score + = -- | The operator was placed at the beginning of a line + AtBeginning Int + | -- | The operator was placed at the end of a line + AtEnd + | -- | The operator was placed in between arguments on a single line + InBetween + deriving (Eq, Ord) + -- | Build a map of inferred 'Fixity's from an 'OpTree'. buildFixityMap :: forall ty op. @@ -101,23 +112,26 @@ -- | Operator tree OpTree (Located ty) (Located op) -> -- | Fixity map - [(RdrName, Fixity)] + Map RdrName Fixity buildFixityMap getOpName opTree = - concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns) - . zip [0 ..] - . L.groupBy (doubleWithinEps 0.00001 `on` snd) - . (overrides ++) - . modeScores + addOverrides + . M.fromList + . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns) + . zip [1 ..] + . L.groupBy ((==) `on` snd) + . selectScores $ score opTree where - -- Add a special case for ($), since it is pretty unlikely for someone - -- to override it. - overrides :: [(RdrName, Double)] - overrides = - [ (mkRdrUnqual $ mkVarOcc "$", -1) - ] - -- Assign scores to operators based on their location in the source. - score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)] + addOverrides :: Map RdrName Fixity -> Map RdrName Fixity + addOverrides m = + let mk k v = (mkRdrUnqual (mkVarOcc k), fixity v InfixL) + in M.fromList + [ mk "$" 0, + mk "." 9 + ] + `M.union` m + fixity = Fixity NoSourceText + score :: OpTree (Located ty) (Located op) -> [(RdrName, Score)] score (OpNode _) = [] score (OpBranch l o r) = fromMaybe (score r) $ do -- If we fail to get any of these, 'defaultFixity' will be used by @@ -129,46 +143,25 @@ oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column opName <- getOpName (unLoc o) let s - | le < ob = - -- if the operator is in the beginning of a line, assign - -- a score relative to its column within range [0, 1). - fromIntegral oc / fromIntegral (maxCol + 1) - | oe < rb = - -- if the operator is in the end of the line, assign the - -- score 1. - 1 - | otherwise = - 2 -- otherwise, assign a high score. + | le < ob = AtBeginning oc + | oe < rb = AtEnd + | otherwise = InBetween return $ (opName, s) : score r - -- Pick the most common score per 'RdrName'. - modeScores :: [(RdrName, Double)] -> [(RdrName, Double)] - modeScores = + selectScores :: [(RdrName, Score)] -> [(RdrName, Score)] + selectScores = L.sortOn snd . mapMaybe ( \case [] -> Nothing - xs@((n, _) : _) -> Just (n, mode $ map snd xs) + xs@((n, _) : _) -> Just (n, selectScore $ map snd xs) ) . L.groupBy ((==) `on` fst) . L.sort - -- Return the most common number, leaning to the smaller - -- one in case of a tie. - mode :: [Double] -> Double - mode = - head - . L.minimumBy (comparing (Down . length)) - . L.groupBy (doubleWithinEps 0.0001) - . L.sort - -- The start column of the rightmost operator. - maxCol = go opTree - where - go (OpNode (L _ _)) = 0 - go (OpBranch l (L o _) r) = - maximum - [ go l, - maybe 0 srcSpanStartCol (unSrcSpan o), - go r - ] + selectScore :: [Score] -> Score + selectScore xs = + case filter (/= InBetween) xs of + [] -> InBetween + xs' -> maximum xs' ---------------------------------------------------------------------------- -- Helpers @@ -182,9 +175,3 @@ OpBranch (OpNode l) lop (normalizeOpTree r) normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) = normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r)) - -fixity :: Int -> FixityDirection -> Fixity -fixity = Fixity NoSourceText - -doubleWithinEps :: Double -> Double -> Double -> Bool -doubleWithinEps eps a b = abs (a - b) < eps diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -6,7 +6,6 @@ ( RelativePos (..), attachRelativePos, combineSrcSpans', - isModule, notImplemented, showOutputable, splitDocString, @@ -15,10 +14,10 @@ incSpanLine, separatedByBlank, separatedByBlankNE, + onTheSameLine, ) where -import Data.Data (Data, showConstr, toConstr) import Data.List (dropWhileEnd) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty (..)) @@ -52,10 +51,6 @@ combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs --- | Return 'True' if given element of AST is module. -isModule :: Data a => a -> Bool -isModule x = showConstr (toConstr x) == "HsModule" - -- | Placeholder for things that are not yet implemented. notImplemented :: String -> a notImplemented msg = error $ "not implemented yet: " ++ msg @@ -139,3 +134,8 @@ -- | Do two declaration groups have a blank between them? separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b) + +-- | Return 'True' if one span ends on the same line the second one starts. +onTheSameLine :: SrcSpan -> SrcSpan -> Bool +onTheSameLine a b = + isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b)) diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -62,7 +62,7 @@ -- | A version of 'shouldBe' that is specialized to comparing 'Text' values. -- It also prints multi-line snippets in a more readable form. shouldMatch :: Bool -> Text -> Text -> Expectation -shouldMatch idempotencyTest actual expected = +shouldMatch idempotenceTest actual expected = when (actual /= expected) . expectationFailure $ unlines [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):", @@ -72,8 +72,8 @@ ] where pass = - if idempotencyTest - then "idempotency pass" + if idempotenceTest + then "idempotence pass" else "first pass" examplesDir :: Path Rel Dir