From 58f01b7ed68ed2d3a5e1876671eea821909d4b5b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sat, 9 Jan 2021 13:54:33 +0100 Subject: [PATCH 1/5] Make adding missing constraints work when 'forall' is present (fixes #1164) --- .../src/Development/IDE/Plugin/CodeAction.hs | 13 ++++---- ghcide/test/exe/Main.hs | 32 ++++++++++++++++++- 2 files changed, 38 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 3c1a73e752..05235eee48 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -803,12 +803,13 @@ suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecl | L _ (SigD _ (TypeSig _ identifiers (HsWC _ (HsIB _ locatedType)))) <- hsmodDecls , any (`isSameName` T.unpack typeSignatureName) $ fmap unLoc identifiers ] - srcSpanToRange $ case splitLHsQualTy locatedType 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 sig where we can write context - let start = srcSpanStart $ getLoc locatedType in mkSrcSpan start start + srcSpanToRange $ case splitLHsForAllTy locatedType of + (_{-ignore `forall` if present-}, typeBody) -> case splitLHsQualTy typeBody of + (L contextSrcSpan _ , _) -> + if isGoodSrcSpan contextSrcSpan + then contextSrcSpan -- The type signature has explicit context + else -- No explicit context, return SrcSpanqq at the start of type body (the part of type which follows the optional `forall`) + let start = srcSpanStart $ getLoc typeBody in mkSrcSpan start start isSameName :: IdP GhcPs -> String -> Bool isSameName x name = showSDocUnsafe (ppr x) == name diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 7173bbb69d..3c366cbb16 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1934,6 +1934,28 @@ addFunctionConstraintTests = let , "eq x y = x == y" ] + missingConstraintWithForAllSourceCode :: T.Text -> T.Text + missingConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "eq :: forall a. " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text + incompleteConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + incompleteConstraintSourceCode :: T.Text -> T.Text incompleteConstraintSourceCode constraint = T.unlines @@ -1982,7 +2004,7 @@ addFunctionConstraintTests = let check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) + actionsOrCommands <- getCodeActions doc (Range (Position 0 0) (Position 6 maxBound)) chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -1993,6 +2015,10 @@ addFunctionConstraintTests = let "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintSourceCode "") (missingConstraintSourceCode "Eq a => ") + , check + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintWithForAllSourceCode "") + (missingConstraintWithForAllSourceCode "Eq a => ") , check "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCode "Eq a") @@ -2001,6 +2027,10 @@ addFunctionConstraintTests = let "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 + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintWithForAllSourceCode "Eq a") + (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") , check "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCodeWithExtraCharsInContext "( Eq a )") From c8f001f1992a80159e34946da574c7b7ea97ee68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sat, 9 Jan 2021 14:22:30 +0100 Subject: [PATCH 2/5] Improve comment --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 05235eee48..1e5578be7b 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -808,7 +808,7 @@ suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecl (L contextSrcSpan _ , _) -> if isGoodSrcSpan contextSrcSpan then contextSrcSpan -- The type signature has explicit context - else -- No explicit context, return SrcSpanqq at the start of type body (the part of type which follows the optional `forall`) + 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 From c3edf3259b7be9f829c5d379b6a6c1ac10a0c5ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sat, 9 Jan 2021 14:42:50 +0100 Subject: [PATCH 3/5] Revert range change --- ghcide/test/exe/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 3c366cbb16..9d227e5c41 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2004,7 +2004,7 @@ addFunctionConstraintTests = let check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 0 0) (Position 6 maxBound)) + actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc From 8e3edcb089a45fb182b6b81966271932a3d76b25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sat, 9 Jan 2021 14:58:03 +0100 Subject: [PATCH 4/5] Don't use code action descr. as test name --- ghcide/test/exe/Main.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9d227e5c41..bfff9cac4f 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2000,8 +2000,8 @@ addFunctionConstraintTests = let , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" ] - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + 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)) @@ -2012,30 +2012,37 @@ addFunctionConstraintTests = let in testGroup "add function constraint" [ check + "no preexisting constraint" "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintSourceCode "") (missingConstraintSourceCode "Eq a => ") , check + "no preexisting constraint, with forall" "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintWithForAllSourceCode "") (missingConstraintWithForAllSourceCode "Eq a => ") , check + "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 + "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 + "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 + "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 + "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)") From d51747387b212dd10e390cd345a16c6d2664eb1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sat, 9 Jan 2021 17:20:44 +0100 Subject: [PATCH 5/5] GHC 8.10+ doesn't have splitLHsForAllTy --- ghcide/src/Development/IDE/GHC/Compat.hs | 11 ++++++++++- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 14 +++++++------- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 8091bdb9c1..1a72edba53 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -58,7 +58,7 @@ module Development.IDE.GHC.Compat( applyPluginsParsedResultAction, module Compat.HieTypes, module Compat.HieUtils, - + dropForAll ) where #if MIN_GHC_API_VERSION(8,10,0) @@ -283,3 +283,12 @@ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr #else pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif + +-- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body +dropForAll :: LHsType pass -> LHsType pass +#if MIN_GHC_API_VERSION(8,10,0) +dropForAll = snd . GHC.splitLHsForAllTyInvis +#else +dropForAll = snd . GHC.splitLHsForAllTy +#endif + diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 1e5578be7b..9b3bcd5703 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -803,13 +803,13 @@ suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecl | L _ (SigD _ (TypeSig _ identifiers (HsWC _ (HsIB _ locatedType)))) <- hsmodDecls , any (`isSameName` T.unpack typeSignatureName) $ fmap unLoc identifiers ] - srcSpanToRange $ case splitLHsForAllTy locatedType of - (_{-ignore `forall` if present-}, typeBody) -> 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 + 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