diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,28 @@ +## Ormolu 0.0.3.0 + +* Fixed an issue related to unnecessary use of curly braces. [Issue + 473](https://github.com/tweag/ormolu/issues/473). + +* Fixed the issue with formatting multi-way if when it happens to be a + function applied to arguments [Issue + 488](https://github.com/tweag/ormolu/issues/488). This changed the way + multi-line if is formatted in general. + +* Added support for record dot pre-processor when used via the plugin. + [Issue 486](https://github.com/tweag/ormolu/issues/486). + +* Stopped hanging record constructors and improved placing + potentially-hanging consturctions in the presence of comments. [Issue + 447](https://github.com/tweag/ormolu/issues/447). + +* Fixed indentation in presence of type applications. [Issue + 493](https://github.com/tweag/ormolu/issues/493). + +* Class and instance declarations now do not have a blank line after + `where`. Grouping of methods from the original input is also preserved + with some normalizations. [Issue + 431](https://github.com/tweag/ormolu/issues/431). + ## Ormolu 0.0.2.0 * Switched to `ghc-lib-parser` instead of depending on the `ghc` package diff --git a/data/examples/declaration/class/associated-data1-out.hs b/data/examples/declaration/class/associated-data1-out.hs --- a/data/examples/declaration/class/associated-data1-out.hs +++ b/data/examples/declaration/class/associated-data1-out.hs @@ -4,7 +4,6 @@ -- | Something. class Bar a where - -- | Bar bar data BarBar a diff --git a/data/examples/declaration/class/associated-data2-out.hs b/data/examples/declaration/class/associated-data2-out.hs --- a/data/examples/declaration/class/associated-data2-out.hs +++ b/data/examples/declaration/class/associated-data2-out.hs @@ -4,7 +4,6 @@ -- | Something more. class Baz a where - -- | Baz bar data BazBar diff --git a/data/examples/declaration/class/associated-type-defaults-out.hs b/data/examples/declaration/class/associated-type-defaults-out.hs --- a/data/examples/declaration/class/associated-type-defaults-out.hs +++ b/data/examples/declaration/class/associated-type-defaults-out.hs @@ -4,7 +4,6 @@ -- | Something. class Bar a where - -- Define bar type BarBar a = @@ -18,7 +17,6 @@ a class Baz a where - type BazBar a diff --git a/data/examples/declaration/class/associated-types1-out.hs b/data/examples/declaration/class/associated-types1-out.hs --- a/data/examples/declaration/class/associated-types1-out.hs +++ b/data/examples/declaration/class/associated-types1-out.hs @@ -4,7 +4,6 @@ -- | Something. class Bar a where - -- | Bar bar type BarBar a diff --git a/data/examples/declaration/class/associated-types2-out.hs b/data/examples/declaration/class/associated-types2-out.hs --- a/data/examples/declaration/class/associated-types2-out.hs +++ b/data/examples/declaration/class/associated-types2-out.hs @@ -4,7 +4,6 @@ -- | Something more. class Baz a where - -- | Baz bar type BazBar diff --git a/data/examples/declaration/class/default-implementations-comments-out.hs b/data/examples/declaration/class/default-implementations-comments-out.hs --- a/data/examples/declaration/class/default-implementations-comments-out.hs +++ b/data/examples/declaration/class/default-implementations-comments-out.hs @@ -2,7 +2,6 @@ -- | Baz class Baz a where - foobar :: a -> a foobar a = barbaz (bazbar a) diff --git a/data/examples/declaration/class/default-signatures-out.hs b/data/examples/declaration/class/default-signatures-out.hs --- a/data/examples/declaration/class/default-signatures-out.hs +++ b/data/examples/declaration/class/default-signatures-out.hs @@ -4,13 +4,11 @@ -- | Something else. class Bar a where - -- | Bar bar :: String -> String -> a - -- Pointless comment default bar :: ( Read a, diff --git a/data/examples/declaration/class/default-signatures-simple-out.hs b/data/examples/declaration/class/default-signatures-simple-out.hs --- a/data/examples/declaration/class/default-signatures-simple-out.hs +++ b/data/examples/declaration/class/default-signatures-simple-out.hs @@ -2,9 +2,7 @@ -- | Something. class Foo a where - -- | Foo foo :: a -> String - default foo :: Show a => a -> String foo = show diff --git a/data/examples/declaration/class/dependency-super-classes-out.hs b/data/examples/declaration/class/dependency-super-classes-out.hs --- a/data/examples/declaration/class/dependency-super-classes-out.hs +++ b/data/examples/declaration/class/dependency-super-classes-out.hs @@ -4,9 +4,7 @@ -- | Something. class (MonadReader r s, MonadWriter w m) => MonadState s m | m -> s where - get :: m s - put :: s -> m () -- | 'MonadParsec' @@ -16,7 +14,6 @@ ) => MonadParsec e s m | m -> e s where - -- | 'getState' returns state getState :: m s diff --git a/data/examples/declaration/class/multi-parameters2-out.hs b/data/examples/declaration/class/multi-parameters2-out.hs --- a/data/examples/declaration/class/multi-parameters2-out.hs +++ b/data/examples/declaration/class/multi-parameters2-out.hs @@ -11,10 +11,8 @@ d -- Baz baz e -- Rest f where - barbaz :: a -> f - bazbar :: e -> f diff --git a/data/examples/declaration/class/newlines-after-where-out.hs b/data/examples/declaration/class/newlines-after-where-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-after-where-out.hs @@ -0,0 +1,5 @@ +class Num a where + (+) :: a -> a -> a + +class Num a where + (+) :: a -> a -> a diff --git a/data/examples/declaration/class/newlines-after-where.hs b/data/examples/declaration/class/newlines-after-where.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-after-where.hs @@ -0,0 +1,7 @@ +class Num a where + (+) :: a -> a -> a + +class Num a where + + + (+) :: a -> a -> a diff --git a/data/examples/declaration/class/newlines-and-default-decls-out.hs b/data/examples/declaration/class/newlines-and-default-decls-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-and-default-decls-out.hs @@ -0,0 +1,11 @@ +class Foo a where + foo :: a + default foo :: () + foo = () + bar :: a + default bar :: () + bar = () + + qux :: a + default qux :: () + qux = () diff --git a/data/examples/declaration/class/newlines-and-default-decls.hs b/data/examples/declaration/class/newlines-and-default-decls.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-and-default-decls.hs @@ -0,0 +1,13 @@ +class Foo a where + foo :: a + default foo :: () + foo = () + bar :: a + default bar :: () + bar = () + + qux :: a + + default qux :: () + + qux = () diff --git a/data/examples/declaration/class/newlines-and-haddocks-out.hs b/data/examples/declaration/class/newlines-and-haddocks-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-and-haddocks-out.hs @@ -0,0 +1,23 @@ +class Foo a where + -- | Haddock + foo :: a + + -- | Another Haddock + bar :: a + + baz :: a + -- ^ Post-Haddock + + raz :: a + -- ^ Another Post-Haddock + + -- | One more Haddock + qux :: a + + -- Comment before a Haddock + + -- | And one more Haddock + xyz :: a + + -- | Haddock followed by a blank line + abc :: a diff --git a/data/examples/declaration/class/newlines-and-haddocks.hs b/data/examples/declaration/class/newlines-and-haddocks.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-and-haddocks.hs @@ -0,0 +1,19 @@ +class Foo a where + -- | Haddock + foo :: a + -- | Another Haddock + bar :: a + baz :: a + -- ^ Post-Haddock + raz :: a + -- ^ Another Post-Haddock + + -- | One more Haddock + qux :: a + -- Comment before a Haddock + -- | And one more Haddock + xyz :: a + + -- | Haddock followed by a blank line + + abc :: a diff --git a/data/examples/declaration/class/newlines-between-methods-out.hs b/data/examples/declaration/class/newlines-between-methods-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-between-methods-out.hs @@ -0,0 +1,17 @@ +class Num a where + (+) :: a -> a -> a + (-) :: a -> a -> a + (*) :: a -> a -> a + + -- Comment before definition + negate :: a -> a + + -- Comment after definition + + -- Separator + + abs :: a -> a + signum :: a -> a + + -- Comment between unrelated definitions + fromInteger :: Integer -> a diff --git a/data/examples/declaration/class/newlines-between-methods.hs b/data/examples/declaration/class/newlines-between-methods.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-between-methods.hs @@ -0,0 +1,15 @@ +class Num a where + (+) :: a -> a -> a + (-) :: a -> a -> a + (*) :: a -> a -> a + + -- Comment before definition + negate :: a -> a + -- Comment after definition + + -- Separator + + abs :: a -> a + signum :: a -> a + -- Comment between unrelated definitions + fromInteger :: Integer -> a diff --git a/data/examples/declaration/class/single-parameters-out.hs b/data/examples/declaration/class/single-parameters-out.hs --- a/data/examples/declaration/class/single-parameters-out.hs +++ b/data/examples/declaration/class/single-parameters-out.hs @@ -21,8 +21,6 @@ a class BarBaz a where - barbaz :: a -> b - bazbar :: b -> a diff --git a/data/examples/declaration/instance/associated-data-out.hs b/data/examples/declaration/instance/associated-data-out.hs --- a/data/examples/declaration/instance/associated-data-out.hs +++ b/data/examples/declaration/instance/associated-data-out.hs @@ -11,9 +11,7 @@ Double instance Foo [a] where - data Bar [a] = ListBar [Bar a] - data Baz [a] = ListBaz diff --git a/data/examples/declaration/instance/associated-data.hs b/data/examples/declaration/instance/associated-data.hs --- a/data/examples/declaration/instance/associated-data.hs +++ b/data/examples/declaration/instance/associated-data.hs @@ -13,6 +13,7 @@ instance Foo [a] where + data Bar [a] = ListBar [Bar a] data Baz [a] = diff --git a/data/examples/declaration/instance/associated-types-out.hs b/data/examples/declaration/instance/associated-types-out.hs --- a/data/examples/declaration/instance/associated-types-out.hs +++ b/data/examples/declaration/instance/associated-types-out.hs @@ -3,7 +3,6 @@ instance Foo Int where type Bar Int = Double instance Foo Double where - type Bar Double = diff --git a/data/examples/declaration/instance/associated-types.hs b/data/examples/declaration/instance/associated-types.hs --- a/data/examples/declaration/instance/associated-types.hs +++ b/data/examples/declaration/instance/associated-types.hs @@ -9,5 +9,7 @@ Double = [Double] + + type instance Baz Double = [Double] diff --git a/data/examples/declaration/instance/instance-sigs-multiple-out.hs b/data/examples/declaration/instance/instance-sigs-multiple-out.hs --- a/data/examples/declaration/instance/instance-sigs-multiple-out.hs +++ b/data/examples/declaration/instance/instance-sigs-multiple-out.hs @@ -1,12 +1,10 @@ {-# LANGUAGE InstanceSigs #-} instance Applicative [] where - pure :: a -> [a] pure a = [a] - (<*>) :: [a] -> [a] -> [a] (<*>) _ _ = [] diff --git a/data/examples/declaration/instance/multi-parameter-out.hs b/data/examples/declaration/instance/multi-parameter-out.hs --- a/data/examples/declaration/instance/multi-parameter-out.hs +++ b/data/examples/declaration/instance/multi-parameter-out.hs @@ -1,7 +1,5 @@ instance MonadReader a ((->) a) where ask = id instance MonadState s (State s) where - get = State.get - put = State.put diff --git a/data/examples/declaration/instance/newlines-after-where-out.hs b/data/examples/declaration/instance/newlines-after-where-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/newlines-after-where-out.hs @@ -0,0 +1,5 @@ +instance Num X where + (+) = undefined + +instance Num Y where + (+) = undefined diff --git a/data/examples/declaration/instance/newlines-after-where.hs b/data/examples/declaration/instance/newlines-after-where.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/newlines-after-where.hs @@ -0,0 +1,7 @@ +instance Num X where + (+) = undefined + +instance Num Y where + + + (+) = undefined diff --git a/data/examples/declaration/instance/newlines-between-methods-out.hs b/data/examples/declaration/instance/newlines-between-methods-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/newlines-between-methods-out.hs @@ -0,0 +1,18 @@ +instance Num a => Num (Diff a) where + D u dudx + D v dvdx = D (u + v) (dudx + dvdx) + D u dudx - D v dvdx = D (u - v) (dudx - dvdx) + D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx) + + -- Comment before definition + negate (D u dudx) = D (- u) (- dudx) + negate (Z u dudx) = undefined + + -- Comment after definition + + -- Separator + + abs (D u _) = D (abs u) (signum u) + signum (D u _) = D (signum u) 0 + + -- Comment between unrelated definitions + fromInteger n = D (fromInteger n) 0 diff --git a/data/examples/declaration/instance/newlines-between-methods.hs b/data/examples/declaration/instance/newlines-between-methods.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/newlines-between-methods.hs @@ -0,0 +1,16 @@ +instance Num a => Num (Diff a) where + D u dudx + D v dvdx = D (u + v) (dudx + dvdx) + D u dudx - D v dvdx = D (u - v) (dudx - dvdx) + D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx) + + -- Comment before definition + negate (D u dudx) = D (-u) (-dudx) + negate (Z u dudx) = undefined + -- Comment after definition + + -- Separator + + abs (D u _) = D (abs u) (signum u) + signum (D u _) = D (signum u) 0 + -- Comment between unrelated definitions + fromInteger n = D (fromInteger n) 0 diff --git a/data/examples/declaration/instance/single-parameter-out.hs b/data/examples/declaration/instance/single-parameter-out.hs --- a/data/examples/declaration/instance/single-parameter-out.hs +++ b/data/examples/declaration/instance/single-parameter-out.hs @@ -1,9 +1,7 @@ instance Monoid Int where (<>) x y = x + y instance Enum Int where - fromEnum x = x - toEnum = \x -> x diff --git a/data/examples/declaration/signature/minimal/minimal-out.hs b/data/examples/declaration/signature/minimal/minimal-out.hs --- a/data/examples/declaration/signature/minimal/minimal-out.hs +++ b/data/examples/declaration/signature/minimal/minimal-out.hs @@ -1,5 +1,4 @@ class Foo a where - {-# MINIMAL (==) | ((/=), foo) #-} {-# MINIMAL @@ -12,5 +11,4 @@ #-} (==) :: a -> a -> Bool - (/=) :: a -> a -> Bool diff --git a/data/examples/declaration/signature/specialize/specialize-instance-out.hs b/data/examples/declaration/signature/specialize/specialize-instance-out.hs --- a/data/examples/declaration/signature/specialize/specialize-instance-out.hs +++ b/data/examples/declaration/signature/specialize/specialize-instance-out.hs @@ -3,16 +3,12 @@ data VT v m r = VT v m r instance (Eq a) => Eq (Foo a) where - {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-} - (==) (Foo a) (Foo b) = (==) a b instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where - {-# SPECIALIZE instance ( Factored m Int => Num (VT U.Vector m Int) ) #-} - VT x + VT y = VT $ V.zipWith (+) x y diff --git a/data/examples/declaration/value/function/block-arguments-out.hs b/data/examples/declaration/value/function/block-arguments-out.hs --- a/data/examples/declaration/value/function/block-arguments-out.hs +++ b/data/examples/declaration/value/function/block-arguments-out.hs @@ -27,3 +27,8 @@ y f9 = foo do { bar } baz + +f10 = foo + do a + do b + do c diff --git a/data/examples/declaration/value/function/block-arguments.hs b/data/examples/declaration/value/function/block-arguments.hs --- a/data/examples/declaration/value/function/block-arguments.hs +++ b/data/examples/declaration/value/function/block-arguments.hs @@ -23,3 +23,8 @@ y f9 = foo do { bar } baz + +f10 = foo + do { a } + do { b } + do c 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,8 +3,12 @@ foo x = if | x == 5 -> 5 bar x y = - if - | x > y -> x - | x < y -> - y - | otherwise -> x + if | x > y -> x + | x < y -> + y + | otherwise -> x + +baz = + if | p -> f + | otherwise -> g + x diff --git a/data/examples/declaration/value/function/multi-way-if.hs b/data/examples/declaration/value/function/multi-way-if.hs --- a/data/examples/declaration/value/function/multi-way-if.hs +++ b/data/examples/declaration/value/function/multi-way-if.hs @@ -7,3 +7,8 @@ | x < y -> y | otherwise -> x + +baz = + if | p -> f + | otherwise -> g + x diff --git a/data/examples/declaration/value/function/overindentation-out.hs b/data/examples/declaration/value/function/overindentation-out.hs --- a/data/examples/declaration/value/function/overindentation-out.hs +++ b/data/examples/declaration/value/function/overindentation-out.hs @@ -1,9 +1,11 @@ -reallyincrediblyLongName = f - a - A - { reallyincrediblyLongName = f - a - A - { reallyincrediblyLongName - } - } +reallyincrediblyLongName = + f + a + A + { reallyincrediblyLongName = + f + a + A + { reallyincrediblyLongName + } + } diff --git a/data/examples/declaration/value/function/record-constructors-out.hs b/data/examples/declaration/value/function/record-constructors-out.hs --- a/data/examples/declaration/value/function/record-constructors-out.hs +++ b/data/examples/declaration/value/function/record-constructors-out.hs @@ -1,9 +1,10 @@ foo = Foo {a = 3} -bar = Bar - { abc = foo, - def = Foo {a = 10} - } +bar = + Bar + { abc = foo, + def = Foo {a = 10} + } baz = Baz {} @@ -12,15 +13,18 @@ aLongVariableName = ALongRecordName { short = baz, - aLongRecordFieldName = YetAnotherLongRecordName - { yetAnotherLongRecordFieldName = "a long string" - }, - aLongRecordFieldName2 = Just YetAnotherLongRecordName - { yetAnotherLongRecordFieldName = "a long string", - yetAnotherLongRecordFieldName = - Just - "a long string" - }, + 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record-dot-out.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +data Foo = Foo {bar :: Int} + +mfoo = fmap (.bar) $ Nothing + +bar = (Foo 1).bar diff --git a/data/examples/declaration/value/function/record-dot.hs b/data/examples/declaration/value/function/record-dot.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record-dot.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} +data Foo = Foo { bar :: Int } + +mfoo = fmap (.bar) $ Nothing + +bar = ( Foo 1).bar diff --git a/data/examples/declaration/value/function/record-inter-comments-out.hs b/data/examples/declaration/value/function/record-inter-comments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record-inter-comments-out.hs @@ -0,0 +1,13 @@ +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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record-inter-comments.hs @@ -0,0 +1,11 @@ +x = Just + -- comment + A + { x + } + +x = Just + -- comment + a + { x + } diff --git a/data/examples/declaration/value/function/record-wildcards-out.hs b/data/examples/declaration/value/function/record-wildcards-out.hs --- a/data/examples/declaration/value/function/record-wildcards-out.hs +++ b/data/examples/declaration/value/function/record-wildcards-out.hs @@ -3,11 +3,12 @@ foo x y = Foo {x, y} -bar x y z = Bar - { x, - y, - z, - .. - } +bar x y z = + Bar + { x, + y, + z, + .. + } baz = Baz {..} diff --git a/data/examples/declaration/value/function/type-applications-out.hs b/data/examples/declaration/value/function/type-applications-out.hs --- a/data/examples/declaration/value/function/type-applications-out.hs +++ b/data/examples/declaration/value/function/type-applications-out.hs @@ -8,3 +8,9 @@ f @Int @String a b + +goo = + hash + @(HASH TPraosStandardCrypto) + @ByteString + "And the lamb lies down on Broadway" diff --git a/data/examples/declaration/value/function/type-applications.hs b/data/examples/declaration/value/function/type-applications.hs --- a/data/examples/declaration/value/function/type-applications.hs +++ b/data/examples/declaration/value/function/type-applications.hs @@ -6,3 +6,8 @@ baz = f @Int @String a b + +goo = hash + @(HASH TPraosStandardCrypto) + @ByteString + "And the lamb lies down on Broadway" diff --git a/data/examples/other/comment-alignment-out.hs b/data/examples/other/comment-alignment-out.hs --- a/data/examples/other/comment-alignment-out.hs +++ b/data/examples/other/comment-alignment-out.hs @@ -1,5 +1,4 @@ class Foo a where - -- | Foo. foo :: Int -> diff --git a/data/examples/other/comment-before-hanging-out.hs b/data/examples/other/comment-before-hanging-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-before-hanging-out.hs @@ -0,0 +1,5 @@ +x = Just + -- comment + do + foo + bar diff --git a/data/examples/other/comment-before-hanging.hs b/data/examples/other/comment-before-hanging.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-before-hanging.hs @@ -0,0 +1,5 @@ +x = Just + -- comment + do + foo + bar diff --git a/ormolu.cabal b/ormolu.cabal --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,5 +1,5 @@ name: ormolu -version: 0.0.2.0 +version: 0.0.3.0 cabal-version: 1.18 tested-with: GHC==8.6.5 license: BSD3 @@ -68,7 +68,7 @@ , containers >= 0.5 && < 0.7 , dlist >= 0.8 && < 0.9 , exceptions >= 0.6 && < 0.11 - , ghc-lib-parser == 8.8.1 + , ghc-lib-parser >= 8.8.1 && < 8.8.2 , mtl >= 2.0 && < 3.0 , syb >= 0.7 && < 0.8 , text >= 0.2 && < 1.3 @@ -150,7 +150,7 @@ main-is: Main.hs hs-source-dirs: app build-depends: base >= 4.12 && < 5.0 - , ghc-lib-parser == 8.8.1 + , ghc-lib-parser >= 8.8.1 && < 8.8.2 , gitrev >= 1.3 && < 1.4 , optparse-applicative >= 0.14 && < 0.15 , ormolu diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -12,13 +12,15 @@ -- | Taken from HLint. fakeSettings :: Settings -fakeSettings = Settings - { sTargetPlatform = platform, - sPlatformConstants = platformConstants, - sProjectVersion = cProjectVersion, - sProgramName = "ghc", - sOpt_P_fingerprint = fingerprint0 - } +fakeSettings = + Settings + { sTargetPlatform = platform, + sPlatformConstants = platformConstants, + sProjectVersion = cProjectVersion, + sProgramName = "ghc", + sOpt_P_fingerprint = fingerprint0, + sPgm_F = "" + } where platform = Platform diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -55,11 +55,10 @@ traceM "warnings:\n" traceM (concatMap showWarn warnings) traceM (prettyPrintParseResult result0) - -- NOTE We're forcing 'txt' here because otherwise errors (such as - -- messages about not-yet-supported functionality) will be thrown later - -- 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. + -- We're forcing 'txt' here because otherwise errors (such as messages + -- about not-yet-supported functionality) will be thrown later 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 !txt = printModule result0 when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do let pathRendered = path ++ "" diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -29,13 +29,14 @@ -- | Default 'Config'. defaultConfig :: Config -defaultConfig = Config - { cfgDynOptions = [], - cfgUnsafe = False, - cfgDebug = False, - cfgTolerateCpp = False, - cfgCheckIdempotency = False - } +defaultConfig = + Config + { cfgDynOptions = [], + cfgUnsafe = False, + cfgDebug = False, + cfgTolerateCpp = False, + cfgCheckIdempotency = False + } -- | A wrapper for dynamic options. newtype DynOption diff --git a/src/Ormolu/Diff.hs b/src/Ormolu/Diff.hs --- a/src/Ormolu/Diff.hs +++ b/src/Ormolu/Diff.hs @@ -55,7 +55,7 @@ where genericQuery :: GenericQ (GenericQ Diff) genericQuery x y - -- NOTE 'ByteString' implements 'Data' instance manually and does not + -- 'ByteString' implements 'Data' instance manually and does not -- implement 'toConstr', so we have to deal with it in a special way. | Just x' <- cast x, Just y' <- cast y = diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -16,7 +16,6 @@ import Data.List ((\\), foldl', isPrefixOf) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes) -import qualified DynFlags as GHC import DynFlags as GHC import qualified FastString as GHC import GHC hiding (IE, UnicodeSyntax) @@ -50,7 +49,7 @@ ) parseModule Config {..} path input' = liftIO $ do let (input, extraComments) = extractCommentsFromLines path input' - -- NOTE It's important that 'setDefaultExts' is done before + -- It's important that 'setDefaultExts' is done before -- 'parsePragmasIntoDynFlags', because otherwise we might enable an -- extension that was explicitly disabled in the file. let baseFlags = @@ -69,18 +68,25 @@ in throwIO (OrmoluParsingFailed loc err) when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $ throwIO (OrmoluCppEnabled path) - let r = case runParser GHC.parseModule dynFlags path input of + let useRecordDot = + "record-dot-preprocessor" == pgm_F dynFlags + || any + (("RecordDotPreprocessor" ==) . moduleNameString) + (pluginModNames dynFlags) + r = case runParser GHC.parseModule dynFlags path input of GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dynFlags m) GHC.POk pstate pmod -> let (comments, exts, shebangs) = mkCommentStream extraComments pstate - in Right ParseResult - { prParsedSource = pmod, - prAnns = mkAnns pstate, - prCommentStream = comments, - prExtensions = exts, - prShebangs = shebangs - } + in Right + ParseResult + { prParsedSource = pmod, + prAnns = mkAnns pstate, + prCommentStream = comments, + prExtensions = exts, + prShebangs = shebangs, + prUseRecordDot = useRecordDot + } return (warnings, r) -- | Extensions that are not enabled automatically and should be activated 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 @@ -24,7 +24,9 @@ -- | Extensions enabled in that module prExtensions :: [Pragma], -- | Shebangs found in the input - prShebangs :: [Located String] + prShebangs :: [Located String], + -- | Whether or not record dot syntax is enabled + prUseRecordDot :: Bool } -- | Pretty-print a 'ParseResult'. diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -24,3 +24,4 @@ (mkSpanStream prParsedSource) prCommentStream prAnns + prUseRecordDot 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 @@ -81,8 +81,8 @@ withPoppedComment p $ \l comment -> do dirtyLine <- case mlastSpn of - -- NOTE When the current line is dirty it means that something that - -- can have comments attached to it is already on the line. To avoid + -- 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 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 @@ -17,6 +17,7 @@ space, newline, isLineDirty, + useRecordDot, inci, sitcc, Layout (..), @@ -83,8 +84,10 @@ rcEnclosingSpans :: [RealSrcSpan], -- | Collection of annotations rcAnns :: Anns, - -- | If the last expression in the layout can use braces - rcCanUseBraces :: Bool + -- | Whether the last expression in the layout can use braces + rcCanUseBraces :: Bool, + -- | Whether the source could have used the record dot preprocessor + rcUseRecDot :: Bool } -- | State context of 'R'. @@ -150,28 +153,33 @@ CommentStream -> -- | Annotations Anns -> + -- | Use Record Dot Syntax + Bool -> -- | Resulting rendition Text -runR (R m) sstream cstream anns = +runR (R m) sstream cstream anns recDot = TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc where - rc = RC - { rcIndent = 0, - rcLayout = MultiLine, - rcEnclosingSpans = [], - rcAnns = anns, - rcCanUseBraces = False - } - sc = SC - { scColumn = 0, - scBuilder = mempty, - scSpanStream = sstream, - scCommentStream = cstream, - scPendingComments = [], - scDirtyLine = False, - scRequestedDelimiter = VeryBeginning, - scLastCommentSpan = Nothing - } + rc = + RC + { rcIndent = 0, + rcLayout = MultiLine, + rcEnclosingSpans = [], + rcAnns = anns, + rcCanUseBraces = False, + rcUseRecDot = recDot + } + sc = + SC + { scColumn = 0, + scBuilder = mempty, + scSpanStream = sstream, + scCommentStream = cstream, + scPendingComments = [], + scDirtyLine = False, + scRequestedDelimiter = VeryBeginning, + scLastCommentSpan = Nothing + } ---------------------------------------------------------------------------- -- Internal functions @@ -234,7 +242,7 @@ scDirtyLine = scDirtyLine sc || dirty, scRequestedDelimiter = RequestedNothing, scLastCommentSpan = - -- NOTE If there are pending comments, do not reset last comment + -- If there are pending comments, do not reset last comment -- location. if printingComments || (not . null . scPendingComments) sc then scLastCommentSpan sc @@ -315,6 +323,10 @@ -- 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 -- | Increase indentation level by one indentation step for the inner -- computation. 'inci' should be used when a part of code must be more 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 @@ -76,10 +76,10 @@ Qual mname occName -> p_qualName mname occName Orig _ occName -> - -- NOTE This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where we - -- want to say that something comes from given module which is - -- not specified in the source code, e.g. @Prelude.map@. + -- This is used when GHC generates code that will be fed into + -- the renamer (e.g. from deriving clauses), but where we want + -- to say that something comes from given module which is not + -- specified in the source code, e.g. @Prelude.map@. -- -- My current understanding is that the provided module name -- serves no purpose for us and can be safely ignored. @@ -99,9 +99,9 @@ doesNotNeedExtraParens = \case Exact name -> let s = nameStableString name - in -- NOTE I'm not sure this "stable string" is stable enough, but it looks - -- like this is the most robust way to tell if we're looking at exactly - -- this piece of built-in syntax. + in -- I'm not sure this "stable string" is stable enough, but it looks + -- like this is the most robust way to tell if we're looking at + -- exactly this piece of built-in syntax. ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s) || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s) _ -> False diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -7,7 +7,7 @@ -- | Rendering of declarations. module Ormolu.Printer.Meat.Declaration ( p_hsDecls, - hasSeparatedDecls, + p_hsDeclsRespectGrouping, ) where @@ -36,19 +36,53 @@ import Ormolu.Utils import RdrName (rdrNameOcc) +data UserGrouping + = -- | Always put newlines where we think they should be + Disregard + | -- | Respect user preferences regarding grouping + Respect + deriving (Eq, Show) + p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R () -p_hsDecls style decls = sepSemi id $ +p_hsDecls = p_hsDecls' Disregard + +-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the +-- user omits newlines between declarations, we also omit them in most +-- cases, except when said declarations have associated Haddocks. +-- +-- Does some normalization (compress subsequent newlines into a single one) +p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R () +p_hsDeclsRespectGrouping = p_hsDecls' Respect + +p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R () +p_hsDecls' grouping style decls = sepSemi id $ -- Return a list of rendered declarations, adding a newline to separate -- groups. case groupDecls decls of [] -> [] - (x : xs) -> - NE.toList (renderGroup x) - ++ concatMap (NE.toList . separateGroup . renderGroup) xs + (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs) where - renderGroup = fmap (located' $ dontUseBraces . p_hsDecl style) - separateGroup (x :| xs) = (breakpoint' >> x) :| xs + renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style) + renderGroupWithPrev prev curr = + -- We can omit a blank line when the user didn't add one, but we must + -- ensure we always add blank lines around documented declarations + if or + [ grouping == Disregard, + separatedByBlank getLoc prev curr, + isDocumented prev, + isDocumented curr + ] + then breakpoint : renderGroup curr + else renderGroup curr +-- | Is a declaration group documented? +isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool +isDocumented = any (isHaddock . unLoc) + where + isHaddock DocNext = True + isHaddock DocPrev = True + isHaddock _ = False + -- | Group relevant declarations together. -- -- Add a declaration to a group iff it is relevant to either the first or @@ -139,6 +173,9 @@ HsDecl GhcPs -> Bool groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns' +groupedDecls (TypeSignature ns) (DefaultSignature ns') = ns `intersects` ns' +groupedDecls (DefaultSignature ns) (TypeSignature ns') = ns `intersects` ns' +groupedDecls (DefaultSignature ns) (FunctionBody ns') = ns `intersects` ns' groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns' groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns' groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns @@ -149,6 +186,7 @@ groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns' groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns' groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns +-- This looks only at Haddocks, normal comments are handled elsewhere groupedDecls DocNext _ = True groupedDecls _ DocPrev = True groupedDecls _ _ = False @@ -164,13 +202,6 @@ | x > y = go (x : xs) ys | otherwise = True --- | Checks if given list of declarations contain a pair which should --- be separated by a blank line. -hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool -hasSeparatedDecls xs = case groupDecls xs of - _ : _ : _ -> True - _ -> False - isPragma :: HsDecl GhcPs -> Maybe [RdrName] @@ -206,11 +237,13 @@ pattern TypeSignature, + DefaultSignature, FunctionBody, PatternSignature, WarningPragma :: [RdrName] -> HsDecl GhcPs pattern TypeSignature n <- (sigRdrNames -> Just n) +pattern DefaultSignature n <- (defSigRdrNames -> Just n) pattern FunctionBody n <- (funRdrNames -> Just n) pattern PatternSignature n <- (patSigRdrNames -> Just n) pattern WarningPragma n <- (warnSigRdrNames -> Just n) @@ -224,6 +257,10 @@ sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns sigRdrNames _ = Nothing + +defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] +defSigRdrNames (SigD NoExt (ClassOpSig NoExt True ns _)) = Just $ map unLoc ns +defSigRdrNames _ = Nothing funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n] diff --git a/src/Ormolu/Printer/Meat/Declaration.hs-boot b/src/Ormolu/Printer/Meat/Declaration.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration.hs-boot @@ -1,6 +1,6 @@ module Ormolu.Printer.Meat.Declaration ( p_hsDecls, - hasSeparatedDecls, + p_hsDeclsRespectGrouping, ) where @@ -10,4 +10,4 @@ p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R () -hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool +p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R () diff --git a/src/Ormolu/Printer/Meat/Declaration/Class.hs b/src/Ormolu/Printer/Meat/Declaration/Class.hs --- a/src/Ormolu/Printer/Meat/Declaration/Class.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Class.hs @@ -50,10 +50,10 @@ (p_rdrName name) (located' p_hsTyVarBndr <$> hsq_explicit) inci (p_classFundeps fdeps) - -- NOTE GHC's AST does not necessarily store each kind of element in - -- source location order. This happens because different declarations are - -- stored in different lists. Consequently, to get all the declarations in - -- proper order, they need to be manually sorted. + -- GHC's AST does not necessarily store each kind of element in source + -- location order. This happens because different declarations are stored + -- in different lists. Consequently, to get all the declarations in proper + -- order, they need to be manually sorted. let sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats @@ -68,10 +68,7 @@ space txt "where" breakpoint -- Ensure whitespace is added after where clause. - -- Add newline before first declaration if the body contains separate - -- declarations. - when (hasSeparatedDecls allDecls) breakpoint' - inci (p_hsDecls Associated allDecls) + inci (p_hsDeclsRespectGrouping Associated allDecls) p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars" p_classContext :: LHsContext GhcPs -> R () diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -95,10 +95,7 @@ $ do -- Ensure whitespace is added after where clause. breakpoint - -- Add newline before first declaration if the body contains separate - -- declarations - when (hasSeparatedDecls allDecls) breakpoint' - dontUseBraces $ p_hsDecls Associated allDecls + dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs" XClsInstDecl NoExt -> notImplemented "XClsInstDecl" 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 @@ -35,9 +35,9 @@ Just xs -> do p_forallBndrs p_hsTyVarBndr xs space - -- NOTE It appears that there is no way to tell if there was an empty - -- forall in the input or no forall at all. We do not want to add - -- redundant foralls, so let's just skip the empty ones. + -- It appears that there is no way to tell if there was an empty forall + -- in the input or no forall at all. We do not want to add redundant + -- foralls, so let's just skip the empty ones. unless (null ruleBndrs) $ p_forallBndrs p_ruleBndr ruleBndrs breakpoint 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 @@ -18,6 +18,7 @@ import Data.Bool (bool) import Data.Char (isPunctuation, isSymbol) import Data.Data hiding (Infix, Prefix) +import Data.Functor ((<&>)) import Data.List (intersperse, sortOn) import Data.List.NonEmpty ((<|), NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE @@ -26,6 +27,7 @@ import GHC import OccName (mkVarOcc) import Ormolu.Printer.Combinators +import Ormolu.Printer.Internal import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import Ormolu.Printer.Meat.Declaration.Signature @@ -98,7 +100,7 @@ Case -> id LambdaCase -> id _ -> dontUseBraces - -- NOTE since we are forcing braces on 'sepSemi' based on 'ob', we have to + -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to -- restore the brace state inside the sepsemi. ub <- bool dontUseBraces useBraces <$> canUseBraces ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts) @@ -167,8 +169,8 @@ GRHSs GhcPs (Located body) -> R () p_match' placer render style isInfix strictness m_pats GRHSs {..} = do - -- NOTE Normally, since patterns may be placed in a multi-line layout, it - -- is necessary to bump indentation for the pattern group so it's more + -- Normally, since patterns may be placed in a multi-line layout, it is + -- necessary to bump indentation for the pattern group so it's more -- indented than function name. This in turn means that indentation for -- the body should also be bumped. Normally this would mean that bodies -- would start with two indentation steps applied, which is ugly, so we @@ -390,14 +392,14 @@ space sitcc $ located binds p_hsLocalBinds ParStmt {} -> - -- NOTE 'ParStmt' should always be eliminated in 'gatherStmt' already, - -- such that it never occurs in 'p_stmt''. Consequently, handling it - -- here would be redundant. + -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such + -- that it never occurs in 'p_stmt''. Consequently, handling it here + -- would be redundant. notImplemented "ParStmt" TransStmt {..} -> - -- NOTE 'TransStmt' only needs to account for render printing itself, - -- since pretty printing of relevant statements (e.g., in 'trS_stmts') - -- is handled through 'gatherStmt'. + -- 'TransStmt' only needs to account for render printing itself, since + -- pretty printing of relevant statements (e.g., in 'trS_stmts') is + -- handled through 'gatherStmt'. case (trS_form, trS_by) of (ThenForm, Nothing) -> do txt "then" @@ -457,7 +459,7 @@ markInit [] = [] markInit [x] = [(False, x)] markInit (x : xs) = (True, x) : markInit xs - -- NOTE When in a single-line layout, there is a chance that the inner + -- When in a single-line layout, there is a chance that the inner -- elements will also contain semicolons and they will confuse the -- parser. so we request braces around every element except the last. br <- layoutToBraces <$> getLayout @@ -540,8 +542,10 @@ -- We need to handle the last argument specially if it is a -- hanging construct, so separate it from the rest. (initp, lastp) = (NE.init args, NE.last args) - initSpan = combineSrcSpans' $ getLoc f :| map getLoc initp - -- Hang the last argument only if the initial arguments spans one + initSpan = + combineSrcSpans' $ + getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp] + -- Hang the last argument only if the initial arguments span one -- line. placement = if isOneLineSpan initSpan @@ -561,11 +565,16 @@ indent = case func of L _ (HsPar NoExt _) -> inci + L _ (HsAppType NoExt _ _) -> inci + L _ (HsMultiIf NoExt _) -> inci L spn _ -> if isOneLineSpan spn then inci else id - useBraces $ do + ub <- getLayout <&> \case + SingleLine -> useBraces + MultiLine -> id + ub $ do located func (p_hsExpr' s) breakpoint indent $ sep breakpoint (located' p_hsExpr) initp @@ -600,7 +609,9 @@ inci (located op p_hsExpr) SectionR NoExt op x -> do located op p_hsExpr - breakpoint + useRecordDot' <- useRecordDot + let isRecordDot' = isRecordDot (unLoc op) (getLoc x) + unless (useRecordDot' && isRecordDot') breakpoint inci (located x p_hsExpr) ExplicitTuple NoExt args boxity -> do let isSection = any (isMissing . unLoc) args @@ -625,9 +636,8 @@ HsIf NoExt _ if' then' else' -> p_if exprPlacement p_hsExpr if' then' else' HsMultiIf NoExt guards -> do - txt "if" - breakpoint - inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards + txt "if " + inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards HsLet NoExt localBinds e -> p_let p_hsExpr localBinds e HsDo NoExt ctx es -> do @@ -1012,8 +1022,8 @@ txt "[" p_rdrName (L srcSpan quoterName) txt "|" - -- NOTE QuasiQuoters often rely on precise custom strings. We cannot do - -- any formatting here without potentially breaking someone's code. + -- QuasiQuoters often rely on precise custom strings. We cannot do any + -- formatting here without potentially breaking someone's code. atom str txt "|]" HsSpliced {} -> notImplemented "HsSpliced" @@ -1204,7 +1214,6 @@ HsCase NoExt _ _ -> Hanging HsDo NoExt DoExpr _ -> Hanging HsDo NoExt MDoExpr _ -> Hanging - RecordCon NoExt _ _ -> Hanging -- If the rightmost expression in an operator chain is hanging, make the -- whole block hanging; so that we can use the common @f = foo $ do@ -- style. @@ -1248,9 +1257,9 @@ R () p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s) p_exprOpTree isDollarSpecial s (OpBranch x op y) = do - -- NOTE If the beginning of the first argument and the second argument - -- are on the same line, and the second argument has a hanging form, use - -- hanging placement. + -- If the beginning of the first argument and the second argument are on + -- the same line, and the second argument has a hanging form, use hanging + -- placement. let placement = if isOneLineSpan (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y))) @@ -1275,19 +1284,53 @@ p_exprOpTree (not gotDollar) s x let p_op = located op (opWrapper . p_hsExpr) p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y) - if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x) + isSection = case (opTreeLoc x, getLoc op) of + (RealSrcSpan treeSpan, RealSrcSpan opSpan) -> + srcSpanEndCol treeSpan /= srcSpanStartCol opSpan + _ -> False + useRecordDot' <- useRecordDot + let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y) + if useRecordDot' && isRecordDot' then do - useBraces lhs - space + lhs + when isSection space p_op - breakpoint - inci p_y - else do - ub lhs - placeHanging placement $ do - p_op - space - p_y + p_y + else + if isDollarSpecial + && gotDollar + && placement + == Normal + && isOneLineSpan (opTreeLoc x) + then do + useBraces lhs + space + p_op + breakpoint + inci p_y + else do + ub lhs + placeHanging placement $ do + p_op + space + p_y + +-- | Return 'True' if given expression is a record-dot operator expression. +isRecordDot :: + -- | Operator expression + HsExpr GhcPs -> + -- | Span of the expression on the right-hand side of the operator + SrcSpan -> + Bool +isRecordDot op (RealSrcSpan ySpan) = case op of + HsVar NoExt (L (RealSrcSpan opSpan) opName) -> + isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan) + _ -> False +isRecordDot _ _ = False + +-- | Check whether a given 'RdrName' is the dot operator. +isDot :: RdrName -> Bool +isDot name = rdrNameOcc name == mkVarOcc "." -- | Get annotations for the enclosing element. getEnclosingAnns :: R [AnnKeywordId] 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 @@ -30,9 +30,9 @@ ParsedSource -> R () p_hsModule shebangs pragmas (L moduleSpan HsModule {..}) = do - -- NOTE If span of exports in multiline, the whole thing is multiline. - -- This is especially important because span of module itself always seems - -- to have length zero, so it's not reliable for layout selection. + -- If span of exports in multiline, the whole thing is multiline. This is + -- especially important because span of module itself always seems to have + -- length zero, so it's not reliable for layout selection. let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage spans' = exportSpans ++ deprecSpan ++ [moduleSpan] 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 @@ -17,6 +17,7 @@ import Data.Ord (Down (Down), comparing) import GHC import OccName (mkVarOcc) +import Ormolu.Utils (unSrcSpan) import RdrName (mkRdrUnqual) import SrcLoc (combineSrcSpans) @@ -171,8 +172,6 @@ maybe 0 srcSpanStartCol (unSrcSpan o), go r ] - unSrcSpan (RealSrcSpan r) = Just r - unSrcSpan (UnhelpfulSpan _) = Nothing ---------------------------------------------------------------------------- -- Helpers diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -9,12 +9,16 @@ showOutputable, splitDocString, typeArgToType, + unSrcSpan, + separatedByBlank, ) where import Data.Data (Data, showConstr, toConstr) import Data.List (dropWhileEnd) +import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import GHC @@ -79,3 +83,15 @@ HsValArg tm -> tm HsTypeArg _ ty -> ty HsArgPar _ -> notImplemented "HsArgPar" + +unSrcSpan :: SrcSpan -> Maybe RealSrcSpan +unSrcSpan (RealSrcSpan r) = Just r +unSrcSpan (UnhelpfulSpan _) = Nothing + +-- | Do two declaration groups have a blank between them? +separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool +separatedByBlank loc a b = + fromMaybe False $ do + endA <- srcSpanEndLine <$> unSrcSpan (loc $ NE.last a) + startB <- srcSpanStartLine <$> unSrcSpan (loc $ NE.head b) + pure (startB - endA >= 2)