{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE CPP #-}
#include "ghc-api-version.h"
module Development.IDE.Plugin.CodeAction(plugin) where
import Language.Haskell.LSP.Types
import Control.Monad (join)
import Development.IDE.Plugin
import Development.IDE.GHC.Compat
import Development.IDE.Core.Rules
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Service
import Development.IDE.Core.Shake
import Development.IDE.GHC.Error
import Development.IDE.LSP.Server
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import qualified Data.HashMap.Strict as Map
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.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
import Control.Monad.Trans.Maybe
import Data.Char
import Data.Maybe
import Data.List.Extra
import qualified Data.Text as T
import Data.Tuple.Extra ((&&&))
import Text.Regex.TDFA ((=~), (=~~))
import Text.Regex.TDFA.Text()
import Outputable (ppr, showSDocUnsafe)
import DynFlags (xFlags, FlagSpec(..))
import GHC.LanguageExtensions.Type (Extension)
plugin :: Plugin
plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens
codeAction
:: LSP.LspFuncs ()
-> IdeState
-> TextDocumentIdentifier
-> Range
-> CodeActionContext
-> IO (Either ResponseError [CAResult])
codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
(ideOptions, parsedModule) <- runAction state $
(,) <$> getIdeOptions
<*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
pure $ Right
[ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
| x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
]
codeLens
:: LSP.LspFuncs ()
-> IdeState
-> CodeLensParams
-> IO (Either ResponseError (List CodeLens))
codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
fmap (Right . List) $ case uriToFilePath' uri of
Just (toNormalizedFilePath -> filePath) -> do
_ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
diag <- getDiagnostics ideState
hDiag <- getHiddenDiagnostics ideState
pure
[ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
| (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag
, dFile == filePath
, (title, tedit) <- suggestSignature False dDiag
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
]
Nothing -> pure []
executeAddSignatureCommand
:: LSP.LspFuncs ()
-> IdeState
-> ExecuteCommandParams
-> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
| _command == "typesignature.add"
, Just (List [edit]) <- _arguments
, Success wedit <- fromJSON edit
= return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
| otherwise
= return (Null, Nothing)
suggestAction :: IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestAction ideOptions parsedModule text diag = concat
[ suggestAddExtension diag
, suggestExtendImport text diag
, suggestFillHole diag
, suggestFillTypeWildcard diag
, suggestFixConstructorImport text diag
, suggestModuleTypo diag
, suggestReplaceIdentifier text diag
, suggestSignature True diag
] ++ concat
[ suggestNewDefinition ideOptions pm text diag
++ suggestRemoveRedundantImport pm text diag
| Just pm <- [parsedModule]]
suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}
| Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
, Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
, Just c <- contents
, ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
, ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
= [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
| _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
= [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
| otherwise = []
suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}
| renameSuggestions@(_:_) <- extractRenamableTerms _message
= [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
| otherwise = []
suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}
| Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
= newDefinitionAction ideOptions parsedModule _range name typ
| Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"
, [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ
= [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
| otherwise = []
where
message = unifySpaces _message
newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]
newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
| Range _ lastLineP : _ <-
[ srcSpanToRange l
| (L l _) <- hsmodDecls
, _start `isInsideSrcSpan` l]
, nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
= [ ("Define " <> sig
, [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]
)]
| otherwise = []
where
colon = if optNewColonConvention then " : " else " :: "
sig = name <> colon <> T.dropWhileEnd isSpace typ
ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
| "Found type wildcard" `T.isInfixOf` _message
, " standing for " `T.isInfixOf` _message
, typeSignature <- extractWildCardTypeSignature _message
= [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
| otherwise = []
suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
suggestAddExtension Diagnostic{_range=_range@Range{..},..}
| exts@(_:_) <- filter (`Map.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]
| otherwise = []
ghcExtensions :: Map.HashMap T.Text Extension
ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
| "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
| otherwise = []
suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
suggestFillHole Diagnostic{_range=_range@Range{..},..}
| 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
| otherwise = []
suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestExtendImport contents Diagnostic{_range=_range,..}
| Just [binding, mod, srcspan] <-
matchRegex _message
"Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
, Just c <- contents
= let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
[s] -> let x = srcSpanToRange s
in x{_end = (_end x){_character = succ (_character (_end x))}}
_ -> error "bug in srcspan parser"
importLine = textInRange range c
in [("Add " <> binding <> " to the import list of " <> mod
, [TextEdit range (addBindingToImportList binding importLine)])]
| otherwise = []
suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestFixConstructorImport _ Diagnostic{_range=_range,..}
| Just [constructor, typ] <-
matchRegex _message
"‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
= let fixedImport = typ <> "(" <> constructor <> ")"
in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
| otherwise = []
suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
| "Top-level binding with no type signature" `T.isInfixOf` _message = let
signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
startOfLine = Position (_line _start) 0
beforeLine = Range startOfLine startOfLine
title = if isQuickFix then "add signature: " <> signature else signature
action = TextEdit beforeLine $ signature <> "\n"
in [(title, [action])]
suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
| "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let
signature = removeInitialForAll
$ T.takeWhile (\x -> x/='*' && x/='•')
$ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
startOfLine = Position (_line _start) (_character _start)
beforeLine = Range startOfLine startOfLine
title = if isQuickFix then "add signature: " <> signature else signature
action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "
in [(title, [action])]
where removeInitialForAll :: T.Text -> T.Text
removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
| "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
| otherwise = nm <> ty
suggestSignature _ _ = []
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
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)
rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
concatMap (map srcSpanToRange . rangesForBinding' b') lies
where
b' = wrapOperatorInParens (unqualify b)
wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
unqualify x = snd $ breakOnEnd "." x
rangesForBinding _ _ = []
rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]
rangesForBinding' b (L l (IEThingWith thing _ inners labels))
| showSDocUnsafe (ppr thing) == b = [l]
| otherwise =
[ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
[ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
rangesForBinding' _ _ = []
addBindingToImportList :: T.Text -> T.Text -> T.Text
addBindingToImportList binding importLine = case T.breakOn "(" importLine of
(pre, T.uncons -> Just (_, rest)) ->
case T.uncons (T.dropWhile isSpace rest) of
Just (')', _) -> T.concat [pre, "(", binding, rest]
_ -> T.concat [pre, "(", binding, ", ", rest]
_ ->
error
$ "importLine does not have the expected structure: "
<> T.unpack importLine
matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
matchRegex message regex = case unifySpaces message =~~ regex of
Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
Nothing -> Nothing
setHandlersCodeLens :: PartialHandlers
setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
LSP.codeLensHandler = withResponse RspCodeLens codeLens,
LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
}
filterNewlines :: T.Text -> T.Text
filterNewlines = T.concat . T.lines
unifySpaces :: T.Text -> T.Text
unifySpaces = T.unwords . T.words
type PositionIndexedString = [(Position, Char)]
indexedByPosition :: String -> PositionIndexedString
indexedByPosition = unfoldr f . (Position 0 0,) where
f (_, []) = Nothing
f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))
f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))
unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)
unconsRange Range {..} indexedString = (before, mid, after)
where
(before, rest) = span ((/= _start) . fst) indexedString
(mid, after) = span ((/= _end) . fst) rest
stripRange :: Range -> PositionIndexedString -> PositionIndexedString
stripRange r s = case unconsRange r s of
(b, _, a) -> b ++ a
extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
extendAllToIncludeCommaIfPossible _ [] = []
extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr
where
r' = case extendToIncludeCommaIfPossible indexedString r of
[] -> r
r' : _ -> r'
indexedString' = stripRange r' indexedString
extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
extendToIncludeCommaIfPossible indexedString range =
[ range{_start = start'}
| (start', ',') : _ <- [before']
]
++
[ range{_end = end'}
| (_, ',') : rest <- [after']
, let (end', _) : _ = dropWhile (isSpace . snd) rest
]
where
(before, _, after) = unconsRange range indexedString
after' = dropWhile (isSpace . snd) after
before' = dropWhile (isSpace . snd) (reverse before)