b08af17 · ormolu · git.iko.soy

git.iko.soy/ormolu

Migrate to ‘ghc-lib-parser’

This would let us have features from GHC 8.8.1 while still using GHC 8.6.5 from Nixpkgs. Bonus: Ormolu will be compilable with GHCJS.

commitb08af17217e42e43042993b0ec4cbd3d00b158bb authorArtyom Kazak <yom@artyom.me> dateSun 27 Oct 2019, 15:58 (7 years ago) parent647e322

52 files changed+542−189

compare with master

unifiedsplit

CHANGELOG.md+5

@@ -1,5 +1,10 @@

11## Unreleased

3+* Switched to `ghc-lib-parser` instead of depending on the `ghc` package

4+ directly. This should allow us to use newest features of GHC while not

5+ necessarily depending on the newest version of the compiler. In addition

6+ to that Ormolu is now GHCJS-compatible.

38* Fixed formatting of result type in closed type families. See [issue

49 420](https://github.com/tweag/ormolu/issues/420).

510

app/Main.hs+1−1

@@ -102,7 +102,7 @@ optsParserInfo = info (helper <*> ver <*> exts <*> optsParser) . mconcat $

102102 , $gitBranch

103103 , $gitHash

104104 ]

105− , "using ghc " ++ VERSION_ghc

105+ , "using ghc-lib-parser " ++ VERSION_ghc_lib_parser

106106 ]

107107 exts :: Parser (a -> a)

108108 exts = infoOption displayExts . mconcat $

data/examples/declaration/class/type-operators3-out.hsnew file+10

@@ -0,0 +1,10 @@

