From 7d605b26dfda5aca7f32442f62b2792b80118704 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 12 Jan 2021 21:25:04 +0000 Subject: [PATCH 1/9] Cache annotated AST --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 34 ++++++++++++++----- ghcide/src/Development/IDE/GHC/Orphans.hs | 7 ++++ .../src/Development/IDE/Plugin/CodeAction.hs | 5 ++- 3 files changed, 37 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 175481741e..b1fc634b71 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.GHC.ExactPrint ( Graft(..), @@ -16,8 +17,11 @@ module Development.IDE.GHC.ExactPrint transformM, useAnnotatedSource, annotateParsedSource, + getAnnotatedParsedSourceRule, + GetAnnotatedParsedSource(..), ASTElement (..), ExceptStringT (..), + Annotated(..), ) where @@ -39,6 +43,9 @@ import Development.IDE.Core.Rules 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 @@ -54,19 +61,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 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..4b16eb31bf 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -30,6 +30,7 @@ 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.PositionIndexed import Development.IDE.Plugin.CodeAction.RuleTypes @@ -66,7 +67,9 @@ plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens rules :: Rules () -rules = rulePackageExports +rules = do + rulePackageExports + getAnnotatedParsedSourceRule -- | a command that blocks forever. Used for testing blockCommandId :: T.Text From de1b0e85f8128914ebbef95092cf2b5950f89dee Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 16 Jan 2021 19:00:11 +0000 Subject: [PATCH 2/9] instance ASTElement RdrName --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index b1fc634b71..9f79e8163f 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -54,6 +54,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 @@ -309,6 +310,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. From 38ce4c57e2aa64da60f90ea7f74b24b1bb1a5521 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 16 Jan 2021 18:56:28 +0000 Subject: [PATCH 3/9] appendConstraint + Rewrite abstraction The Rewrite abstraction is similar to D.IDE.GHC.ExactPrint.Graft but it does fewer things more efficiently: - It doesn't annotate things for you (so it doesn't destroy user format) - It doesn't provide a Monoid instance (for now) - It doesn't need a fully parsed source - It doesn't use SYB to perform the replacement - It doesn't diff to compute the result The use case is code actions where you don't have the SrcSpan that you need to edit at hand, and instead you need to traverse the AST manually to locate the declaration to edit --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/GHC/ExactPrint.hs | 5 + .../IDE/Plugin/CodeAction/ExactPrint.hs | 177 ++++++++++++++++++ 3 files changed, 183 insertions(+) create mode 100644 ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs 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/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 9f79e8163f..4abca28d14 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -10,6 +10,7 @@ module Development.IDE.GHC.ExactPrint graft, graftDecls, graftDeclsWithM, + annotate, hoistGraft, graftWithM, graftWithSmallestM, @@ -22,6 +23,9 @@ module Development.IDE.GHC.ExactPrint ASTElement (..), ExceptStringT (..), Annotated(..), + TransformT, + Anns, + Annotate, ) where @@ -325,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/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs new file mode 100644 index 0000000000..07bc47cf16 --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE CPP #-} +{-# 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 From d1b64bc3917553b7e391da3a359deaab99158db3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 12:09:01 +0000 Subject: [PATCH 4/9] Refactor suggest constraint code action to use exactprint Tweaking the suggest constraints tests to reflect the increased precision in whitespace preservation --- .../src/Development/IDE/Plugin/CodeAction.hs | 207 +++++++++--------- ghcide/test/exe/Main.hs | 12 +- 2 files changed, 107 insertions(+), 112 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 4b16eb31bf..4a938f56a3 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -32,6 +32,7 @@ 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 @@ -53,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 @@ -91,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 @@ -151,6 +170,16 @@ 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 + ] + suggestAction :: ExportsMap -> IdeOptions @@ -169,8 +198,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 @@ -178,6 +206,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,..} @@ -210,14 +256,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" @@ -687,13 +728,12 @@ 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 @@ -702,59 +742,43 @@ suggestConstraint parsedModule mContents diag@Diagnostic {..} 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 <> ")" - -- | 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 @@ -768,8 +792,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 @@ -792,43 +817,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/test/exe/Main.hs b/ghcide/test/exe/Main.hs index cedbda82fd..69f177ce6e 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2028,7 +2028,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,7 +2038,7 @@ 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'" ] @@ -2082,13 +2082,13 @@ addFunctionConstraintTests = let , check "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)") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") , check "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") ] removeRedundantConstraintsTests :: TestTree From 99e6ed69a6e12b01864638ca2b4809acf160126e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 11:38:17 +0000 Subject: [PATCH 5/9] Catch missing 'Monad m' constraints too --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 +- ghcide/test/exe/Main.hs | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 4a938f56a3..46307375c4 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -739,7 +739,7 @@ suggestConstraint df parsedModule diag@Diagnostic {..} where findMissingConstraint :: T.Text -> Maybe T.Text findMissingConstraint t = - let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from a use of" + let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement in matchRegexUnifySpaces t regex <&> last -- | Suggests a constraint for an instance declaration for which a constraint is missing. diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 69f177ce6e..47ef6c2733 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2043,6 +2043,13 @@ addFunctionConstraintTests = let , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" ] + missingMonadConstraint constraint = T.unlines + [ "module Testing where" + , "f :: " <> constraint <> "m ()" + , "f = do " + , " return ()" + ] + check :: String -> T.Text -> T.Text -> T.Text -> TestTree check testName actionTitle originalCode expectedCode = testSession testName $ do doc <- createDoc "Testing.hs" "haskell" originalCode @@ -2089,6 +2096,11 @@ addFunctionConstraintTests = let "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , check + "missing Monad constraint" + "Add `Monad m` to the context of the type signature for `f`" + (missingMonadConstraint "") + (missingMonadConstraint "Monad m => ") ] removeRedundantConstraintsTests :: TestTree From bf12e63dd7c91aa6f5afe49f16cfe18f3ebd7885 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 12:18:30 +0000 Subject: [PATCH 6/9] Suggestions for missing implicit parameters --- .../src/Development/IDE/Plugin/CodeAction.hs | 20 ++++- ghcide/test/exe/Main.hs | 73 ++++++++++++++----- 2 files changed, 74 insertions(+), 19 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 46307375c4..6ae7047adb 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -63,6 +63,7 @@ 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 @@ -178,6 +179,7 @@ suggestExactAction :: suggestExactAction df ps x = concat [ suggestConstraint df (astA ps) x + , suggestImplicitParameter (astA ps) x ] suggestAction @@ -740,7 +742,10 @@ suggestConstraint df parsedModule diag@Diagnostic {..} findMissingConstraint :: T.Text -> Maybe T.Text findMissingConstraint t = let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement - in matchRegexUnifySpaces t regex <&> last + 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 :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -784,6 +789,19 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing 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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 47ef6c2733..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 @@ -2050,59 +2051,95 @@ addFunctionConstraintTests = let , " return ()" ] - 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 - 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 + , 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") - , check + , 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 = From 267c426fdd780091c9b80e72eaa15ce5914f21ea Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 15:00:13 +0000 Subject: [PATCH 7/9] hlints --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 +- ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 6ae7047adb..e72f3dbf48 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -838,7 +838,7 @@ suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing , 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)] + = [(title, appendConstraint (T.unpack missingConstraint) sig)] | otherwise = [] where diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 07bc47cf16..5031321758 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -58,9 +57,8 @@ rewriteToEdit dflags uri anns (Rewrite dst f) = do HMap.fromList [ ( uri, List - [ ( TextEdit (fromJust $ srcSpanToRange dst) $ + [ TextEdit (fromJust $ srcSpanToRange dst) $ T.pack $ tail $ exactPrint ast anns - ) ] ) ] From 2bff53361c5b27c0da7a4ecd12485f0c40f34810 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 16:04:27 +0000 Subject: [PATCH 8/9] compat --- ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 5031321758..18caf7fa71 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -151,7 +151,7 @@ appendConstraint constraintT = go ] | hsTypeNeedsParens sigPrec $ unLoc constraint ] - return $ L lTop $ HsQualTy NoExtField context (L l other) + 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 From 04bcae1c76d37035d77c371ae5819eec5bfa7871 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 21:47:55 +0000 Subject: [PATCH 9/9] Include getAnnotatedParsedSourceRule in the main rule --- ghcide/src/Development/IDE/Core/Rules.hs | 2 ++ ghcide/src/Development/IDE/GHC/ExactPrint.hs | 2 +- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 1 - 3 files changed, 3 insertions(+), 2 deletions(-) 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 4abca28d14..46a1654933 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -43,7 +43,7 @@ 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 diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index e72f3dbf48..2422ccc64d 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -71,7 +71,6 @@ plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlers rules :: Rules () rules = do rulePackageExports - getAnnotatedParsedSourceRule -- | a command that blocks forever. Used for testing blockCommandId :: T.Text