{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | Provides code actions to add missing pragmas (whenever GHC suggests to) module Ide.Plugin.Pragmas ( descriptor -- For testing , validPragmas ) where import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.HashMap.Strict as H import Data.List.Extra (nubOrdOn) import Data.Maybe (catMaybes) import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Types import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as J import qualified Language.LSP.Types.Lens as J import qualified Language.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction codeActionProvider <> mkPluginHandler J.STextDocumentCompletion completion , pluginPriority = ghcideCompletionsPluginPriority + 1 } -- --------------------------------------------------------------------- -- | Title and pragma type PragmaEdit = (T.Text, Pragma) data Pragma = LangExt T.Text | OptGHC T.Text deriving (Show, Eq, Ord) codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) | let J.TextDocumentIdentifier{ _uri = uri } = docId , Just normalizedFilePath <- J.uriToNormalizedFilePath $ toNormalizedUri uri = do -- ghc session to get some dynflags even if module isn't parsed ghcSession <- liftIO $ runAction "Pragmas.GhcSession" state $ useWithStale 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 case ghcSession of Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents pedits = nubOrdOn snd . concat $ suggest parsedModuleDynFlags <$> diags in pure $ Right $ List $ pragmaEditToAction uri nextPragmaInfo <$> pedits Nothing -> pure $ Right $ List [] | otherwise = pure $ Right $ List [] -- | 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 -> (J.Command J.|? J.CodeAction) pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) = J.InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) 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 J.TextEdit{ _range, _newText } = insertTextEdit -> [J.TextEdit _range (render p <> _newText), deleteTextEdit] | otherwise -> [J.TextEdit pragmaInsertRange (render p)] edit = J.WorkspaceEdit (Just $ H.singleton uri (J.List textEdits)) Nothing Nothing suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] suggest dflags diag = suggestAddPragma dflags diag ++ suggestDisableWarning diag -- --------------------------------------------------------------------- suggestDisableWarning :: Diagnostic -> [PragmaEdit] suggestDisableWarning Diagnostic {_code} | Just (J.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 = [] 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} = 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 catMaybes $ 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. [] -- | 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" #if MIN_VERSION_ghc(9,2,0) , "GHC2021" #endif ] -- --------------------------------------------------------------------- flags :: [T.Text] flags = map (T.pack . stripLeading '-') $ flagsForCompletion False completion :: PluginMethodHandler IdeState 'J.TextDocumentCompletion completion _ide _ complParams = do let (J.TextDocumentIdentifier uri) = complParams ^. J.textDocument position = complParams ^. J.position contents <- LSP.getVirtualFile $ toNormalizedUri uri fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> result <$> VFS.getCompletionPrefix position cnts where result (Just pfix) | "{-# language" `T.isPrefixOf` line = J.List $ map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas) | "{-# options_ghc" `T.isPrefixOf` line = J.List $ map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) flags) | "{-#" `T.isPrefixOf` line = J.List $ [ mkPragmaCompl (a <> suffix) b c | (a, b, c, w) <- validPragmas, w == NewLine ] | otherwise = J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c | (a, b, c, _) <- validPragmas, Fuzzy.test word b] where line = T.toLower $ VFS.fullLine pfix word = VFS.prefixText pfix -- Not completely correct, may fail if more than one "{-#" exist -- , we can ignore it since it rarely happen. prefix | "{-# " `T.isInfixOf` line = "" | "{-#" `T.isInfixOf` line = " " | otherwise = "{-# " suffix | " #-}" `T.isSuffixOf` line = "" | "#-}" `T.isSuffixOf` line = " " | "-}" `T.isSuffixOf` line = " #" | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" result Nothing = J.List [] _ -> return $ J.List [] ----------------------------------------------------------------------- -- | 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 -> J.CompletionItem mkPragmaCompl insertText label detail = J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail) Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet) Nothing Nothing Nothing Nothing Nothing Nothing stripLeading :: Char -> String -> String stripLeading _ [] = [] stripLeading c (s:ss) | s == c = ss | otherwise = s:ss buildCompletion :: T.Text -> J.CompletionItem buildCompletion label = J.CompletionItem label (Just J.CiKeyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing