diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index ff7633afe..8de813064 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} @@ -212,16 +211,24 @@ type SymbolProvider = Uri -> IdeDeferM (IdeResult [DocumentSymbol]) data FormattingType = FormatDocument | FormatRange Range --- | Formats the given Uri with the given options. +-- | Formats the given Text associated with the given Uri. +-- Should, but might not, honor the provided formatting options (e.g. Floskell does not). -- A formatting type can be given to either format the whole document or only a Range. +-- +-- Text to format, may or may not, originate from the associated Uri. +-- E.g. it is ok, to modify the text and then reformat it through this API. +-- +-- The Uri is mainly used to discover formatting configurations in the file's path. +-- -- Fails if the formatter can not parse the source. --- Failing menas here that a IdeResultFail is returned. +-- Failing means here that a IdeResultFail is returned. -- This can be used to display errors to the user, unless the error is an Internal one. -- The record 'IdeError' and 'IdeErrorCode' can be used to determine the type of error. -type FormattingProvider = Uri -- ^ Uri to the file to format. Can be mapped to a file with `pluginGetFile` +type FormattingProvider = T.Text -- ^ Text to format + -> Uri -- ^ Uri of the file being formatted -> FormattingType -- ^ How much to format -> FormattingOptions -- ^ Options for the formatter - -> IdeDeferM (IdeResult [TextEdit]) -- ^ Result of the formatting or the unchanged text. + -> IdeM (IdeResult [TextEdit]) -- ^ Result of the formatting or the unchanged text. data PluginDescriptor = PluginDescriptor { pluginId :: PluginId @@ -272,7 +279,7 @@ runPluginCommand p com arg = do case Map.lookup p m of Nothing -> return $ IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null - Just (PluginDescriptor { pluginCommands = xs }) -> case List.find ((com ==) . commandName) xs of + Just PluginDescriptor { pluginCommands = xs } -> case List.find ((com ==) . commandName) xs of Nothing -> return $ IdeResultFail $ IdeError UnknownCommand ("Command " <> com <> " isn't defined for plugin " <> p <> ". Legal commands are: " <> T.pack(show $ map commandName xs)) Null Just (PluginCommand _ _ (CmdSync f)) -> case fromJSON arg of diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index c96ffa00e..acdb382db 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -40,6 +40,8 @@ data REnv = REnv , hoverProviders :: [HoverProvider] , symbolProviders :: [SymbolProvider] , formattingProviders :: Map.Map PluginId FormattingProvider + -- | Ide Plugins that are available + , idePlugins :: IdePlugins -- TODO: Add code action providers here } @@ -61,11 +63,12 @@ runReactor -> [HoverProvider] -> [SymbolProvider] -> Map.Map PluginId FormattingProvider + -> IdePlugins -> R a -> IO a -runReactor lf sc dps hps sps fps f = do +runReactor lf sc dps hps sps fps plugins f = do pid <- getProcessID - runReaderT f (REnv sc lf pid dps hps sps fps) + runReaderT f (REnv sc lf pid dps hps sps fps plugins) -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/Brittany.hs b/src/Haskell/Ide/Engine/Plugin/Brittany.hs index 83a74b527..c5c180132 100644 --- a/src/Haskell/Ide/Engine/Plugin/Brittany.hs +++ b/src/Haskell/Ide/Engine/Plugin/Brittany.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Haskell.Ide.Engine.Plugin.Brittany where @@ -11,7 +9,6 @@ import Data.Coerce import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T -import GHC.Generics import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginUtils import Language.Haskell.Brittany @@ -20,52 +17,62 @@ import qualified Language.Haskell.LSP.Types.Lens as J import System.FilePath (FilePath, takeDirectory) import Data.Maybe (maybeToList) -data FormatParams = FormatParams Int Uri (Maybe Range) - deriving (Eq, Show, Generic, FromJSON, ToJSON) - brittanyDescriptor :: PluginId -> PluginDescriptor brittanyDescriptor plId = PluginDescriptor - { pluginId = plId - , pluginName = "Brittany" - , pluginDesc = "Brittany is a tool to format source code." - , pluginCommands = [] + { pluginId = plId + , pluginName = "Brittany" + , pluginDesc = "Brittany is a tool to format source code." + , pluginCommands = [] , pluginCodeActionProvider = Nothing , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Nothing - , pluginSymbolProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolProvider = Nothing , pluginFormattingProvider = Just provider } -- | Formatter provider of Brittany. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingProvider -provider uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \file -> do - confFile <- liftIO $ getConfFile file - mtext <- readVFS uri - case mtext of - Nothing -> return $ IdeResultFail (IdeError InternalError "File was not open" Null) - Just text -> case formatType of - FormatRange r -> do - res <- liftIO $ runBrittany tabSize confFile $ extractRange r text - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Null) - Right newText -> do - let textEdit = J.TextEdit (normalize r) newText - return $ IdeResultOk [textEdit] - FormatDocument -> do - res <- liftIO $ runBrittany tabSize confFile text - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Null) - Right newText -> - return $ IdeResultOk [J.TextEdit (fullRange text) newText] +provider + :: MonadIO m + => Text + -> Uri + -> FormattingType + -> FormattingOptions + -> m (IdeResult [TextEdit]) +provider text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do + confFile <- liftIO $ getConfFile fp + let (range, selectedContents) = case formatType of + FormatDocument -> (fullRange text, text) + FormatRange r -> (normalize r, extractRange r text) + + res <- formatText confFile opts selectedContents + case res of + Left err -> return $ IdeResultFail + (IdeError PluginError + (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) + Null + ) + Right newText -> do + let textEdit = J.TextEdit range newText + return $ IdeResultOk [textEdit] + +-- | Primitive to format text with the given option. +-- May not throw exceptions but return a Left value. +-- Errors may be presented to the user. +formatText + :: MonadIO m + => Maybe FilePath -- ^ Path to configs. If Nothing, default configs will be used. + -> FormattingOptions -- ^ Options for the formatter such as indentation. + -> Text -- ^ Text to format + -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany. +formatText confFile opts text = + liftIO $ runBrittany tabSize confFile text where tabSize = opts ^. J.tabSize +-- | Extend to the line below to replace newline character, as above. normalize :: Range -> Range normalize (Range (Position sl _) (Position el _)) = - -- Extend to the line below to replace newline character, as above Range (Position sl 0) (Position (el + 1) 0) -- | Recursively search in every directory of the given filepath for brittany.yaml diff --git a/src/Haskell/Ide/Engine/Plugin/Floskell.hs b/src/Haskell/Ide/Engine/Plugin/Floskell.hs index e66843ad4..796bb22e9 100644 --- a/src/Haskell/Ide/Engine/Plugin/Floskell.hs +++ b/src/Haskell/Ide/Engine/Plugin/Floskell.hs @@ -31,20 +31,16 @@ floskellDescriptor plId = PluginDescriptor -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. provider :: FormattingProvider -provider uri typ _opts = +provider contents uri typ _opts = pluginGetFile "Floskell: " uri $ \file -> do config <- liftIO $ findConfigOrDefault file - mContents <- readVFS uri - case mContents of - Nothing -> return $ IdeResultFail (IdeError InternalError "File was not open" Null) - Just contents -> - let (range, selectedContents) = case typ of - FormatDocument -> (fullRange contents, contents) - FormatRange r -> (r, extractRange r contents) - result = reformat config (uriToFilePath uri) (BS.fromStrict (T.encodeUtf8 selectedContents)) - in case result of - Left err -> return $ IdeResultFail (IdeError PluginError (T.pack err) Null) - Right new -> return $ IdeResultOk [TextEdit range (T.decodeUtf8 (BS.toStrict new))] + let (range, selectedContents) = case typ of + FormatDocument -> (fullRange contents, contents) + FormatRange r -> (r, extractRange r contents) + result = reformat config (uriToFilePath uri) (BS.fromStrict (T.encodeUtf8 selectedContents)) + case result of + Left err -> return $ IdeResultFail (IdeError PluginError (T.pack $ "floskellCmd: " ++ err) Null) + Right new -> return $ IdeResultOk [TextEdit range (T.decodeUtf8 (BS.toStrict new))] -- | Find Floskell Config, user and system wide or provides a default style. -- Every directory of the filepath will be searched to find a user configuration. diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 62636debe..29c318c95 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -10,7 +10,6 @@ import Control.Monad import Data.Aeson import Data.Bitraversable import Data.Bifunctor -import Data.Either import Data.Foldable import Data.Maybe import Data.Monoid ( (<>) ) @@ -21,11 +20,10 @@ import qualified GhcMod.Utils as GM import HsImport import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.MonadTypes +import qualified Haskell.Ide.Engine.Support.HieExtras as Hie import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J import Haskell.Ide.Engine.PluginUtils -import qualified Haskell.Ide.Engine.Plugin.Brittany - as Brittany import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle import System.Directory @@ -54,12 +52,10 @@ importCmd :: CommandFunc ImportParams J.WorkspaceEdit importCmd = CmdSync $ \(ImportParams uri modName) -> importModule uri modName importModule :: Uri -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit) -importModule uri modName = - pluginGetFile "hsimport cmd: " uri $ \origInput -> do - +importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do shouldFormat <- formatOnImportOn <$> getConfig - fileMap <- GM.mkRevRedirMapFunc + fileMap <- GM.mkRevRedirMapFunc GM.withMappedFile origInput $ \input -> do tmpDir <- liftIO getTemporaryDirectory @@ -79,25 +75,40 @@ importModule uri modName = Nothing -> do newText <- liftIO $ T.readFile output liftIO $ removeFile output - J.WorkspaceEdit mChanges mDocChanges <- liftToGhc $ makeDiffResult input newText fileMap + J.WorkspaceEdit mChanges mDocChanges <- liftToGhc + $ makeDiffResult input newText fileMap if shouldFormat then do - -- Format the import with Brittany - confFile <- liftIO $ Brittany.getConfFile origInput - newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) - newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do - ftes <- forM tes (formatTextEdit confFile) - return (J.TextDocumentEdit vDocId ftes) - - return $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) - else - return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) - - where formatTextEdit confFile (J.TextEdit r t) = do - -- TODO: This tab size of 2 spaces should probably be taken from a config - ft <- fromRight t <$> liftIO (Brittany.runBrittany 2 confFile t) - return (J.TextEdit r ft) + config <- getConfig + plugins <- getPlugins + let mprovider = Hie.getFormattingPlugin config plugins + case mprovider of + Nothing -> + return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) + + Just (_, provider) -> do + let formatEdit :: J.TextEdit -> IdeGhcM J.TextEdit + formatEdit origEdit@(J.TextEdit _ t) = do + -- TODO: are these default FormattingOptions ok? + res <- liftToGhc $ provider t uri FormatDocument (FormattingOptions 2 True) + let formatEdits = case res of + IdeResultOk xs -> xs + _ -> [] + return $ foldl' J.editTextEdit origEdit formatEdits + + -- behold: the legendary triple mapM + newChanges <- (mapM . mapM . mapM) formatEdit mChanges + + newDocChanges <- forM mDocChanges $ \change -> do + let cmd (J.TextDocumentEdit vids edits) = do + newEdits <- mapM formatEdit edits + return $ J.TextDocumentEdit vids newEdits + mapM cmd change + + return + $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) + else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) codeActionProvider :: CodeActionProvider codeActionProvider plId docId _ context = do diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index c4807f126..f890ba905 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -22,6 +22,7 @@ module Haskell.Ide.Engine.Support.HieExtras , runGhcModCommand , splitCaseCmd' , splitCaseCmd + , getFormattingPlugin ) where import ConLike @@ -55,6 +56,7 @@ import qualified GhcMod.Gap as GM import qualified GhcMod.LightGhc as GM import qualified GhcMod.Utils as GM import Haskell.Ide.Engine.ArtifactMap +import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.Context import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes @@ -799,3 +801,12 @@ prefixes = , "$c" , "$m" ] + +-- --------------------------------------------------------------------- + +getFormattingPlugin :: Config -> IdePlugins -> Maybe (PluginDescriptor, FormattingProvider) +getFormattingPlugin config plugins = do + let providerName = formattingProvider config + fmtPlugin <- Map.lookup providerName (ipMap plugins) + fmtProvider <- pluginFormattingProvider fmtPlugin + return (fmtPlugin, fmtProvider) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 062c9d390..3ef4d3819 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -122,7 +122,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do let dp lf = do diagIn <- atomically newTChan - let react = runReactor lf scheduler diagnosticProviders hps sps fps + let react = runReactor lf scheduler diagnosticProviders hps sps fps plugins reactorFunc = react $ reactor rin diagIn let errorHandler :: Scheduler.ErrorHandler @@ -734,9 +734,10 @@ reactor inp diagIn = do provider <- getFormattingProvider let params = req ^. J.params doc = params ^. J.textDocument . J.uri - callback = reactorSend . RspDocumentFormatting . Core.makeResponseMessage req . J.List - hreq = IReq tn (req ^. J.id) callback $ provider doc FormatDocument (params ^. J.options) - makeRequest hreq + withDocumentContents (req ^. J.id) doc $ \text -> + let callback = reactorSend . RspDocumentFormatting . Core.makeResponseMessage req . J.List + hreq = IReq tn (req ^. J.id) callback $ lift $ provider text doc FormatDocument (params ^. J.options) + in makeRequest hreq -- ------------------------------- @@ -745,10 +746,11 @@ reactor inp diagIn = do provider <- getFormattingProvider let params = req ^. J.params doc = params ^. J.textDocument . J.uri - range = params ^. J.range - callback = reactorSend . RspDocumentRangeFormatting . Core.makeResponseMessage req . J.List - hreq = IReq tn (req ^. J.id) callback $ provider doc (FormatRange range) (params ^. J.options) - makeRequest hreq + withDocumentContents (req ^. J.id) doc $ \text -> + let range = params ^. J.range + callback = reactorSend . RspDocumentRangeFormatting . Core.makeResponseMessage req . J.List + hreq = IReq tn (req ^. J.id) callback $ lift $ provider text doc (FormatRange range) (params ^. J.options) + in makeRequest hreq -- ------------------------------- @@ -806,22 +808,48 @@ reactor inp diagIn = do -- --------------------------------------------------------------------- +-- | Execute a function in the current request with an Uri. +-- Reads the content of the file specified by the Uri and invokes +-- the function on it. +-- +-- If the Uri can not be mapped to a real file, the function will +-- not be executed and an error message will be sent to the client. +-- Error message is associated with the request id and, thus, identifiable. +withDocumentContents :: J.LspId -> J.Uri -> (T.Text -> R ()) -> R () +withDocumentContents reqId uri f = do + vfsFunc <- asksLspFuncs Core.getVirtualFileFunc + mvf <- liftIO $ vfsFunc uri + lf <- asks lspFuncs + case mvf of + Nothing -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId reqId) + J.InvalidRequest + "Document was not open" + Just (VFS.VirtualFile _ txt) -> f (Yi.toText txt) + +-- | Get the currently configured formatter provider. +-- The currently configured formatter provider is defined in @Config@ by PluginId. +-- +-- It is possible that formatter configured by the user is not present. +-- In this case, a nop (No-Operation) formatter is returned and a message will +-- be sent to the user. getFormattingProvider :: R FormattingProvider getFormattingProvider = do - providers <- asks formattingProviders - clientConfig <- getClientConfig + plugins <- asks idePlugins + config <- getClientConfig -- LL: Is this overengineered? Do we need a pluginFormattingProvider -- or should we just call plugins straight from here based on the providerType? - let providerName = formattingProvider clientConfig - mProvider = Map.lookup providerName providers - case mProvider of + let providerName = formattingProvider config + mprovider = Hie.getFormattingPlugin config plugins + case mprovider of Nothing -> do unless (providerName == "none") $ do let msg = providerName <> " is not a recognised plugin for formatting. Check your config" reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg - reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg - return (\_ _ _ -> return (IdeResultOk [])) -- nop formatter - Just provider -> return provider + reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg + return (\_ _ _ _ -> return (IdeResultOk [])) -- nop formatter + Just (_, provider) -> return provider -- ---------------------------------------------------------------------