22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE TypeApplications #-}
5+ {-# LANGUAGE DataKinds #-}
6+ {-# LANGUAGE OverloadedLabels #-}
57
68module Ide.Plugin.Fourmolu (
79 descriptor ,
810 provider ,
911) where
1012
11- import Control.Exception (try )
13+ import Control.Exception (IOException , try )
1214import Control.Lens ((^.) )
15+ import Control.Monad
1316import Control.Monad.IO.Class
1417import Data.Bifunctor (first )
18+ import Data.Maybe
1519import qualified Data.Text as T
20+ import qualified Data.Text.IO as T
1621import Development.IDE hiding (pluginHandlers )
1722import Development.IDE.GHC.Compat as Compat hiding (Cpp )
1823import qualified Development.IDE.GHC.Compat.Util as S
1924import GHC.LanguageExtensions.Type (Extension (Cpp ))
20- import Ide.PluginUtils (makeDiffTextEdit )
25+ import Ide.Plugin.Properties
26+ import Ide.PluginUtils (makeDiffTextEdit , usePropertyLsp )
2127import Ide.Types
2228import Language.LSP.Server hiding (defaultConfig )
2329import Language.LSP.Types
2430import Language.LSP.Types.Lens (HasTabSize (tabSize ))
2531import Ormolu
32+ import System.Exit
2633import System.FilePath
27-
28- -- ---------------------------------------------------------------------
34+ import System.IO (stderr )
35+ import System.Process.Run (proc , cwd )
36+ import System.Process.Text (readCreateProcessWithExitCode )
2937
3038descriptor :: PluginId -> PluginDescriptor IdeState
3139descriptor plId =
3240 (defaultPluginDescriptor plId)
33- { pluginHandlers = mkFormattingHandlers provider
41+ { pluginHandlers = mkFormattingHandlers $ provider plId
3442 }
3543
36- -- ---------------------------------------------------------------------
37-
38- provider :: FormattingHandler IdeState
39- provider ideState typ contents fp fo = withIndefiniteProgress title Cancellable $ do
40- ghc <- liftIO $ runAction " Fourmolu" $ use GhcSession fp
41- fileOpts <- case hsc_dflags . hscEnv <$> ghc of
42- Nothing -> return []
43- Just df -> liftIO $ convertDynFlags df
44-
45- let format printerOpts =
46- first (responseError . (" Fourmolu: " <> ) . T. pack . show )
47- <$> try @ OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T. unpack contents))
48- where
49- config =
50- defaultConfig
51- { cfgDynOptions = fileOpts
52- , cfgRegion = region
53- , cfgDebug = True
54- , cfgPrinterOpts =
55- fillMissingPrinterOpts
56- (printerOpts <> lspPrinterOpts)
57- defaultPrinterOpts
58- }
44+ properties :: Properties '[ 'PropertyKey " external"
45+ properties =
46+ emptyProperties
47+ & defineBooleanProperty
48+ # external
49+ " Call out to an external \" fourmolu\" executable, rather than using the bundled library"
50+ False
5951
60- liftIO (loadConfigFile fp') >>= \ case
61- ConfigLoaded file opts -> liftIO $ do
62- putStrLn $ " Loaded Fourmolu config from: " <> file
63- format opts
64- ConfigNotFound searchDirs -> liftIO $ do
65- putStrLn
66- . unlines
67- $ (" No " ++ show configFileName ++ " found in any of:" :
68- map (" " ++ ) searchDirs
69- format mempty
70- ConfigParseError f (_, err) -> do
71- sendNotification SWindowShowMessage $
72- ShowMessageParams
73- { _xtype = MtError
74- , _message = errorMessage
75- }
76- return . Left $ responseError errorMessage
77- where
78- errorMessage = " Failed to load " <> T. pack f <> " : " <> T. pack err
52+ provider :: PluginId -> FormattingHandler IdeState
53+ provider plId ideState typ contents fp fo = withIndefiniteProgress title Cancellable $ do
54+ fileOpts <-
55+ maybe [] (convertDynFlags . hsc_dflags . hscEnv)
56+ <$> liftIO (runAction " Fourmolu" $ use GhcSession fp)
57+ useCLI <- usePropertyLsp # external plId properties
58+ if useCLI
59+ then liftIO
60+ . fmap (join . first (mkError . show ))
61+ . try @ IOException
62+ $ do
63+ (exitCode, out, err) <-
64+ readCreateProcessWithExitCode
65+ ( proc " fourmolu" $
66+ [" -d"
67+ <> catMaybes
68+ [ (" --start-line=" <> ) . show <$> regionStartLine region
69+ , (" --end-line=" <> ) . show <$> regionEndLine region
70+ ]
71+ <> map (" -o" <> ) fileOpts
72+ ){cwd = Just $ takeDirectory fp'}
73+ contents
74+ T. hPutStrLn stderr err
75+ case exitCode of
76+ ExitSuccess ->
77+ pure . Right $ makeDiffTextEdit contents out
78+ ExitFailure n ->
79+ pure . Left . responseError $ " Fourmolu failed with exit code " <> T. pack (show n)
80+ else do
81+ let format printerOpts =
82+ first (mkError . show )
83+ <$> try @ OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T. unpack contents))
84+ where
85+ config =
86+ defaultConfig
87+ { cfgDynOptions = map DynOption fileOpts
88+ , cfgRegion = region
89+ , cfgDebug = True
90+ , cfgPrinterOpts =
91+ fillMissingPrinterOpts
92+ (printerOpts <> lspPrinterOpts)
93+ defaultPrinterOpts
94+ }
95+ in liftIO (loadConfigFile fp') >>= \ case
96+ ConfigLoaded file opts -> liftIO $ do
97+ putStrLn $ " Loaded Fourmolu config from: " <> file
98+ format opts
99+ ConfigNotFound searchDirs -> liftIO $ do
100+ putStrLn
101+ . unlines
102+ $ (" No " ++ show configFileName ++ " found in any of:" :
103+ map (" " ++ ) searchDirs
104+ format mempty
105+ ConfigParseError f (_, err) -> do
106+ sendNotification SWindowShowMessage $
107+ ShowMessageParams
108+ { _xtype = MtError
109+ , _message = errorMessage
110+ }
111+ return . Left $ responseError errorMessage
112+ where
113+ errorMessage = " Failed to load " <> T. pack f <> " : " <> T. pack err
79114 where
80115 fp' = fromNormalizedFilePath fp
81116 title = " Formatting " <> T. pack (takeFileName fp')
117+ mkError = responseError . (" Fourmolu: " <> ) . T. pack
82118 lspPrinterOpts = mempty {poIndentation = Just $ fromIntegral $ fo ^. tabSize}
83119 region = case typ of
84120 FormatText ->
85121 RegionIndices Nothing Nothing
86122 FormatRange (Range (Position sl _) (Position el _)) ->
87123 RegionIndices (Just $ fromIntegral $ sl + 1 ) (Just $ fromIntegral $ el + 1 )
88124
89- convertDynFlags :: DynFlags -> IO [ DynOption ]
125+ convertDynFlags :: DynFlags -> [ String
90126convertDynFlags df =
91127 let pp = [" -pgmF=" <> p | not (null p)]
92128 p = sPgm_F $ Compat. settings df
@@ -95,4 +131,4 @@ convertDynFlags df =
95131 showExtension = \ case
96132 Cpp -> " -XCPP"
97133 x -> " -X" ++ show x
98- in return $ map DynOption $ pp <> pm <> ex
134+ in pp <> pm <> ex
0 commit comments