Merge pull request #2763 from haskell/fourmolu-cli

Add an option to run Fourmolu via the CLI interface of a separate binary, rather than the bundled library

hls-test-utils/src/Test/Hls.hs

@@ -48,6 +48,7 @@ import qualified Data.Aeson                      as A
 import           Data.ByteString.Lazy            (ByteString)
 import           Data.Default                    (def)
 import           Data.Maybe                      (fromMaybe)
+import qualified Data.Map                        as M
 import qualified Data.Text                       as T
 import qualified Data.Text.Lazy                  as TL
 import qualified Data.Text.Lazy.Encoding         as TL
@@ -68,7 +69,7 @@ import           Development.IDE.Types.Logger    (Logger (Logger),
 import           Development.IDE.Types.Options
 import           GHC.IO.Handle
 import           GHC.Stack                       (emptyCallStack)
-import           Ide.Plugin.Config               (Config, formattingProvider)
+import           Ide.Plugin.Config               (Config, formattingProvider, PluginConfig, plugins)
 import           Ide.PluginUtils                 (idePluginsToPluginDesc,
                                                   pluginDescToIdePlugins)
 import           Ide.Types
@@ -131,16 +132,17 @@ goldenWithHaskellDoc plugin title testDataDir path desc ext act =
 goldenWithHaskellDocFormatter
   :: PluginDescriptor IdeState
   -> String
+  -> PluginConfig
   -> TestName
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> (TextDocumentIdentifier -> Session ())
   -> TestTree
-goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext act =
+goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc ext act =
   goldenGitDiff title (testDataDir </> path <.> desc <.> ext)
-  $ runSessionWithServerFormatter plugin formatter testDataDir
+  $ runSessionWithServerFormatter plugin formatter conf testDataDir
   $ TL.encodeUtf8 . TL.fromStrict
   <$> do
     doc <- openDoc (path <.> ext) "haskell"
@@ -151,11 +153,14 @@ goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext a
 runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
 runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps
 
-runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a
-runSessionWithServerFormatter plugin formatter =
+runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a
+runSessionWithServerFormatter plugin formatter conf =
   runSessionWithServer'
     [plugin]
-    def {formattingProvider = T.pack formatter}
+    def
+      { formattingProvider = T.pack formatter
+      , plugins = M.singleton (T.pack formatter) conf
+      }
     def
     fullCaps
 

plugins/hls-brittany-plugin/test/Main.hs

@@ -31,7 +31,7 @@ tests = testGroup "brittany"
   ]
 
 brittanyGolden :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
-brittanyGolden title path desc = goldenWithHaskellDocFormatter brittanyPlugin "brittany" title testDataDir path desc "hs"
+brittanyGolden title path desc = goldenWithHaskellDocFormatter brittanyPlugin "brittany" def title testDataDir path desc "hs"
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"

plugins/hls-floskell-plugin/test/Main.hs

@@ -24,7 +24,7 @@ tests = testGroup "floskell"
   ]
 
 goldenWithFloskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
-goldenWithFloskell title path desc = goldenWithHaskellDocFormatter floskellPlugin "floskell" title testDataDir path desc "hs"
+goldenWithFloskell title path desc = goldenWithHaskellDocFormatter floskellPlugin "floskell" def title testDataDir path desc "hs"
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"

plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal

@@ -30,6 +30,7 @@ library
     , hls-plugin-api  ^>=1.3
     , lens
     , lsp
+    , process-extras
     , text
 
   default-language: Haskell2010
@@ -40,9 +41,14 @@ test-suite tests
   hs-source-dirs:   test
   main-is:          Main.hs
   ghc-options:      -Wall -threaded -rtsopts -with-rtsopts=-N
+  build-tool-depends:
+    fourmolu:fourmolu
   build-depends:
     , base
+    , aeson
+    , containers
     , filepath
     , hls-fourmolu-plugin
+    , hls-plugin-api
     , hls-test-utils       ^>=1.2
     , lsp-test

plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs

@@ -2,91 +2,127 @@
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE TypeApplications         #-}
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE OverloadedLabels         #-}
 
 module Ide.Plugin.Fourmolu (
     descriptor,
     provider,
 ) where
 
-import           Control.Exception               (try)
+import           Control.Exception               (IOException, try)
 import           Control.Lens                    ((^.))
+import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Bifunctor                  (first)
+import           Data.Maybe
 import qualified Data.Text                       as T
+import qualified Data.Text.IO                    as T
 import           Development.IDE                 hiding (pluginHandlers)
 import           Development.IDE.GHC.Compat      as Compat hiding (Cpp)
 import qualified Development.IDE.GHC.Compat.Util as S
 import           GHC.LanguageExtensions.Type     (Extension (Cpp))
-import           Ide.PluginUtils                 (makeDiffTextEdit)
+import           Ide.Plugin.Properties
+import           Ide.PluginUtils                 (makeDiffTextEdit, usePropertyLsp)
 import           Ide.Types
 import           Language.LSP.Server             hiding (defaultConfig)
 import           Language.LSP.Types
 import           Language.LSP.Types.Lens         (HasTabSize (tabSize))
 import           Ormolu
+import           System.Exit
 import           System.FilePath
-
--- ---------------------------------------------------------------------
+import           System.IO                       (stderr)
+import           System.Process.Run              (proc, cwd)
+import           System.Process.Text             (readCreateProcessWithExitCode)
 
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId =
     (defaultPluginDescriptor plId)
-        { pluginHandlers = mkFormattingHandlers provider
+        { pluginHandlers = mkFormattingHandlers $ provider plId
         }
 
--- ---------------------------------------------------------------------
-
-provider :: FormattingHandler IdeState
-provider ideState typ contents fp fo = withIndefiniteProgress title Cancellable $ do
-    ghc <- liftIO $ runAction "Fourmolu" ideState $ use GhcSession fp
-    fileOpts <- case hsc_dflags . hscEnv <$> ghc of
-        Nothing -> return []
-        Just df -> liftIO $ convertDynFlags df
-
-    let format printerOpts =
-            first (responseError . ("Fourmolu: " <>) . T.pack . show)
-                <$> try @OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T.unpack contents))
-          where
-            config =
-                defaultConfig
-                    { cfgDynOptions = fileOpts
-                    , cfgRegion = region
-                    , cfgDebug = True
-                    , cfgPrinterOpts =
-                        fillMissingPrinterOpts
-                            (printerOpts <> lspPrinterOpts)
-                            defaultPrinterOpts
-                    }
+properties :: Properties '[ 'PropertyKey "external" 'TBoolean]
+properties =
+    emptyProperties
+        & defineBooleanProperty
+            #external
+            "Call out to an external \"fourmolu\" executable, rather than using the bundled library"
+            False
 
