From 06b91daad0f29d417214900fbd11bfdb5b0ba81f Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Sun, 11 Sep 2022 19:27:07 +0200 Subject: [PATCH] support add to where --- .../src/Development/IDE/GHC/ExactPrint.hs | 34 +++ .../src/Development/IDE/Plugin/CodeAction.hs | 96 ++++++-- plugins/hls-refactor-plugin/test/Main.hs | 213 +++++++++++++++++- 3 files changed, 317 insertions(+), 26 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 67c1f89f323..2b1412b8afe 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -47,6 +47,7 @@ module Development.IDE.GHC.ExactPrint ExceptStringT (..), TransformT, Log(..), + insertAtStart', ) where @@ -109,6 +110,11 @@ import GHC.Parser.Annotation (AnnContext (..), DeltaPos (SameLine), EpaLocation (EpaDelta), deltaPos) +import GHC (DeltaPos(..)) +import GHC.Types.SrcLoc (generatedSrcSpan) +import GHC (Anchor(..)) +import GHC (AnchorOperation(..)) +import GHC (realSrcSpan) #endif #if MIN_VERSION_ghc(9,2,0) @@ -475,6 +481,34 @@ modifyMgMatchesT :: modifyMgMatchesT (MG xMg (L locMatches matches) originMg) f = do matches' <- mapM f matches pure $ MG xMg (L locMatches matches') originMg + +insertAtStart' :: (Monad m, HasDecls ast) => ast -> HsDecl GhcPs -> TransformT m ast +insertAtStart' old newDecl = do + srcs <- replicateM 5 uniqueSrcSpanT + liftT $ insertAt (insertDeclAtStart srcs) old . noLocA $ newDecl + where + insertDeclAtStart ssps (L _ newDecl) [] = [L (noAnnSrcSpanDP (ssps !! 0) (DifferentLine 1 4)) newDecl] + insertDeclAtStart _ (L _ newDecl) [L (SrcSpanAnn (EpAnn (Anchor dRealSpan (MovedAnchor (SameLine _))) dAnn dComments) dSpan) d] = + [ L (noAnnSrcSpanDP generatedSrcSpan (DifferentLine 1 2)) newDecl, + L (SrcSpanAnn (EpAnn (Anchor dRealSpan (MovedAnchor $ DifferentLine 1 0)) dAnn dComments) dSpan) d + ] + insertDeclAtStart ssps (L _ newDecl) (L (SrcSpanAnn (EpAnn (Anchor dRealSpan ancOp) dAnn dComments) dSpan) d:ds) = + let newDeclSpan = ssps !! 0 + newDecl' = L + (SrcSpanAnn + (EpAnn (Anchor dRealSpan ancOp) mempty emptyComments) + newDeclSpan) + newDecl + secondDecl' = L + (SrcSpanAnn + (EpAnn + (Anchor (realSrcSpan $ newDeclSpan) (MovedAnchor $ DifferentLine 1 0)) + dAnn + dComments) + dSpan) + d + in newDecl' : secondDecl' : ds + insertDeclAtStart _ d ds = d : ds #endif graftSmallestDeclsWithM :: diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 442ffcb253e..d365fc62289 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -1,6 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Plugin.CodeAction ( @@ -92,14 +92,17 @@ import qualified Text.Fuzzy.Parallel as TFP import Text.Regex.TDFA (mrAfter, (=~), (=~~)) #if MIN_VERSION_ghc(9,2,1) +import GHC (realSrcSpan) +import GHC.Parser.Annotation (emptyComments) import GHC.Types.SrcLoc (generatedSrcSpan) -import Language.Haskell.GHC.ExactPrint (noAnnSrcSpanDP1, - runTransformT) +import Language.Haskell.GHC.ExactPrint.Transform #endif #if MIN_VERSION_ghc(9,2,0) +import Control.Monad.Except (lift) +import Control.Monad.Identity (Identity (..)) import Extra (maybeToEither) import GHC (AddEpAnn (AddEpAnn), - Anchor (anchor_op), + Anchor (..), AnchorOperation (..), AnnsModule (am_main), DeltaPos (..), @@ -107,6 +110,7 @@ import GHC (AddEpAnn (Ad EpaLocation (..), LEpaComment, LocatedA) + #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos, @@ -177,7 +181,8 @@ bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ #endif , wrap suggestNewDefinition #if MIN_VERSION_ghc(9,2,1) - , wrap suggestAddArgument + , wrap (undefinedVariableCodeAction addAsLastArgument) + , wrap (undefinedVariableCodeAction addToWhere) #endif , wrap suggestDeleteUnusedBinding ] @@ -950,12 +955,30 @@ newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule #if MIN_VERSION_ghc(9,2,1) + +type UndefinedVariableCodeAction = ParsedModule -> Diagnostic -> Either ResponseError [(T.Text, [TextEdit])] + +type UndefinedVariableHandler = ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])] + -- When GHC tells us that a variable is not bound, it will tell us either: -- - there is an unbound variable with a given type -- - there is an unbound variable (GHC provides no type suggestion) +-- - there is a typed hole `_` -- --- When we receive either of these errors, we produce a text edit that will add a new argument (as a new pattern in the --- last position of each LHS of the top-level bindings for this HsDecl). +-- When we receive either of these errors, we can produce a text edit that will put this variable in scope, such as: +-- - Adding an argument binding +-- - Adding a binding in a where clause +-- - ... up to your creativity :) +undefinedVariableCodeAction :: UndefinedVariableHandler -> UndefinedVariableCodeAction +undefinedVariableCodeAction handler parsedModule Diagnostic {_message, _range} + | Just (name, typ) <- matchVariableNotInScope message = handler parsedModule _range name typ + | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = handler parsedModule _range name (Just typ) + | otherwise = pure [] + where + message = unifySpaces _message + +-- Handle unbound variables by adding a new argument as a new pattern in the last position of each LHS of the +-- top-level bindings for this HsDecl. -- -- TODO Include logic to also update the type signature of a binding -- @@ -964,17 +987,8 @@ newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ -- foo :: a -> b -> c -> d -- foo a b = \c -> ... -- In this case a new argument would have to add its type between b and c in the signature. -suggestAddArgument :: ParsedModule -> Diagnostic -> Either ResponseError [(T.Text, [TextEdit])] -suggestAddArgument parsedModule Diagnostic {_message, _range} - | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ - | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ) - | otherwise = pure [] - where - message = unifySpaces _message - --- TODO use typ to modify type signature -addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])] -addArgumentAction (ParsedModule _ parsedSource _ _) range name _typ = +addAsLastArgument :: UndefinedVariableHandler +addAsLastArgument (ParsedModule _ parsedSource _ _) range name _typ = do let addArgToMatch (L locMatch (Match xMatch ctxMatch pats rhs)) = do let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name @@ -986,17 +1000,55 @@ addArgumentAction (ParsedModule _ parsedSource _ _) range name _typ = let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind)) pure [decl'] decl -> pure [decl] - case runTransformT $ modifySmallestDeclWithM spanContainsRangeOrErr insertArg (makeDeltaAst parsedSource) of + case runTransformT $ modifySmallestDeclWithM (flip spanContainsRangeOrErr range) insertArg (makeDeltaAst parsedSource) of Left err -> Left err Right (newSource, _, _) -> let diff = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint newSource) in pure [("Add argument ‘" <> name <> "’ to function", fromLspList diff)] - where - spanContainsRangeOrErr = maybeToEither (responseError "SrcSpan was not valid range") . (`spanContainsRange` range) -#endif + +-- TODO use typ to initialise type signature +addToWhere :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])] +addToWhere (ParsedModule _ parsedSource _ _) range name _typ = do + let mkUnqual name = noLocA $ mkRdrUnqual $ mkVarOcc $ T.unpack name + equalAnn dp = AddEpAnn AnnEqual (EpaDelta dp []) + addArg = modifySmallestDeclWithM (flip spanContainsRangeOrErr range) $ \case + (L locDecl (ValD xVal (FunBind xFunBind idFunBind mg coreFunBind))) -> do + declMatchSrcSpan <- uniqueSrcSpanT + grhsSrcSpan <- uniqueSrcSpanT + mg' <- modifyMgMatchesT mg $ \match -> do + spanInRange <- lift $ getLoc match `spanContainsRangeOrErr` range + if spanInRange + then do + let grhs_ann = GrhsAnn Nothing $ equalAnn (SameLine 0) + rhs_hole = L (noAnnSrcSpanDP1 generatedSrcSpan) $ HsVar NoExtField (mkUnqual "_") + grhs = GRHS (EpAnn (generatedAnchor m1) grhs_ann emptyComments) [] rhs_hole + grhss = GRHSs emptyComments [L grhsSrcSpan grhs] (EmptyLocalBinds NoExtField) + newDeclMatchAnn = emptyEpAnnAnchor (generatedAnchor m0) + newDeclMatch = + noLocA (Match newDeclMatchAnn (FunRhs (mkUnqual name) Prefix SrcStrict) [] grhss) + newDeclMg = MG NoExtField (L (noAnnSrcSpanDP0 declMatchSrcSpan) [newDeclMatch]) Generated + newDecl = ValD xVal (FunBind NoExtField (mkUnqual name) newDeclMg []) + hoistTransform (Right . runIdentity) $ insertAtStart' match newDecl + else pure match + let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind)) + pure [decl'] + _ -> pure [] + (newSource, _, _) <- runTransformT $ addArg (makeDeltaAst parsedSource) + let diffText = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint newSource) + pure [("Add to where ‘" <> name <> "’", fromLspList diffText)] + +spanContainsRangeOrErr :: SrcSpan -> Range -> Either ResponseError Bool +spanContainsRangeOrErr srcSpan range = maybeToEither (responseError "SrcSpan was not valid range") . (`spanContainsRange` range) $ srcSpan + +generatedAnchor :: AnchorOperation -> Anchor +generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp + +emptyEpAnnAnchor :: Monoid a => Anchor -> EpAnn a +emptyEpAnnAnchor anchor = EpAnn anchor mempty emptyComments fromLspList :: List a -> [a] fromLspList (List a) = a +#endif suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] suggestFillTypeWildcard Diagnostic{_range=_range,..} diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 124f28acf1e..3a036948063 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3,9 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -312,7 +310,6 @@ codeActionTests = testGroup "code actions" , fillTypedHoleTests , addSigActionTests , insertNewDefinitionTests - , deleteUnusedDefinitionTests , addInstanceConstraintTests , addFunctionConstraintTests , removeRedundantConstraintsTests @@ -322,6 +319,7 @@ codeActionTests = testGroup "code actions" , removeExportTests #if MIN_VERSION_ghc(9,2,1) , addFunctionArgumentTests + , addToWhereTests #endif ] @@ -1511,7 +1509,10 @@ extendImportTests = testGroup "extend import actions" actionsOrCommands <- getCodeActions docB range let codeActions = filter - (liftA2 (&&) (T.isPrefixOf "Add") (not . T.isPrefixOf "Add argument") . codeActionTitle) + (liftA2 (&&) + (T.isPrefixOf "Add") + (\cmd -> not $ or $ fmap ($ cmd) [T.isPrefixOf "Add argument", T.isPrefixOf "Add to where"]) + . codeActionTitle) [ca | InR ca <- actionsOrCommands] actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the @@ -2376,6 +2377,210 @@ addFunctionArgumentTests = ] #endif +addToWhereTests :: TestTree +addToWhereTests = + testGroup + "add to where" + [ testSession "insert new where" $ do + let foo = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , "" + , "foo False = False" + ] + foo' = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , " _select = _" + , "" + , "foo False = False" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 4 0 4 50) + liftIO $ actionTitle @?= "Add to where ‘_select’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + , testSession "simple" $ do + let foo = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , " baz = 2" + , "foo False = False" + ] + foo' = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , " _select = _" + , " baz = 2" + , "foo False = False" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 4 0 4 50) + liftIO $ actionTitle @?= "Add to where ‘_select’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + , testSession "simple" $ do + let foo = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where baz = 2" + , "foo False = False" + ] + foo' = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , " _select = _" + , " baz = 2" + , "foo False = False" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 4 0 4 50) + liftIO $ actionTitle @?= "Add to where ‘_select’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + , testSession "simple" $ do + let foo = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , "foo False = False" + ] + foo' = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , " _select = _" + , "foo False = False" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 4 0 4 50) + liftIO $ actionTitle @?= "Add to where ‘_select’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + , testSession "empty where" $ do + let foo = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , "foo False = False" + ] + foo' = + [ "module Foo where" + , "" + , "bar = 1" + , "" + , "foo True = _select [True]" + , " where" + , " _select = _" + , "foo False = False" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 4 0 4 50) + liftIO $ actionTitle @?= "Add to where ‘_select’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + , testSession "untyped error" $ do + let foo = + ["module Foo where" + ,"" + ,"foo = select" + ] + foo' = + ["module Foo where" + ,"" + ,"foo = select" + , " where" + , " select = _" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 2 0 2 50) + liftIO $ actionTitle @?= "Add to where ‘select’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + , testSession "untyped error" $ do + let foo = + [ "module Foo where" + , "" + , "foo = bar" + , " where" + , " -- hi" + , " baz = 2" + ] + foo' = + [ "module Foo where" + , "" + , "foo = bar" + , " where" + , " bar = _" + , " " + , " -- hibaz = 2" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> + getCodeActions docB (R 2 0 2 50) + liftIO $ actionTitle @?= "Add to where ‘bar’" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines foo' + ] + deleteUnusedDefinitionTests :: TestTree deleteUnusedDefinitionTests = testGroup "delete unused definition action" [ testSession "delete unused top level binding" $