ormolu 0.0.1.0 → 0.0.2.0

raw patch · 100 files changed

+1179/−430 lines, 100 filesdep +ghc-lib-parserdep −ghcdep −ghc-boot-thdep −ghc-paths

Dependencies added: ghc-lib-parser

Dependencies removed: ghc, ghc-boot-th, ghc-paths

Files

• CHANGELOG.md +46/−0
• README.md +8/−4
• app/Main.hs +1/−1
• data/examples/declaration/class/type-operators3-out.hs +10/−0
• data/examples/declaration/class/type-operators3.hs +7/−0
• data/examples/declaration/data/existential-out.hs +2/−0
• data/examples/declaration/data/existential.hs +2/−0
• data/examples/declaration/data/gadt/strictness-out.hs +2/−1
• data/examples/declaration/data/gadt/strictness.hs +2/−1
• data/examples/declaration/data/kind-annotations-out.hs +8/−0
• data/examples/declaration/data/kind-annotations.hs +7/−0
• data/examples/declaration/data/operators-out.hs +12/−0
• data/examples/declaration/data/operators.hs +12/−0
• data/examples/declaration/data/strictness-out.hs +3/−1
• data/examples/declaration/data/strictness.hs +3/−1
• data/examples/declaration/foreign/foreign-export-out.hs +2/−1
• data/examples/declaration/rewrite-rule/forall-0-out.hs +9/−0
• data/examples/declaration/rewrite-rule/forall-0.hs +8/−0
• data/examples/declaration/rewrite-rule/forall-1-out.hs +23/−0
• data/examples/declaration/rewrite-rule/forall-1.hs +17/−0
• data/examples/declaration/rewrite-rule/forall-out.hs +0/−9
• data/examples/declaration/rewrite-rule/forall.hs +0/−8
• data/examples/declaration/signature/type/long-multiline-applications-out.hs +1/−0
• data/examples/declaration/signature/type/long-multiline-applications.hs +2/−1
• data/examples/declaration/type-families/closed-type-family/with-equal-sign-out.hs +2/−0
• data/examples/declaration/type-families/closed-type-family/with-equal-sign.hs +2/−0
• data/examples/declaration/type-families/closed-type-family/with-forall-out.hs +3/−0
• data/examples/declaration/type-families/closed-type-family/with-forall.hs +3/−0
• data/examples/declaration/type-families/type-family/operator-out.hs +3/−0
• data/examples/declaration/type-families/type-family/operator.hs +2/−0
• data/examples/declaration/type/type-applications-out.hs +3/−0
• data/examples/declaration/type/type-applications.hs +3/−0
• data/examples/declaration/value/function/application-0-out.hs +17/−0
• data/examples/declaration/value/function/application-0.hs +12/−0
• data/examples/declaration/value/function/application-1-out.hs +19/−0
• data/examples/declaration/value/function/application-1.hs +14/−0
• data/examples/declaration/value/function/application-out.hs +0/−17
• data/examples/declaration/value/function/application.hs +0/−12
• data/examples/declaration/value/function/infix/dollar-chains-out.hs +4/−0
• data/examples/declaration/value/function/infix/dollar-chains.hs +4/−0
• data/examples/declaration/value/function/operators-out.hs +5/−0
• data/examples/declaration/value/function/operators.hs +4/−0
• data/examples/module-header/preceding-comment-with-haddock-out.hs +11/−0
• data/examples/module-header/preceding-comment-with-haddock.hs +8/−0
• data/examples/module-header/shebang-out.hs +1/−0
• data/examples/module-header/shebang-with-pragmas-out.hs +5/−0
• data/examples/module-header/shebang-with-pragmas.hs +5/−0
• data/examples/module-header/shebang.hs +1/−0
• data/examples/module-header/stack-header-0-out.hs +6/−0
• data/examples/module-header/stack-header-0.hs +4/−0
• data/examples/module-header/stack-header-1-out.hs +7/−0
• data/examples/module-header/stack-header-1.hs +5/−0
• data/examples/module-header/stack-header-2-out.hs +12/−0
• data/examples/module-header/stack-header-2.hs +12/−0
• data/examples/other/comment-after-preceding-haddock-out.hs +12/−0
• data/examples/other/comment-after-preceding-haddock.hs +12/−0
• data/examples/other/empty-forall-out.hs +18/−0
• data/examples/other/empty-forall.hs +17/−0
• data/examples/other/haddock-sections-out.hs +7/−0
• data/examples/other/haddock-sections.hs +7/−0
• data/examples/other/multiline-forall-out.hs +59/−0
• data/examples/other/multiline-forall.hs +46/−0
• data/examples/other/pragma-sorting-out.hs +12/−0
• data/examples/other/pragma-sorting.hs +10/−0
• ormolu.cabal +7/−5
• src/GHC.hs +23/−0
• src/GHC/DynFlags.hs +36/−0
• src/Ormolu.hs +5/−7
• src/Ormolu/Config.hs +0/−4
• src/Ormolu/Diff.hs +2/−5
• src/Ormolu/Exception.hs +21/−9
• src/Ormolu/Imports.hs +8/−4
• src/Ormolu/Parser.hs +89/−71
• src/Ormolu/Parser/CommentStream.hs +16/−14
• src/Ormolu/Parser/Pragma.hs +10/−7
• src/Ormolu/Parser/Result.hs +3/−1
• src/Ormolu/Printer.hs +1/−3
• src/Ormolu/Printer/Combinators.hs +26/−1
• src/Ormolu/Printer/Comments.hs +25/−20
• src/Ormolu/Printer/Internal.hs +0/−2
• src/Ormolu/Printer/Meat/Common.hs +5/−4
• src/Ormolu/Printer/Meat/Declaration.hs +11/−11
• src/Ormolu/Printer/Meat/Declaration/Class.hs +7/−8
• src/Ormolu/Printer/Meat/Declaration/Data.hs +9/−18
• src/Ormolu/Printer/Meat/Declaration/Foreign.hs +8/−5
• src/Ormolu/Printer/Meat/Declaration/Instance.hs +12/−11
• src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +0/−1
• src/Ormolu/Printer/Meat/Declaration/Rule.hs +13/−13
• src/Ormolu/Printer/Meat/Declaration/Type.hs +4/−3
• src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +28/−22
• src/Ormolu/Printer/Meat/Declaration/Value.hs +86/−61
• src/Ormolu/Printer/Meat/Declaration/Warning.hs +6/−4
• src/Ormolu/Printer/Meat/ImportExport.hs +1/−1
• src/Ormolu/Printer/Meat/Module.hs +20/−5
• src/Ormolu/Printer/Meat/Pragma.hs +47/−3
• src/Ormolu/Printer/Meat/Type.hs +48/−31
• src/Ormolu/Printer/Operators.hs +28/−16
• src/Ormolu/Printer/SpanStream.hs +1/−1
• src/Ormolu/Utils.hs +8/−1
• tests/Ormolu/Parser/PragmaSpec.hs +1/−1

@@ -1,3 +1,49 @@+## Ormolu 0.0.2.0++* Switched to `ghc-lib-parser` instead of depending on the `ghc` package+  directly. This should allow us to use newest features of GHC while not+  necessarily depending on the newest version of the compiler. In addition+  to that Ormolu is now GHCJS-compatible.++* Now unrecognized GHC options passed with `--ghc-opt` cause Ormolu to fail+  (exit code 7).++* Fixed formatting of result type in closed type families. See [issue+  420](https://github.com/tweag/ormolu/issues/420).++* Fixed a minor inconsistency between formatting of normal and foreign type+  signatures. See [issue 408](https://github.com/tweag/ormolu/issues/408).++* Fixed a bug when comment before module header with Haddock was moved+  inside the export list. See [issue+  430](https://github.com/tweag/ormolu/issues/430).++* Empty `forall`s are now correctly preserved. See [issue+  429](https://github.com/tweag/ormolu/issues/429).++* Fixed [issue 446](https://github.com/tweag/ormolu/issues/446), which+  involved braces and operators.++* When there are comments between preceding Haddock (pipe-style) and its+  corresponding declaration they are preserved like this in the output+  instead of being shifted. To be clear, this is not a very good idea to+  have comments in that position because the Haddock will end up not being+  associated with the declarations. Issues+  [440](https://github.com/tweag/ormolu/issues/440) and+  [448](https://github.com/tweag/ormolu/issues/448).++* Implemented correct handling of shebangs. [Issue+  377](https://github.com/tweag/ormolu/issues/377).++* Implemented correct handling of stack headers. [Issue+  393](https://github.com/tweag/ormolu/issues/393).++* Sorting language pragmas cannot not change meaning of the input program+  anymore. [Issue 404](https://github.com/tweag/ormolu/issues/404).++* Fixed formatting of applications where function is a complex expression.+  [Issue 444](https://github.com/tweag/ormolu/issues/444).+ ## Ormolu 0.0.1.0  * Initial release.

@@ -102,7 +102,8 @@  We know of the following editor integrations: -* [For Emacs][emacs-package]+* [Emacs][emacs-package]+* [VS Code][vs-code-plugin]  ## Running on Hackage @@ -120,14 +121,17 @@  ## Contributing -See [CONTRIBUTING.md](./CONTRIBUTING.md).+See [CONTRIBUTING.md][contributing].  ## License -See [LICENSE.md](./LICENSE.md).+See [LICENSE.md][license].  Copyright © 2018–present Tweag I/O -[design]: ./DESIGN.md#cpp+[design]: 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 [emacs-package]: https://github.com/vyorkin/ormolu.el+[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode

@@ -102,7 +102,7 @@         , $gitBranch         , $gitHash         ]-      , "using ghc " ++ VERSION_ghc+      , "using ghc-lib-parser " ++ VERSION_ghc_lib_parser       ]     exts :: Parser (a -> a)     exts = infoOption displayExts . mconcat $

@@ -0,0 +1,10 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++class PNum x where+  type (a :: x) * (b :: x)++instance PNum Nat where+  type a * b = ()

@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies, TypeOperators, NoStarIsType, PolyKinds #-}++class PNum x where+  type (a :: x) * (b :: x)++instance PNum Nat where+  type a * b = ()

@@ -1,3 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-}  data Foo = forall a. MkFoo a (a -> Bool)++data Bar = forall a b. a + b => Bar a b

@@ -1,3 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-}  data Foo = forall a. MkFoo a (a -> Bool)++data Bar = forall a b. a + b => Bar a b

@@ -1,2 +1,3 @@ data Foo a where-  Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int+  Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int+  Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int

@@ -1,2 +1,3 @@ data Foo a where-  Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int+  Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int+  Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int

@@ -1,3 +1,11 @@ data Something (n :: Nat) = Something  data Format (k :: *) (k' :: *) (k'' :: *)++type Parens1 = Proxy '(a :: A, b :: (B :: *))++type Parens2 = Proxy '((a :: A), (b :: B))++type family Foo a where+  Foo '(a :: Int, b :: Bool) = Int+  Foo '((a :: Int), (b :: Bool)) = Int

@@ -1,3 +1,10 @@ data Something (n :: Nat) = Something  data Format (k :: *) (k' :: *) (k'' :: *)++type Parens1 = Proxy '(a :: A, b :: (B :: *))+type Parens2 = Proxy '((a :: A), (b :: B))++type family Foo a where+  Foo '(a :: Int, b :: Bool) = Int+  Foo '((a :: Int), (b :: Bool)) = Int

@@ -0,0 +1,12 @@+data ErrorMessage' s+  = -- | Show the text as is.+    Text s+  | -- | Pretty print the type.+    -- @ShowType :: k -> ErrorMessage@+    forall t. ShowType t+  | -- | Put two pieces of error message next+    -- to each other.+    ErrorMessage' s :<>: ErrorMessage' s+  | -- | Stack two pieces of error message on top+    -- of each other.+    ErrorMessage' s :$$: ErrorMessage' s

@@ -0,0 +1,12 @@+data ErrorMessage' s+  = -- | Show the text as is.+    Text s+  | -- | Pretty print the type.+    -- @ShowType :: k -> ErrorMessage@+    forall t. ShowType t+  | -- | Put two pieces of error message next+    -- to each other.+    ErrorMessage' s :<>: ErrorMessage' s+  | -- | Stack two pieces of error message on top+    -- of each other.+    ErrorMessage' s :$$: ErrorMessage' s

@@ -1,4 +1,6 @@ module Main where  -- | Something.-data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String+data Foo+  = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String+  | Foo2 {a :: {-# UNPACK #-} Maybe Int && Bool}

@@ -2,4 +2,6 @@  -- | Something. -data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String+data Foo+  = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String+  | Foo2 { a :: {-# UNPACK #-} Maybe Int && Bool }

@@ -2,7 +2,8 @@  -- | 'foreignTomFun' is a very important thing foreign export ccall "tomography"-  foreignTomFun :: StablePtr Storage {- Storage is bad -} -> TomForegin+  foreignTomFun ::+    StablePtr Storage {- Storage is bad -} -> TomForegin  foreign export {- We can't use capi here -} ccall "dynamic"   export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())

@@ -0,0 +1,9 @@+{-# RULES+"fold/build" forall k z. foldr k z (build g) = g k z+  #-}++{-# RULES+"fusable/aux" forall x y.+  fusable x (aux y) =+    faux x y+  #-}

@@ -0,0 +1,8 @@+{-# RULES+"fold/build" forall k z . foldr k z (build g) = g k z+  #-}++{-# RULES+"fusable/aux" forall x y.+  fusable x (aux y) = faux x y+  #-}

@@ -0,0 +1,23 @@+{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}++{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}++{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}++{-# RULES+"rd_tyvs_multiline1" forall (a :: *). forall (x :: a).+  id x =+    x+  #-}++{-# RULES+"rd_tyvs_multiline2" forall+  ( a ::+      *+  ). forall+  ( x ::+      a+  ).+  id x =+    x+  #-}

@@ -0,0 +1,17 @@+{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}++{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}++{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}++{-# RULES "rd_tyvs_multiline1"+  forall (a :: *).+  forall (x :: a).+  id x = x #-}++{-# RULES "rd_tyvs_multiline2"+  forall (a ::+            *).+  forall (x ::+            a).+  id x = x #-}

@@ -1,9 +0,0 @@-{-# RULES-"fold/build" forall k z. foldr k z (build g) = g k z-  #-}--{-# RULES-"fusable/aux" forall x y.-  fusable x (aux y) =-    faux x y-  #-}

@@ -1,8 +0,0 @@-{-# RULES-"fold/build" forall k z . foldr k z (build g) = g k z-  #-}--{-# RULES-"fusable/aux" forall x y.-  fusable x (aux y) = faux x y-  #-}

@@ -1,5 +1,6 @@ functionName ::   (C1, C2, C3, C4, C5) =>+  forall a b c.   a ->   b ->   ( LongDataTypeName

@@ -1,6 +1,7 @@ functionName   :: (C1, C2, C3, C4, C5)-  => a+  => forall a b c+   . a   -> b   -> (  LongDataTypeName           AnotherLongDataTypeName

@@ -0,0 +1,2 @@+type family TF a b = result where+  TF a b = Int

@@ -0,0 +1,2 @@+type family TF a b = result where+  TF a b = Int

@@ -0,0 +1,3 @@+type family G a b where+  forall x y. G [x] (Proxy y) = Double+  forall z. z `G` z = Bool

@@ -0,0 +1,3 @@+type family G a b where+  forall x y. G [x] (Proxy y) = Double+  forall z. z `G` z = Bool

@@ -0,0 +1,3 @@+type family a ! b++type family a . b

@@ -0,0 +1,2 @@+type family a ! b+type family a . b

@@ -0,0 +1,3 @@+{-# LANGUAGE TypeApplications #-}++type P = K @Bool @(Bool :: *) 'True 'False

@@ -0,0 +1,3 @@+{-# LANGUAGE TypeApplications #-}++type P = K @Bool @(Bool :: *) 'True 'False

@@ -0,0 +1,17 @@+foo =+  f1+    p1+    p2+    p3++foo' =+  f2+    p1+    p2+    p3++foo'' =+  f3+    p1+    p2+    p3

@@ -0,0 +1,12 @@+foo =+  f1+    p1+    p2 p3++foo' = f2 p1+  p2+  p3++foo'' =+  f3 p1 p2+    p3

@@ -0,0 +1,19 @@+main =+  do+    x+    y+  z++main =+  case foo of+    x -> a+  foo+  a+  b++main =+  do+    if x then y else z+  foo+  a+  b

@@ -0,0 +1,14 @@+main =+  do+    x+    y+   z++main =+  case foo of+    x -> a+   foo a b++main = do+  if x then y else z+ foo a b

@@ -1,17 +0,0 @@-foo =-  f1-    p1-    p2-    p3--foo' =-  f2-    p1-    p2-    p3--foo'' =-  f3-    p1-    p2-    p3

@@ -1,12 +0,0 @@-foo =-  f1-    p1-    p2 p3--foo' = f2 p1-  p2-  p3--foo'' =-  f3 p1 p2-    p3

@@ -16,3 +16,7 @@   bar     $ baz     $ quux++x =+  case l of { A -> B } $+    case q of r -> s

@@ -16,3 +16,7 @@   bar     $ baz     $ quux++x =+  case l of { A -> B } $+  case q of r -> s

@@ -0,0 +1,5 @@+a =+  b & c .~ d+    & e+      %~ f+        g

@@ -0,0 +1,4 @@+a =+  b & c .~ d+    & e %~ f+            g

@@ -0,0 +1,11 @@+{-+   Here we go.+-}++-- | This is the module's Haddock.+module Main+  ( main,+  )+where++main = return ()

@@ -0,0 +1,8 @@+{-+   Here we go.+-}++-- | This is the module's Haddock.+module Main (main) where++main = return ()

@@ -1,4 +1,5 @@ #! /usr/bin/env runhaskell+ import Prelude  main :: IO ()

@@ -0,0 +1,5 @@+#!/usr/bin/env stack++{-# LANGUAGE OverloadedStrings #-}++main = pure ()

@@ -0,0 +1,5 @@+#!/usr/bin/env stack++{-# LANGUAGE OverloadedStrings #-}++main = pure ()

@@ -1,4 +1,5 @@ #! /usr/bin/env runhaskell+ import Prelude  main :: IO ()

@@ -0,0 +1,6 @@+-- stack runhaskell++{-# LANGUAGE OverloadedStrings #-}++main = return ()+-- stack runhaskell

@@ -0,0 +1,4 @@+-- stack runhaskell+{-# LANGUAGE OverloadedStrings #-}+main = return ()+-- stack runhaskell

@@ -0,0 +1,7 @@+#!/usr/bin/env stack+-- stack runhaskell++{-# LANGUAGE OverloadedStrings #-}++main = return ()+-- stack runhaskell

@@ -0,0 +1,5 @@+#!/usr/bin/env stack+-- stack runhaskell+{-# LANGUAGE OverloadedStrings #-}+main = return ()+-- stack runhaskell

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+{- stack+  script+  --resolver lts-6.25+  --package turtle+  --package "stm async"+  --package http-client,http-conduit+-}++{-# LANGUAGE OverloadedStrings #-}++main = return ()

@@ -0,0 +1,12 @@+#!/usr/bin/env stack+{- stack+  script+  --resolver lts-6.25+  --package turtle+  --package "stm async"+  --package http-client,http-conduit+-}++{-# LANGUAGE OverloadedStrings #-}++main = return ()

@@ -0,0 +1,12 @@+module Main where++-- | A++-- B++type D = E++-- | This is 'f'++--     * Comment+f :: a -> b

@@ -0,0 +1,12 @@+module Main where++-- | A++-- B++type D = E++-- | This is 'f'++--     * Comment+f :: a -> b

@@ -0,0 +1,18 @@+-- Empty foralls are handled correctly in different situations.++data D = forall. D Int++data G where+  G :: forall. Int -> G++f :: forall. a -> a+f x = x++type family T x where+  forall. T x = x++{-# RULES+"r"+  r a =+    ()+  #-}

@@ -0,0 +1,17 @@+-- Empty foralls are handled correctly in different situations.++data D = forall. D Int++data G where+  G :: forall. Int -> G++f :: forall. a -> a+f x = x++type family T x where+  forall. T x = x++{-# RULES+  "r"+  forall. r a = ()+#-}

@@ -0,0 +1,7 @@+-- $weird #anchor#+--+-- Section 1++-- $normal+--+-- Section 2

@@ -0,0 +1,7 @@+-- $weird #anchor#+--+-- Section 1++-- $normal+--+-- Section 2

@@ -0,0 +1,59 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- Multiline foralls are consistent across all declarations++data D+  = forall+      ( f ::+          * -> * -> *+      )+      (x :: *)+      (y :: *).+    D+      (f x y)++data G where+  G ::+    forall+      ( f ::+          * -> * -> *+      )+      (x :: *)+      (y :: *).+    f x y ->+    G++f ::+  forall+    ( f ::+        * -> * -> *+    )+    (x :: *)+    (y :: *).+  f x y ->+  ()+f = const ()++type family T f x y where+  forall+    ( f ::+        * -> * -> *+    )+    (x :: *)+    (y :: *).+    T f x y =+      f x y++{-# RULES+"r" forall+  ( f ::+      * -> * -> *+  )+  (x :: *)+  (y :: *).+  r (a :: f x y) =+    ()+  #-}

@@ -0,0 +1,46 @@+{-# LANGUAGE RankNTypes, PolyKinds, GADTs, TypeFamilies #-}++-- Multiline foralls are consistent across all declarations++data D =+  forall+    (f ::+     * -> * -> *)+    (x :: *)+    (y :: *)+  . D (f x y)++data G where+  G :: forall+         (f ::+          * -> * -> *)+         (x :: *)+         (y :: *)+     . f x y -> G++f :: forall+       (f ::+        * -> * -> *)+       (x :: *)+       (y :: *)+   . f x y -> ()+f = const ()++type family T f x y where+  forall+    (f ::+     * -> * -> *)+    (x :: *)+    (y :: *)+    . T f x y = f x y++{-# RULES+  "r"+  forall+    (f ::+     * -> * -> *)+    (x :: *)+    (y :: *)+  . r (a :: f x y) =+    ()+  #-}

@@ -0,0 +1,12 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}++-- This gap is necessary for stylish Haskell not to re-arrange+-- NoMonoLocalBinds before TypeFamilies++module Foo+  ( bar,+  )+where

@@ -0,0 +1,10 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE NondecreasingIndentation #-}+-- This gap is necessary for stylish Haskell not to re-arrange+-- NoMonoLocalBinds before TypeFamilies+{-# LANGUAGE NoMonoLocalBinds    #-}++module Foo (+   bar+  ) where

@@ -1,5 +1,5 @@ name:                 ormolu-version:              0.0.1.0+version:              0.0.2.0 cabal-version:        1.18 tested-with:          GHC==8.6.5 license:              BSD3@@ -68,9 +68,7 @@                     , containers     >= 0.5 && < 0.7                     , dlist          >= 0.8 && < 0.9                     , exceptions     >= 0.6 && < 0.11-                    , ghc            == 8.6.5-                    , ghc-boot-th    == 8.6.5-                    , ghc-paths      >= 0.1 && < 0.2+                    , ghc-lib-parser == 8.8.1                     , mtl            >= 2.0 && < 3.0                     , syb            >= 0.7 && < 0.8                     , text           >= 0.2 && < 1.3@@ -111,12 +109,16 @@                     , Ormolu.Printer.Operators                     , Ormolu.Printer.SpanStream                     , Ormolu.Utils+  other-modules:      GHC+                    , GHC.DynFlags   if flag(dev)     ghc-options:      -Wall -Werror -Wcompat                       -Wincomplete-record-updates                       -Wincomplete-uni-patterns                       -Wnoncanonical-monad-instances                       -Wnoncanonical-monadfail-instances+                      -- https://github.com/haskell/haddock/issues/1116+                      -Wno-missing-home-modules   else     ghc-options:      -O2 -Wall   default-language:   Haskell2010@@ -148,7 +150,7 @@   main-is:            Main.hs   hs-source-dirs:     app   build-depends:      base           >= 4.12 && < 5.0-                    , ghc            == 8.6.5+                    , ghc-lib-parser == 8.8.1                     , gitrev         >= 1.3 && < 1.4                     , optparse-applicative >= 0.14 && < 0.15                     , ormolu

@@ -0,0 +1,23 @@+module GHC+  ( module X,+    ParsedSource,+  )+where++import ApiAnnotation as X+import BasicTypes as X+import HsBinds as X+import HsDecls as X+import HsDoc as X+import HsExpr as X+import HsExtension as X+import HsImpExp as X+import HsInstances as X ()+import HsLit as X+import HsPat as X+import HsSyn as X+import Module as X+import RdrName as X+import SrcLoc as X++type ParsedSource = Located (HsModule GhcPs)

@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module GHC.DynFlags+  ( baseDynFlags,+  )+where++import Config+import DynFlags+import Fingerprint+import Platform++-- | Taken from HLint.+fakeSettings :: Settings+fakeSettings = Settings+  { sTargetPlatform = platform,+    sPlatformConstants = platformConstants,+    sProjectVersion = cProjectVersion,+    sProgramName = "ghc",+    sOpt_P_fingerprint = fingerprint0+  }+  where+    platform =+      Platform+        { platformWordSize = 8,+          platformOS = OSUnknown,+          platformUnregisterised = True+        }+    platformConstants =+      PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}++fakeLlvmConfig :: (LlvmTargets, LlvmPasses)+fakeLlvmConfig = ([], [])++baseDynFlags :: DynFlags+baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}  -- | A formatter for Haskell source code. module Ormolu@@ -29,7 +28,6 @@ import Ormolu.Printer import Ormolu.Utils (showOutputable) import qualified SrcLoc as GHC-import System.IO (hGetContents, stdin)  -- | Format a 'String', return formatted version as 'Text'. --@@ -51,11 +49,11 @@   String ->   m Text ormolu cfg path str = do-  (ws, result0) <-+  (warnings, result0) <-     parseModule' cfg OrmoluParsingFailed path str   when (cfgDebug cfg) $ do     traceM "warnings:\n"-    traceM (concatMap showWarn ws)+    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@@ -115,7 +113,7 @@   -- | Resulting rendition   m Text ormoluStdin cfg =-  liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"+  liftIO getContents >>= ormolu cfg "<stdin>"  ---------------------------------------------------------------------------- -- Helpers@@ -133,10 +131,10 @@   String ->   m ([GHC.Warn], ParseResult) parseModule' cfg mkException path str = do-  (ws, r) <- parseModule cfg path str+  (warnings, r) <- parseModule cfg path str   case r of     Left (spn, err) -> liftIO $ throwIO (mkException spn err)-    Right x -> return (ws, x)+    Right x -> return (warnings, x)  -- | Pretty-print a 'GHC.Warn'. showWarn :: GHC.Warn -> String

@@ -1,7 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}- -- | Configuration options used by the tool. module Ormolu.Config   ( Config (..),

@@ -1,6 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}  -- | Diffing GHC ASTs modulo span positions. module Ormolu.Diff@@ -20,7 +18,6 @@ import Ormolu.Imports (sortImports) import Ormolu.Parser.Result import Ormolu.Utils-import qualified SrcLoc as GHC  -- | Result of comparing two 'ParseResult's. data Diff@@ -58,7 +55,7 @@   where     genericQuery :: GenericQ (GenericQ Diff)     genericQuery x y-      -- NOTE 'ByteString' implement 'Data' instance manually and does not+      -- NOTE '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 =@@ -108,7 +105,7 @@     appendSpan :: SrcSpan -> Diff -> Diff     appendSpan s (Different ss) | fresh && helpful = Different (s : ss)       where-        fresh = not $ any (flip isSubspanOf s) ss+        fresh = not $ any (`isSubspanOf` s) ss         helpful = isGoodSrcSpan s     appendSpan _ d = d 

@@ -8,6 +8,8 @@ where  import Control.Exception+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified GHC import Ormolu.Utils (showOutputable)@@ -27,6 +29,8 @@     OrmoluASTDiffers FilePath [GHC.SrcSpan]   | -- | Formatted source code is not idempotent     OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text+  | -- | Some GHC options were not recognized+    OrmoluUnrecognizedOpts (NonEmpty String)   deriving (Eq, Show)  instance Exception OrmoluException where@@ -45,10 +49,12 @@       unlines $         [ "AST of input and AST of formatted code differ."         ]-          ++ ( fmap withIndent $ case fmap (\s -> "at " ++ showOutputable s) ss of-                 [] -> ["in " ++ path]-                 xs -> xs-             )+          ++ fmap+            withIndent+            ( case fmap (\s -> "at " ++ showOutputable s) ss of+                [] -> ["in " ++ path]+                xs -> xs+            )           ++ ["Please, consider reporting the bug."]     OrmoluNonIdempotentOutput loc left right ->       showParsingErr@@ -56,6 +62,11 @@         loc         ["before: " ++ show left, "after:  " ++ show right]         ++ "Please, consider reporting the bug.\n"+    OrmoluUnrecognizedOpts opts ->+      unlines+        [ "The following GHC options were not recognized:",+          (withIndent . unwords . NE.toList) opts+        ]  -- | Inside this wrapper 'OrmoluException' will be caught and displayed -- nicely using 'displayException'.@@ -71,11 +82,12 @@       exitWith . ExitFailure $         case e of           -- Error code 1 is for `error` or `notImplemented`-          OrmoluCppEnabled _ -> 2-          OrmoluParsingFailed _ _ -> 3-          OrmoluOutputParsingFailed _ _ -> 4-          OrmoluASTDiffers _ _ -> 5-          OrmoluNonIdempotentOutput _ _ _ -> 6+          OrmoluCppEnabled {} -> 2+          OrmoluParsingFailed {} -> 3+          OrmoluOutputParsingFailed {} -> 4+          OrmoluASTDiffers {} -> 5+          OrmoluNonIdempotentOutput {} -> 6+          OrmoluUnrecognizedOpts {} -> 7  ---------------------------------------------------------------------------- -- Helpers

@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}  -- | Manipulations on import lists. module Ormolu.Imports@@ -22,10 +23,13 @@ sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)   where     sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs-    sortImportLists decl =-      decl-        { ideclHiding = second (fmap sortLies) <$> ideclHiding decl-        }+    sortImportLists = \case+      ImportDecl {..} ->+        ImportDecl+          { ideclHiding = second (fmap sortLies) <$> ideclHiding,+            ..+          }+      XImportDecl {} -> notImplemented "XImportDecl"  -- | Compare two @'LImportDecl' 'GhcPs'@ things. compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering

@@ -1,5 +1,5 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Parser for Haskell source code.@@ -14,13 +14,16 @@ import Control.Monad import Control.Monad.IO.Class 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, parseModule, parser)+import GHC hiding (IE, UnicodeSyntax)+import GHC.DynFlags (baseDynFlags) import GHC.LanguageExtensions.Type (Extension (..))-import GHC.Paths (libdir) import qualified HeaderInfo as GHC+import qualified HscTypes as GHC import qualified Lexer as GHC import Ormolu.Config import Ormolu.Exception@@ -28,8 +31,8 @@ import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import qualified Outputable as GHC+import qualified Panic as GHC import qualified Parser as GHC-import qualified SrcLoc as GHC import qualified StringBuffer as GHC  -- | Parse a complete module from string.@@ -46,31 +49,39 @@       Either (SrcSpan, String) ParseResult     ) parseModule Config {..} path input' = liftIO $ do-  let (input, extraComments) = stripLinePragmas path input'-  (ws, dynFlags) <- ghcWrapper $ do-    dynFlags0 <- initDynFlagsPure path input-    (dynFlags1, _, ws) <--      GHC.parseDynamicFilePragma-        dynFlags0-        (dynOptionToLocatedStr <$> cfgDynOptions)-    return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)-  -- NOTE It's better to throw this outside of 'ghcWrapper' because-  -- otherwise the exception will be wrapped as a GHC panic, which we don't-  -- want.+  let (input, extraComments) = extractCommentsFromLines path input'+  -- NOTE 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 =+        GHC.setGeneralFlag'+          GHC.Opt_Haddock+          (setDefaultExts baseDynFlags)+      extraOpts = dynOptionToLocatedStr <$> cfgDynOptions+  (warnings, dynFlags) <-+    parsePragmasIntoDynFlags baseFlags extraOpts path input' >>= \case+      Right res -> pure res+      Left err ->+        let loc =+              mkSrcSpan+                (mkSrcLoc (GHC.mkFastString path) 1 1)+                (mkSrcLoc (GHC.mkFastString path) 1 1)+         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         GHC.PFailed _ ss m ->           Left (ss, GHC.showSDoc dynFlags m)         GHC.POk pstate pmod ->-          let (comments, exts) = mkCommentStream extraComments pstate+          let (comments, exts, shebangs) = mkCommentStream extraComments pstate            in Right ParseResult                 { prParsedSource = pmod,                   prAnns = mkAnns pstate,                   prCommentStream = comments,-                  prExtensions = exts+                  prExtensions = exts,+                  prShebangs = shebangs                 }-  return (ws, r)+  return (warnings, r)  -- | Extensions that are not enabled automatically and should be activated -- by user.@@ -99,47 +110,6 @@ ---------------------------------------------------------------------------- -- Helpers (taken from ghc-exactprint) --- | Requires GhcMonad constraint because there is no pure variant of--- 'parseDynamicFilePragma'. Yet, in constrast to 'initDynFlags', it does--- not (try to) read the file at filepath, but solely depends on the module--- source in the input string.------ Passes "-hide-all-packages" to the GHC API to prevent parsing of package--- environment files. However this only works if there is no invocation of--- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets--- #15513, #15541.-initDynFlagsPure ::-  GHC.GhcMonad m =>-  -- | Module path-  FilePath ->-  -- | Module contents-  String ->-  -- | Dynamic flags for that module-  m GHC.DynFlags-initDynFlagsPure fp input = do-  -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as-  -- long as 'parseDynamicFilePragma' is impure there seems to be no reason-  -- to use it.-  dflags0 <- setDefaultExts <$> GHC.getSessionDynFlags-  let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp-  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens-  -- Turn this on last to avoid T10942-  let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream-  -- Prevent parsing of .ghc.environment.* "package environment files"-  (dflags3, _, _) <--    GHC.parseDynamicFlagsCmdLine-      dflags2-      [GHC.noLoc "-hide-all-packages"]-  _ <- GHC.setSessionDynFlags dflags3-  return dflags3---- | Default runner of 'GHC.Ghc' action in 'IO'.-ghcWrapper :: GHC.Ghc a -> IO a-ghcWrapper act =-  let GHC.FlushOut flushOut = GHC.defaultFlushOut-   in GHC.runGhc (Just libdir) act-        `finally` flushOut- -- | Run a 'GHC.P' computation. runParser ::   -- | Computation to run@@ -158,31 +128,50 @@     buffer = GHC.stringToStringBuffer input     parseState = GHC.mkPState flags buffer location --- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into--- comments.-stripLinePragmas :: FilePath -> String -> (String, [Located String])-stripLinePragmas path = unlines' . unzip . findLines path . lines+-- | Transform given lines possibly returning comments extracted from them.+-- This handles LINE pragmas and shebangs.+extractCommentsFromLines ::+  -- | File name, just to use in the spans+  FilePath ->+  -- | List of lines from that file+  String ->+  -- | Adjusted lines together with comments extracted from them+  (String, [Located String])+extractCommentsFromLines path =+  unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines   where     unlines' (a, b) = (unlines a, catMaybes b) -findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]-findLines path = zipWith (checkLine path) [1 ..]--checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))-checkLine path line s+-- | Transform a given line possibly returning a comment extracted from it.+extractCommentFromLine ::+  -- | File name, just to use in the spans+  FilePath ->+  -- | Line number of this line+  Int ->+  -- | The actual line+  String ->+  -- | Adjusted line and possibly a comment extracted from it+  (String, Maybe (Located String))+extractCommentFromLine path line s   | "{-# LINE" `isPrefixOf` s =     let (pragma, res) = getPragma s         size = length pragma         ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))      in (res, Just $ L ss pragma)-  | "#!" `isPrefixOf` s =+  | isShebang s =     let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))      in ("", Just $ L ss s)   | otherwise = (s, Nothing)   where     mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line -getPragma :: String -> (String, String)+-- | Take a line pragma and output its replacement (where line pragma is+-- replaced with spaces) and the contents of the pragma itself.+getPragma ::+  -- | Pragma line to analyze+  String ->+  -- | Contents of the pragma and its replacement line+  (String, String) getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty" getPragma s@(x : xs)   | "#-}" `isPrefixOf` s = ("#-}", "   " ++ drop 3 s)@@ -198,4 +187,33 @@     autoExts = allExts \\ manualExts     allExts = [minBound .. maxBound] -deriving instance Bounded Extension+----------------------------------------------------------------------------+-- More helpers (taken from HLint)++parsePragmasIntoDynFlags ::+  -- | Pre-set 'DynFlags'+  DynFlags ->+  -- | Extra options (provided by user)+  [Located String] ->+  -- | File name (only for source location annotations)+  FilePath ->+  -- | Input for parser+  String ->+  IO (Either String ([GHC.Warn], DynFlags))+parsePragmasIntoDynFlags flags extraOpts filepath str =+  catchErrors $ do+    let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath+    (flags', leftovers, warnings) <-+      parseDynamicFilePragma flags (opts <> extraOpts)+    case NE.nonEmpty leftovers of+      Nothing -> return ()+      Just unrecognizedOpts ->+        throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts))+    let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream+    return $ Right (warnings, flags'')+  where+    catchErrors act =+      GHC.handleGhcException+        reportErr+        (GHC.handleSourceError reportErr act)+    reportErr e = return $ Left (show e)

@@ -1,14 +1,13 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}  -- | Functions for working with comment stream. module Ormolu.Parser.CommentStream   ( CommentStream (..),     Comment (..),     mkCommentStream,+    isShebang,     isPrevHaddock,     isMultilineComment,     showCommentStream,@@ -38,34 +37,37 @@ newtype Comment = Comment (NonEmpty String)   deriving (Eq, Show, Data) --- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of--- extensions here, which is not sorted in any way. The pragma comment are--- removed from the 'CommentStream'.+-- | 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 ::   -- | Extra comments to include   [Located String] ->   -- | Parser state to use for comment extraction   GHC.PState ->-  -- | Comment stream and a set of extracted pragmas-  (CommentStream, [Pragma])+  -- | Comment stream, a set of extracted pragmas, and extracted shebangs+  (CommentStream, [Pragma], [Located String]) mkCommentStream extraComments pstate =   ( CommentStream $-      -- NOTE It's easier to normalize pragmas right when we construct comment-      -- streams. Because this way we need to do it only once and when we-      -- perform checking later they'll automatically match.-      mkComment <$> sortOn (realSrcSpanStart . getLoc) comments,-    pragmas+      mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,+    pragmas,+    shebangs   )   where     (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)     rawComments =       mapMaybe toRealSpan $-        extraComments+        otherExtraComments           ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)           ++ concatMap             (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)             (GHC.annotations_comments pstate)+    (shebangs, otherExtraComments) = span (isShebang . unLoc) extraComments +-- | Return 'True' if given 'String' is a shebang.+isShebang :: String -> Bool+isShebang str = "#!" `isPrefixOf` str+ -- | Test whether a 'Comment' looks like a Haddock following a definition, -- i.e. something starting with @-- ^@. isPrevHaddock :: Comment -> Bool@@ -133,6 +135,6 @@   RealLocated String ->   Either (RealLocated String) Pragma partitionComments input =-  case parsePragma (unLoc input) of+  case parsePragma (unRealSrcSpan input) of     Nothing -> Left input     Just pragma -> Right pragma

@@ -54,7 +54,7 @@ parseExtensions str = tokenize str >>= go   where     go = \case-      (L.ITconid ext : []) -> return [unpackFS ext]+      [L.ITconid ext] -> return [unpackFS ext]       (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs       _ -> Nothing @@ -68,12 +68,15 @@     location = mkRealSrcLoc (mkFastString "") 1 1     buffer = stringToStringBuffer input     parseState = L.mkPStatePure parserFlags buffer location-    parserFlags = L.ParserFlags-      { L.pWarningFlags = ES.empty,-        L.pExtensionFlags = ES.empty,-        L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),-        L.pExtsBitmap = 0xffffffffffffffff-      }+    parserFlags =+      L.mkParserFlags'+        ES.empty+        ES.empty+        (newSimpleUnitId (ComponentId (mkFastString "")))+        True+        True+        True+        True  -- | Haskell lexer. pLexer :: L.P [L.Token]

@@ -22,7 +22,9 @@         -- | Comment stream         prCommentStream :: CommentStream,         -- | Extensions enabled in that module-        prExtensions :: [Pragma]+        prExtensions :: [Pragma],+        -- | Shebangs found in the input+        prShebangs :: [Located String]       }  -- | Pretty-print a 'ParseResult'.

@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  -- | Pretty-printer for Haskell AST.@@ -22,7 +20,7 @@   Text printModule ParseResult {..} =   runR-    (p_hsModule prExtensions prParsedSource)+    (p_hsModule prShebangs prExtensions prParsedSource)     (mkSpanStream prParsedSource)     prCommentStream     prAnns

@@ -1,6 +1,7 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}  -- | Printing combinators. The definitions here are presented in such an -- order so you can just go through the Haddocks and by the end of the file@@ -22,6 +23,7 @@     inci,     located,     located',+    locatedPat,     switchLayout,     Layout (..),     vlayout,@@ -62,6 +64,7 @@ import Data.Data (Data) import Data.List (intersperse) import Data.Text (Text)+import GHC (Pat (XPat), XXPat) import Ormolu.Printer.Comments import Ormolu.Printer.Internal import Ormolu.Utils (isModule)@@ -107,6 +110,28 @@   Located a ->   R () located' = flip located++-- | A version of 'located' that works on 'Pat'.+--+-- Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always+-- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.+--+-- Most of the time, we can just use 'p_pat' directly, because it handles+-- located 'Pat's. However, sometimes we want to use the location to render+-- something other than the given 'Pat'.+--+-- If given 'Pat' does not contain a location, we error out.+--+-- This should become unnecessary if+-- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.+locatedPat ::+  (Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>+  Pat pass ->+  (Pat pass -> R ()) ->+  R ()+locatedPat p f = case p of+  XPat pat -> located pat f+  _ -> error "locatedPat: Pat does not contain a location"  -- | Set layout according to combination of given 'SrcSpan's for a given. -- Use this only when you need to set layout based on e.g. combined span of

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  -- | Helpers for formatting of comments. This is low-level code, use@@ -7,13 +6,17 @@   ( spitPrecedingComments,     spitFollowingComments,     spitRemainingComments,+    spitStackHeader,   ) where  import Control.Monad+import Data.Char (isSpace) import Data.Coerce (coerce) import Data.Data (Data)+import Data.List (isPrefixOf) import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Text as T import Ormolu.Parser.CommentStream import Ormolu.Printer.Internal@@ -30,19 +33,12 @@   RealLocated a ->   R () spitPrecedingComments ref = do-  r <- getLastCommentSpan-  case r of-    Just (Just Pipe, _) ->-      -- We should not insert comments between pipe Haddock and the thing-      -- it's attached to.-      return ()-    _ -> do-      gotSome <- handleCommentSeries (spitPrecedingComment ref)-      when gotSome $ do-        -- Insert a blank line between the preceding comments and the thing-        -- after them if there was a blank line in the input.-        lastSpn <- fmap snd <$> getLastCommentSpan-        when (needsNewlineBefore (getLoc ref) lastSpn) newline+  gotSome <- handleCommentSeries (spitPrecedingComment ref)+  when gotSome $ do+    -- Insert a blank line between the preceding comments and the thing+    -- after them if there was a blank line in the input.+    lastSpn <- fmap snd <$> getLastCommentSpan+    when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline  -- | Output all comments following an element at given location. spitFollowingComments ::@@ -51,13 +47,23 @@   RealLocated a ->   R () spitFollowingComments ref = do-  trimSpanStream (getLoc ref)+  trimSpanStream (getRealSrcSpan ref)   void $ handleCommentSeries (spitFollowingComment ref)  -- | Output all remaining comments in the comment stream. spitRemainingComments :: R () spitRemainingComments = void $ handleCommentSeries spitRemainingComment +-- | If there is a stack header in the comment stream, print it.+spitStackHeader :: R ()+spitStackHeader = do+  let isStackHeader (Comment (x :| _)) =+        "stack" `isPrefixOf` dropWhile isSpace (drop 2 x)+  mstackHeader <- popComment (isStackHeader . unRealSrcSpan)+  forM_ mstackHeader $ \(L spn x) -> do+    spitCommentNow spn x+    newline+ ---------------------------------------------------------------------------- -- Single-comment functions @@ -244,11 +250,10 @@         Nothing -> True         Just espn ->           let startColumn = srcLocCol . realSrcSpanStart-           in if startColumn espn > startColumn ref-                then True-                else-                  abs (startColumn espn - startColumn l)-                    >= abs (startColumn ref - startColumn l)+           in startColumn espn > startColumn ref+                || ( abs (startColumn espn - startColumn l)+                       >= abs (startColumn ref - startColumn l)+                   )     continuation =       case mlastSpn of         Nothing -> False

@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -62,7 +61,6 @@ import Ormolu.Printer.SpanStream import Ormolu.Utils (showOutputable) import Outputable (Outputable)-import SrcLoc  ---------------------------------------------------------------------------- -- The 'R' monad

@@ -162,11 +162,12 @@   forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do     if isFirst       then case hstyle of-        Pipe -> txt "-- |" >> space-        Caret -> txt "-- ^" >> space-        Asterisk n -> txt ("-- " <> T.replicate n "*") >> space+        Pipe -> txt "-- |"+        Caret -> txt "-- ^"+        Asterisk n -> txt ("-- " <> T.replicate n "*")         Named name -> p_hsDocName name-      else newline >> txt "--" >> space+      else newline >> txt "--"+    space     unless (T.null x) (txt x)   when needsNewline newline   case l of

@@ -14,7 +14,7 @@ import Data.List (sort) import Data.List.NonEmpty ((<|), NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import GHC+import GHC hiding (InlinePragma) import OccName (occNameFS) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common@@ -227,7 +227,7 @@  funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]-funRdrNames (ValD NoExt (PatBind NoExt (L _ n) _ _)) = Just $ patBindNames n+funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n funRdrNames _ = Nothing  patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]@@ -244,19 +244,19 @@ patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps patBindNames (VarPat NoExt (L _ n)) = [n] patBindNames (WildPat NoExt) = []-patBindNames (LazyPat NoExt (L _ p)) = patBindNames p-patBindNames (BangPat NoExt (L _ p)) = patBindNames p-patBindNames (ParPat NoExt (L _ p)) = patBindNames p+patBindNames (LazyPat NoExt p) = patBindNames p+patBindNames (BangPat NoExt p) = patBindNames p+patBindNames (ParPat NoExt p) = patBindNames p patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps-patBindNames (AsPat NoExt (L _ n) (L _ p)) = n : patBindNames p-patBindNames (SumPat NoExt (L _ p) _ _) = patBindNames p-patBindNames (ViewPat NoExt _ (L _ p)) = patBindNames p+patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p+patBindNames (SumPat NoExt p _ _) = patBindNames p+patBindNames (ViewPat NoExt _ p) = patBindNames p patBindNames (SplicePat NoExt _) = [] patBindNames (LitPat NoExt _) = []-patBindNames (SigPat _ (L _ p)) = patBindNames p+patBindNames (SigPat _ p _) = patBindNames p patBindNames (NPat NoExt _ _ _) = [] patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n] patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)-patBindNames (ConPatOut _ _ _ _ _ _ _) = notImplemented "ConPatOut" -- created by renamer+patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer patBindNames (CoPat NoExt _ p _) = patBindNames p-patBindNames (XPat NoExt) = notImplemented "XPat"+patBindNames (XPat p) = patBindNames (unLoc p)

@@ -12,8 +12,7 @@ import Control.Arrow import Control.Monad import Data.Foldable-import Data.List (sortBy)-import Data.Ord (comparing)+import Data.List (sortOn) import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common@@ -34,9 +33,8 @@   [LTyFamDefltEqn GhcPs] ->   [LDocDecl] ->   R ()-p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do-  let HsQTvs {..} = tvars-      variableSpans = getLoc <$> hsq_explicit+p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do+  let variableSpans = getLoc <$> hsq_explicit       signatureSpans = getLoc name : variableSpans       dependencySpans = getLoc <$> fdeps       combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans)@@ -45,7 +43,7 @@     breakpoint     inci $ do       p_classContext ctx-      switchLayout signatureSpans $ do+      switchLayout signatureSpans $         p_infixDefHelper           (isInfix fixity)           inci@@ -65,7 +63,7 @@         )           <$> catdefs       allDecls =-        snd <$> sortBy (comparing fst) (sigs <> vals <> tyFams <> tyFamDefs <> docs)+        snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs)   unless (null allDecls) $ do     space     txt "where"@@ -74,6 +72,7 @@     -- declarations.     when (hasSeparatedDecls allDecls) breakpoint'     inci (p_hsDecls Associated allDecls)+p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars"  p_classContext :: LHsContext GhcPs -> R () p_classContext ctx = unless (null (unLoc ctx)) $ do@@ -103,7 +102,7 @@ defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}   where-    eqn = FamEqn {feqn_pats = tyVarsToTypes feqn_pats, ..}+    eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}     tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn} defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn" 

@@ -9,8 +9,7 @@ where  import Control.Monad-import Data.Maybe (isJust)-import Data.Maybe (maybeToList)+import Data.Maybe (isJust, maybeToList) import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common@@ -73,7 +72,7 @@                   (newline >> txt "|" >> space)           sep s (sitcc . located' p_conDecl) dd_cons   unless (null $ unLoc dd_derivs) breakpoint-  inci . located dd_derivs $ \xs -> do+  inci . located dd_derivs $ \xs ->     sep newline (located' p_hsDerivingClause) xs p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn" @@ -104,8 +103,9 @@                 then newline                 else breakpoint         interArgBreak-        p_forallBndrs (hsq_explicit con_qvars)-        unless (null $ hsq_explicit con_qvars) interArgBreak+        when (unLoc con_forall) $ do+          p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)+          interArgBreak         forM_ con_mb_cxt p_lhsContext         case con_args of           PrefixCon xs -> do@@ -126,12 +126,14 @@     mapM_ (p_hsDocString Pipe True) con_doc     let conDeclSpn =           [getLoc con_name]+            <> [getLoc con_forall]             <> fmap getLoc con_ex_tvs             <> maybeToList (fmap getLoc con_mb_cxt)             <> conArgsSpans con_args     switchLayout conDeclSpn $ do-      p_forallBndrs con_ex_tvs-      unless (null con_ex_tvs) breakpoint+      when (unLoc con_forall) $ do+        p_forallBndrs p_hsTyVarBndr con_ex_tvs+        breakpoint       forM_ con_mb_cxt p_lhsContext       case con_args of         PrefixCon xs -> do@@ -164,17 +166,6 @@ conTyVarsSpans = \case   HsQTvs {..} -> getLoc <$> hsq_explicit   XLHsQTyVars NoExt -> []--p_forallBndrs ::-  [LHsTyVarBndr GhcPs] ->-  R ()-p_forallBndrs = \case-  [] -> return ()-  bndrs -> do-    txt "forall"-    space-    sep space (located' p_hsTyVarBndr) bndrs-    txt "."  p_lhsContext ::   LHsContext GhcPs ->

@@ -32,11 +32,14 @@ p_foreignTypeSig :: ForeignDecl GhcPs -> R () p_foreignTypeSig fd = do   breakpoint-  -- Switch into the layout of the signature, to allow us to pull name and-  -- signature onto a single line.-  inci . switchLayout [getLoc . hsib_body $ fd_sig_ty fd] $ do-    p_rdrName (fd_name fd)-    p_typeAscription (HsWC NoExt (fd_sig_ty fd))+  inci+    . switchLayout+      [ getLoc (fd_name fd),+        (getLoc . hsib_body . fd_sig_ty) fd+      ]+    $ do+      p_rdrName (fd_name fd)+      p_typeAscription (HsWC NoExt (fd_sig_ty fd))  -- | Printer for 'ForeignImport'. --

@@ -15,8 +15,7 @@ import Control.Arrow import Control.Monad import Data.Foldable-import Data.List (sortBy)-import Data.Ord (comparing)+import Data.List (sortOn) import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common@@ -39,7 +38,7 @@   txt "deriving"   space   case deriv_strategy of-    Nothing -> do+    Nothing ->       instTypes False     Just (L _ a) -> case a of       StockStrategy -> do@@ -82,8 +81,7 @@               )                 <$> cid_datafam_insts             allDecls =-              snd-                <$> sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)+              snd <$> sortOn fst (sigs <> vals <> tyFamInsts <> dataFamInsts)         located hsib_body $ \x -> do           breakpoint           inci $ do@@ -92,8 +90,9 @@             unless (null allDecls) $ do               breakpoint               txt "where"-        unless (null allDecls) $ do-          inci $ do+        unless (null allDecls)+          $ inci+          $ do             -- Ensure whitespace is added after where clause.             breakpoint             -- Add newline before first declaration if the body contains separate@@ -114,10 +113,12 @@  p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R () p_dataFamInstDecl style = \case-  DataFamInstDecl {..} -> do-    let HsIB {..} = dfid_eqn-        FamEqn {..} = hsib_body-    p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs+  DataFamInstDecl {dfid_eqn = HsIB {hsib_body = FamEqn {..}}} ->+    p_dataDecl style feqn_tycon (map typeArgToType feqn_pats) feqn_fixity feqn_rhs+  DataFamInstDecl {dfid_eqn = HsIB {hsib_body = XFamEqn {}}} ->+    notImplemented "XFamEqn"+  DataFamInstDecl {dfid_eqn = XHsImplicitBndrs {}} ->+    notImplemented "XHsImplicitBndrs"  match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R () match_overlap_mode overlap_mode layoutStrategy =

@@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}  -- | Rendering of Role annotation declarations.

@@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}  module Ormolu.Printer.Meat.Declaration.Rule   ( p_ruleDecls,@@ -8,11 +7,13 @@ where  import BasicTypes+import Control.Monad (unless) import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Signature import Ormolu.Printer.Meat.Declaration.Value+import Ormolu.Printer.Meat.Type import Ormolu.Utils  p_ruleDecls :: RuleDecls GhcPs -> R ()@@ -24,12 +25,21 @@  p_ruleDecl :: RuleDecl GhcPs -> R () p_ruleDecl = \case-  HsRule NoExt ruleName activation ruleBndrs lhs rhs -> do+  HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do     located ruleName p_ruleName     space     p_activation activation     space-    p_ruleBndrs ruleBndrs+    case tyvars of+      Nothing -> return ()+      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.+    unless (null ruleBndrs) $+      p_forallBndrs p_ruleBndr ruleBndrs     breakpoint     inci $ do       located lhs p_hsExpr@@ -42,16 +52,6 @@  p_ruleName :: (SourceText, RuleName) -> R () p_ruleName (_, name) = atom $ HsString NoSourceText name--p_ruleBndrs :: [LRuleBndr GhcPs] -> R ()-p_ruleBndrs [] = return ()-p_ruleBndrs bndrs =-  switchLayout (getLoc <$> bndrs) $ do-    txt "forall"-    breakpoint-    inci $ do-      sitcc $ sep breakpoint (sitcc . located' p_ruleBndr) bndrs-      txt "."  p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case

@@ -11,6 +11,7 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type+import Ormolu.Utils (notImplemented) import RdrName (RdrName (..)) import SrcLoc (Located) @@ -24,11 +25,10 @@   -- | RHS of type declaration   LHsType GhcPs ->   R ()-p_synDecl name fixity tvars t = do+p_synDecl name fixity HsQTvs {..} t = do   txt "type"   space-  let HsQTvs {..} = tvars-  switchLayout (getLoc name : map getLoc hsq_explicit) $ do+  switchLayout (getLoc name : map getLoc hsq_explicit) $     p_infixDefHelper       (case fixity of Infix -> True; _ -> False)       inci@@ -38,3 +38,4 @@   txt "="   breakpoint   inci (located t p_hsType)+p_synDecl _ _ XLHsQTyVars {} _ = notImplemented "XLHsQTyVars"

@@ -20,7 +20,7 @@ import SrcLoc (GenLocated (..), Located)  p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()-p_famDecl style FamilyDecl {..} = do+p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do   mmeqs <- case fdInfo of     DataFamily -> Nothing <$ txt "data"     OpenTypeFamily -> Nothing <$ txt "type"@@ -28,18 +28,16 @@   txt $ case style of     Associated -> mempty     Free -> " family"-  let HsQTvs {..} = fdTyVars   breakpoint   inci $ do-    switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $ do+    switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $       p_infixDefHelper         (isInfix fdFixity)         inci         (p_rdrName fdLName)         (located' p_hsTyVarBndr <$> hsq_explicit)-    let rsig = p_familyResultSigL (isJust fdInjectivityAnn) fdResultSig-    unless (isNothing rsig && isNothing fdInjectivityAnn) $-      space+    let rsig = p_familyResultSigL fdResultSig+    unless (isNothing rsig && isNothing fdInjectivityAnn) space     inci $ do       sequence_ rsig       when (isJust rsig && isJust fdInjectivityAnn) breakpoint@@ -56,22 +54,23 @@         Just eqs -> do           newline           sep newline (located' (inci . p_tyFamInstEqn)) eqs+p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =+  notImplemented "XLHsQTyVars" p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"  p_familyResultSigL ::-  Bool ->   Located (FamilyResultSig GhcPs) ->   Maybe (R ())-p_familyResultSigL injAnn l =+p_familyResultSigL l =   case l of     L _ a -> case a of       NoSig NoExt -> Nothing       KindSig NoExt k -> Just $ do-        if injAnn then txt "=" else txt "::"+        txt "::"         breakpoint         located k p_hsType       TyVarSig NoExt bndr -> Just $ do-        if injAnn then txt "=" else txt "::"+        txt "="         breakpoint         located bndr p_hsTyVarBndr       XFamilyResultSig NoExt ->@@ -88,18 +87,25 @@   sep space p_rdrName bs  p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()-p_tyFamInstEqn HsIB {..} = do-  let FamEqn {..} = hsib_body-  switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $-    p_infixDefHelper-      (isInfix feqn_fixity)-      inci-      (p_rdrName feqn_tycon)-      (located' p_hsType <$> feqn_pats)-  space-  txt "="-  breakpoint-  inci (located feqn_rhs p_hsType)+p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do+  case feqn_bndrs of+    Nothing -> return ()+    Just bndrs -> do+      p_forallBndrs p_hsTyVarBndr bndrs+      breakpoint+  (if null feqn_bndrs then id else inci) $ do+    let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats+    switchLayout famLhsSpn $+      p_infixDefHelper+        (isInfix feqn_fixity)+        inci+        (p_rdrName feqn_tycon)+        (located' p_hsType . typeArgToType <$> feqn_pats)+    space+    txt "="+    breakpoint+    inci (located feqn_rhs p_hsType)+p_tyFamInstEqn HsIB {hsib_body = XFamEqn {}} = notImplemented "HsIB XFamEqn" p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"  ----------------------------------------------------------------------------

@@ -32,8 +32,7 @@ import Ormolu.Printer.Meat.Type import Ormolu.Printer.Operators import Ormolu.Utils-import RdrName (RdrName (..))-import RdrName (rdrNameOcc)+import RdrName (RdrName (..), rdrNameOcc) import SrcLoc (combineSrcSpans, isOneLineSpan)  -- | Style of a group of equations.@@ -167,7 +166,7 @@   -- | Equations   GRHSs GhcPs (Located body) ->   R ()-p_match' placer render style isInfix strictness m_pats m_grhss = do+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   -- indented than function name. This in turn means that indentation for@@ -192,14 +191,14 @@               then id               else inci       switchLayout [combinedSpans] $ do-        let stdCase = sep breakpoint (located' p_pat) m_pats+        let stdCase = sep breakpoint p_pat m_pats         case style of           Function name ->             p_infixDefHelper               isInfix               inci'               (p_rdrName name)-              (located' p_pat <$> m_pats)+              (p_pat <$> m_pats)           PatternBind -> stdCase           Case -> stdCase           Lambda -> do@@ -224,9 +223,8 @@         Case -> True         LambdaCase -> True         _ -> False-  let GRHSs {..} = m_grhss-      hasGuards = withGuards grhssGRHSs-  unless (length grhssGRHSs > 1) $ do+  let hasGuards = withGuards grhssGRHSs+  unless (length grhssGRHSs > 1) $     case style of       Function _ | hasGuards -> return ()       Function _ -> space >> txt "="@@ -266,6 +264,7 @@     switchLayout [patGrhssSpan] $       placeHanging placement p_body     inci p_where+p_match' _ _ _ _ _ _ XGRHSs {} = notImplemented "XGRHSs"  p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R () p_grhs = p_grhs' exprPlacement p_hsExpr@@ -367,18 +366,22 @@   R () p_stmt' placer render = \case   LastStmt NoExt body _ _ -> located body render-  BindStmt NoExt l f _ _ -> do-    located l p_pat+  BindStmt NoExt p f _ _ -> do+    p_pat p     space     txt "<-"+    -- https://gitlab.haskell.org/ghc/ghc/issues/17330+    let loc = case p of+          XPat pat -> getLoc pat+          _ -> error "p_stmt': BindStmt: Pat does not contain a location"     let placement =           case f of             L l' x ->               if isOneLineSpan-                (mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))+                (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l'))                 then placer x                 else Normal-    switchLayout [getLoc l, getLoc f] $+    switchLayout [loc, getLoc f] $       placeHanging placement (located f render)   ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer   BodyStmt NoExt body _ _ -> located body render@@ -391,7 +394,7 @@     -- such that it never occurs in 'p_stmt''. Consequently, handling it     -- here would be redundant.     notImplemented "ParStmt"-  TransStmt {..} -> do+  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'.@@ -452,7 +455,7 @@         -- Assigns 'False' to the last element, 'True' to the rest.         markInit :: [a] -> [(Bool, a)]         markInit [] = []-        markInit (x : []) = [(False, x)]+        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     -- elements will also contain semicolons and they will confuse the@@ -480,7 +483,7 @@ p_hsRecField ::   HsRecField' RdrName (LHsExpr GhcPs) ->   R ()-p_hsRecField = \HsRecField {..} -> do+p_hsRecField HsRecField {..} = do   p_rdrName hsRecFieldLbl   unless hsRecPun $ do     space@@ -550,11 +553,23 @@     -- one.     case placement of       Normal -> do+        let -- Usually we want to bump indentation for arguments for the+            -- sake of readability. However, when the function itself is a+            -- do-block or case expression it is not a good idea. It seems+            -- to be safe to always bump indentation when the function+            -- expression is parenthesised.+            indent =+              case func of+                L _ (HsPar NoExt _) -> inci+                L spn _ ->+                  if isOneLineSpan spn+                    then inci+                    else id         useBraces $ do           located func (p_hsExpr' s)           breakpoint-          inci $ sep breakpoint (located' p_hsExpr) initp-        inci $ do+          indent $ sep breakpoint (located' p_hsExpr) initp+        indent $ do           unless (null initp) breakpoint           located lastp p_hsExpr       Hanging -> do@@ -564,7 +579,7 @@           sep breakpoint (located' p_hsExpr) initp         placeHanging placement $           located lastp p_hsExpr-  HsAppType a e -> do+  HsAppType NoExt e a -> do     located e p_hsExpr     breakpoint     inci $ do@@ -687,16 +702,16 @@         (comma >> breakpoint)         (sitcc . located' (p_hsRecField . updName))         rupd_flds-  ExprWithTySig affix x -> sitcc $ do+  ExprWithTySig NoExt x HsWC {hswc_body = HsIB {..}} -> sitcc $ do     located x p_hsExpr     space     txt "::"     breakpoint-    inci $ do-      let HsWC {..} = affix-          HsIB {..} = hswc_body-      located hsib_body p_hsType-  ArithSeq NoExt _ x -> do+    inci $ located hsib_body p_hsType+  ExprWithTySig NoExt _ HsWC {hswc_body = XHsImplicitBndrs {}} ->+    notImplemented "XHsImplicitBndrs"+  ExprWithTySig NoExt _ XHsWildCardBndrs {} -> notImplemented "XHsWildCardBndrs"+  ArithSeq NoExt _ x ->     case x of       From from -> brackets s . sitcc $ do         located from p_hsExpr@@ -736,7 +751,7 @@   HsSpliceE NoExt splice -> p_hsSplice splice   HsProc NoExt p e -> do     txt "proc"-    located p $ \x -> do+    locatedPat p $ \x -> do       breakpoint       inci (p_pat x)       breakpoint@@ -781,15 +796,15 @@           Unidirectional -> do             txt "<-"             breakpoint-            located psb_def p_pat+            p_pat psb_def           ImplicitBidirectional -> do             txt "="             breakpoint-            located psb_def p_pat+            p_pat psb_def           ExplicitBidirectional mgroup -> do             txt "<-"             breakpoint-            located psb_def p_pat+            p_pat psb_def             newline             txt "where"             newline@@ -834,7 +849,7 @@   -- | Expression   LHsExpr GhcPs ->   -- | Match group-  (MatchGroup GhcPs (Located body)) ->+  MatchGroup GhcPs (Located body) ->   R () p_case placer render e mgroup = do   txt "case"@@ -890,37 +905,40 @@  p_pat :: Pat GhcPs -> R () p_pat = \case+  -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always+  -- constructed with the 'XPat' constructor, containing a @Located Pat@.+  XPat pat -> located pat p_pat   WildPat NoExt -> txt "_"   VarPat NoExt name -> p_rdrName name   LazyPat NoExt pat -> do     txt "~"-    located pat p_pat+    p_pat pat   AsPat NoExt name pat -> do     p_rdrName name     txt "@"-    located pat p_pat+    p_pat pat   ParPat NoExt pat ->-    located pat (parens S . p_pat)+    locatedPat pat (parens S . p_pat)   BangPat NoExt pat -> do     txt "!"-    located pat p_pat-  ListPat NoExt pats -> do-    brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats+    p_pat pat+  ListPat NoExt pats ->+    brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats   TuplePat NoExt pats boxing -> do     let f =           case boxing of             Boxed -> parens S             Unboxed -> parensHash S-    f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats+    f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats   SumPat NoExt pat tag arity ->-    p_unboxedSum S tag arity (located pat p_pat)+    p_unboxedSum S tag arity (p_pat pat)   ConPatIn pat details ->     case details of       PrefixCon xs -> sitcc $ do         p_rdrName pat         unless (null xs) $ do           breakpoint-          inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs+          inci . sitcc $ sep breakpoint (sitcc . p_pat) xs       RecCon (HsRecFields fields dotdot) -> do         p_rdrName pat         breakpoint@@ -932,18 +950,18 @@             Nothing -> Just <$> fields             Just n -> (Just <$> take n fields) ++ [Nothing]       InfixCon x y -> do-        located x p_pat+        p_pat x         space         p_rdrName pat         breakpoint-        inci (located y p_pat)+        inci (p_pat y)   ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?   ViewPat NoExt expr pat -> sitcc $ do     located expr p_hsExpr     space     txt "->"     breakpoint-    inci (located pat p_pat)+    inci (p_pat pat)   SplicePat NoExt splice -> p_hsSplice splice   LitPat NoExt p -> atom p   NPat NoExt v _ _ -> located v (atom . ol_val)@@ -954,11 +972,10 @@       txt "+"       space       located k (atom . ol_val)-  SigPat hswc pat -> do-    located pat p_pat+  SigPat NoExt pat hswc -> do+    p_pat pat     p_typeAscription hswc   CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage-  XPat NoExt -> notImplemented "XPat"  p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () p_pat_hsRecField HsRecField {..} = do@@ -968,7 +985,7 @@     space     txt "="     breakpoint-    inci (located hsRecFieldArg p_pat)+    inci (p_pat hsRecFieldArg)  p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R () p_unboxedSum s tag arity m = do@@ -1000,6 +1017,7 @@     atom str     txt "|]"   HsSpliced {} -> notImplemented "HsSpliced"+  HsSplicedT {} -> notImplemented "HsSplicedT"   XSplice {} -> notImplemented "XSplice"  p_hsSpliceTH ::@@ -1030,7 +1048,7 @@           AnnOpenEQ : _ -> ""           _ -> "e"     quote name (located expr p_hsExpr)-  PatBr NoExt pat -> quote "p" (located pat p_pat)+  PatBr NoExt pat -> quote "p" (p_pat pat)   DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)   DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer   TypBr NoExt ty -> quote "t" (located ty p_hsType)@@ -1157,7 +1175,7 @@   (body -> Placement) ->   [LGRHS GhcPs (Located body)] ->   Placement-blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x+blockPlacement placer [L _ (GRHS NoExt _ (L _ x))] = placer x blockPlacement _ _ = Normal  -- | Check if given command has a hanging form.@@ -1193,12 +1211,16 @@   OpApp NoExt _ _ y -> exprPlacement (unLoc y)   -- Same thing for function applications (usually with -XBlockArguments)   HsApp NoExt _ y -> exprPlacement (unLoc y)-  HsProc NoExt (L s _) _ ->-    -- Indentation breaks if pattern is longer than one line and left-    -- hanging. Consequently, only apply hanging when it is safe.-    if isOneLineSpan s-      then Hanging-      else Normal+  HsProc NoExt p _ ->+    -- https://gitlab.haskell.org/ghc/ghc/issues/17330+    let loc = case p of+          XPat pat -> getLoc pat+          _ -> error "exprPlacement: HsProc: Pat does not contain a location"+     in -- Indentation breaks if pattern is longer than one line and left+        -- hanging. Consequently, only apply hanging when it is safe.+        if isOneLineSpan loc+          then Hanging+          else Normal   _ -> Normal  withGuards :: [LGRHS GhcPs (Located body)] -> Bool@@ -1246,23 +1268,26 @@           Hanging -> useBraces           Normal -> dontUseBraces       gotDollar = case getOpName (unLoc op) of-        Just rname -> mkVarOcc "$" == (rdrNameOcc rname)+        Just rname -> mkVarOcc "$" == rdrNameOcc rname         _ -> False-  switchLayout [opTreeLoc x]-    $ ub-    $ p_exprOpTree (not gotDollar) s x+      lhs =+        switchLayout [opTreeLoc x] $+          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)     then do+      useBraces lhs       space       p_op       breakpoint       inci p_y-    else placeHanging placement $ do-      p_op-      space-      p_y+    else do+      ub lhs+      placeHanging placement $ do+        p_op+        space+        p_y  -- | Get annotations for the enclosing element. getEnclosingAnns :: R [AnnKeywordId]

