{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Provides code actions to add missing pragmas (whenever GHC suggests to) module Ide.Plugin.Pragmas ( suggestPragmaDescriptor , completionDescriptor , suggestDisableWarningDescriptor -- For testing , validPragmas , AppearWhere(..) ) where import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) import Data.Char (isAlphaNum) import Data.List.Extra (nubOrdOn) import qualified Data.Map as M import Data.Maybe (mapMaybe) import qualified Data.Text as T import Development.IDE hiding (line) import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import Development.IDE.Plugin.Completions.Logic (getCompletionPrefix) import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState suggestPragmaDescriptor plId = (defaultPluginDescriptor plId "Provides a code action to add missing LANGUAGE pragmas") { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestPragmaProvider , pluginPriority = defaultPluginPriority + 1000 } completionDescriptor :: PluginId -> PluginDescriptor IdeState completionDescriptor plId = (defaultPluginDescriptor plId "Provides completion of LANGAUGE pragmas") { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCompletion completion , pluginPriority = ghcideCompletionsPluginPriority + 1 } suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState suggestDisableWarningDescriptor plId = (defaultPluginDescriptor plId "Provides a code action to disable warnings") { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestDisableWarningProvider -- #3636 Suggestions to disable warnings should appear last. , pluginPriority = 0 } -- --------------------------------------------------------------------- -- | Title and pragma type PragmaEdit = (T.Text, Pragma) data Pragma = LangExt T.Text | OptGHC T.Text deriving (Show, Eq, Ord) suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction suggestPragmaProvider = mkCodeActionProvider suggest suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction mkCodeActionProvider mkSuggest state _plId (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do normalizedFilePath <- getNormalizedFilePathE uri -- ghc session to get some dynflags even if module isn't parsed (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits -- | Add a Pragma to the given URI at the top of the file. -- It is assumed that the pragma name is a valid pragma, -- thus, not validated. pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (LSP.Command LSP.|? LSP.CodeAction) pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) = LSP.InR $ LSP.CodeAction title (Just LSP.CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing where render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" pragmaInsertPosition = Position (fromIntegral nextPragmaLine) 0 pragmaInsertRange = Range pragmaInsertPosition pragmaInsertPosition -- workaround the fact that for some reason lsp-test applies text -- edits in reverse order than lsp (tried in both coc.nvim and vscode) textEdits = if | Just (Pragmas.LineSplitTextEdits insertTextEdit deleteTextEdit) <- lineSplitTextEdits , let LSP.TextEdit{ _range, _newText } = insertTextEdit -> [LSP.TextEdit _range (render p <> _newText), deleteTextEdit] | otherwise -> [LSP.TextEdit pragmaInsertRange (render p)] edit = LSP.WorkspaceEdit (Just $ M.singleton uri textEdits) Nothing Nothing suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] suggest dflags diag = suggestAddPragma dflags diag -- --------------------------------------------------------------------- suggestDisableWarning :: Diagnostic -> [PragmaEdit] suggestDisableWarning Diagnostic {_code} | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code , w `notElem` warningBlacklist = pure ("Disable \"" <> w <> "\" warnings", OptGHC w) | otherwise = [] -- Don't suggest disabling type errors as a solution to all type errors warningBlacklist :: [T.Text] warningBlacklist = ["deferred-type-errors"] -- --------------------------------------------------------------------- -- | Offer to add a missing Language Pragma to the top of a file. -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] suggestAddPragma mDynflags Diagnostic {_message, _source} | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message where genPragma target = [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled] disabled | Just dynFlags <- mDynflags = -- GHC does not export 'OnOff', so we have to view it as string mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags) | otherwise = -- When the module failed to parse, we don't have access to its -- dynFlags. In that case, simply don't disable any pragmas. [] suggestAddPragma _ _ = [] -- | Find all Pragmas are an infix of the search term. findPragma :: T.Text -> [T.Text] findPragma str = concatMap check possiblePragmas where check p = [p | T.isInfixOf p str] -- We exclude the Strict extension as it causes many false positives, see -- the discussion at https://github.com/haskell/ghcide/pull/638 -- -- We don't include the No- variants, as GHC never suggests disabling an -- extension in an error message. possiblePragmas :: [T.Text] possiblePragmas = [ name | FlagSpec{flagSpecName = T.pack -> name} <- xFlags , "Strict" /= name ] -- | All language pragmas, including the No- variants allPragmas :: [T.Text] allPragmas = concat [ [name, "No" <> name] | FlagSpec{flagSpecName = T.pack -> name} <- xFlags ] <> -- These pragmas are not part of xFlags as they are not reversable -- by prepending "No". [ -- Safe Haskell "Unsafe" , "Trustworthy" , "Safe" -- Language Version Extensions , "Haskell98" , "Haskell2010" , "GHC2021" ] -- --------------------------------------------------------------------- flags :: [T.Text] flags = map T.pack $ flagsForCompletion False completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument position@(Position ln col) = complParams ^. L.position contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri fmap LSP.InL $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> pure $ result $ getCompletionPrefix position cnts where result pfix | "{-# language" `T.isPrefixOf` line = map mkLanguagePragmaCompl $ Fuzzy.simpleFilter word allPragmas | "{-# options_ghc" `T.isPrefixOf` line = let optionPrefix = getGhcOptionPrefix pfix prefixLength = fromIntegral $ T.length optionPrefix prefixRange = LSP.Range (Position ln (col - prefixLength)) position in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter optionPrefix flags | "{-#" `T.isPrefixOf` line = [ mkPragmaCompl (a <> suffix) b c | (a, b, c, w) <- validPragmas, w == NewLine ] | -- Do not suggest any pragmas under any of these conditions: -- 1. Current line is an import -- 2. There is a module name right before the current word. -- Something like `Text.la` shouldn't suggest adding the -- 'LANGUAGE' pragma. -- 3. The user has not typed anything yet. "import" `T.isPrefixOf` line || not (T.null module_) || T.null word = [] | otherwise = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas , case appearWhere of -- Only suggest a pragma that needs its own line if the whole line -- fuzzily matches the pragma NewLine -> Fuzzy.test line matcher -- Only suggest a pragma that appears in the middle of a line when -- the current word is not the only thing in the line and the -- current word fuzzily matches the pragma CanInline -> line /= word && Fuzzy.test word matcher ] where line = T.toLower $ fullLine pfix module_ = prefixScope pfix word = prefixText pfix -- Not completely correct, may fail if more than one "{-#" exists. -- We can ignore it since it rarely happens. prefix | "{-# " `T.isInfixOf` line = "" | "{-#" `T.isInfixOf` line = " " | otherwise = "{-# " suffix | " #-}" `T.isSuffixOf` line = "" | "#-}" `T.isSuffixOf` line = " " | "-}" `T.isSuffixOf` line = " #" | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" _ -> return [] ----------------------------------------------------------------------- -- | Pragma where exist data AppearWhere = NewLine -- ^Must be on a new line | CanInline -- ^Can appear in the line deriving (Show, Eq) validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)] validPragmas = [ ("LANGUAGE ${1:extension}" , "LANGUAGE" , "{-# LANGUAGE #-}" , NewLine) , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC" , "{-# OPTIONS_GHC #-}" , NewLine) , ("INLINE ${1:function}" , "INLINE" , "{-# INLINE #-}" , NewLine) , ("NOINLINE ${1:function}" , "NOINLINE" , "{-# NOINLINE #-}" , NewLine) , ("INLINABLE ${1:function}" , "INLINABLE" , "{-# INLINABLE #-}" , NewLine) , ("WARNING ${1:message}" , "WARNING" , "{-# WARNING #-}" , CanInline) , ("DEPRECATED ${1:message}" , "DEPRECATED" , "{-# DEPRECATED #-}" , CanInline) , ("ANN ${1:annotation}" , "ANN" , "{-# ANN #-}" , NewLine) , ("RULES" , "RULES" , "{-# RULES #-}" , NewLine) , ("SPECIALIZE ${1:function}" , "SPECIALIZE" , "{-# SPECIALIZE #-}" , NewLine) , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}", NewLine) , ("SPECIALISE ${1:function}" , "SPECIALISE" , "{-# SPECIALISE #-}" , NewLine) , ("SPECIALISE INLINE ${1:function}", "SPECIALISE INLINE", "{-# SPECIALISE INLINE #-}", NewLine) , ("MINIMAL ${1:functions}" , "MINIMAL" , "{-# MINIMAL #-}" , CanInline) , ("UNPACK" , "UNPACK" , "{-# UNPACK #-}" , CanInline) , ("NOUNPACK" , "NOUNPACK" , "{-# NOUNPACK #-}" , CanInline) , ("COMPLETE ${1:function}" , "COMPLETE" , "{-# COMPLETE #-}" , NewLine) , ("OVERLAPPING" , "OVERLAPPING" , "{-# OVERLAPPING #-}" , CanInline) , ("OVERLAPPABLE" , "OVERLAPPABLE" , "{-# OVERLAPPABLE #-}" , CanInline) , ("OVERLAPS" , "OVERLAPS" , "{-# OVERLAPS #-}" , CanInline) , ("INCOHERENT" , "INCOHERENT" , "{-# INCOHERENT #-}" , CanInline) ] mkPragmaCompl :: T.Text -> T.Text -> T.Text -> LSP.CompletionItem mkPragmaCompl insertText label detail = LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing (Just detail) Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet) Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkLanguagePragmaCompl :: T.Text -> LSP.CompletionItem mkLanguagePragmaCompl label = LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkGhcOptionCompl :: Range -> T.Text -> LSP.CompletionItem mkGhcOptionCompl editRange completedFlag = LSP.CompletionItem completedFlag Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just insertCompleteFlag) Nothing Nothing Nothing Nothing Nothing where insertCompleteFlag = LSP.InL $ LSP.TextEdit editRange completedFlag -- The prefix extraction logic of getCompletionPrefix -- doesn't consider '-' part of prefix which breaks completion -- of flags like "-ddump-xyz". For OPTIONS_GHC completion we need the whole thing -- to be considered completion prefix, but `prefixText posPrefixInfo` would return"xyz" in this case getGhcOptionPrefix :: PosPrefixInfo -> T.Text getGhcOptionPrefix PosPrefixInfo {cursorPos = Position _ col, fullLine}= T.takeWhileEnd isGhcOptionChar beforePos where beforePos = T.take (fromIntegral col) fullLine -- Is this character contained in some GHC flag? Based on: -- >>> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False -- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz" isGhcOptionChar :: Char -> Bool isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String)