diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3b2ec6085f..1a7806d61c 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -169,6 +169,7 @@ library Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.CodeAction.ExactPrint Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde Development.IDE.Plugin.Test diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 289b9f1b2f..31fdf4d352 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -79,6 +79,7 @@ import Development.IDE.Core.FileStore (modificationTime, getFil import Development.IDE.Types.Diagnostics as Diag import Development.IDE.Types.Location import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile) +import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util import Data.Either.Extra import qualified Development.IDE.Types.Logger as L @@ -1020,6 +1021,7 @@ mainRule = do needsCompilationRule generateCoreRule getImportMapRule + getAnnotatedParsedSourceRule -- | Given the path to a module src file, this rule returns True if the -- corresponding `.hi` file is stable, that is, if it is newer diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 175481741e..46a1654933 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -3,12 +3,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.GHC.ExactPrint ( Graft(..), graft, graftDecls, graftDeclsWithM, + annotate, hoistGraft, graftWithM, graftWithSmallestM, @@ -16,8 +18,14 @@ module Development.IDE.GHC.ExactPrint transformM, useAnnotatedSource, annotateParsedSource, + getAnnotatedParsedSourceRule, + GetAnnotatedParsedSource(..), ASTElement (..), ExceptStringT (..), + Annotated(..), + TransformT, + Anns, + Annotate, ) where @@ -35,10 +43,13 @@ import Data.Functor.Classes import Data.Functor.Contravariant import qualified Data.Text as T import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Rules +import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake import Development.IDE.GHC.Compat hiding (parseExpr) import Development.IDE.Types.Location +import Development.Shake (RuleResult, Rules) +import Development.Shake.Classes +import qualified GHC.Generics as GHC import Generics.SYB import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint @@ -47,6 +58,7 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) +import Parser (parseIdentifier) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow #endif @@ -54,19 +66,30 @@ import Control.Arrow ------------------------------------------------------------------------------ +data GetAnnotatedParsedSource = GetAnnotatedParsedSource + deriving (Eq, Show, Typeable, GHC.Generic) + +instance Hashable GetAnnotatedParsedSource +instance NFData GetAnnotatedParsedSource +instance Binary GetAnnotatedParsedSource +type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource + -- | Get the latest version of the annotated parse source. -useAnnotatedSource :: - String -> - IdeState -> - NormalizedFilePath -> - IO (Maybe (Annotated ParsedSource)) -useAnnotatedSource herald state nfp = - fmap annotateParsedSource - <$> runAction herald state (use GetParsedModule nfp) +getAnnotatedParsedSourceRule :: Rules () +getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do + pm <- use GetParsedModule nfp + return ([], fmap annotateParsedSource pm) annotateParsedSource :: ParsedModule -> Annotated ParsedSource annotateParsedSource = fixAnns +useAnnotatedSource :: + String -> + IdeState -> + NormalizedFilePath -> + IO (Maybe (Annotated ParsedSource)) +useAnnotatedSource herald state nfp = + runAction herald state (use GetAnnotatedParsedSource nfp) ------------------------------------------------------------------------------ {- | A transformation for grafting source trees together. Use the semigroup @@ -291,6 +314,10 @@ instance p ~ GhcPs => ASTElement (HsDecl p) where parseAST = parseDecl maybeParensAST = id +instance ASTElement RdrName where + parseAST df fp = parseWith df fp parseIdentifier + maybeParensAST = id + ------------------------------------------------------------------------------ -- | Dark magic I stole from retrie. No idea what it does. @@ -302,6 +329,7 @@ fixAnns ParsedModule {..} = ------------------------------------------------------------------------------ -- | Given an 'LHSExpr', compute its exactprint annotations. +-- Note that this function will throw away any existing annotations (and format) annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast) annotate dflags ast = do uniq <- show <$> uniqueSrcSpanT diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 9155ca2439..e9a5e91538 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -21,6 +21,7 @@ import GhcPlugins import qualified StringBuffer as SB import Data.Text (Text) import Data.String (IsString(fromString)) +import Retrie.ExactPrint (Annotated) -- Orphan instances for types from the GHC API. @@ -144,3 +145,9 @@ instance NFData ModGuts where instance NFData (ImportDecl GhcPs) where rnf = rwhnf + +instance Show (Annotated ParsedSource) where + show _ = "" + +instance NFData (Annotated ParsedSource) where + rnf = rwhnf diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 9b3bcd5703..2422ccc64d 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -30,7 +30,9 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint import Development.IDE.LSP.Server +import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.CodeAction.RuleTypes import Development.IDE.Plugin.CodeAction.Rules @@ -52,7 +54,7 @@ import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Text.Regex.TDFA (mrAfter, (=~), (=~~)) -import Outputable (ppr, showSDocUnsafe) +import Outputable (Outputable, ppr, showSDoc, showSDocUnsafe) import Data.Function import Control.Arrow ((>>>)) import Data.Functor @@ -61,12 +63,14 @@ import Safe (atMay) import Bag (isEmptyBag) import qualified Data.HashSet as Set import Control.Concurrent.Extra (threadDelay, readVar) +import Development.IDE.GHC.Util (printRdrName) plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens rules :: Rules () -rules = rulePackageExports +rules = do + rulePackageExports -- | a command that blocks forever. Used for testing blockCommandId :: T.Text @@ -88,20 +92,38 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (ideOptions, join -> parsedModule, join -> env) <- runAction "CodeAction" state $ - (,,) <$> getIdeOptions + (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS) <- runAction "CodeAction" state $ + (,,,) <$> getIdeOptions <*> getParsedModule `traverse` mbFile <*> use GhcSession `traverse` mbFile + <*> use GetAnnotatedParsedSource `traverse` mbFile -- This is quite expensive 0.6-0.7s on GHC pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env localExports <- readVar (exportsMap $ shakeExtras state) - let exportsMap = localExports <> fromMaybe mempty pkgExports - pure . Right $ - [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing + let + exportsMap = localExports <> fromMaybe mempty pkgExports + df = ms_hspp_opts . pm_mod_summary <$> parsedModule + actions = + [ mkCA title [x] edit | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] <> caRemoveRedundantImports parsedModule text diag xs uri + actions' = + [mkCA title [x] edit + | x <- xs + , Just ps <- [annotatedPS] + , Just dynflags <- [df] + , (title, graft) <- suggestExactAction dynflags ps x + , let edit = either error id $ + rewriteToEdit dynflags uri (annsA ps) graft + ] + pure $ Right $ actions' <> actions + +mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult +mkCA title diags edit = + CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing + -- | Generate code lenses. codeLens :: LSP.LspFuncs c @@ -148,6 +170,17 @@ commandHandler lsp _ideState ExecuteCommandParams{..} | otherwise = return (Right Null, Nothing) +suggestExactAction :: + DynFlags -> + Annotated ParsedSource -> + Diagnostic -> + [(T.Text, Rewrite)] +suggestExactAction df ps x = + concat + [ suggestConstraint df (astA ps) x + , suggestImplicitParameter (astA ps) x + ] + suggestAction :: ExportsMap -> IdeOptions @@ -166,8 +199,7 @@ suggestAction packageExports ideOptions parsedModule text diag = concat , removeRedundantConstraints text diag , suggestAddTypeAnnotationToSatisfyContraints text diag ] ++ concat - [ suggestConstraint pm text diag - ++ suggestNewDefinition ideOptions pm text diag + [ suggestNewDefinition ideOptions pm text diag ++ suggestNewImport packageExports pm diag ++ suggestDeleteUnusedBinding pm text diag ++ suggestExportUnusedTopBinding text pm diag @@ -175,6 +207,24 @@ suggestAction packageExports ideOptions parsedModule text diag = concat ] ++ suggestFillHole diag -- Lowest priority +findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDecl pred decls = + listToMaybe + [ sig + | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, + any (pred . unLoc) idsSig + ] + +findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) +findInstanceHead df instanceHead decls = + listToMaybe + [ hsib_body + | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, + showSDoc df (ppr hsib_body) == instanceHead + ] + +findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) +findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} @@ -207,14 +257,9 @@ caRemoveRedundantImports m contents digs ctxDigs uri = caRemoveCtx ++ [caRemoveAll] | otherwise = [] where - removeSingle title tedit diagnostic = CACodeAction CodeAction{..} where + removeSingle title tedit diagnostic = mkCA title [diagnostic] WorkspaceEdit{..} where _changes = Just $ Map.singleton uri $ List tedit - _title = title - _kind = Just CodeActionQuickFix - _diagnostics = Just $ List [diagnostic] _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _command = Nothing removeAll tedit = CACodeAction CodeAction {..} where _changes = Just $ Map.singleton uri $ List tedit _title = "Remove all redundant imports" @@ -684,79 +729,78 @@ suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..} suggestSignature _ _ = [] -- | Suggests a constraint for a declaration for which a constraint is missing. -suggestConstraint :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestConstraint parsedModule mContents diag@Diagnostic {..} - | Just contents <- mContents - , Just missingConstraint <- findMissingConstraint _message +suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +suggestConstraint df parsedModule diag@Diagnostic {..} + | Just missingConstraint <- findMissingConstraint _message = let codeAction = if _message =~ ("the type signature for:" :: String) - then suggestFunctionConstraint parsedModule - else suggestInstanceConstraint contents + then suggestFunctionConstraint df parsedModule + else suggestInstanceConstraint df parsedModule in codeAction diag missingConstraint | otherwise = [] where findMissingConstraint :: T.Text -> Maybe T.Text findMissingConstraint t = - let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from a use of" - in matchRegexUnifySpaces t regex <&> last - -normalizeConstraints :: T.Text -> T.Text -> T.Text -normalizeConstraints existingConstraints constraint = - let constraintsInit = if "(" `T.isPrefixOf` existingConstraints - then T.dropEnd 1 existingConstraints - else "(" <> existingConstraints - in constraintsInit <> ", " <> constraint <> ")" + let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement + regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" + match = matchRegexUnifySpaces t regex + matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams + in match <|> matchImplicitParams <&> last -- | Suggests a constraint for an instance declaration for which a constraint is missing. -suggestInstanceConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])] -suggestInstanceConstraint contents Diagnostic {..} missingConstraint --- Suggests a constraint for an instance declaration with no existing constraints. --- • No instance for (Eq a) arising from a use of ‘==’ --- Possible fix: add (Eq a) to the context of the instance declaration --- • In the expression: x == y --- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y --- In the instance declaration for ‘Eq (Wrap a)’ - | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" - = let instanceLine = contents - & T.splitOn ("instance " <> instanceDeclaration) - & head & T.lines & length - startOfConstraint = Position instanceLine (length ("instance " :: String)) - range = Range startOfConstraint startOfConstraint - newConstraint = missingConstraint <> " => " - in [(actionTitle missingConstraint, [TextEdit range newConstraint])] - --- Suggests a constraint for an instance declaration with one or more existing constraints. --- • Could not deduce (Eq b) arising from a use of ‘==’ --- from the context: Eq a --- bound by the instance declaration at /path/to/Main.hs:7:10-32 --- Possible fix: add (Eq b) to the context of the instance declaration --- • In the second argument of ‘(&&)’, namely ‘x' == y'’ --- In the expression: x == y && x' == y' --- In an equation for ‘==’: --- (Pair x x') == (Pair y y') = x == y && x' == y' - | Just [instanceLineStr, constraintFirstCharStr] - <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" - = let existingConstraints = findExistingConstraints _message - newConstraints = normalizeConstraints existingConstraints missingConstraint - instanceLine = readPositionNumber instanceLineStr - constraintFirstChar = readPositionNumber constraintFirstCharStr - startOfConstraint = Position instanceLine constraintFirstChar - endOfConstraint = Position instanceLine $ - constraintFirstChar + T.length existingConstraints - range = Range startOfConstraint endOfConstraint - in [(actionTitle missingConstraint, [TextEdit range newConstraints])] +suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint + | Just instHead <- instanceHead + = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] | otherwise = [] where - findExistingConstraints :: T.Text -> T.Text - findExistingConstraints t = - T.replace "from the context: " "" . T.strip $ T.lines t !! 1 + instanceHead + -- Suggests a constraint for an instance declaration with no existing constraints. + -- • No instance for (Eq a) arising from a use of ‘==’ + -- Possible fix: add (Eq a) to the context of the instance declaration + -- • In the expression: x == y + -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y + -- In the instance declaration for ‘Eq (Wrap a)’ + | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" + , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls + = Just instHead + -- Suggests a constraint for an instance declaration with one or more existing constraints. + -- • Could not deduce (Eq b) arising from a use of ‘==’ + -- from the context: Eq a + -- bound by the instance declaration at /path/to/Main.hs:7:10-32 + -- Possible fix: add (Eq b) to the context of the instance declaration + -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ + -- In the expression: x == y && x' == y' + -- In an equation for ‘==’: + -- (Pair x x') == (Pair y y') = x == y && x' == y' + | Just [instanceLineStr, constraintFirstCharStr] + <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" + , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) + <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls + = Just hsib_body + | otherwise + = Nothing readPositionNumber :: T.Text -> Int - readPositionNumber = T.unpack >>> read >>> pred + readPositionNumber = T.unpack >>> read actionTitle :: T.Text -> T.Text actionTitle constraint = "Add `" <> constraint <> "` to the context of the instance declaration" +suggestImplicitParameter :: + ParsedSource -> + Diagnostic -> + [(T.Text, Rewrite)] +suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} + | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", + Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, + Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls + = + [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) + , appendConstraint (T.unpack implicitT) hsib_body)] + | otherwise = [] + findTypeSignatureName :: T.Text -> Maybe T.Text findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head @@ -765,8 +809,9 @@ findTypeSignatureLine contents typeSignatureName = T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length -- | Suggests a constraint for a type signature with any number of existing constraints. -suggestFunctionConstraint :: ParsedModule -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])] -suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{..} missingConstraint +suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint -- • No instance for (Eq a) arising from a use of ‘==’ -- Possible fix: -- add (Eq a) to the context of @@ -789,43 +834,13 @@ suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecl -- In an equation for ‘eq’: -- eq (Pair x y) (Pair x' y') = x == x' && y == y' | Just typeSignatureName <- findTypeSignatureName _message - = let mExistingConstraints = findExistingConstraints _message - newConstraint = buildNewConstraints missingConstraint mExistingConstraints - in case findRangeOfContextForFunctionNamed typeSignatureName of - Just range -> [(actionTitle missingConstraint typeSignatureName, [TextEdit range newConstraint])] - Nothing -> [] - | otherwise = [] + , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) + <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls + , title <- actionTitle missingConstraint typeSignatureName + = [(title, appendConstraint (T.unpack missingConstraint) sig)] + | otherwise + = [] where - findRangeOfContextForFunctionNamed :: T.Text -> Maybe Range - findRangeOfContextForFunctionNamed typeSignatureName = do - locatedType <- listToMaybe - [ locatedType - | L _ (SigD _ (TypeSig _ identifiers (HsWC _ (HsIB _ locatedType)))) <- hsmodDecls - , any (`isSameName` T.unpack typeSignatureName) $ fmap unLoc identifiers - ] - let typeBody = dropForAll locatedType - srcSpanToRange $ case splitLHsQualTy typeBody of - (L contextSrcSpan _ , _) -> - if isGoodSrcSpan contextSrcSpan - then contextSrcSpan -- The type signature has explicit context - else -- No explicit context, return SrcSpan at the start of type (after a potential `forall`) - let start = srcSpanStart $ getLoc typeBody in mkSrcSpan start start - - isSameName :: IdP GhcPs -> String -> Bool - isSameName x name = showSDocUnsafe (ppr x) == name - - findExistingConstraints :: T.Text -> Maybe T.Text - findExistingConstraints message = - if message =~ ("from the context:" :: String) - then fmap (T.strip . head) $ matchRegexUnifySpaces message "\\. ([^=]+)" - else Nothing - - buildNewConstraints :: T.Text -> Maybe T.Text -> T.Text - buildNewConstraints constraint mExistingConstraints = - case mExistingConstraints of - Just existingConstraints -> normalizeConstraints existingConstraints constraint - Nothing -> constraint <> " => " - actionTitle :: T.Text -> T.Text -> T.Text actionTitle constraint typeSignatureName = "Add `" <> constraint <> "` to the context of the type signature for `" <> typeSignatureName <> "`" diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs new file mode 100644 index 0000000000..18caf7fa71 --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Development.IDE.Plugin.CodeAction.ExactPrint + ( Rewrite (..), + rewriteToEdit, + + -- * Utilities + appendConstraint, + ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Data.Data (Data) +import Data.Functor +import qualified Data.HashMap.Strict as HMap +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.ExactPrint +import Development.IDE.Types.Location +import GhcPlugins (realSrcSpanEnd, realSrcSpanStart, sigPrec) +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) +import Language.Haskell.LSP.Types + +------------------------------------------------------------------------------ + +-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the +-- given 'ast'. +data Rewrite where + Rewrite :: + Annotate ast => + -- | The 'SrcSpan' that we want to rewrite + SrcSpan -> + -- | The ast that we want to graft + (DynFlags -> TransformT (Either String) (Located ast)) -> + Rewrite + +------------------------------------------------------------------------------ + +-- | Convert a 'Rewrite' into a 'WorkspaceEdit'. +rewriteToEdit :: + DynFlags -> + Uri -> + Anns -> + Rewrite -> + Either String WorkspaceEdit +rewriteToEdit dflags uri anns (Rewrite dst f) = do + (ast, (anns, _), _) <- runTransformT anns $ f dflags + let editMap = + HMap.fromList + [ ( uri, + List + [ TextEdit (fromJust $ srcSpanToRange dst) $ + T.pack $ tail $ exactPrint ast anns + ] + ) + ] + pure $ WorkspaceEdit (Just editMap) Nothing + +srcSpanToRange :: SrcSpan -> Maybe Range +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real + +realSrcSpanToRange :: RealSrcSpan -> Range +realSrcSpanToRange real = + Range + (realSrcLocToPosition $ realSrcSpanStart real) + (realSrcLocToPosition $ realSrcSpanEnd real) + +realSrcLocToPosition :: RealSrcLoc -> Position +realSrcLocToPosition real = + Position (srcLocLine real - 1) (srcLocCol real - 1) + +------------------------------------------------------------------------------ + +-- | Fix the parentheses around a type context +fixParens :: + (Monad m, Data (HsType pass)) => + Maybe DeltaPos -> + Maybe DeltaPos -> + LHsContext pass -> + TransformT m [LHsType pass] +fixParens openDP closeDP ctxt@(L _ elems) = do + -- Paren annotation for type contexts are usually quite screwed up + -- we remove duplicates and fix negative DPs + modifyAnnsT $ + Map.adjust + ( \x -> + let annsMap = Map.fromList (annsDP x) + in x + { annsDP = + Map.toList $ + Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $ + Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $ + annsMap <> parens + } + ) + (mkAnnKey ctxt) + return $ map dropHsParTy elems + where + parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] + + dropHsParTy :: LHsType pass -> LHsType pass + dropHsParTy (L _ (HsParTy _ ty)) = ty + dropHsParTy other = other + +-- | Append a constraint at the end of a type context. +-- If no context is present, a new one will be created. +appendConstraint :: + -- | The new constraint to append + String -> + -- | The type signature where the constraint is to be inserted, also assuming annotated + LHsType GhcPs -> + Rewrite +appendConstraint constraintT = go + where + go (L l it@HsQualTy {hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do + constraint <- liftParseAST df constraintT + setEntryDPT constraint (DP (0, 1)) + + -- Paren annotations are usually attached to the first and last constraints, + -- rather than to the constraint list itself, so to preserve them we need to reposition them + closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt + openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt + ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt) + + addTrailingCommaT (last ctxt') + + return $ L l $ it {hst_ctxt = L l' $ ctxt' ++ [constraint]} + go (L _ HsForAllTy {hst_body}) = go hst_body + go (L _ (HsParTy _ ty)) = go ty + go (L l other) = Rewrite l $ \df -> do + -- there isn't a context, so we must create one + constraint <- liftParseAST df constraintT + lContext <- uniqueSrcSpanT + lTop <- uniqueSrcSpanT + let context = L lContext [constraint] + addSimpleAnnT context (DP (0, 1)) $ + [ (G AnnDarrow, DP (0, 1)) + ] + ++ concat + [ [ (G AnnOpenP, dp00), + (G AnnCloseP, dp00) + ] + | hsTypeNeedsParens sigPrec $ unLoc constraint + ] + return $ L lTop $ HsQualTy noExtField context (L l other) + +liftParseAST :: ASTElement ast => DynFlags -> String -> TransformT (Either String) (Located ast) +liftParseAST df s = case parseAST df "" s of + Right (anns, x) -> modifyAnnsT (anns <>) $> x + Left _ -> lift $ Left $ "No parse: " <> s + +lookupAnn :: (Data a, Monad m) => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) +lookupAnn comment la = do + anns <- getAnnsT + return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP + +dp00 :: DeltaPos +dp00 = DP (0, 0) + +headMaybe :: [a] -> Maybe a +headMaybe [] = Nothing +headMaybe (a : _) = Just a + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe other = Just $ last other diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index cedbda82fd..c71bef3c3c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -687,6 +687,7 @@ codeActionTests = testGroup "code actions" , removeRedundantConstraintsTests , addTypeAnnotationsToLiteralsTest , exportUnusedTests + , addImplicitParamsConstraintTests ] codeActionHelperFunctionTests :: TestTree @@ -2028,7 +2029,7 @@ addFunctionConstraintTests = let , "" , "data Pair a b = Pair a b" , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" ] @@ -2038,59 +2039,107 @@ addFunctionConstraintTests = let [ "module Testing where" , "data Pair a b = Pair a b" , "eq " - , " :: " <> constraint + , " :: (" <> constraint <> ")" , " => Pair a b -> Pair a b -> Bool" , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" ] - check :: String -> T.Text -> T.Text -> T.Text -> TestTree - check testName actionTitle originalCode expectedCode = testSession testName $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode + missingMonadConstraint constraint = T.unlines + [ "module Testing where" + , "f :: " <> constraint <> "m ()" + , "f = do " + , " return ()" + ] in testGroup "add function constraint" - [ check + [ checkCodeAction "no preexisting constraint" "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintSourceCode "") (missingConstraintSourceCode "Eq a => ") - , check + , checkCodeAction "no preexisting constraint, with forall" "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintWithForAllSourceCode "") (missingConstraintWithForAllSourceCode "Eq a => ") - , check + , checkCodeAction "preexisting constraint, no parenthesis" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCode "Eq a") (incompleteConstraintSourceCode "(Eq a, Eq b)") - , check + , checkCodeAction "preexisting constraints in parenthesis" "Add `Eq c` to the context of the type signature for `eq`" (incompleteConstraintSourceCode2 "(Eq a, Eq b)") (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") - , check + , checkCodeAction "preexisting constraints with forall" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintWithForAllSourceCode "Eq a") (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") - , check + , checkCodeAction "preexisting constraint, with extra spaces in context" "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithExtraCharsInContext "( Eq a )") - (incompleteConstraintSourceCodeWithExtraCharsInContext "(Eq a, Eq b)") - , check + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") + , checkCodeAction "preexisting constraint, with newlines in type signature" "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a)") - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a, Eq b)") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , checkCodeAction + "missing Monad constraint" + "Add `Monad m` to the context of the type signature for `f`" + (missingMonadConstraint "") + (missingMonadConstraint "Monad m => ") ] +checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree +checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + +addImplicitParamsConstraintTests :: TestTree +addImplicitParamsConstraintTests = + testGroup + "add missing implicit params constraints" + [ testGroup + "introduced" + [ let ex ctxtA = exampleCode "?a" ctxtA "" + in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), + let ex ctxA = exampleCode "x where x = ?a" ctxA "" + in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") + ], + testGroup + "inherited" + [ let ex = exampleCode "()" "?a::()" + in checkCodeAction + "with preexisting context" + "Add `?a::()` to the context of the type signature for `fCaller`" + (ex "Eq ()") + (ex "Eq (), ?a::()"), + let ex = exampleCode "()" "?a::()" + in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") + ] + ] + where + mkContext "" = "" + mkContext contents = "(" <> contents <> ") => " + + exampleCode bodyBase contextBase contextCaller = + T.unlines + [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", + "module Testing where", + "fBase :: " <> mkContext contextBase <> "()", + "fBase = " <> bodyBase, + "fCaller :: " <> mkContext contextCaller <> "()", + "fCaller = fBase" + ] removeRedundantConstraintsTests :: TestTree removeRedundantConstraintsTests = let header =