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.

CHANGELOG.md

@@ -1,5 +1,10 @@
 ## Unreleased
 
+* 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.
+
 * Fixed formatting of result type in closed type families. See [issue
   420](https://github.com/tweag/ormolu/issues/420).
 

app/Main.hs

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

data/examples/declaration/class/type-operators3-out.hs

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

data/examples/declaration/class/type-operators3.hs

@@ -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 = ()

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

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

data/examples/declaration/data/existential.hs

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

data/examples/declaration/data/gadt/strictness-out.hs

@@ -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

data/examples/declaration/data/gadt/strictness.hs

@@ -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

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

@@ -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

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

@@ -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

data/examples/declaration/data/operators-out.hs

@@ -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

data/examples/declaration/data/operators.hs

@@ -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

data/examples/declaration/data/strictness-out.hs

@@ -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}

data/examples/declaration/data/strictness.hs

@@ -2,4 +2,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 }

data/examples/declaration/rewrite-rule/forall-1-out.hs

@@ -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
+  #-}

data/examples/declaration/rewrite-rule/forall-1.hs

@@ -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 #-}

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

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

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

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

data/examples/declaration/type-families/closed-type-family/with-forall-out.hs

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

data/examples/declaration/type-families/closed-type-family/with-forall.hs

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

data/examples/declaration/type-families/type-family/operator-out.hs

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

data/examples/declaration/type-families/type-family/operator.hs

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

data/examples/declaration/type/type-applications-out.hs

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

data/examples/declaration/type/type-applications.hs

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

data/examples/other/haddock-sections-out.hs

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

data/examples/other/haddock-sections.hs

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

data/examples/other/multiline-forall-out.hs

@@ -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) =
+    ()
+  #-}

data/examples/other/multiline-forall.hs

@@ -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) =
+    ()
+  #-}

default.nix

@@ -15,6 +15,11 @@ let
   };
   ormoluOverlay = self: super: {
     "ormolu" = super.callCabal2nix "ormolu" source { };
+    # Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want
+    # ghc-lib-parser-8.8.1. We disable Haddock generation because it's way
+    # too slow.
+    "ghc-lib-parser" = pkgs.haskell.lib.dontHaddock
+      (super.callHackage "ghc-lib-parser" "8.8.1" { });
   };
   ormolize = import ./nix/ormolize {
     inherit pkgs;
@@ -73,6 +78,7 @@ in {
       "hlint"
       "megaparsec"
       "ormolu"
+      "optics"
       "postgrest"
       "servant"
       "servant-server"

nix/nixpkgs/default.nix

@@ -1,6 +1,6 @@
 let
-  rev = "3f4144c30a6351dd79b177328ec4dea03e2ce45f";
-  sha256 = "1qg5n60n3fr6cypihnrjw451fadps5pysj5p0vvfb320mpfvlbjb";
+  rev = "19.09";
+  sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";
   nixpkgs = builtins.fetchTarball {
     url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
     inherit sha256;

ormolu.cabal

@@ -68,9 +68,7 @@ library
                     , 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,6 +109,8 @@ library
                     , Ormolu.Printer.Operators
                     , Ormolu.Printer.SpanStream
                     , Ormolu.Utils
+  other-modules:      GHC
+                    , GHC.DynFlags
   if flag(dev)
     ghc-options:      -Wall -Werror -Wcompat
                       -Wincomplete-record-updates
@@ -148,7 +148,7 @@ executable ormolu
   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

src/GHC.hs

@@ -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)

src/GHC/DynFlags.hs

@@ -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

src/Ormolu/Diff.hs

@@ -20,7 +20,6 @@ import GHC
 import Ormolu.Imports (sortImports)
 import Ormolu.Parser.Result
 import Ormolu.Utils
-import qualified SrcLoc as GHC
 
 -- | Result of comparing two 'ParseResult's.
 data Diff

src/Ormolu/Parser.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -16,11 +17,13 @@ import Control.Monad.IO.Class
 import Data.List ((\\), foldl', isPrefixOf)
 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.Anns
 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.
@@ -47,16 +50,22 @@ parseModule ::
     )
 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.
+  -- 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)
+  (warnings, dynFlags) <-
+    parsePragmasIntoDynFlags baseFlags 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
@@ -70,7 +79,7 @@ parseModule Config {..} path input' = liftIO $ do
                   prCommentStream = comments,
                   prExtensions = exts
                 }