-    liftIO (loadConfigFile fp') >>= \case
-        ConfigLoaded file opts -> liftIO $ do
-            putStrLn $ "Loaded Fourmolu config from: " <> file
-            format opts
-        ConfigNotFound searchDirs -> liftIO $ do
-            putStrLn
-                . unlines
-                $ ("No " ++ show configFileName ++ " found in any of:") :
-                map ("  " ++) searchDirs
-            format mempty
-        ConfigParseError f (_, err) -> do
-            sendNotification SWindowShowMessage $
-                ShowMessageParams
-                    { _xtype = MtError
-                    , _message = errorMessage
-                    }
-            return . Left $ responseError errorMessage
-          where
-            errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack err
+provider :: PluginId -> FormattingHandler IdeState
+provider plId ideState typ contents fp fo = withIndefiniteProgress title Cancellable $ do
+    fileOpts <-
+        maybe [] (convertDynFlags . hsc_dflags . hscEnv)
+            <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp)
+    useCLI <- usePropertyLsp #external plId properties
+    if useCLI
+        then liftIO
+            . fmap (join . first (mkError . show))
+            . try @IOException
+            $ do
+                (exitCode, out, err) <-
+                    readCreateProcessWithExitCode
+                        ( proc "fourmolu" $
+                            ["-d"]
+                                <> catMaybes
+                                    [ ("--start-line=" <>) . show <$> regionStartLine region
+                                    , ("--end-line=" <>) . show <$> regionEndLine region
+                                    ]
+                                <> map ("-o" <>) fileOpts
+                        ){cwd = Just $ takeDirectory fp'}
+                        contents
+                T.hPutStrLn stderr err
+                case exitCode of
+                    ExitSuccess ->
+                        pure . Right $ makeDiffTextEdit contents out
+                    ExitFailure n ->
+                        pure . Left . responseError $ "Fourmolu failed with exit code " <> T.pack (show n)
+        else do
+            let format printerOpts =
+                    first (mkError . show)
+                        <$> try @OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T.unpack contents))
+                  where
+                    config =
+                        defaultConfig
+                            { cfgDynOptions = map DynOption fileOpts
+                            , cfgRegion = region
+                            , cfgDebug = True
+                            , cfgPrinterOpts =
+                                fillMissingPrinterOpts
+                                    (printerOpts <> lspPrinterOpts)
+                                    defaultPrinterOpts
+                            }
+             in liftIO (loadConfigFile fp') >>= \case
+                    ConfigLoaded file opts -> liftIO $ do
+                        putStrLn $ "Loaded Fourmolu config from: " <> file
+                        format opts
+                    ConfigNotFound searchDirs -> liftIO $ do
+                        putStrLn
+                            . unlines
+                            $ ("No " ++ show configFileName ++ " found in any of:") :
+                            map ("  " ++) searchDirs
+                        format mempty
+                    ConfigParseError f (_, err) -> do
+                        sendNotification SWindowShowMessage $
+                            ShowMessageParams
+                                { _xtype = MtError
+                                , _message = errorMessage
+                                }
+                        return . Left $ responseError errorMessage
+                      where
+                        errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack err
   where
     fp' = fromNormalizedFilePath fp
     title = "Formatting " <> T.pack (takeFileName fp')
+    mkError = responseError . ("Fourmolu: " <>) . T.pack
     lspPrinterOpts = mempty{poIndentation = Just $ fromIntegral $ fo ^. tabSize}
     region = case typ of
         FormatText ->
             RegionIndices Nothing Nothing
         FormatRange (Range (Position sl _) (Position el _)) ->
             RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1)
 
-convertDynFlags :: DynFlags -> IO [DynOption]
+convertDynFlags :: DynFlags -> [String]
 convertDynFlags df =
     let pp = ["-pgmF=" <> p | not (null p)]
         p = sPgm_F $ Compat.settings df
@@ -95,4 +131,4 @@ convertDynFlags df =
         showExtension = \case
             Cpp -> "-XCPP"
             x   -> "-X" ++ show x
-     in return $ map DynOption $ pp <> pm <> ex
+     in pp <> pm <> ex

plugins/hls-fourmolu-plugin/test/Main.hs

@@ -3,6 +3,9 @@ module Main
   ( main
   ) where
 
+import           Data.Aeson
+import           Data.Functor
+import           Ide.Plugin.Config
 import qualified Ide.Plugin.Fourmolu as Fourmolu
 import           Language.LSP.Test
 import           Language.LSP.Types
@@ -16,15 +19,21 @@ fourmoluPlugin :: PluginDescriptor IdeState
 fourmoluPlugin = Fourmolu.descriptor "fourmolu"
 
 tests :: TestTree
-tests = testGroup "fourmolu"
-  [ goldenWithFourmolu "formats correctly" "Fourmolu" "formatted" $ \doc -> do
-      formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
-  , goldenWithFourmolu "formats imports correctly" "Fourmolu" "formatted" $ \doc -> do
-      formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
-  ]
+tests =
+  testGroup "fourmolu" $
+    [False, True] <&> \cli ->
+      testGroup
+        (if cli then "cli" else "lib")
+        [ goldenWithFourmolu cli "formats correctly" "Fourmolu" "formatted" $ \doc -> do
+            formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
+        , goldenWithFourmolu cli "formats imports correctly" "Fourmolu" "formatted" $ \doc -> do
+            formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
+        ]
 
-goldenWithFourmolu :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
-goldenWithFourmolu title path desc = goldenWithHaskellDocFormatter fourmoluPlugin "fourmolu" title testDataDir path desc "hs"
+goldenWithFourmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
+goldenWithFourmolu cli title path desc = goldenWithHaskellDocFormatter fourmoluPlugin "fourmolu" conf title testDataDir path desc "hs"
+ where
+  conf = def{plcConfig = (\(Object obj) -> obj) $ object ["external" .= cli]}
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"

plugins/hls-ormolu-plugin/test/Main.hs

@@ -23,7 +23,7 @@ tests = testGroup "ormolu"
   ]
 
 goldenWithOrmolu :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
-goldenWithOrmolu title path desc = goldenWithHaskellDocFormatter ormoluPlugin "ormolu" title testDataDir path desc "hs"
+goldenWithOrmolu title path desc = goldenWithHaskellDocFormatter ormoluPlugin "ormolu" def title testDataDir path desc "hs"
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"

plugins/hls-stylish-haskell-plugin/test/Main.hs

@@ -22,7 +22,7 @@ tests = testGroup "stylish-haskell"
   ]
 
 goldenWithStylishHaskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
-goldenWithStylishHaskell title fp desc = goldenWithHaskellDocFormatter stylishHaskellPlugin "stylishHaskell" title testDataDir fp desc "hs"
+goldenWithStylishHaskell title fp desc = goldenWithHaskellDocFormatter stylishHaskellPlugin "stylishHaskell" def title testDataDir fp desc "hs"
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"