{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} module Ide.Plugin.Fourmolu ( descriptor, provider, ) where 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.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 :: PluginId -> PluginDescriptor IdeState descriptor PluginId plId = (PluginId -> PluginDescriptor IdeState forall ideState. PluginId -> PluginDescriptor ideState defaultPluginDescriptor PluginId plId) { pluginHandlers :: PluginHandlers IdeState pluginHandlers = FormattingHandler IdeState -> PluginHandlers IdeState forall a. FormattingHandler a -> PluginHandlers a mkFormattingHandlers (FormattingHandler IdeState -> PluginHandlers IdeState) -> FormattingHandler IdeState -> PluginHandlers IdeState forall a b. (a -> b) -> a -> b $ PluginId -> FormattingHandler IdeState provider PluginId plId } properties :: Properties '[ 'PropertyKey "external" 'TBoolean] properties :: Properties '[ 'PropertyKey "external" 'TBoolean] properties = Properties '[] emptyProperties Properties '[] -> (Properties '[] -> Properties '[ 'PropertyKey "external" 'TBoolean]) -> Properties '[ 'PropertyKey "external" 'TBoolean] forall a b. a -> (a -> b) -> b & KeyNameProxy "external" -> Text -> Bool -> Properties '[] -> Properties '[ 'PropertyKey "external" 'TBoolean] forall (s :: Symbol) (r :: [PropertyKey]). (KnownSymbol s, NotElem s r) => KeyNameProxy s -> Text -> Bool -> Properties r -> Properties ('PropertyKey s 'TBoolean : r) defineBooleanProperty #external Text "Call out to an external \"fourmolu\" executable, rather than using the bundled library" Bool False provider :: PluginId -> FormattingHandler IdeState provider :: PluginId -> FormattingHandler IdeState provider PluginId plId IdeState ideState FormattingType typ Text contents NormalizedFilePath fp FormattingOptions fo = Text -> ProgressCancellable -> LspT Config IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall c (m :: * -> *) a. MonadLsp c m => Text -> ProgressCancellable -> m a -> m a withIndefiniteProgress Text title ProgressCancellable Cancellable (LspT Config IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit))) -> LspT Config IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ do [String] fileOpts <- [String] -> (HscEnvEq -> [String]) -> Maybe HscEnvEq -> [String] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (DynFlags -> [String] convertDynFlags (DynFlags -> [String]) -> (HscEnvEq -> DynFlags) -> HscEnvEq -> [String] forall b c a. (b -> c) -> (a -> b) -> a -> c . HscEnv -> DynFlags hsc_dflags (HscEnv -> DynFlags) -> (HscEnvEq -> HscEnv) -> HscEnvEq -> DynFlags forall b c a. (b -> c) -> (a -> b) -> a -> c . HscEnvEq -> HscEnv hscEnv) (Maybe HscEnvEq -> [String]) -> LspT Config IO (Maybe HscEnvEq) -> LspT Config IO [String] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO (Maybe HscEnvEq) -> LspT Config IO (Maybe HscEnvEq) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (String -> IdeState -> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq) forall a. String -> IdeState -> Action a -> IO a runAction String "Fourmolu" IdeState ideState (Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq)) -> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq) forall a b. (a -> b) -> a -> b $ GhcSession -> NormalizedFilePath -> Action (Maybe HscEnvEq) forall k v. IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) use GhcSession GhcSession NormalizedFilePath fp) Bool useCLI <- KeyNameProxy "external" -> PluginId -> Properties '[ 'PropertyKey "external" 'TBoolean] -> LspT Config IO (ToHsType 'TBoolean) forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType) (r :: [PropertyKey]) (m :: * -> *). (HasProperty s k t r, MonadLsp Config m) => KeyNameProxy s -> PluginId -> Properties r -> m (ToHsType t) usePropertyLsp IsLabel "external" (KeyNameProxy "external") KeyNameProxy "external" #external PluginId plId Properties '[ 'PropertyKey "external" 'TBoolean] properties if Bool useCLI then IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit))) -> (IO (Either ResponseError (List TextEdit)) -> IO (Either ResponseError (List TextEdit))) -> IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Either IOException (Either ResponseError (List TextEdit)) -> Either ResponseError (List TextEdit)) -> IO (Either IOException (Either ResponseError (List TextEdit))) -> IO (Either ResponseError (List TextEdit)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Either ResponseError (Either ResponseError (List TextEdit)) -> Either ResponseError (List TextEdit) forall (m :: * -> *) a. Monad m => m (m a) -> m a join (Either ResponseError (Either ResponseError (List TextEdit)) -> Either ResponseError (List TextEdit)) -> (Either IOException (Either ResponseError (List TextEdit)) -> Either ResponseError (Either ResponseError (List TextEdit))) -> Either IOException (Either ResponseError (List TextEdit)) -> Either ResponseError (List TextEdit) forall b c a. (b -> c) -> (a -> b) -> a -> c . (IOException -> ResponseError) -> Either IOException (Either ResponseError (List TextEdit)) -> Either ResponseError (Either ResponseError (List TextEdit)) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (String -> ResponseError mkError (String -> ResponseError) -> (IOException -> String) -> IOException -> ResponseError forall b c a. (b -> c) -> (a -> b) -> a -> c . IOException -> String forall a. Show a => a -> String show)) (IO (Either IOException (Either ResponseError (List TextEdit))) -> IO (Either ResponseError (List TextEdit))) -> (IO (Either ResponseError (List TextEdit)) -> IO (Either IOException (Either ResponseError (List TextEdit)))) -> IO (Either ResponseError (List TextEdit)) -> IO (Either ResponseError (List TextEdit)) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Exception IOException => IO a -> IO (Either IOException a) forall e a. Exception e => IO a -> IO (Either e a) try @IOException (IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit))) -> IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ do (ExitCode exitCode, Text out, Text err) <- CreateProcess -> Text -> IO (ExitCode, Text, Text) readCreateProcessWithExitCode ( String -> [String] -> CreateProcess proc String "fourmolu" ([String] -> CreateProcess) -> [String] -> CreateProcess forall a b. (a -> b) -> a -> b $ [String "-d"] [String] -> [String] -> [String] forall a. Semigroup a => a -> a -> a <> [Maybe String] -> [String] forall a. [Maybe a] -> [a] catMaybes [ (String "--start-line=" String -> String -> String forall a. Semigroup a => a -> a -> a <>) (String -> String) -> (Int -> String) -> Int -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> String forall a. Show a => a -> String show (Int -> String) -> Maybe Int -> Maybe String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RegionIndices -> Maybe Int regionStartLine RegionIndices region , (String "--end-line=" String -> String -> String forall a. Semigroup a => a -> a -> a <>) (String -> String) -> (Int -> String) -> Int -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> String forall a. Show a => a -> String show (Int -> String) -> Maybe Int -> Maybe String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RegionIndices -> Maybe Int regionEndLine RegionIndices region ] [String] -> [String] -> [String] forall a. Semigroup a => a -> a -> a <> (String -> String) -> [String] -> [String] forall a b. (a -> b) -> [a] -> [b] map (String "-o" String -> String -> String forall a. Semigroup a => a -> a -> a <>) [String] fileOpts ){cwd :: Maybe String cwd = String -> Maybe String forall a. a -> Maybe a Just (String -> Maybe String) -> String -> Maybe String forall a b. (a -> b) -> a -> b $ String -> String takeDirectory String fp'} Text contents Handle -> Text -> IO () T.hPutStrLn Handle stderr Text err case ExitCode exitCode of ExitCode ExitSuccess -> Either ResponseError (List TextEdit) -> IO (Either ResponseError (List TextEdit)) forall (f :: * -> *) a. Applicative f => a -> f a pure (Either ResponseError (List TextEdit) -> IO (Either ResponseError (List TextEdit))) -> (List TextEdit -> Either ResponseError (List TextEdit)) -> List TextEdit -> IO (Either ResponseError (List TextEdit)) forall b c a. (b -> c) -> (a -> b) -> a -> c . List TextEdit -> Either ResponseError (List TextEdit) forall a b. b -> Either a b Right (List TextEdit -> IO (Either ResponseError (List TextEdit))) -> List TextEdit -> IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ Text -> Text -> List TextEdit makeDiffTextEdit Text contents Text out ExitFailure Int n -> Either ResponseError (List TextEdit) -> IO (Either ResponseError (List TextEdit)) forall (f :: * -> *) a. Applicative f => a -> f a pure (Either ResponseError (List TextEdit) -> IO (Either ResponseError (List TextEdit))) -> (Text -> Either ResponseError (List TextEdit)) -> Text -> IO (Either ResponseError (List TextEdit)) forall b c a. (b -> c) -> (a -> b) -> a -> c . ResponseError -> Either ResponseError (List TextEdit) forall a b. a -> Either a b Left (ResponseError -> Either ResponseError (List TextEdit)) -> (Text -> ResponseError) -> Text -> Either ResponseError (List TextEdit) forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> ResponseError responseError (Text -> IO (Either ResponseError (List TextEdit))) -> Text -> IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ Text "Fourmolu failed with exit code " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text T.pack (Int -> String forall a. Show a => a -> String show Int n) else do let format :: PrinterOpts Maybe -> IO (Either ResponseError (List TextEdit)) format PrinterOpts Maybe printerOpts = (OrmoluException -> ResponseError) -> Either OrmoluException (List TextEdit) -> Either ResponseError (List TextEdit) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (String -> ResponseError mkError (String -> ResponseError) -> (OrmoluException -> String) -> OrmoluException -> ResponseError forall b c a. (b -> c) -> (a -> b) -> a -> c . OrmoluException -> String forall a. Show a => a -> String show) (Either OrmoluException (List TextEdit) -> Either ResponseError (List TextEdit)) -> IO (Either OrmoluException (List TextEdit)) -> IO (Either ResponseError (List TextEdit)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO (List TextEdit) -> IO (Either OrmoluException (List TextEdit)) forall e a. Exception e => IO a -> IO (Either e a) try @OrmoluException (Text -> Text -> List TextEdit makeDiffTextEdit Text contents (Text -> List TextEdit) -> IO Text -> IO (List TextEdit) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Config RegionIndices -> String -> String -> IO Text forall (m :: * -> *). MonadIO m => Config RegionIndices -> String -> String -> m Text ormolu Config RegionIndices config String fp' (Text -> String T.unpack Text contents)) where config :: Config RegionIndices config = Config RegionIndices defaultConfig { cfgDynOptions :: [DynOption] cfgDynOptions = (String -> DynOption) -> [String] -> [DynOption] forall a b. (a -> b) -> [a] -> [b] map String -> DynOption DynOption [String] fileOpts , cfgRegion :: RegionIndices cfgRegion = RegionIndices region , cfgDebug :: Bool cfgDebug = Bool True , cfgPrinterOpts :: PrinterOptsTotal cfgPrinterOpts = PrinterOpts Maybe -> PrinterOptsTotal -> PrinterOptsTotal forall (f :: * -> *). Applicative f => PrinterOpts Maybe -> PrinterOpts f -> PrinterOpts f fillMissingPrinterOpts (PrinterOpts Maybe printerOpts PrinterOpts Maybe -> PrinterOpts Maybe -> PrinterOpts Maybe forall a. Semigroup a => a -> a -> a <> PrinterOpts Maybe lspPrinterOpts) PrinterOptsTotal defaultPrinterOpts } in IO ConfigFileLoadResult -> LspT Config IO ConfigFileLoadResult forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (String -> IO ConfigFileLoadResult loadConfigFile String fp') LspT Config IO ConfigFileLoadResult -> (ConfigFileLoadResult -> LspT Config IO (Either ResponseError (List TextEdit))) -> LspT Config IO (Either ResponseError (List TextEdit)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case ConfigLoaded String file PrinterOpts Maybe opts -> IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit))) -> IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ do String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "Loaded Fourmolu config from: " String -> String -> String forall a. Semigroup a => a -> a -> a <> String file PrinterOpts Maybe -> IO (Either ResponseError (List TextEdit)) format PrinterOpts Maybe opts ConfigNotFound [String] searchDirs -> IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit))) -> IO (Either ResponseError (List TextEdit)) -> LspT Config IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ do String -> IO () putStrLn (String -> IO ()) -> ([String] -> String) -> [String] -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . [String] -> String unlines ([String] -> IO ()) -> [String] -> IO () forall a b. (a -> b) -> a -> b $ (String "No " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String configFileName String -> String -> String forall a. [a] -> [a] -> [a] ++ String " found in any of:") String -> [String] -> [String] forall a. a -> [a] -> [a] : (String -> String) -> [String] -> [String] forall a b. (a -> b) -> [a] -> [b] map (String " " String -> String -> String forall a. [a] -> [a] -> [a] ++) [String] searchDirs PrinterOpts Maybe -> IO (Either ResponseError (List TextEdit)) format PrinterOpts Maybe forall a. Monoid a => a mempty ConfigParseError String f (Pos _, String err) -> do SServerMethod 'WindowShowMessage -> MessageParams 'WindowShowMessage -> LspT Config IO () forall (m :: Method 'FromServer 'Notification) (f :: * -> *) config. MonadLsp config f => SServerMethod m -> MessageParams m -> f () sendNotification SServerMethod 'WindowShowMessage SWindowShowMessage (MessageParams 'WindowShowMessage -> LspT Config IO ()) -> MessageParams 'WindowShowMessage -> LspT Config IO () forall a b. (a -> b) -> a -> b $ ShowMessageParams :: MessageType -> Text -> ShowMessageParams ShowMessageParams { $sel:_xtype:ShowMessageParams :: MessageType _xtype = MessageType MtError , $sel:_message:ShowMessageParams :: Text _message = Text errorMessage } Either ResponseError (List TextEdit) -> LspT Config IO (Either ResponseError (List TextEdit)) forall (m :: * -> *) a. Monad m => a -> m a return (Either ResponseError (List TextEdit) -> LspT Config IO (Either ResponseError (List TextEdit))) -> (ResponseError -> Either ResponseError (List TextEdit)) -> ResponseError -> LspT Config IO (Either ResponseError (List TextEdit)) forall b c a. (b -> c) -> (a -> b) -> a -> c . ResponseError -> Either ResponseError (List TextEdit) forall a b. a -> Either a b Left (ResponseError -> LspT Config IO (Either ResponseError (List TextEdit))) -> ResponseError -> LspT Config IO (Either ResponseError (List TextEdit)) forall a b. (a -> b) -> a -> b $ Text -> ResponseError responseError Text errorMessage where errorMessage :: Text errorMessage = Text "Failed to load " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text T.pack String f Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ": " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text T.pack String err where fp' :: String fp' = NormalizedFilePath -> String fromNormalizedFilePath NormalizedFilePath fp title :: Text title = Text "Formatting " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text T.pack (String -> String takeFileName String fp') mkError :: String -> ResponseError mkError = Text -> ResponseError responseError (Text -> ResponseError) -> (String -> Text) -> String -> ResponseError forall b c a. (b -> c) -> (a -> b) -> a -> c . (Text "Fourmolu: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <>) (Text -> Text) -> (String -> Text) -> String -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Text T.pack lspPrinterOpts :: PrinterOpts Maybe lspPrinterOpts = PrinterOpts Maybe forall a. Monoid a => a mempty{poIndentation :: Maybe Int poIndentation = Int -> Maybe Int forall a. a -> Maybe a Just (Int -> Maybe Int) -> Int -> Maybe Int forall a b. (a -> b) -> a -> b $ UInt -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UInt -> Int) -> UInt -> Int forall a b. (a -> b) -> a -> b $ FormattingOptions fo FormattingOptions -> Getting UInt FormattingOptions UInt -> UInt forall s a. s -> Getting a s a -> a ^. Getting UInt FormattingOptions UInt forall s a. HasTabSize s a => Lens' s a tabSize} region :: RegionIndices region = case FormattingType typ of FormattingType FormatText -> Maybe Int -> Maybe Int -> RegionIndices RegionIndices Maybe Int forall a. Maybe a Nothing Maybe Int forall a. Maybe a Nothing FormatRange (Range (Position UInt sl UInt _) (Position UInt el UInt _)) -> Maybe Int -> Maybe Int -> RegionIndices RegionIndices (Int -> Maybe Int forall a. a -> Maybe a Just (Int -> Maybe Int) -> Int -> Maybe Int forall a b. (a -> b) -> a -> b $ UInt -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UInt -> Int) -> UInt -> Int forall a b. (a -> b) -> a -> b $ UInt sl UInt -> UInt -> UInt forall a. Num a => a -> a -> a + UInt 1) (Int -> Maybe Int forall a. a -> Maybe a Just (Int -> Maybe Int) -> Int -> Maybe Int forall a b. (a -> b) -> a -> b $ UInt -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UInt -> Int) -> UInt -> Int forall a b. (a -> b) -> a -> b $ UInt el UInt -> UInt -> UInt forall a. Num a => a -> a -> a + UInt 1) convertDynFlags :: DynFlags -> [String] convertDynFlags :: DynFlags -> [String] convertDynFlags DynFlags df = let pp :: [String] pp = [String "-pgmF=" String -> String -> String forall a. Semigroup a => a -> a -> a <> String p | Bool -> Bool not (String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String p)] p :: String p = Settings -> String sPgm_F (Settings -> String) -> Settings -> String forall a b. (a -> b) -> a -> b $ DynFlags -> Settings Compat.settings DynFlags df pm :: [String] pm = (ModuleName -> String) -> [ModuleName] -> [String] forall a b. (a -> b) -> [a] -> [b] map ((String "-fplugin=" String -> String -> String forall a. Semigroup a => a -> a -> a <>) (String -> String) -> (ModuleName -> String) -> ModuleName -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . ModuleName -> String moduleNameString) ([ModuleName] -> [String]) -> [ModuleName] -> [String] forall a b. (a -> b) -> a -> b $ DynFlags -> [ModuleName] pluginModNames DynFlags df ex :: [String] ex = (Extension -> String) -> [Extension] -> [String] forall a b. (a -> b) -> [a] -> [b] map Extension -> String showExtension ([Extension] -> [String]) -> [Extension] -> [String] forall a b. (a -> b) -> a -> b $ EnumSet Extension -> [Extension] forall a. Enum a => EnumSet a -> [a] S.toList (EnumSet Extension -> [Extension]) -> EnumSet Extension -> [Extension] forall a b. (a -> b) -> a -> b $ DynFlags -> EnumSet Extension extensionFlags DynFlags df showExtension :: Extension -> String showExtension = \case Extension Cpp -> String "-XCPP" Extension x -> String "-X" String -> String -> String forall a. [a] -> [a] -> [a] ++ Extension -> String forall a. Show a => a -> String show Extension x in [String] pp [String] -> [String] -> [String] forall a. Semigroup a => a -> a -> a <> [String] pm [String] -> [String] -> [String] forall a. Semigroup a => a -> a -> a <> [String] ex