@@ -28,14 +28,16 @@ p_moduleWarning :: WarningTxt -> R () p_moduleWarning wtxt = do   let (pragmaText, lits) = warningText wtxt-  switchLayout (getLoc <$> lits) $ do-    inci $ pragma pragmaText (inci $ p_lits lits)+  switchLayout (getLoc <$> lits)+    $ inci+    $ pragma pragmaText (inci $ p_lits lits)  p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R () p_topLevelWarning fnames wtxt = do   let (pragmaText, lits) = warningText wtxt-  switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $ do-    pragma pragmaText . inci $ do+  switchLayout (fmap getLoc fnames ++ fmap getLoc lits)+    $ pragma pragmaText . inci+    $ do       sitcc $ sep (comma >> breakpoint) p_rdrName fnames       breakpoint       p_lits lits

@@ -56,7 +56,7 @@         when hiding (txt "hiding")     case ideclHiding of       Nothing -> return ()-      Just (_, (L _ xs)) -> do+      Just (_, L _ xs) -> do         breakpoint         parens N . sitcc $ do           layout <- getLayout

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -9,6 +8,7 @@ where  import Control.Monad+import qualified Data.Text as T import GHC import Ormolu.Imports import Ormolu.Parser.Pragma@@ -20,8 +20,16 @@ import Ormolu.Printer.Meat.ImportExport import Ormolu.Printer.Meat.Pragma -p_hsModule :: [Pragma] -> ParsedSource -> R ()-p_hsModule pragmas (L moduleSpan HsModule {..}) = do+-- | Render a module.+p_hsModule ::+  -- | Shebangs+  [Located String] ->+  -- | Pragmas+  [Pragma] ->+  -- | AST to print+  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.@@ -29,13 +37,20 @@       deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage       spans' = exportSpans ++ deprecSpan ++ [moduleSpan]   switchLayout spans' $ do+    forM_ shebangs $ \x ->+      located x $ \shebang -> do+        txt (T.pack shebang)+        newline+    spitStackHeader+    newline     p_pragmas pragmas     newline-    forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)     case hsmodName of       Nothing -> return ()       Just hsmodName' -> do-        located hsmodName' p_hsmodName+        located hsmodName' $ \name -> do+          forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)+          p_hsmodName name         forM_ hsmodDeprecMessage $ \w -> do           breakpoint           located' p_moduleWarning w

