diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index e3459e0560..227bec3e06 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/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,6 +132,7 @@ goldenWithHaskellDoc plugin title testDataDir path desc ext act = goldenWithHaskellDocFormatter :: PluginDescriptor IdeState -> String + -> PluginConfig -> TestName -> FilePath -> FilePath @@ -138,9 +140,9 @@ goldenWithHaskellDocFormatter -> 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 diff --git a/plugins/hls-brittany-plugin/test/Main.hs b/plugins/hls-brittany-plugin/test/Main.hs index 2a4ef9f7d4..a7a840d7c3 100644 --- a/plugins/hls-brittany-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-floskell-plugin/test/Main.hs b/plugins/hls-floskell-plugin/test/Main.hs index e63aee2f2e..155291eec4 100644 --- a/plugins/hls-floskell-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal index 5b47bc7b4d..df2639a8d2 100644 --- a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal +++ b/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 diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 6f8a32553a..ea19ddf8f5 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -2,83 +2,119 @@ {-# 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 -> @@ -86,7 +122,7 @@ provider ideState typ contents fp fo = withIndefiniteProgress title Cancellable 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 diff --git a/plugins/hls-fourmolu-plugin/test/Main.hs b/plugins/hls-fourmolu-plugin/test/Main.hs index a33b505790..f339d716bc 100644 --- a/plugins/hls-fourmolu-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-ormolu-plugin/test/Main.hs b/plugins/hls-ormolu-plugin/test/Main.hs index d42cc7fb91..bc637bd4dc 100644 --- a/plugins/hls-ormolu-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-stylish-haskell-plugin/test/Main.hs b/plugins/hls-stylish-haskell-plugin/test/Main.hs index d8cc09157f..236b705c42 100644 --- a/plugins/hls-stylish-haskell-plugin/test/Main.hs +++ b/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"