Formatting with Brittany Fails When Warnings are Emitted

[prikhi]

Your environment

Output of haskell-language-server --probe-tools or haskell-language-server-wrapper --probe-tools:

haskell-language-server version: 1.2.0.0 (GHC: 8.8.4) (PATH: /home/prikhi/.local/bin/haskell-language-server-wrapper) (GIT hash: b8bb06eb1b117943f4436a6fdafe5c09e76cac1c)
Tool versions found on the $PATH
cabal:		3.2.0.0
stack:		2.7.1
ghc:		8.10.5

Which OS do you use:
ArchLinux

Which lsp-client do you use:
Neovim + coc.nvim

Steps to reproduce

Chang formatter to brittany & attempt to format a file that contains type operators in a multi-line expression:

{-# LANGUAGE TypeOperators #-}
module HsOpTy where

-- brittany *should* remove the extra spaces between import & module name 
import     GHC.TypeLits

type Foo = 
  Int :
  '[]

See lspitzner/brittany#271 for more repros.
As noted in that issue, if you remove the newlines, formatting proceeds correctly

Expected behaviour

HLS ignores the warnings & uses the formatted text.
This is the behavior brittany's CLI tool exhibits:

$ cat test.hs
{-# LANGUAGE TypeOperators #-}
module HsOpTy where

import     GHC.TypeLits

type Foo =
  Int :
  '[]
$ brittany --write-mode display test.hs >/dev/null
WARNING: encountered unknown syntactical constructs:
  HsOpTy{} at test.hs:(7,3)-(8,5)
  -> falling back on exactprint for this element of the module
$ brittany --write-mode display test.hs 2>/dev/null
{-# LANGUAGE TypeOperators #-}
module HsOpTy where

import GHC.TypeLits

type Foo =
  Int :
  '[]

Actual behaviour

Nothing happens, following output appears in coc's HLS workspace output:

2021-07-08 00:11:10.475037968 [ThreadId 15168] INFO hls:	finish: brittany (took 0.00s)
[Error  - 12:11:10 AM] Request textDocument/formatting failed.
  Message: brittanyCmd: HsOpTy{}
HsOpTy{}
HsOpTy{}

  Code: -32602 

Include debug information

Execute in the root of your project the command haskell-language-server --debug . and paste the logs here:

Debug output:

can't share actual dump, contains proprietary information...

Paste the logs from the lsp-client, e.g. for VS Code

LSP logs:

Found "/home/prikhi/code/backend-2/hie.yaml" for "/home/prikhi/code/backend-2/a"
Run entered for haskell-language-server-wrapper(haskell-language-server-wrapper) Version 1.2.0.0, Git revision b8bb06eb1b117943f4436a6fdafe5c09e76cac1c (dirty) (2297 commits) x86_64 ghc-8.8.4
Current directory: /home/prikhi/code/backend-2
Operating system: linux
Arguments: ["--lsp"]
Cradle directory: /home/prikhi/code/backend-2
Cradle type: Stack

Tool versions found on the $PATH
cabal:		3.2.0.0
stack:		2.7.1
ghc:		8.10.5


Consulting the cradle to get project GHC version...
Project GHC version: 8.8.4
haskell-language-server exe candidates: ["haskell-language-server-8.8.4","haskell-language-server"]
Launching haskell-language-server exe at:/home/prikhi/.local/bin/haskell-language-server-8.8.4
haskell-language-server version: 1.2.0.0 (GHC: 8.8.4) (PATH: /home/prikhi/.local/bin/haskell-language-server-8.8.4) (GIT hash: b8bb06eb1b117943f4436a6fdafe5c09e76cac1c)
Starting (haskell-language-server)LSP server...
  with arguments: GhcideArguments {argsCommand = LSP, argsCwd = Nothing, argsShakeProfiling = Nothing, argsTesting = False, argsExamplePlugin = False, argsDebugOn = False, argsLogFile = Nothing, argsThreads = 0, argsProjectGhcVersion = False}
  with plugins: [PluginId "pragmas",PluginId "floskell",PluginId "fourmolu",PluginId "tactics",PluginId "ormolu",PluginId "stylish-haskell",PluginId "retrie",PluginId "brittany",PluginId "class",PluginId "haddockComments",PluginId "eval",PluginId "importLens",PluginId "refineImports",PluginId "moduleName",PluginId "hlint",PluginId "splice",PluginId "ghcide-hover-and-symbols",PluginId "ghcide-code-actions-imports-exports",PluginId "ghcide-code-actions-type-signatures",PluginId "ghcide-code-actions-bindings",PluginId "ghcide-code-actions-fill-holes",PluginId "ghcide-completions",PluginId "ghcide-type-lenses",PluginId "ghcide-core"]
  in directory: /home/prikhi/code/backend-2
 Starting LSP server...
If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!
Started LSP server in 0.00s
setInitialDynFlags cradle: Cradle {cradleRootDir = "/home/prikhi/code/backend-2", cradleOptsProg = CradleAction: Stack}
2021-07-08 00:09:22.425059367 [ThreadId 5] INFO hls:	Registering ide configuration: IdeConfiguration {workspaceFolders = fromList [NormalizedUri 4597480009621044856 "file:///home/prikhi/code/backend-2"], clientSettings = hashed (Just (Object (fromList [("haskell",Object (fromList [("hlintOn",Bool True),("formatOnImportOn",Bool True),("formattingProvider",String "brittany")]))])))}
2021-07-08 00:09:22.478204734 [ThreadId 89] INFO hls:	Consulting the cradle for "src/Api.hs"
Output from setting up the cradle Cradle {cradleRootDir = "/home/prikhi/code/backend-2", cradleOptsProg = CradleAction: Stack}
> horrorscopeapp> configure (lib)
> Configuring horrorscopeapp-0.1.0.0...
> horrorscopeapp> initial-build-steps (lib)
> The following GHC options are incompatible with GHCi and have not been passed to it: -Werror
> Configuring GHCi with the following packages: horrorscopeapp
> /home/prikhi/code/backend-2/.stack-work/install/x86_64-linux-tinfo6/a6768a29cf9d734944d8ba2d6d60991c59641ad9d318a0f6ffa7df794775f31e/8.8.4/pkgdb:/home/prikhi/.stack/snapshots/x86_64-linux-tinfo6/a6768a29cf9d734944d8ba2d6d60991c59641ad9d318a0f6ffa7df794775f31e/8.8.4/pkgdb:/home/prikhi/.stack/programs/x86_64-linux/ghc-tinfo6-8.8.4/lib/ghc-8.8.4/package.conf.d
2021-07-08 00:09:26.458398216 [ThreadId 89] INFO hls:	Using interface files cache dir: /home/prikhi/.cache/ghcide/main-7f306e53217a845a4abeedac27a777551d74e0c3
2021-07-08 00:09:26.458763864 [ThreadId 89] INFO hls:	Making new HscEnv[main]
2021-07-08 00:10:46.055551279 [ThreadId 4709] INFO hls:	finish: brittany (took 0.00s)
[Error  - 12:10:46 AM] Request textDocument/formatting failed.
  Message: brittanyCmd: HsOpTy{}
HsOpTy{}
HsOpTy{}

  Code: -32602 
2021-07-08 00:11:02.181722538 [ThreadId 13441] INFO hls:	Typechecking reverse dependencies for NormalizedFilePath "/home/prikhi/code/backend-2/src/Api.hs": Just [NormalizedFilePath "/home/prikhi/code/backend-2/src/Interpret.hs",NormalizedFilePath "/home/prikhi/code/backend-2/src/Context.hs"]
2021-07-08 00:11:10.475037968 [ThreadId 15168] INFO hls:	finish: brittany (took 0.00s)
[Error  - 12:11:10 AM] Request textDocument/formatting failed.
  Message: brittanyCmd: HsOpTy{}
HsOpTy{}
HsOpTy{}

  Code: -32602 

[prikhi]

Doing some digging into brittany's CLI tool, it seems to be using pPrintModuleAndCheck instead of parsePrintModule:
https://github.com/lspitzner/brittany/blob/master/src/Language/Haskell/Brittany/Main.hs#L365

Which is not a simple drop-in replacement. I hacked/copy-and-pasted together a very ugly port of Language.Haskell.Brittany.Main.coreIO into the plugin, rebuilt & was able to resolve this issue:

Shit-tier patch:

diff --git a/plugins/hls-brittany-plugin/hls-brittany-plugin.cabal b/plugins/hls-brittany-plugin/hls-brittany-plugin.cabal
index 51d278c2..6b59d837 100644
--- a/plugins/hls-brittany-plugin/hls-brittany-plugin.cabal
+++ b/plugins/hls-brittany-plugin/hls-brittany-plugin.cabal
@@ -21,13 +21,16 @@ library
   hs-source-dirs:   src
   build-depends:
     , base            >=4.12     && <5
     , brittany        >=0.13.1.0
     , filepath
     , ghc
     , ghc-boot-th
     , ghcide           >=1.2 && <1.5
     , hls-plugin-api  ^>=1.1
+    , extra
+    , ghc-exactprint
     , lens
+    , czipwith
     , lsp-types
     , text
     , transformers
diff --git a/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs b/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs
index 8f6e4e19..2bc7ddaa 100644
--- a/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs
+++ b/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs
@@ -1,12 +1,16 @@
 {-# LANGUAGE PolyKinds    #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE LambdaCase #-}
 module Ide.Plugin.Brittany where
 
 import           Control.Exception           (bracket_)
 import           Control.Lens
+import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Maybe   (MaybeT, runMaybeT)
-import           Data.Maybe                  (mapMaybe, maybeToList)
+import Control.Monad.Trans.Class (lift)
+import           Data.Maybe                  (mapMaybe, maybeToList, fromMaybe)
 import           Data.Semigroup
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
@@ -18,11 +22,36 @@ import           GHC.LanguageExtensions.Type
 import           Ide.PluginUtils
 import           Ide.Types
 import           Language.Haskell.Brittany
+import           Language.Haskell.Brittany.Internal.Config.Types
+import           Language.Haskell.Brittany.Internal.Types
+import           Language.Haskell.Brittany.Internal
+import           Language.Haskell.Brittany.Internal.Config
+import           Language.Haskell.Brittany.Internal.Utils
+import           Language.Haskell.Brittany.Internal.Obfuscation
 import           Language.LSP.Types          as J
 import qualified Language.LSP.Types.Lens     as J
 import           System.Environment          (setEnv, unsetEnv)
 import           System.FilePath
 
+import           Data.CZipWith
+import qualified Data.Text.Lazy as TextL
+import qualified Data.Text.Lazy.Encoding as TextL.Encoding
+import qualified Data.Text.Lazy.IO as TextL.IO
+import qualified GHC.OldList as List
+import qualified Control.Monad.Trans.Except as ExceptT
+import qualified Data.List.Extra
+import qualified Data.Text as Text
+import qualified Language.Haskell.GHC.ExactPrint         as ExactPrint
+import qualified Language.Haskell.GHC.ExactPrint.Types   as ExactPrint
+import qualified GHC                           as GHC
+import           GHC                                      ( Located
+                                                          , runGhc
+                                                          , GenLocated(L)
+                                                          , moduleNameString
+                                                          )
+import qualified DynFlags                                as GHC
+import qualified GHC.LanguageExtensions.Type             as GHC
+
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId = (defaultPluginDescriptor plId)
   { pluginHandlers = mkFormattingHandlers provider
@@ -89,7 +118,176 @@ runBrittany tabSize df confPath text = do
               }
 
   config <- fromMaybeT (pure staticDefaultConfig) (readConfigsWithUserConfig cfg (maybeToList confPath))
-  parsePrintModule config text
+  _myPPrintModule config $ Text.unpack text
+
+_myPPrintModule config text =
+  ExceptT.runExceptT $ do
+    let putErrorLn = const $ return ()
+    let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
+    -- there is a good of code duplication between the following code and the
+    -- `pureModuleTransform` function. Unfortunately, there are also a good
+    -- amount of slight differences: This module is a bit more verbose, and
+    -- it tries to use the full-blown `parseModule` function which supports
+    -- CPP (but requires the input to be a file..).
+    let cppMode    = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
+    -- the flag will do the following: insert a marker string
+    -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
+    -- "#include" before processing (parsing) input; and remove that marker
+    -- string from the transformation output.
+    -- The flag is intentionally misspelled to prevent clashing with
+    -- inline-config stuff.
+    let hackAroundIncludes =
+          config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
+    let exactprintOnly = viaGlobal || viaDebug
+         where
+          viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
+          viaDebug =
+            config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
+
+    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
+          then case cppMode of
+            CPPModeAbort -> do
+              return $ Left "Encountered -XCPP. Aborting."
+            CPPModeWarn -> do
+              return $ Right True
+            CPPModeNowarn -> return $ Right True
+          else return $ Right False
+    (parseResult, originalContents) <- do
+        -- TODO: refactor this hack to not be mixed into parsing logic
+        let hackF s = if "#include" `Data.List.Extra.isPrefixOf` s
+              then "-- BRITANY_INCLUDE_HACK " ++ s
+              else s
+        let hackTransform = if hackAroundIncludes && not exactprintOnly
+              then List.intercalate "\n" . fmap hackF . lines'
+              else id
+        let inputString = text
+        parseRes <- liftIO $ parseModuleFromString ghcOptions
+                                                   "stdin"
+                                                   cppCheckFunc
+                                                   (hackTransform inputString)
+        return (parseRes, Text.pack inputString)
+    case parseResult of
+      Left left -> do
+        putErrorLn "parse error:"
+        putErrorLn left
+        ExceptT.throwE [ ErrorInput left ]
+      Right (anns, parsedSource, hasCPP) -> do
+        (inlineConf, perItemConf) <-
+          case
+            extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
+          of
+            Left (err, input) ->
+              ExceptT.throwE
+                [ ErrorInput $ concat
+                    ["Error: parse error in inline configuration:"
+                    , err
+                    , "  in the string \"" ++ input ++ "\"."
+                    ]
+                ]
+            Right c ->
+              pure c
+        let moduleConf = cZipWith fromOptionIdentity config inlineConf
+        let disableFormatting =
+              moduleConf & _conf_disable_formatting & confUnpack
+        (errsWarns, outSText, hasChanges) <- do
+          if
+            | disableFormatting -> do
+              pure ([], originalContents, False)
+            | exactprintOnly -> do
+              let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
+              pure ([], r, r /= originalContents)
+            | otherwise -> do
+              (ews, outRaw) <- if hasCPP
+                then return
+                  $ pPrintModule moduleConf perItemConf anns parsedSource
+                else liftIO $ pPrintModuleAndCheck moduleConf
+                                                   perItemConf
+                                                   anns
+                                                   parsedSource
+              let hackF s = fromMaybe s $ TextL.stripPrefix
+                    (TextL.pack "-- BRITANY_INCLUDE_HACK ")
+                    s
+              let out = TextL.toStrict $ if hackAroundIncludes
+                    then
+                      TextL.intercalate (TextL.pack "\n")
+                      $ fmap hackF
+                      $ TextL.splitOn (TextL.pack "\n") outRaw
+                    else outRaw
+              out' <- if moduleConf & _conf_obfuscate & confUnpack
+                then lift $ obfuscate out
+                else pure out
+              pure $ (ews, out', out' /= originalContents)
+        let customErrOrder ErrorInput{}         = 4
+            customErrOrder LayoutWarning{}      = -1 :: Int
+            customErrOrder ErrorOutputCheck{}   = 1
+            customErrOrder ErrorUnusedComment{} = 2
+            customErrOrder ErrorUnknownNode{}   = -2 :: Int
+            customErrOrder ErrorMacroConfig{}   = 5
+        when (not $ null errsWarns) $ do
+          let groupedErrsWarns =
+                Data.List.Extra.groupOn customErrOrder
+                  $ List.sortOn customErrOrder
+                  $ errsWarns
+          groupedErrsWarns `forM_` \case
+            (ErrorOutputCheck{} : _) -> do
+              putErrorLn
+                $  "ERROR: brittany pretty printer"
+                ++ " returned syntactically invalid result."
+            (ErrorInput str : _) -> do
+              putErrorLn $ "ERROR: parse error: " ++ str
+            uns@(ErrorUnknownNode{} : _) -> do
+              putErrorLn
+                $ "WARNING: encountered unknown syntactical constructs:"
+              uns `forM_` \case
+                ErrorUnknownNode str ast@(L loc _) -> do
+                  when
+                      ( config
+                      & _conf_debug
+                      & _dconf_dump_ast_unknown
+                      & confUnpack
+                      )
+                    $ do
+                        putErrorLn $ "  " ++ show (astToDoc ast)
+                _ -> error "cannot happen (TM)"
+              putErrorLn
+                "  -> falling back on exactprint for this element of the module"
+            warns@(LayoutWarning{} : _) -> do
+              putErrorLn $ "WARNINGS:"
+              warns `forM_` \case
+                LayoutWarning str -> putErrorLn str
+                _                 -> error "cannot happen (TM)"
+            unused@(ErrorUnusedComment{} : _) -> do
+              putErrorLn
+                $  "Error: detected unprocessed comments."
+                ++ " The transformation output will most likely"
+                ++ " not contain some of the comments"
+                ++ " present in the input haskell source file."
+              putErrorLn $ "Affected are the following comments:"
+              unused `forM_` \case
+                ErrorUnusedComment str -> putErrorLn str
+                _                      -> error "cannot happen (TM)"
+            (ErrorMacroConfig err input : _) -> do
+              putErrorLn $ "Error: parse error in inline configuration:"
+              putErrorLn err
+              putErrorLn $ "  in the string \"" ++ input ++ "\"."
+            [] -> error "cannot happen"
+        -- TODO: don't output anything when there are errors unless user
+        -- adds some override?
+        let
+          hasErrors =
+            case config & _conf_errorHandling & _econf_Werror & confUnpack of
+              False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
+              True  -> not $ null errsWarns
+          outputOnErrs =
+            config
+              & _conf_errorHandling
+              & _econf_produceOutputOnErrors
+              & confUnpack
+          shouldOutput =
+              (not hasErrors || outputOnErrs)
+
+        when hasErrors $ ExceptT.throwE errsWarns
+        return outSText
 
 fromMaybeT :: Monad m => m a -> MaybeT m a -> m a
 fromMaybeT def act = runMaybeT act >>= maybe def return

[jneira]

Thanks for the report and the patch. Do you think it could be tidied and converted in a pr?

[prikhi]

Yeah, I'll try & find some time in the next few days to submit a PR. Is that sort of code out-of-scope for an HLS plugin? I could see if brittany would accept a PR instead. Then the "fix" would be to just swap out the parsePrintModule w/ the new function.

[jneira]

I could see if brittany would accept a PR instead. Then the "fix" would be to just swap out the parsePrintModule w/ the new function.

Yeah, that sounds sensible and it will be good for brittany itself