diff --git a/hls-fourmolu-plugin.cabal b/hls-fourmolu-plugin.cabal --- a/hls-fourmolu-plugin.cabal +++ b/hls-fourmolu-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-fourmolu-plugin -version: 1.0.2.0 +version: 1.0.3.0 synopsis: Integration with the Fourmolu code formatter description: Please see the README on GitHub at @@ -26,10 +26,11 @@ , fourmolu ^>=0.3 || ^>=0.4 || ^>= 0.5 , ghc , ghc-boot-th - , ghcide ^>=1.6 - , hls-plugin-api ^>=1.3 + , ghcide ^>=1.7 + , hls-plugin-api ^>=1.4 , lens , lsp + , process-extras , text default-language: Haskell2010 @@ -40,9 +41,14 @@ 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-test-utils ^>=1.2 + , hls-plugin-api + , hls-test-utils ^>=1.3 , lsp-test diff --git a/src/Ide/Plugin/Fourmolu.hs b/src/Ide/Plugin/Fourmolu.hs --- a/src/Ide/Plugin/Fourmolu.hs +++ b/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 @@ 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 @@ showExtension = \case Cpp -> "-XCPP" x -> "-X" ++ show x - in return $ map DynOption $ pp <> pm <> ex + in pp <> pm <> ex diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,9 @@ ( 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 = 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"