1+{-# LANGUAGE NoStarIsType #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeOperators #-}

6+class PNum x where

7+ type (a :: x) * (b :: x)

9+instance PNum Nat where

10+ type a * b = ()

data/examples/declaration/class/type-operators3.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# LANGUAGE TypeFamilies, TypeOperators, NoStarIsType, PolyKinds #-}

3+class PNum x where

4+ type (a :: x) * (b :: x)

6+instance PNum Nat where

7+ type a * b = ()

data/examples/declaration/data/existential-out.hs+2

@@ -1,3 +1,5 @@

11{-# LANGUAGE ExistentialQuantification #-}

33data Foo = forall a. MkFoo a (a -> Bool)

5+data Bar = forall a b. a + b => Bar a b

data/examples/declaration/data/existential.hs+2

@@ -1,3 +1,5 @@

11{-# LANGUAGE ExistentialQuantification #-}

33data Foo = forall a. MkFoo a (a -> Bool)

5+data Bar = forall a b. a + b => Bar a b

data/examples/declaration/data/gadt/strictness-out.hs+2−1

@@ -1,2 +1,3 @@

11data Foo a where

2− Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int

2+ Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int

3+ Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int

data/examples/declaration/data/gadt/strictness.hs+2−1

@@ -1,2 +1,3 @@

11data Foo a where

2− Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int

2+ Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int

3+ Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int

data/examples/declaration/data/kind-annotations-out.hs+8

@@ -1,3 +1,11 @@

11data Something (n :: Nat) = Something

33data Format (k :: *) (k' :: *) (k'' :: *)

5+type Parens1 = Proxy '(a :: A, b :: (B :: *))

7+type Parens2 = Proxy '((a :: A), (b :: B))

9+type family Foo a where

10+ Foo '(a :: Int, b :: Bool) = Int

11+ Foo '((a :: Int), (b :: Bool)) = Int

data/examples/declaration/data/kind-annotations.hs+7

@@ -1,3 +1,10 @@

11data Something (n :: Nat) = Something

33data Format (k :: *) (k' :: *) (k'' :: *)

5+type Parens1 = Proxy '(a :: A, b :: (B :: *))

6+type Parens2 = Proxy '((a :: A), (b :: B))

8+type family Foo a where

9+ Foo '(a :: Int, b :: Bool) = Int

10+ Foo '((a :: Int), (b :: Bool)) = Int

data/examples/declaration/data/operators-out.hsnew file+12

@@ -0,0 +1,12 @@

1+data ErrorMessage' s

2+ = -- | Show the text as is.

3+ Text s

4+ | -- | Pretty print the type.

5+ -- @ShowType :: k -> ErrorMessage@

6+ forall t. ShowType t

7+ | -- | Put two pieces of error message next

8+ -- to each other.

9+ ErrorMessage' s :<>: ErrorMessage' s

10+ | -- | Stack two pieces of error message on top

11+ -- of each other.

12+ ErrorMessage' s :$$: ErrorMessage' s

data/examples/declaration/data/operators.hsnew file+12

@@ -0,0 +1,12 @@

1+data ErrorMessage' s

2+ = -- | Show the text as is.

3+ Text s

4+ | -- | Pretty print the type.

5+ -- @ShowType :: k -> ErrorMessage@

6+ forall t. ShowType t

7+ | -- | Put two pieces of error message next

8+ -- to each other.

9+ ErrorMessage' s :<>: ErrorMessage' s

10+ | -- | Stack two pieces of error message on top

11+ -- of each other.

12+ ErrorMessage' s :$$: ErrorMessage' s

data/examples/declaration/data/strictness-out.hs+3−1

@@ -1,4 +1,6 @@

11module Main where

33-- | Something.

4−data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String

4+data Foo

5+ = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String

6+ | Foo2 {a :: {-# UNPACK #-} Maybe Int && Bool}

data/examples/declaration/data/strictness.hs+3−1

@@ -2,4 +2,6 @@ module Main where

33-- | Something.

5−data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String

5+data Foo

6+ = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String

7+ | Foo2 { a :: {-# UNPACK #-} Maybe Int && Bool }

data/examples/declaration/rewrite-rule/forall-out.hs → data/examples/declaration/rewrite-rule/forall-0-out.hsrenamed

The content is the same.

data/examples/declaration/rewrite-rule/forall.hs → data/examples/declaration/rewrite-rule/forall-0.hsrenamed

The content is the same.

data/examples/declaration/rewrite-rule/forall-1-out.hsnew file+23

@@ -0,0 +1,23 @@

1+{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}

3+{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}

5+{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}

7+{-# RULES

8+"rd_tyvs_multiline1" forall (a :: *). forall (x :: a).

9+ id x =

10+ x

11+ #-}

12+

13+{-# RULES

14+"rd_tyvs_multiline2" forall

15+ ( a ::

16+ *

17+ ). forall

18+ ( x ::

19+ a

20+ ).

21+ id x =

22+ x

23+ #-}

data/examples/declaration/rewrite-rule/forall-1.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}

3+{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}

5+{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}

7+{-# RULES "rd_tyvs_multiline1"

8+ forall (a :: *).

9+ forall (x :: a).

10+ id x = x #-}

11+

12+{-# RULES "rd_tyvs_multiline2"

13+ forall (a ::

14+ *).

15+ forall (x ::

16+ a).

17+ id x = x #-}

data/examples/declaration/signature/type/long-multiline-applications-out.hs+1

@@ -1,5 +1,6 @@

11functionName ::

22 (C1, C2, C3, C4, C5) =>

3+ forall a b c.

34 a ->

45 b ->

56 ( LongDataTypeName

data/examples/declaration/signature/type/long-multiline-applications.hs+2−1

@@ -1,6 +1,7 @@

11functionName

22 :: (C1, C2, C3, C4, C5)

3− => a

3+ => forall a b c

4+ . a

45 -> b

56 -> ( LongDataTypeName

67 AnotherLongDataTypeName

data/examples/declaration/type-families/closed-type-family/with-forall-out.hsnew file+3

@@ -0,0 +1,3 @@

1+type family G a b where

2+ forall x y. G [x] (Proxy y) = Double

3+ forall z. z `G` z = Bool

data/examples/declaration/type-families/closed-type-family/with-forall.hsnew file+3

@@ -0,0 +1,3 @@

1+type family G a b where

2+ forall x y. G [x] (Proxy y) = Double

3+ forall z. z `G` z = Bool

data/examples/declaration/type-families/type-family/operator-out.hsnew file+3

@@ -0,0 +1,3 @@

1+type family a ! b

3+type family a . b

data/examples/declaration/type-families/type-family/operator.hsnew file+2

@@ -0,0 +1,2 @@

1+type family a ! b

2+type family a . b

data/examples/declaration/type/type-applications-out.hsnew file+3

@@ -0,0 +1,3 @@

1+{-# LANGUAGE TypeApplications #-}

3+type P = K @Bool @(Bool :: *) 'True 'False

data/examples/declaration/type/type-applications.hsnew file+3

@@ -0,0 +1,3 @@

1+{-# LANGUAGE TypeApplications #-}

3+type P = K @Bool @(Bool :: *) 'True 'False

data/examples/other/haddock-sections-out.hsnew file+7

@@ -0,0 +1,7 @@

1+-- $weird #anchor#

2+--

3+-- Section 1

5+-- $normal

6+--

7+-- Section 2

data/examples/other/haddock-sections.hsnew file+7

@@ -0,0 +1,7 @@

1+-- $weird #anchor#

2+--

3+-- Section 1

5+-- $normal

6+--

7+-- Section 2

data/examples/other/multiline-forall-out.hsnew file+59

@@ -0,0 +1,59 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE TypeFamilies #-}

6+-- Multiline foralls are consistent across all declarations

8+data D

9+ = forall

10+ ( f ::

11+ * -> * -> *

12+ )

13+ (x :: *)

14+ (y :: *).

15+ D

16+ (f x y)

17+

18+data G where

19+ G ::

20+ forall

21+ ( f ::

22+ * -> * -> *

23+ )

24+ (x :: *)

25+ (y :: *).

26+ f x y ->

27+ G

28+

29+f ::

30+ forall

31+ ( f ::

32+ * -> * -> *

33+ )

34+ (x :: *)

35+ (y :: *).

36+ f x y ->

37+ ()

38+f = const ()

39+

40+type family T f x y where

41+ forall

42+ ( f ::

43+ * -> * -> *

44+ )

45+ (x :: *)

46+ (y :: *).

47+ T f x y =

48+ f x y

49+

50+{-# RULES

51+"r" forall

52+ ( f ::

53+ * -> * -> *

54+ )

55+ (x :: *)

56+ (y :: *).

57+ r (a :: f x y) =

58+ ()

59+ #-}

data/examples/other/multiline-forall.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# LANGUAGE RankNTypes, PolyKinds, GADTs, TypeFamilies #-}

3+-- Multiline foralls are consistent across all declarations

5+data D =

6+ forall

7+ (f ::

8+ * -> * -> *)

9+ (x :: *)

10+ (y :: *)

11+ . D (f x y)

12+

13+data G where

14+ G :: forall

15+ (f ::

16+ * -> * -> *)

17+ (x :: *)

18+ (y :: *)

19+ . f x y -> G

20+

21+f :: forall

22+ (f ::

23+ * -> * -> *)

24+ (x :: *)

25+ (y :: *)

26+ . f x y -> ()

27+f = const ()

28+

29+type family T f x y where

30+ forall

31+ (f ::

32+ * -> * -> *)

33+ (x :: *)

34+ (y :: *)

35+ . T f x y = f x y

36+

37+{-# RULES

38+ "r"

39+ forall

40+ (f ::

41+ * -> * -> *)

42+ (x :: *)

43+ (y :: *)

44+ . r (a :: f x y) =

45+ ()

46+ #-}

default.nix+6

@@ -15,6 +15,11 @@ let

1515 };

1616 ormoluOverlay = self: super: {

1717 "ormolu" = super.callCabal2nix "ormolu" source { };

18+ # Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want

19+ # ghc-lib-parser-8.8.1. We disable Haddock generation because it's way

20+ # too slow.

21+ "ghc-lib-parser" = pkgs.haskell.lib.dontHaddock

22+ (super.callHackage "ghc-lib-parser" "8.8.1" { });

1823 };

1924 ormolize = import ./nix/ormolize {

2025 inherit pkgs;

@@ -73,6 +78,7 @@ in {

7378 "hlint"

7479 "megaparsec"

7580 "ormolu"

81+ "optics"

7682 "postgrest"

7783 "servant"

7884 "servant-server"

nix/nixpkgs/default.nix+2−2

@@ -1,6 +1,6 @@

11let

2− rev = "3f4144c30a6351dd79b177328ec4dea03e2ce45f";

3− sha256 = "1qg5n60n3fr6cypihnrjw451fadps5pysj5p0vvfb320mpfvlbjb";

2+ rev = "19.09";

3+ sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";

44 nixpkgs = builtins.fetchTarball {

55 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";

66 inherit sha256;

ormolu.cabal+4−4

@@ -68,9 +68,7 @@ library

6868 , containers >= 0.5 && < 0.7

6969 , dlist >= 0.8 && < 0.9

7070 , exceptions >= 0.6 && < 0.11

71− , ghc == 8.6.5

72− , ghc-boot-th == 8.6.5

73− , ghc-paths >= 0.1 && < 0.2

71+ , ghc-lib-parser == 8.8.1

7472 , mtl >= 2.0 && < 3.0

7573 , syb >= 0.7 && < 0.8

7674 , text >= 0.2 && < 1.3

@@ -111,6 +109,8 @@ library

111109 , Ormolu.Printer.Operators

112110 , Ormolu.Printer.SpanStream

113111 , Ormolu.Utils

112+ other-modules: GHC

113+ , GHC.DynFlags

114114 if flag(dev)

115115 ghc-options: -Wall -Werror -Wcompat

116116 -Wincomplete-record-updates

@@ -148,7 +148,7 @@ executable ormolu

148148 main-is: Main.hs

149149 hs-source-dirs: app

150150 build-depends: base >= 4.12 && < 5.0

151− , ghc == 8.6.5

151+ , ghc-lib-parser == 8.8.1

152152 , gitrev >= 1.3 && < 1.4

153153 , optparse-applicative >= 0.14 && < 0.15

154154 , ormolu

src/GHC.hsnew file+23

@@ -0,0 +1,23 @@

1+module GHC

2+ ( module X,

3+ ParsedSource,

4+ )

5+where

7+import ApiAnnotation as X

8+import BasicTypes as X

9+import HsBinds as X

10+import HsDecls as X

11+import HsDoc as X

12+import HsExpr as X

13+import HsExtension as X

14+import HsImpExp as X

15+import HsInstances as X ()

16+import HsLit as X

17+import HsPat as X

18+import HsSyn as X

19+import Module as X

20+import RdrName as X

21+import SrcLoc as X

22+

23+type ParsedSource = Located (HsModule GhcPs)

src/GHC/DynFlags.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# OPTIONS_GHC -Wno-missing-fields #-}

3+module GHC.DynFlags

4+ ( baseDynFlags,

5+ )

6+where

8+import Config

9+import DynFlags

10+import Fingerprint

11+import Platform

12+

13+-- | Taken from HLint.

14+fakeSettings :: Settings

15+fakeSettings = Settings

16+ { sTargetPlatform = platform,

17+ sPlatformConstants = platformConstants,

18+ sProjectVersion = cProjectVersion,

19+ sProgramName = "ghc",

20+ sOpt_P_fingerprint = fingerprint0

21+ }

22+ where

23+ platform =

24+ Platform

25+ { platformWordSize = 8,

26+ platformOS = OSUnknown,

27+ platformUnregisterised = True

28+ }

29+ platformConstants =

30+ PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}

31+

32+fakeLlvmConfig :: (LlvmTargets, LlvmPasses)

33+fakeLlvmConfig = ([], [])

34+

35+baseDynFlags :: DynFlags

36+baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

src/Ormolu/Diff.hs−1

@@ -20,7 +20,6 @@ import GHC

2020import Ormolu.Imports (sortImports)

2121import Ormolu.Parser.Result

2222import Ormolu.Utils

23−import qualified SrcLoc as GHC

2423

2524-- | Result of comparing two 'ParseResult's.

2625data Diff

src/Ormolu/Parser.hs+43−56

@@ -1,3 +1,4 @@

1+{-# LANGUAGE LambdaCase #-}

12{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE StandaloneDeriving #-}

34{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -16,11 +17,13 @@ import Control.Monad.IO.Class

1617import Data.List ((\\), foldl', isPrefixOf)

1718import Data.Maybe (catMaybes)

1819import qualified DynFlags as GHC

20+import DynFlags as GHC

1921import qualified FastString as GHC

20−import GHC hiding (IE, parseModule, parser)

22+import GHC hiding (IE, UnicodeSyntax)

23+import GHC.DynFlags (baseDynFlags)

2124import GHC.LanguageExtensions.Type (Extension (..))

22−import GHC.Paths (libdir)

2325import qualified HeaderInfo as GHC

26+import qualified HscTypes as GHC

2427import qualified Lexer as GHC

2528import Ormolu.Config

2629import Ormolu.Exception

@@ -28,8 +31,8 @@ import Ormolu.Parser.Anns

2831import Ormolu.Parser.CommentStream

2932import Ormolu.Parser.Result

3033import qualified Outputable as GHC

34+import qualified Panic as GHC

3135import qualified Parser as GHC

32−import qualified SrcLoc as GHC

3336import qualified StringBuffer as GHC

3437

3538-- | Parse a complete module from string.

@@ -47,16 +50,22 @@ parseModule ::

4750 )

4851parseModule Config {..} path input' = liftIO $ do

4952 let (input, extraComments) = stripLinePragmas path input'

50− (ws, dynFlags) <- ghcWrapper $ do

51− dynFlags0 <- initDynFlagsPure path input

52− (dynFlags1, _, ws) <-

53− GHC.parseDynamicFilePragma

54− dynFlags0

55− (dynOptionToLocatedStr <$> cfgDynOptions)

56− return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)

57− -- NOTE It's better to throw this outside of 'ghcWrapper' because

58− -- otherwise the exception will be wrapped as a GHC panic, which we don't

59− -- want.

53+ -- NOTE It's important that 'setDefaultExts' is done before

54+ -- 'parsePragmasIntoDynFlags', because otherwise we might enable an

55+ -- extension that was explicitly disabled in the file.

56+ let baseFlags =

57+ GHC.setGeneralFlag'

58+ GHC.Opt_Haddock

59+ (setDefaultExts baseDynFlags)

60+ (warnings, dynFlags) <-

61+ parsePragmasIntoDynFlags baseFlags path input' >>= \case

62+ Right res -> pure res

63+ Left err ->

64+ let loc =

65+ mkSrcSpan

66+ (mkSrcLoc (GHC.mkFastString path) 1 1)

67+ (mkSrcLoc (GHC.mkFastString path) 1 1)

68+ in throwIO (OrmoluParsingFailed loc err)

6069 when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $

6170 throwIO (OrmoluCppEnabled path)

6271 let r = case runParser GHC.parseModule dynFlags path input of

@@ -70,7 +79,7 @@ parseModule Config {..} path input' = liftIO $ do

7079 prCommentStream = comments,

7180 prExtensions = exts

7281 }

73− return (ws, r)

82+ return (warnings, r)

7483

7584-- | Extensions that are not enabled automatically and should be activated

7685-- by user.

@@ -99,47 +108,6 @@ manualExts =

99108----------------------------------------------------------------------------

100109-- Helpers (taken from ghc-exactprint)

101110

102−-- | Requires GhcMonad constraint because there is no pure variant of

103−-- 'parseDynamicFilePragma'. Yet, in constrast to 'initDynFlags', it does

104−-- not (try to) read the file at filepath, but solely depends on the module

105−-- source in the input string.

106−--

107−-- Passes "-hide-all-packages" to the GHC API to prevent parsing of package

108−-- environment files. However this only works if there is no invocation of

109−-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets

110−-- #15513, #15541.

111−initDynFlagsPure ::

112− GHC.GhcMonad m =>

113− -- | Module path

114− FilePath ->

115− -- | Module contents

116− String ->

117− -- | Dynamic flags for that module

118− m GHC.DynFlags

119−initDynFlagsPure fp input = do

120− -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as

121− -- long as 'parseDynamicFilePragma' is impure there seems to be no reason

122− -- to use it.

123− dflags0 <- setDefaultExts <$> GHC.getSessionDynFlags

124− let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp

125− (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens

126− -- Turn this on last to avoid T10942

127− let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream

128− -- Prevent parsing of .ghc.environment.* "package environment files"

129− (dflags3, _, _) <-

130− GHC.parseDynamicFlagsCmdLine

131− dflags2

132− [GHC.noLoc "-hide-all-packages"]

133− _ <- GHC.setSessionDynFlags dflags3

134− return dflags3

135−

136−-- | Default runner of 'GHC.Ghc' action in 'IO'.

137−ghcWrapper :: GHC.Ghc a -> IO a

138−ghcWrapper act =

139− let GHC.FlushOut flushOut = GHC.defaultFlushOut

140− in GHC.runGhc (Just libdir) act

141− `finally` flushOut

142−

143111-- | Run a 'GHC.P' computation.

144112runParser ::

145113 -- | Computation to run

@@ -198,4 +166,23 @@ setDefaultExts flags = foldl' GHC.xopt_set flags autoExts

198166 autoExts = allExts \\ manualExts

199167 allExts = [minBound .. maxBound]

200168

201−deriving instance Bounded Extension

169+----------------------------------------------------------------------------

170+-- More helpers (taken from HLint)

171+

172+parsePragmasIntoDynFlags ::

173+ DynFlags ->

174+ FilePath ->

175+ String ->

176+ IO (Either String ([GHC.Warn], DynFlags))

177+parsePragmasIntoDynFlags flags filepath str =

178+ catchErrors $ do

179+ let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath

180+ (flags', _, warnings) <- parseDynamicFilePragma flags opts

181+ let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream

182+ return $ Right (warnings, flags'')

183+ where

184+ catchErrors act =

185+ GHC.handleGhcException

186+ reportErr

187+ (GHC.handleSourceError reportErr act)

188+ reportErr e = return $ Left (show e)

src/Ormolu/Parser/CommentStream.hs+2−2

@@ -53,7 +53,7 @@ mkCommentStream extraComments pstate =

5353 -- NOTE It's easier to normalize pragmas right when we construct comment

5454 -- streams. Because this way we need to do it only once and when we

5555 -- perform checking later they'll automatically match.

56− mkComment <$> sortOn (realSrcSpanStart . getLoc) comments,

56+ mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,

5757 pragmas

5858 )

5959 where

@@ -133,6 +133,6 @@ partitionComments ::

133133 RealLocated String ->

134134 Either (RealLocated String) Pragma

135135partitionComments input =

136− case parsePragma (unLoc input) of

136+ case parsePragma (unRealSrcSpan input) of

137137 Nothing -> Left input

138138 Just pragma -> Right pragma

src/Ormolu/Parser/Pragma.hs+9−6

@@ -68,12 +68,15 @@ tokenize input =

6868 location = mkRealSrcLoc (mkFastString "") 1 1

6969 buffer = stringToStringBuffer input

7070 parseState = L.mkPStatePure parserFlags buffer location

71− parserFlags = L.ParserFlags

72− { L.pWarningFlags = ES.empty,

73− L.pExtensionFlags = ES.empty,

74− L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),

75− L.pExtsBitmap = 0xffffffffffffffff

76− }

71+ parserFlags =

72+ L.mkParserFlags'

73+ ES.empty

74+ ES.empty

75+ (newSimpleUnitId (ComponentId (mkFastString "")))

76+ True

77+ True

78+ True

79+ True

7780

7881-- | Haskell lexer.

7982pLexer :: L.P [L.Token]

src/Ormolu/Printer/Combinators.hs+26

@@ -1,3 +1,5 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

13{-# LANGUAGE LambdaCase #-}

24{-# LANGUAGE OverloadedStrings #-}

35{-# LANGUAGE RecordWildCards #-}

@@ -22,6 +24,7 @@ module Ormolu.Printer.Combinators

2224 inci,

2325 located,

2426 located',

27+ locatedPat,

2528 switchLayout,

2629 Layout (..),

2730 vlayout,

@@ -62,6 +65,7 @@ import Control.Monad

6265import Data.Data (Data)

6366import Data.List (intersperse)

6467import Data.Text (Text)

68+import GHC (Pat (XPat), XXPat)

6569import Ormolu.Printer.Comments

6670import Ormolu.Printer.Internal

6771import Ormolu.Utils (isModule)

@@ -108,6 +112,28 @@ located' ::

108112 R ()

109113located' = flip located

110114

115+-- | A version of 'located' that works on 'Pat'.

116+--

117+-- Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always

118+-- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.

119+--

120+-- Most of the time, we can just use 'p_pat' directly, because it handles

121+-- located 'Pat's. However, sometimes we want to use the location to render

122+-- something other than the given 'Pat'.

123+--

124+-- If given 'Pat' does not contain a location, we error out.

125+--

126+-- This should become unnecessary if

127+-- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.

128+locatedPat ::

129+ (Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>

130+ Pat pass ->

131+ (Pat pass -> R ()) ->

132+ R ()

133+locatedPat p f = case p of

134+ XPat pat -> located pat f

135+ _ -> error "locatedPat: Pat does not contain a location"

136+

111137-- | Set layout according to combination of given 'SrcSpan's for a given.

112138-- Use this only when you need to set layout based on e.g. combined span of

113139-- several elements when there is no corresponding 'Located' wrapper

src/Ormolu/Printer/Comments.hs+2−2

@@ -42,7 +42,7 @@ spitPrecedingComments ref = do

4242 -- Insert a blank line between the preceding comments and the thing

4343 -- after them if there was a blank line in the input.

4444 lastSpn <- fmap snd <$> getLastCommentSpan

45− when (needsNewlineBefore (getLoc ref) lastSpn) newline

45+ when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline

4646

4747-- | Output all comments following an element at given location.

4848spitFollowingComments ::

@@ -51,7 +51,7 @@ spitFollowingComments ::

5151 RealLocated a ->

5252 R ()

5353spitFollowingComments ref = do

54− trimSpanStream (getLoc ref)

54+ trimSpanStream (getRealSrcSpan ref)

5555 void $ handleCommentSeries (spitFollowingComment ref)

5656

5757-- | Output all remaining comments in the comment stream.

src/Ormolu/Printer/Internal.hs−1

@@ -62,7 +62,6 @@ import Ormolu.Parser.CommentStream

6262import Ormolu.Printer.SpanStream

6363import Ormolu.Utils (showOutputable)

6464import Outputable (Outputable)

65−import SrcLoc

6665

6766----------------------------------------------------------------------------

6867-- The 'R' monad

src/Ormolu/Printer/Meat/Common.hs+5−4

@@ -162,11 +162,12 @@ p_hsDocString hstyle needsNewline (L l str) = do

162162 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do

163163 if isFirst

164164 then case hstyle of

165− Pipe -> txt "-- |" >> space

166− Caret -> txt "-- ^" >> space

167− Asterisk n -> txt ("-- " <> T.replicate n "*") >> space

165+ Pipe -> txt "-- |"

166+ Caret -> txt "-- ^"

167+ Asterisk n -> txt ("-- " <> T.replicate n "*")

168168 Named name -> p_hsDocName name

169− else newline >> txt "--" >> space

169+ else newline >> txt "--"

170+ space

170171 unless (T.null x) (txt x)

171172 when needsNewline newline

172173 case l of

src/Ormolu/Printer/Meat/Declaration.hs+10−10

@@ -14,7 +14,7 @@ where

1414import Data.List (sort)

1515import Data.List.NonEmpty ((<|), NonEmpty (..))

1616import qualified Data.List.NonEmpty as NE

17−import GHC

17+import GHC hiding (InlinePragma)

1818import OccName (occNameFS)

1919import Ormolu.Printer.Combinators

2020import Ormolu.Printer.Meat.Common

@@ -227,7 +227,7 @@ sigRdrNames _ = Nothing

227227

228228funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

229229funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]

230−funRdrNames (ValD NoExt (PatBind NoExt (L _ n) _ _)) = Just $ patBindNames n

230+funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n

231231funRdrNames _ = Nothing

232232

233233patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

@@ -244,19 +244,19 @@ patBindNames :: Pat GhcPs -> [RdrName]

244244patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps

245245patBindNames (VarPat NoExt (L _ n)) = [n]

246246patBindNames (WildPat NoExt) = []

247−patBindNames (LazyPat NoExt (L _ p)) = patBindNames p

248−patBindNames (BangPat NoExt (L _ p)) = patBindNames p

249−patBindNames (ParPat NoExt (L _ p)) = patBindNames p

247+patBindNames (LazyPat NoExt p) = patBindNames p

248+patBindNames (BangPat NoExt p) = patBindNames p

249+patBindNames (ParPat NoExt p) = patBindNames p

250250patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps

251−patBindNames (AsPat NoExt (L _ n) (L _ p)) = n : patBindNames p

252−patBindNames (SumPat NoExt (L _ p) _ _) = patBindNames p

253−patBindNames (ViewPat NoExt _ (L _ p)) = patBindNames p

251+patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p

252+patBindNames (SumPat NoExt p _ _) = patBindNames p

253+patBindNames (ViewPat NoExt _ p) = patBindNames p

254254patBindNames (SplicePat NoExt _) = []

255255patBindNames (LitPat NoExt _) = []

256−patBindNames (SigPat _ (L _ p)) = patBindNames p

256+patBindNames (SigPat _ p _) = patBindNames p

257257patBindNames (NPat NoExt _ _ _) = []

258258patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]

259259patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)

260260patBindNames (ConPatOut _ _ _ _ _ _ _) = notImplemented "ConPatOut" -- created by renamer

261261patBindNames (CoPat NoExt _ p _) = patBindNames p

262−patBindNames (XPat NoExt) = notImplemented "XPat"

262+patBindNames (XPat p) = patBindNames (unLoc p)

src/Ormolu/Printer/Meat/Declaration/Class.hs+1−1

@@ -103,7 +103,7 @@ p_funDep (before, after) = do

103103defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs

104104defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}

105105 where

106− eqn = FamEqn {feqn_pats = tyVarsToTypes feqn_pats, ..}

106+ eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}

107107 tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}

108108defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn"

109109

src/Ormolu/Printer/Meat/Declaration/Data.hs+2−13

@@ -104,7 +104,7 @@ p_conDecl = \case

104104 then newline

105105 else breakpoint

106106 interArgBreak

107− p_forallBndrs (hsq_explicit con_qvars)

107+ p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)

108108 unless (null $ hsq_explicit con_qvars) interArgBreak

109109 forM_ con_mb_cxt p_lhsContext

110110 case con_args of

@@ -130,7 +130,7 @@ p_conDecl = \case

130130 <> maybeToList (fmap getLoc con_mb_cxt)

131131 <> conArgsSpans con_args

132132 switchLayout conDeclSpn $ do

133− p_forallBndrs con_ex_tvs

133+ p_forallBndrs p_hsTyVarBndr con_ex_tvs

134134 unless (null con_ex_tvs) breakpoint

135135 forM_ con_mb_cxt p_lhsContext

136136 case con_args of

@@ -165,17 +165,6 @@ conTyVarsSpans = \case

165165 HsQTvs {..} -> getLoc <$> hsq_explicit

166166 XLHsQTyVars NoExt -> []

167167

168−p_forallBndrs ::

169− [LHsTyVarBndr GhcPs] ->

170− R ()

171−p_forallBndrs = \case

172− [] -> return ()

173− bndrs -> do

174− txt "forall"

175− space

176− sep space (located' p_hsTyVarBndr) bndrs

177− txt "."

178−

179168p_lhsContext ::

180169 LHsContext GhcPs ->

181170 R ()

src/Ormolu/Printer/Meat/Declaration/Instance.hs+1−1

@@ -117,7 +117,7 @@ p_dataFamInstDecl style = \case

117117 DataFamInstDecl {..} -> do

118118 let HsIB {..} = dfid_eqn

119119 FamEqn {..} = hsib_body

120− p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs

120+ p_dataDecl style feqn_tycon (map typeArgToType feqn_pats) feqn_fixity feqn_rhs

121121

122122match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()

123123match_overlap_mode overlap_mode layoutStrategy =

src/Ormolu/Printer/Meat/Declaration/Rule.hs+6−12

@@ -8,11 +8,13 @@ module Ormolu.Printer.Meat.Declaration.Rule

88where

1010import BasicTypes

11+import Data.Maybe (fromMaybe)

1112import GHC

1213import Ormolu.Printer.Combinators

1314import Ormolu.Printer.Meat.Common

1415import Ormolu.Printer.Meat.Declaration.Signature

1516import Ormolu.Printer.Meat.Declaration.Value

17+import Ormolu.Printer.Meat.Type

1618import Ormolu.Utils

1719

1820p_ruleDecls :: RuleDecls GhcPs -> R ()

@@ -24,12 +26,14 @@ p_ruleDecls = \case

2426

2527p_ruleDecl :: RuleDecl GhcPs -> R ()

2628p_ruleDecl = \case

27− HsRule NoExt ruleName activation ruleBndrs lhs rhs -> do

29+ HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do

2830 located ruleName p_ruleName

2931 space

3032 p_activation activation

3133 space

32− p_ruleBndrs ruleBndrs

34+ p_forallBndrs p_hsTyVarBndr (fromMaybe [] tyvars)

35+ space

36+ p_forallBndrs p_ruleBndr ruleBndrs

3337 breakpoint

3438 inci $ do

3539 located lhs p_hsExpr

@@ -43,16 +47,6 @@ p_ruleDecl = \case

4347p_ruleName :: (SourceText, RuleName) -> R ()

4448p_ruleName (_, name) = atom $ HsString NoSourceText name

4549

46−p_ruleBndrs :: [LRuleBndr GhcPs] -> R ()

47−p_ruleBndrs [] = return ()

48−p_ruleBndrs bndrs =

49− switchLayout (getLoc <$> bndrs) $ do

50− txt "forall"

51− breakpoint

52− inci $ do

53− sitcc $ sep breakpoint (sitcc . located' p_ruleBndr) bndrs

54− txt "."

55−

5650p_ruleBndr :: RuleBndr GhcPs -> R ()

5751p_ruleBndr = \case

5852 RuleBndr NoExt x -> p_rdrName x

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+17−10

@@ -89,16 +89,23 @@ p_injectivityAnn (InjectivityAnn a bs) = do

8989p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()

9090p_tyFamInstEqn HsIB {..} = do

9191 let FamEqn {..} = hsib_body

92− switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $

93− p_infixDefHelper

94− (isInfix feqn_fixity)

95− inci

96− (p_rdrName feqn_tycon)

97− (located' p_hsType <$> feqn_pats)

98− space

99− txt "="

100− breakpoint

101− inci (located feqn_rhs p_hsType)

92+ case feqn_bndrs of

93+ Nothing -> return ()

94+ Just bndrs -> do

95+ p_forallBndrs p_hsTyVarBndr bndrs

96+ breakpoint

97+ (if null feqn_bndrs then id else inci) $ do

98+ let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats

99+ switchLayout famLhsSpn $

100+ p_infixDefHelper

101+ (isInfix feqn_fixity)

102+ inci

103+ (p_rdrName feqn_tycon)

104+ (located' p_hsType . typeArgToType <$> feqn_pats)

105+ space

106+ txt "="

107+ breakpoint

108+ inci (located feqn_rhs p_hsType)

102109p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"

103110

104111----------------------------------------------------------------------------

src/Ormolu/Printer/Meat/Declaration/Value.hs+45−34

@@ -192,14 +192,14 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do

192192 then id

193193 else inci

194194 switchLayout [combinedSpans] $ do

195− let stdCase = sep breakpoint (located' p_pat) m_pats

195+ let stdCase = sep breakpoint p_pat m_pats

196196 case style of

197197 Function name ->

198198 p_infixDefHelper

199199 isInfix

200200 inci'

201201 (p_rdrName name)

202− (located' p_pat <$> m_pats)

202+ (p_pat <$> m_pats)

203203 PatternBind -> stdCase

204204 Case -> stdCase

205205 Lambda -> do

@@ -367,18 +367,22 @@ p_stmt' ::

367367 R ()

368368p_stmt' placer render = \case

369369 LastStmt NoExt body _ _ -> located body render

370− BindStmt NoExt l f _ _ -> do

371− located l p_pat

370+ BindStmt NoExt p f _ _ -> do

371+ p_pat p

372372 space

373373 txt "<-"

374+ -- https://gitlab.haskell.org/ghc/ghc/issues/17330

375+ let loc = case p of

376+ XPat pat -> getLoc pat

377+ _ -> error "p_stmt': BindStmt: Pat does not contain a location"

374378 let placement =

375379 case f of

376380 L l' x ->

377381 if isOneLineSpan

378− (mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))

382+ (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l'))

379383 then placer x

380384 else Normal

381− switchLayout [getLoc l, getLoc f] $

385+ switchLayout [loc, getLoc f] $

382386 placeHanging placement (located f render)

383387 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer

384388 BodyStmt NoExt body _ _ -> located body render

@@ -564,7 +568,7 @@ p_hsExpr' s = \case

564568 sep breakpoint (located' p_hsExpr) initp

565569 placeHanging placement $

566570 located lastp p_hsExpr

567− HsAppType a e -> do

571+ HsAppType NoExt e a -> do

568572 located e p_hsExpr

569573 breakpoint

570574 inci $ do

@@ -687,7 +691,7 @@ p_hsExpr' s = \case

687691 (comma >> breakpoint)

688692 (sitcc . located' (p_hsRecField . updName))

689693 rupd_flds

690− ExprWithTySig affix x -> sitcc $ do

694+ ExprWithTySig NoExt x affix -> sitcc $ do

691695 located x p_hsExpr

692696 space

693697 txt "::"

@@ -736,7 +740,7 @@ p_hsExpr' s = \case

736740 HsSpliceE NoExt splice -> p_hsSplice splice

737741 HsProc NoExt p e -> do

738742 txt "proc"

739− located p $ \x -> do

743+ locatedPat p $ \x -> do

740744 breakpoint

741745 inci (p_pat x)

742746 breakpoint

@@ -781,15 +785,15 @@ p_patSynBind PSB {..} = do

781785 Unidirectional -> do

782786 txt "<-"

783787 breakpoint

784− located psb_def p_pat

788+ p_pat psb_def

785789 ImplicitBidirectional -> do

786790 txt "="

787791 breakpoint

788− located psb_def p_pat

792+ p_pat psb_def

789793 ExplicitBidirectional mgroup -> do

790794 txt "<-"

791795 breakpoint

792− located psb_def p_pat

796+ p_pat psb_def

793797 newline

794798 txt "where"

795799 newline

@@ -890,37 +894,40 @@ p_let render localBinds e = sitcc $ do

890894

891895p_pat :: Pat GhcPs -> R ()

892896p_pat = \case

897+ -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always

898+ -- constructed with the 'XPat' constructor, containing a @Located Pat@.

899+ XPat pat -> located pat p_pat

893900 WildPat NoExt -> txt "_"

894901 VarPat NoExt name -> p_rdrName name

895902 LazyPat NoExt pat -> do

896903 txt "~"

897− located pat p_pat

904+ p_pat pat

898905 AsPat NoExt name pat -> do

899906 p_rdrName name

900907 txt "@"

901− located pat p_pat

908+ p_pat pat

902909 ParPat NoExt pat ->

903− located pat (parens S . p_pat)

910+ locatedPat pat (parens S . p_pat)

904911 BangPat NoExt pat -> do

905912 txt "!"

906− located pat p_pat

913+ p_pat pat

907914 ListPat NoExt pats -> do

908− brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats

915+ brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats

909916 TuplePat NoExt pats boxing -> do

910917 let f =

911918 case boxing of

912919 Boxed -> parens S

913920 Unboxed -> parensHash S

914− f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats

921+ f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats

915922 SumPat NoExt pat tag arity ->

916− p_unboxedSum S tag arity (located pat p_pat)

923+ p_unboxedSum S tag arity (p_pat pat)

917924 ConPatIn pat details ->

918925 case details of

919926 PrefixCon xs -> sitcc $ do

920927 p_rdrName pat

921928 unless (null xs) $ do

922929 breakpoint

923− inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs

930+ inci . sitcc $ sep breakpoint (sitcc . p_pat) xs

924931 RecCon (HsRecFields fields dotdot) -> do

925932 p_rdrName pat

926933 breakpoint

@@ -932,18 +939,18 @@ p_pat = \case

932939 Nothing -> Just <$> fields

933940 Just n -> (Just <$> take n fields) ++ [Nothing]

934941 InfixCon x y -> do

935− located x p_pat

942+ p_pat x

936943 space

937944 p_rdrName pat

938945 breakpoint

939− inci (located y p_pat)

946+ inci (p_pat y)

940947 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?

941948 ViewPat NoExt expr pat -> sitcc $ do

942949 located expr p_hsExpr

943950 space

944951 txt "->"

945952 breakpoint

946− inci (located pat p_pat)

953+ inci (p_pat pat)

947954 SplicePat NoExt splice -> p_hsSplice splice

948955 LitPat NoExt p -> atom p

949956 NPat NoExt v _ _ -> located v (atom . ol_val)

@@ -954,11 +961,10 @@ p_pat = \case

954961 txt "+"

955962 space

956963 located k (atom . ol_val)

957− SigPat hswc pat -> do

958− located pat p_pat

964+ SigPat NoExt pat hswc -> do

965+ p_pat pat

959966 p_typeAscription hswc

960967 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage

961− XPat NoExt -> notImplemented "XPat"

962968

963969p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()

964970p_pat_hsRecField HsRecField {..} = do

@@ -968,7 +974,7 @@ p_pat_hsRecField HsRecField {..} = do

968974 space

969975 txt "="

970976 breakpoint

971− inci (located hsRecFieldArg p_pat)

977+ inci (p_pat hsRecFieldArg)

972978

973979p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()

974980p_unboxedSum s tag arity m = do

@@ -1000,6 +1006,7 @@ p_hsSplice = \case

10001006 atom str

10011007 txt "|]"

10021008 HsSpliced {} -> notImplemented "HsSpliced"

1009+ HsSplicedT {} -> notImplemented "HsSplicedT"

10031010 XSplice {} -> notImplemented "XSplice"

10041011

10051012p_hsSpliceTH ::

@@ -1030,7 +1037,7 @@ p_hsBracket = \case

10301037 AnnOpenEQ : _ -> ""

10311038 _ -> "e"

10321039 quote name (located expr p_hsExpr)

1033− PatBr NoExt pat -> quote "p" (located pat p_pat)

1040+ PatBr NoExt pat -> quote "p" (p_pat pat)

10341041 DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)

10351042 DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer

10361043 TypBr NoExt ty -> quote "t" (located ty p_hsType)

@@ -1193,12 +1200,16 @@ exprPlacement = \case

11931200 OpApp NoExt _ _ y -> exprPlacement (unLoc y)

11941201 -- Same thing for function applications (usually with -XBlockArguments)

11951202 HsApp NoExt _ y -> exprPlacement (unLoc y)

1196− HsProc NoExt (L s _) _ ->

1197− -- Indentation breaks if pattern is longer than one line and left

1198− -- hanging. Consequently, only apply hanging when it is safe.

1199− if isOneLineSpan s

1200− then Hanging

1201− else Normal

1203+ HsProc NoExt p _ ->

1204+ -- https://gitlab.haskell.org/ghc/ghc/issues/17330

1205+ let loc = case p of

1206+ XPat pat -> getLoc pat

1207+ _ -> error "exprPlacement: HsProc: Pat does not contain a location"

1208+ in -- Indentation breaks if pattern is longer than one line and left

1209+ -- hanging. Consequently, only apply hanging when it is safe.

1210+ if isOneLineSpan loc

1211+ then Hanging

1212+ else Normal

12021213 _ -> Normal

12031214

12041215withGuards :: [LGRHS GhcPs (Located body)] -> Bool

src/Ormolu/Printer/Meat/Type.hs+39−23

@@ -8,13 +8,14 @@ module Ormolu.Printer.Meat.Type

88 hasDocStrings,

99 p_hsContext,

1010 p_hsTyVarBndr,

11+ p_forallBndrs,

1112 p_conDeclFields,

1213 tyVarsToTypes,

1314 )

1415where

1516

16−import BasicTypes

17−import GHC

17+import Data.Data (Data)

18+import GHC hiding (isPromoted)

1819import Ormolu.Printer.Combinators

1920import Ormolu.Printer.Meat.Common

2021import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)

@@ -27,9 +28,7 @@ p_hsType t = p_hsType' (hasDocStrings t) t

2728p_hsType' :: Bool -> HsType GhcPs -> R ()

2829p_hsType' multilineArgs = \case

2930 HsForAllTy NoExt bndrs t -> do

30− txt "forall "

31− sep space (located' p_hsTyVarBndr) bndrs

32− txt "."

31+ p_forallBndrs p_hsTyVarBndr bndrs

3332 interArgBreak

3433 p_hsType' multilineArgs (unLoc t)

3534 HsQualTy NoExt qs t -> do

@@ -43,7 +42,7 @@ p_hsType' multilineArgs = \case

4342 _ -> located t p_hsTypeR

4443 HsTyVar NoExt p n -> do

4544 case p of

46− Promoted -> do

45+ IsPromoted -> do

4746 txt "'"

4847 case showOutputable (unLoc n) of

4948 _ : '\'' : _ -> space

@@ -54,6 +53,15 @@ p_hsType' multilineArgs = \case

5453 located f p_hsType

5554 breakpoint

5655 inci (located x p_hsType)

56+ HsAppKindTy _ ty kd -> sitcc $ do

57+ -- The first argument is the location of the "@..." part. Not 100% sure,

58+ -- but I think we can ignore it as long as we use 'located' on both the

59+ -- type and the kind.

60+ located ty p_hsType

61+ breakpoint

62+ inci $ do

63+ txt "@"

64+ located kd p_hsType

5765 HsFunTy NoExt x y@(L _ y') -> do

5866 located x p_hsType

5967 space

@@ -79,12 +87,6 @@ p_hsType' multilineArgs = \case

7987 HsOpTy NoExt x op y -> sitcc $ do

8088 let opTree = OpBranch (tyOpTree x) op (tyOpTree y)

8189 in p_tyOpTree (reassociateOpTree Just opTree)

82− HsParTy NoExt (L _ t@HsKindSig {}) ->

83− -- NOTE Kind signatures already put parentheses around in all cases, so

84− -- skip this layer of parentheses. The reason for this behavior is that

85− -- parentheses are not always encoded with 'HsParTy', but seem to be

86− -- always necessary when we have kind signatures in place.

87− p_hsType t

8890 HsParTy NoExt t ->

8991 parens N (located t p_hsType)

9092 HsIParamTy NoExt n t -> sitcc $ do

@@ -94,14 +96,12 @@ p_hsType' multilineArgs = \case

9496 breakpoint

9597 inci (located t p_hsType)

9698 HsStarTy NoExt _ -> txt "*"

97− HsKindSig NoExt t k ->

98− -- NOTE Also see the comment for 'HsParTy'.

99− parens N . sitcc $ do

100− located t p_hsType

101− space -- FIXME

102− txt "::"

103− space

104− inci (located k p_hsType)

99+ HsKindSig NoExt t k -> sitcc $ do

100+ located t p_hsType

101+ space -- FIXME

102+ txt "::"

103+ space

104+ inci (located k p_hsType)

105105 HsSpliceTy NoExt splice -> p_hsSplice splice

106106 HsDocTy NoExt t str -> do

107107 p_hsDocString Pipe True str

@@ -120,13 +120,13 @@ p_hsType' multilineArgs = \case

120120 p_conDeclFields fields

121121 HsExplicitListTy NoExt p xs -> do

122122 case p of

123− Promoted -> txt "'"

123+ IsPromoted -> txt "'"

124124 NotPromoted -> return ()

125125 brackets N $ do

126126 -- If both this list itself and the first element is promoted,

127127 -- we need to put a space in between or it fails to parse.

128128 case (p, xs) of

129− (Promoted, ((L _ t) : _)) | isPromoted t -> space

129+ (IsPromoted, ((L _ t) : _)) | isPromoted t -> space

130130 _ -> return ()

131131 sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

132132 HsExplicitTupleTy NoExt xs -> do

@@ -144,7 +144,7 @@ p_hsType' multilineArgs = \case

144144 XHsType (NHsCoreTy t) -> atom t

145145 where

146146 isPromoted = \case

147− HsTyVar _ Promoted _ -> True

147+ HsTyVar _ IsPromoted _ -> True

148148 HsExplicitListTy _ _ _ -> True

149149 HsExplicitTupleTy _ _ -> True

150150 _ -> False

@@ -182,6 +182,17 @@ p_hsTyVarBndr = \case

182182 inci (located k p_hsType)

183183 XTyVarBndr NoExt -> notImplemented "XTyVarBndr"

184184

185+-- | Render several @forall@-ed variables.

186+p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()

187+p_forallBndrs _ [] = return ()

188+p_forallBndrs p tyvars =

189+ switchLayout (getLoc <$> tyvars) $ do

190+ txt "forall"

191+ breakpoint

192+ inci $ do

193+ sitcc $ sep breakpoint (sitcc . located' p) tyvars

194+ txt "."

195+

185196p_conDeclFields :: [LConDeclField GhcPs] -> R ()

186197p_conDeclFields xs =

187198 braces N . sitcc $

@@ -229,6 +240,11 @@ tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs

229240tyVarToType = \case

230241 UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar

231242 KindedTyVar NoExt tvar kind ->

243+ -- Note: we always add parentheses because for whatever reason GHC does

244+ -- not use HsParTy for left-hand sides of declarations. Please see

245+ -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as

246+ -- long as 'tyVarToType' does not get applied to right-hand sides of

247+ -- declarations.

232248 HsParTy NoExt $ noLoc $

233249 HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind

234250 XTyVarBndr {} -> notImplemented "XTyVarBndr"

src/Ormolu/Utils.hs+8−1

@@ -8,6 +8,7 @@ module Ormolu.Utils

88 notImplemented,

99 showOutputable,

1010 splitDocString,

11+ typeArgToType,

1112 )

1213where

1314

@@ -16,9 +17,9 @@ import Data.List (dropWhileEnd)

1617import Data.List.NonEmpty (NonEmpty (..))

1718import Data.Text (Text)

1819import qualified Data.Text as T

20+import GHC

1921import HsDoc (HsDocString, unpackHDS)

2022import qualified Outputable as GHC

21−import SrcLoc

2223

2324-- | Combine all source spans from the given list.

2425combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

@@ -72,3 +73,9 @@ splitDocString docStr =

7273 in if leadingSpace x

7374 then dropSpace <$> xs

7475 else xs

76+

77+typeArgToType :: LHsTypeArg p -> LHsType p

78+typeArgToType = \case

79+ HsValArg tm -> tm

80+ HsTypeArg _ ty -> ty

81+ HsArgPar _ -> notImplemented "HsArgPar"