-  return (ws, r)
+  return (warnings, r)
 
 -- | Extensions that are not enabled automatically and should be activated
 -- by user.
@@ -99,47 +108,6 @@ manualExts =
 ----------------------------------------------------------------------------
 -- 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
@@ -198,4 +166,23 @@ setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
     autoExts = allExts \\ manualExts
     allExts = [minBound .. maxBound]
 
-deriving instance Bounded Extension
+----------------------------------------------------------------------------
+-- More helpers (taken from HLint)
+
+parsePragmasIntoDynFlags ::
+  DynFlags ->
+  FilePath ->
+  String ->
+  IO (Either String ([GHC.Warn], DynFlags))
+parsePragmasIntoDynFlags flags filepath str =
+  catchErrors $ do
+    let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath
+    (flags', _, warnings) <- parseDynamicFilePragma flags opts
+    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)

src/Ormolu/Parser/CommentStream.hs

@@ -53,7 +53,7 @@ mkCommentStream extraComments pstate =
       -- 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,
+      mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,
     pragmas
   )
   where
@@ -133,6 +133,6 @@ partitionComments ::
   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

src/Ormolu/Parser/Pragma.hs

@@ -68,12 +68,15 @@ tokenize input =
     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]

src/Ormolu/Printer/Combinators.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -22,6 +24,7 @@ module Ormolu.Printer.Combinators
     inci,
     located,
     located',
+    locatedPat,
     switchLayout,
     Layout (..),
     vlayout,
@@ -62,6 +65,7 @@ import Control.Monad
 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)
@@ -108,6 +112,28 @@ located' ::
   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
 -- several elements when there is no corresponding 'Located' wrapper

src/Ormolu/Printer/Comments.hs

@@ -42,7 +42,7 @@ spitPrecedingComments ref = 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
+        when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline
 
 -- | Output all comments following an element at given location.
 spitFollowingComments ::
@@ -51,7 +51,7 @@ spitFollowingComments ::
   RealLocated a ->
   R ()
 spitFollowingComments ref = do
-  trimSpanStream (getLoc ref)
+  trimSpanStream (getRealSrcSpan ref)
   void $ handleCommentSeries (spitFollowingComment ref)
 
 -- | Output all remaining comments in the comment stream.

src/Ormolu/Printer/Internal.hs

@@ -62,7 +62,6 @@ import Ormolu.Parser.CommentStream
 import Ormolu.Printer.SpanStream
 import Ormolu.Utils (showOutputable)
 import Outputable (Outputable)
-import SrcLoc
 
 ----------------------------------------------------------------------------
 -- The 'R' monad

src/Ormolu/Printer/Meat/Common.hs

@@ -162,11 +162,12 @@ p_hsDocString hstyle needsNewline (L l str) = do
   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

src/Ormolu/Printer/Meat/Declaration.hs

@@ -14,7 +14,7 @@ where
 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 @@ sigRdrNames _ = Nothing
 
 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 :: Pat GhcPs -> [RdrName]
 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 (CoPat NoExt _ p _) = patBindNames p
-patBindNames (XPat NoExt) = notImplemented "XPat"
+patBindNames (XPat p) = patBindNames (unLoc p)

src/Ormolu/Printer/Meat/Declaration/Class.hs

@@ -103,7 +103,7 @@ p_funDep (before, after) = do
 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"
 

src/Ormolu/Printer/Meat/Declaration/Data.hs

@@ -104,7 +104,7 @@ p_conDecl = \case
                 then newline
                 else breakpoint
         interArgBreak
-        p_forallBndrs (hsq_explicit con_qvars)
+        p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)
         unless (null $ hsq_explicit con_qvars) interArgBreak
         forM_ con_mb_cxt p_lhsContext
         case con_args of
@@ -130,7 +130,7 @@ p_conDecl = \case
             <> maybeToList (fmap getLoc con_mb_cxt)
             <> conArgsSpans con_args
     switchLayout conDeclSpn $ do
-      p_forallBndrs con_ex_tvs
+      p_forallBndrs p_hsTyVarBndr con_ex_tvs
       unless (null con_ex_tvs) breakpoint
       forM_ con_mb_cxt p_lhsContext
       case con_args of
@@ -165,17 +165,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 ->
   R ()

src/Ormolu/Printer/Meat/Declaration/Instance.hs

