{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE CPP #-}
#include "ghc-api-version.h"
module Development.IDE.LSP.CodeAction
( setHandlersCodeAction
) where
import Language.Haskell.LSP.Types
import Development.IDE.GHC.Compat
import Development.IDE.Core.Rules
import Development.IDE.LSP.Server
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Language.Haskell.LSP.Core as LSP
import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Messages
import qualified Data.Rope.UTF16 as Rope
import Data.Char
import Data.Maybe
import Data.List.Extra
import qualified Data.Text as T
codeAction
:: LSP.LspFuncs ()
-> IdeState
-> CodeActionParams
-> IO (List CAResult)
codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do
contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
pure $ List
[ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
| x <- xs, (title, tedit) <- suggestAction text x
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
]
suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestAction contents Diagnostic{_range=_range@Range{..},..}
| "The import of " `T.isInfixOf` _message
|| "The qualified import of " `T.isInfixOf` _message
, " is redundant" `T.isInfixOf` _message
= [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
| renameSuggestions@(_:_) <- extractRenamableTerms _message
= [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
| "Found type wildcard" `T.isInfixOf` _message
, " standing for " `T.isInfixOf` _message
, typeSignature <- extractWildCardTypeSignature _message
= [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
| exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
= [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
| "Could not find module" `T.isInfixOf` _message
, "Perhaps you meant" `T.isInfixOf` _message = let
findSuggestedModules = map (head . T.words) . drop 2 . T.lines
proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
in map proposeModule $ nubOrd $ findSuggestedModules _message
| topOfHoleFitsMarker `T.isInfixOf` _message = let
findSuggestedHoleFits :: T.Text -> [T.Text]
findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])
holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
selectLinesWithFits = filter ("::" `T.isInfixOf`)
extractFitNames = map (T.strip . head . T.splitOn " :: ")
in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
| "Top-level binding with no type signature" `T.isInfixOf` _message = let
filterNewlines = T.concat . T.lines
unifySpaces = T.unwords . T.words
signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
startOfLine = Position (_line _start) 0
beforeLine = Range startOfLine startOfLine
title = "add signature: " <> signature
action = TextEdit beforeLine $ signature <> "\n"
in [(title, [action])]
suggestAction _ _ = []
topOfHoleFitsMarker :: T.Text
topOfHoleFitsMarker =
#if MIN_GHC_API_VERSION(8,6,0)
"Valid hole fits include"
#else
"Valid substitutions include"
#endif
mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
mkRenameEdit contents range name =
if fromMaybe False maybeIsInfixFunction
then TextEdit range ("`" <> name <> "`")
else TextEdit range name
where
maybeIsInfixFunction = do
curr <- textInRange range <$> contents
pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
extractWildCardTypeSignature :: T.Text -> T.Text
extractWildCardTypeSignature =
("(" `T.append`) . (`T.append` ")") .
T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
snd . T.breakOnEnd "standing for "
extractRenamableTerms :: T.Text -> [T.Text]
extractRenamableTerms msg
| "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg
| otherwise = []
where
extractSuggestions = map getEnclosed
. concatMap singleSuggestions
. filter isKnownSymbol
. T.lines
singleSuggestions = T.splitOn "), "
isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t
getEnclosed = T.dropWhile (== '‘')
. T.dropWhileEnd (== '’')
. T.dropAround (\c -> c /= '‘' && c /= '’')
extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range
extendToWholeLineIfPossible contents range@Range{..} =
let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents
extend = newlineAfter && _character _start == 0
in if extend then Range _start (Position (_line _end + 1) 0) else range
ghcExtensions :: Set.HashSet T.Text
ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions
splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
splitTextAtPosition (Position row col) x
| (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
, (preCol, postCol) <- T.splitAt col mid
= (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
| otherwise = (x, T.empty)
textInRange :: Range -> T.Text -> T.Text
textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
case compare startRow endRow of
LT ->
let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
(textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
[] -> ("", [])
firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
EQ ->
let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
in T.take (endCol - startCol) (T.drop startCol line)
GT -> ""
where
linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
setHandlersCodeAction :: PartialHandlers
setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
LSP.codeActionHandler = withResponse RspCodeAction codeAction
}