@@ -8,18 +8,46 @@   ) where +import Data.Char (isUpper)+import Data.Maybe (listToMaybe) import qualified Data.Set as S import qualified Data.Text as T import Ormolu.Parser.Pragma (Pragma (..)) import Ormolu.Printer.Combinators -data PragmaTy = Language | OptionsGHC | OptionsHaddock+-- | Pragma classification.+data PragmaTy+  = Language LanguagePragmaClass+  | OptionsGHC+  | OptionsHaddock   deriving (Eq, Ord) +-- | Language pragma classification.+--+-- The order in which language pragmas are put in the input sometimes+-- matters. This is because some language extensions can enable other+-- extensions, yet the extensions coming later in the list have the ability+-- to change it. So here we classify all extensions by assigning one of the+-- four groups to them. Then we only sort inside of the groups.+--+-- 'Ord' instance of this data type is what affects the sorting.+--+-- See also: <https://github.com/tweag/ormolu/issues/404>+data LanguagePragmaClass+  = -- | All other extensions+    Normal+  | -- | Extensions starting with "No"+    Disabling+  | -- | Extensions that should go after everything else+    Final+  deriving (Eq, Ord)+ p_pragmas :: [Pragma] -> R () p_pragmas ps =   let prepare = concatMap $ \case-        PragmaLanguage xs -> (Language,) <$> xs+        PragmaLanguage xs ->+          let f x = (Language (classifyLanguagePragma x), x)+           in f <$> xs         PragmaOptionsGHC x -> [(OptionsGHC, x)]         PragmaOptionsHaddock x -> [(OptionsHaddock, x)]    in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)@@ -28,10 +56,26 @@ p_pragma ty c = do   txt "{-# "   txt $ case ty of-    Language -> "LANGUAGE"+    Language _ -> "LANGUAGE"     OptionsGHC -> "OPTIONS_GHC"     OptionsHaddock -> "OPTIONS_HADDOCK"   space   txt (T.pack c)   txt " #-}"   newline++-- | Classify a 'LanguagePragma'.+classifyLanguagePragma :: String -> LanguagePragmaClass+classifyLanguagePragma = \case+  "ImplicitPrelude" -> Final+  "CUSKs" -> Final+  str ->+    case splitAt 2 str of+      ("No", rest) ->+        case listToMaybe rest of+          Nothing -> Normal+          Just x ->+            if isUpper x+              then Disabling+              else Normal+      _ -> Normal

@@ -8,13 +8,14 @@     hasDocStrings,     p_hsContext,     p_hsTyVarBndr,+    p_forallBndrs,     p_conDeclFields,     tyVarsToTypes,   ) where -import BasicTypes-import GHC+import Data.Data (Data)+import GHC hiding (isPromoted) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)@@ -27,9 +28,7 @@ p_hsType' :: Bool -> HsType GhcPs -> R () p_hsType' multilineArgs = \case   HsForAllTy NoExt bndrs t -> do-    txt "forall "-    sep space (located' p_hsTyVarBndr) bndrs-    txt "."+    p_forallBndrs p_hsTyVarBndr bndrs     interArgBreak     p_hsType' multilineArgs (unLoc t)   HsQualTy NoExt qs t -> do@@ -43,7 +42,7 @@       _ -> located t p_hsTypeR   HsTyVar NoExt p n -> do     case p of-      Promoted -> do+      IsPromoted -> do         txt "'"         case showOutputable (unLoc n) of           _ : '\'' : _ -> space@@ -54,6 +53,15 @@     located f p_hsType     breakpoint     inci (located x p_hsType)+  HsAppKindTy _ ty kd -> sitcc $ do+    -- The first argument is the location of the "@..." part. Not 100% sure,+    -- but I think we can ignore it as long as we use 'located' on both the+    -- type and the kind.+    located ty p_hsType+    breakpoint+    inci $ do+      txt "@"+      located kd p_hsType   HsFunTy NoExt x y@(L _ y') -> do     located x p_hsType     space@@ -76,15 +84,10 @@   HsSumTy NoExt xs ->     parensHash N . sitcc $       sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs-  HsOpTy NoExt x op y -> sitcc $ do-    let opTree = OpBranch (tyOpTree x) op (tyOpTree y)-     in p_tyOpTree (reassociateOpTree Just opTree)-  HsParTy NoExt (L _ t@HsKindSig {}) ->-    -- NOTE Kind signatures already put parentheses around in all cases, so-    -- skip this layer of parentheses. The reason for this behavior is that-    -- parentheses are not always encoded with 'HsParTy', but seem to be-    -- always necessary when we have kind signatures in place.-    p_hsType t+  HsOpTy NoExt x op y ->+    sitcc $+      let opTree = OpBranch (tyOpTree x) op (tyOpTree y)+       in p_tyOpTree (reassociateOpTree Just opTree)   HsParTy NoExt t ->     parens N (located t p_hsType)   HsIParamTy NoExt n t -> sitcc $ do@@ -94,14 +97,12 @@     breakpoint     inci (located t p_hsType)   HsStarTy NoExt _ -> txt "*"-  HsKindSig NoExt t k ->-    -- NOTE Also see the comment for 'HsParTy'.-    parens N . sitcc $ do-      located t p_hsType-      space -- FIXME-      txt "::"-      space-      inci (located k p_hsType)+  HsKindSig NoExt t k -> sitcc $ do+    located t p_hsType+    space -- FIXME+    txt "::"+    space+    inci (located k p_hsType)   HsSpliceTy NoExt splice -> p_hsSplice splice   HsDocTy NoExt t str -> do     p_hsDocString Pipe True str@@ -120,20 +121,20 @@     p_conDeclFields fields   HsExplicitListTy NoExt p xs -> do     case p of-      Promoted -> txt "'"+      IsPromoted -> txt "'"       NotPromoted -> return ()     brackets N $ do       -- If both this list itself and the first element is promoted,       -- we need to put a space in between or it fails to parse.       case (p, xs) of-        (Promoted, ((L _ t) : _)) | isPromoted t -> space+        (IsPromoted, L _ t : _) | isPromoted t -> space         _ -> return ()       sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs   HsExplicitTupleTy NoExt xs -> do     txt "'"     parens N $ do       case xs of-        ((L _ t) : _) | isPromoted t -> space+        L _ t : _ | isPromoted t -> space         _ -> return ()       sep (comma >> breakpoint) (located' p_hsType) xs   HsTyLit NoExt t ->@@ -144,9 +145,9 @@   XHsType (NHsCoreTy t) -> atom t   where     isPromoted = \case-      HsTyVar _ Promoted _ -> True-      HsExplicitListTy _ _ _ -> True-      HsExplicitTupleTy _ _ -> True+      HsTyVar _ IsPromoted _ -> True+      HsExplicitListTy {} -> True+      HsExplicitTupleTy {} -> True       _ -> False     interArgBreak =       if multilineArgs@@ -158,7 +159,7 @@ -- attached to it. hasDocStrings :: HsType GhcPs -> Bool hasDocStrings = \case-  HsDocTy _ _ _ -> True+  HsDocTy {} -> True   HsFunTy _ (L _ x) (L _ y) -> hasDocStrings x || hasDocStrings y   _ -> False @@ -182,6 +183,17 @@     inci (located k p_hsType)   XTyVarBndr NoExt -> notImplemented "XTyVarBndr" +-- | Render several @forall@-ed variables.+p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()+p_forallBndrs _ [] = txt "forall."+p_forallBndrs p tyvars =+  switchLayout (getLoc <$> tyvars) $ do+    txt "forall"+    breakpoint+    inci $ do+      sitcc $ sep breakpoint (sitcc . located' p) tyvars+      txt "."+ p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields xs =   braces N . sitcc $@@ -209,7 +221,7 @@ p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R () p_tyOpTree (OpNode n) = located n p_hsType p_tyOpTree (OpBranch l op r) = do-  switchLayout [opTreeLoc l] $ do+  switchLayout [opTreeLoc l] $     p_tyOpTree l   breakpoint   inci . switchLayout [opTreeLoc r] $ do@@ -229,6 +241,11 @@ tyVarToType = \case   UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar   KindedTyVar NoExt tvar kind ->+    -- Note: we always add parentheses because for whatever reason GHC does+    -- not use HsParTy for left-hand sides of declarations. Please see+    -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as+    -- long as 'tyVarToType' does not get applied to right-hand sides of+    -- declarations.     HsParTy NoExt $ noLoc $       HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind   XTyVarBndr {} -> notImplemented "XTyVarBndr"

@@ -13,7 +13,8 @@ import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity) import Data.Function (on) import Data.List-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Ord (Down (Down), comparing) import GHC import OccName (mkVarOcc) import RdrName (mkRdrUnqual)@@ -108,7 +109,7 @@     . zip [0 ..]     . groupBy (doubleWithinEps 0.00001 `on` snd)     . (overrides ++)-    . avgScores+    . modeScores     $ score opTree   where     -- Add a special case for ($), since it is pretty unlikely for someone@@ -129,26 +130,37 @@       rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin       oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column       opName <- getOpName (unLoc o)-      let s =-            if le < ob-              then-- if the operator is in the beginning of a line, assign+      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)-              else-- if the operator is in the end of the line, assign the+              fromIntegral oc / fromIntegral (maxCol + 1)+            | oe < rb =+              -- if the operator is in the end of the line, assign the               -- score 1.--                if oe < rb-                  then 1-                  else 2 -- otherwise, assign a high score.+              1+            | otherwise =+              2 -- otherwise, assign a high score.       return $ (opName, s) : score r-    avgScores :: [(RdrName, Double)] -> [(RdrName, Double)]-    avgScores =+    -- Pick the most common score per 'RdrName'.+    modeScores :: [(RdrName, Double)] -> [(RdrName, Double)]+    modeScores =       sortOn snd-        . map (\xs@((n, _) : _) -> (n, avg $ map snd xs))+        . mapMaybe+          ( \case+              [] -> Nothing+              xs@((n, _) : _) -> Just (n, mode $ map snd xs)+          )         . groupBy ((==) `on` fst)         . sort-    avg :: [Double] -> Double-    avg i = sum i / fromIntegral (length i)+    -- Return the most common number, leaning to the smaller+    -- one in case of a tie.+    mode :: [Double] -> Double+    mode =+      head+        . minimumBy (comparing (Down . length))+        . groupBy (doubleWithinEps 0.0001)+        . sort     -- The start column of the rightmost operator.     maxCol = go opTree       where

@@ -36,7 +36,7 @@     $ everything mappend (const mempty `ext2Q` queryLocated) a   where     queryLocated ::-      (Data e0, Data e1) =>+      (Data e0) =>       GenLocated e0 e1 ->       DList RealSrcSpan     queryLocated (L mspn _) =

@@ -8,6 +8,7 @@     notImplemented,     showOutputable,     splitDocString,+    typeArgToType,   ) where @@ -16,9 +17,9 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import qualified Data.Text as T+import GHC import HsDoc (HsDocString, unpackHDS) import qualified Outputable as GHC-import SrcLoc  -- | Combine all source spans from the given list. combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan@@ -72,3 +73,9 @@            in if leadingSpace x                 then dropSpace <$> xs                 else xs++typeArgToType :: LHsTypeArg p -> LHsType p+typeArgToType = \case+  HsValArg tm -> tm+  HsTypeArg _ ty -> ty+  HsArgPar _ -> notImplemented "HsArgPar"

@@ -4,7 +4,7 @@ import Test.Hspec  spec :: Spec-spec = do+spec =   describe "parsePragma" $ do     stdTest "{-# LANGUAGE Foo #-}" (Just (PragmaLanguage ["Foo"]))     stdTest "{-# language Foo #-}" (Just (PragmaLanguage ["Foo"]))