@@ -117,7 +117,7 @@ p_dataFamInstDecl style = \case
   DataFamInstDecl {..} -> do
     let HsIB {..} = dfid_eqn
         FamEqn {..} = hsib_body
-    p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs
+    p_dataDecl style feqn_tycon (map typeArgToType feqn_pats) feqn_fixity feqn_rhs
 
 match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
 match_overlap_mode overlap_mode layoutStrategy =

src/Ormolu/Printer/Meat/Declaration/Rule.hs

@@ -8,11 +8,13 @@ module Ormolu.Printer.Meat.Declaration.Rule
 where
 
 import BasicTypes
+import Data.Maybe (fromMaybe)
 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 +26,14 @@ p_ruleDecls = \case
 
 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
+    p_forallBndrs p_hsTyVarBndr (fromMaybe [] tyvars)
+    space
+    p_forallBndrs p_ruleBndr ruleBndrs
     breakpoint
     inci $ do
       located lhs p_hsExpr
@@ -43,16 +47,6 @@ p_ruleDecl = \case
 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
   RuleBndr NoExt x -> p_rdrName x

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs

@@ -89,16 +89,23 @@ p_injectivityAnn (InjectivityAnn a bs) = do
 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)
+  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 (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
 
 ----------------------------------------------------------------------------

src/Ormolu/Printer/Meat/Declaration/Value.hs

@@ -192,14 +192,14 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
               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
@@ -367,18 +367,22 @@ p_stmt' ::
   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
@@ -564,7 +568,7 @@ p_hsExpr' s = \case
           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,7 +691,7 @@ p_hsExpr' s = \case
         (comma >> breakpoint)
         (sitcc . located' (p_hsRecField . updName))
         rupd_flds
-  ExprWithTySig affix x -> sitcc $ do
+  ExprWithTySig NoExt x affix -> sitcc $ do
     located x p_hsExpr
     space
     txt "::"
@@ -736,7 +740,7 @@ p_hsExpr' s = \case
   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 +785,15 @@ p_patSynBind PSB {..} = do
           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
@@ -890,37 +894,40 @@ p_let render localBinds e = sitcc $ do
 
 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
+    p_pat pat
   ListPat NoExt pats -> do
-    brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) 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 +939,18 @@ p_pat = \case
             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 +961,10 @@ p_pat = \case
       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 +974,7 @@ p_pat_hsRecField HsRecField {..} = do
     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 +1006,7 @@ p_hsSplice = \case
     atom str
     txt "|]"
   HsSpliced {} -> notImplemented "HsSpliced"
+  HsSplicedT {} -> notImplemented "HsSplicedT"
   XSplice {} -> notImplemented "XSplice"
 
 p_hsSpliceTH ::
@@ -1030,7 +1037,7 @@ p_hsBracket = \case
           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)
@@ -1193,12 +1200,16 @@ exprPlacement = \case
   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

src/Ormolu/Printer/Meat/Type.hs

@@ -8,13 +8,14 @@ module Ormolu.Printer.Meat.Type
     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 t = p_hsType' (hasDocStrings t) t
 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 @@ p_hsType' multilineArgs = \case
       _ -> 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 @@ p_hsType' multilineArgs = \case
     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
@@ -79,12 +87,6 @@ p_hsType' multilineArgs = \case
   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
   HsParTy NoExt t ->
     parens N (located t p_hsType)
   HsIParamTy NoExt n t -> sitcc $ do
@@ -94,14 +96,12 @@ p_hsType' multilineArgs = \case
     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,13 +120,13 @@ p_hsType' multilineArgs = \case
     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
@@ -144,7 +144,7 @@ p_hsType' multilineArgs = \case
   XHsType (NHsCoreTy t) -> atom t
   where
     isPromoted = \case
-      HsTyVar _ Promoted _ -> True
+      HsTyVar _ IsPromoted _ -> True
       HsExplicitListTy _ _ _ -> True
       HsExplicitTupleTy _ _ -> True
       _ -> False
@@ -182,6 +182,17 @@ p_hsTyVarBndr = \case
     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 _ [] = return ()
+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 $
@@ -229,6 +240,11 @@ tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
 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"

src/Ormolu/Utils.hs

@@ -8,6 +8,7 @@ module Ormolu.Utils
     notImplemented,
     showOutputable,
     splitDocString,
+    typeArgToType,
   )
 where
 
@@ -16,9 +17,9 @@ import Data.List (dropWhileEnd)
 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 @@ splitDocString docStr =
            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"