{-# 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 ) where import Control.Applicative ((<|>)) import Control.Lens hiding (List) import Control.Monad (join) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.State.Strict (State) import Data.Bits (Bits (bit, complement, setBit, (.&.))) import Data.Char (isSpace) import qualified Data.Char as Char import Data.Coerce (coerce) import Data.Functor (void, ($>)) import qualified Data.HashMap.Strict as H import qualified Data.List as List import Data.List.Extra (nubOrdOn) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, listToMaybe, mapMaybe) import qualified Data.Maybe as Maybe import Data.Ord (Down (Down)) import Data.Semigroup (Semigroup ((<>))) import qualified Data.Text as T import Data.Word (Word64) import Development.IDE as D (Diagnostic (Diagnostic, _code, _message), GhcSession (GhcSession), HscEnvEq (hscEnv), IdeState, List (List), ParseResult (POk), Position (Position), Range (Range), Uri, getFileContents, getParsedModule, printOutputable, runAction, srcSpanToRange, toNormalizedUri, uriToFilePath', useWithStale) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util (StringBuffer, atEnd, nextChar, stringToStringBuffer) import qualified Development.IDE.Spans.Pragmas as Pragmas import Development.IDE.Types.HscEnvEq (HscEnvEq, hscEnv) 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 } -- --------------------------------------------------------------------- -- | 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" -- Maybe, GHC 2021 after its release? ] -- --------------------------------------------------------------------- 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 mkExtCompl (Fuzzy.simpleFilter (VFS.prefixText pfix) flags) | "{-#" `T.isPrefixOf` line = J.List $ map (\(a, b, c) -> mkPragmaCompl (a <> suffix) b c) validPragmas | otherwise = J.List [] where line = T.toLower $ VFS.fullLine pfix suffix | "#-}" `T.isSuffixOf` line = " " | "-}" `T.isSuffixOf` line = " #" | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" result Nothing = J.List [] buildCompletion p = J.CompletionItem { _label = p, _kind = Just J.CiKeyword, _tags = Nothing, _detail = Nothing, _documentation = Nothing, _deprecated = Nothing, _preselect = Nothing, _sortText = Nothing, _filterText = Nothing, _insertText = Nothing, _insertTextFormat = Nothing, _insertTextMode = Nothing, _textEdit = Nothing, _additionalTextEdits = Nothing, _commitCharacters = Nothing, _command = Nothing, _xdata = Nothing } _ -> return $ J.List [] ----------------------------------------------------------------------- validPragmas :: [(T.Text, T.Text, T.Text)] validPragmas = [ ("LANGUAGE ${1:extension}" , "LANGUAGE", "{-# LANGUAGE #-}") , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC", "{-# OPTIONS_GHC #-}") , ("INLINE ${1:function}" , "INLINE", "{-# INLINE #-}") , ("NOINLINE ${1:function}" , "NOINLINE", "{-# NOINLINE #-}") , ("INLINABLE ${1:function}" , "INLINABLE", "{-# INLINABLE #-}") , ("WARNING ${1:message}" , "WARNING", "{-# WARNING #-}") , ("DEPRECATED ${1:message}" , "DEPRECATED", "{-# DEPRECATED #-}") , ("ANN ${1:annotation}" , "ANN", "{-# ANN #-}") , ("RULES" , "RULES", "{-# RULES #-}") , ("SPECIALIZE ${1:function}" , "SPECIALIZE", "{-# SPECIALIZE #-}") , ("SPECIALIZE INLINE ${1:function}" , "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}") ] 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 mkExtCompl :: T.Text -> J.CompletionItem mkExtCompl label = J.CompletionItem label (Just J.CiKeyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing