Merge pull request #771 from lorenzo/better-type-hole-actions

Improved the suggestions for typed holes actions

haskell-ide-engine.cabal

@@ -245,18 +245,18 @@ test-suite func-test
   main-is:             Main.hs
   other-modules:       CompletionSpec
                      , CommandSpec
-                     , CodeActionsSpec
                      , DeferredSpec
                      , DefinitionSpec
                      , DiagnosticsSpec
                      , FormatSpec
+                     , FunctionalCodeActionsSpec
+                     , FunctionalSpec
                      , HaReSpec
                      , HighlightSpec
                      , HoverSpec
                      , ReferencesSpec
                      , RenameSpec
                      , SymbolsSpec
-                     , Spec
 
                      , TestUtils
   build-depends:       aeson

src/Haskell/Ide/Engine/Plugin/GhcMod.hs

@@ -389,9 +389,27 @@ runGhcModCommand cmd =
 
 -- ---------------------------------------------------------------------
 
+newtype TypeDef = TypeDef T.Text deriving (Eq, Show)
+
+data FunctionSig =
+  FunctionSig { fsName :: !T.Text
+              , fsType :: !TypeDef
+              } deriving (Eq, Show)
+
+newtype ValidSubstitutions = ValidSubstitutions [FunctionSig] deriving (Eq, Show)
+
+newtype Bindings = Bindings [FunctionSig] deriving (Eq, Show)
+
+data TypedHoles =
+  TypedHoles { thDiag :: LSP.Diagnostic
+             , thWant :: TypeDef
+             , thSubstitutions :: ValidSubstitutions
+             , thBIndings :: Bindings
+             } deriving (Eq, Show)
+
 codeActionProvider :: CodeActionProvider
 codeActionProvider pid docId mfp r ctx = do
-  support <- clientSupportsDocumentChanges 
+  support <- clientSupportsDocumentChanges
   codeActionProvider' support pid docId mfp r ctx
 
 codeActionProvider' :: Bool -> CodeActionProvider
@@ -401,7 +419,7 @@ codeActionProvider' supportsDocChanges _ docId _ _ context =
       renameActions = map (uncurry mkRenamableAction) terms
       redundantTerms = mapMaybe getRedundantImports diags
       redundantActions = concatMap (uncurry mkRedundantImportActions) redundantTerms
-      typedHoleActions = map (uncurry mkTypedHoleAction) (concatMap getTypedHoles diags)
+      typedHoleActions = concatMap mkTypedHoleActions (mapMaybe getTypedHoles diags)
   in return $ IdeResponseOk (renameActions ++ redundantActions ++ typedHoleActions)
 
   where
@@ -457,18 +475,30 @@ codeActionProvider' supportsDocChanges _ docId _ _ context =
     getRedundantImports diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) = (diag,) <$> extractRedundantImport msg
     getRedundantImports _ = Nothing
 
-    mkTypedHoleAction :: LSP.Diagnostic -> T.Text -> LSP.CodeAction
-    mkTypedHoleAction diag sub = codeAction
-      where title = "Substitute with " <> sub
-            diags = LSP.List [diag]
-            edit = mkWorkspaceEdit [LSP.TextEdit (diag ^. LSP.range) sub]
-            kind = LSP.CodeActionQuickFix
-            codeAction = LSP.CodeAction title (Just kind) (Just diags) (Just edit) Nothing
-
-
-    getTypedHoles :: LSP.Diagnostic -> [(LSP.Diagnostic, T.Text)]
-    getTypedHoles diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) = map (diag,) $ extractHoleSubstitutions msg
-    getTypedHoles _ = []
+    mkTypedHoleActions :: TypedHoles -> [LSP.CodeAction]
+    mkTypedHoleActions (TypedHoles diag (TypeDef want) (ValidSubstitutions subs) (Bindings bindings))
+      | onlyErrorFuncs = substitutions <> suggestions
+      | otherwise = substitutions
+      where
+        onlyErrorFuncs = null
+                       $ (map fsName subs) \\ ["undefined", "error", "errorWithoutStackTrace"]
+        substitutions = map mkHoleAction subs
+        suggestions = map mkHoleAction bindings
+        mkHoleAction (FunctionSig name (TypeDef sig)) = codeAction
+          where title :: T.Text
+                title = "Substitute hole (" <> want <> ") with " <> name <> " (" <> sig <> ")"
+                diags = LSP.List [diag]
+                edit = mkWorkspaceEdit [LSP.TextEdit (diag ^. LSP.range) name]
+                kind = LSP.CodeActionQuickFix
+                codeAction = LSP.CodeAction title (Just kind) (Just diags) (Just edit) Nothing
+
+
+    getTypedHoles :: LSP.Diagnostic -> Maybe TypedHoles
+    getTypedHoles diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) =
+      case extractHoleSubstitutions msg of
+        Nothing -> Nothing
+        Just (want, subs, bindings) -> Just $ TypedHoles diag want subs bindings
+    getTypedHoles _ = Nothing
 
 extractRenamableTerms :: T.Text -> [T.Text]
 extractRenamableTerms msg
@@ -479,7 +509,7 @@ extractRenamableTerms msg
         -- Extract everything in between ‘ ’
         go t
           | t == "" = []
-          | "‘" `T.isPrefixOf` t = 
+          | "‘" `T.isPrefixOf` t =
             let rest = T.tail t
                 x = T.takeWhile (/= '’') rest
               in x:go rest
@@ -493,12 +523,63 @@ extractRedundantImport msg =
     else Nothing
   where firstLine = head (T.lines msg)
 
-extractHoleSubstitutions :: T.Text -> [T.Text]
+extractHoleSubstitutions :: T.Text -> Maybe (TypeDef, ValidSubstitutions, Bindings)
 extractHoleSubstitutions diag
   | "Found hole:" `T.isInfixOf` diag =
-      let ls = T.lines $ snd $ T.breakOnEnd "Valid substitutions include" diag
-        in map (T.strip . fst . T.breakOn " ::") $ filter (T.isInfixOf "::") ls
-  | otherwise = mempty
+      let (header, subsBlock) = T.breakOn "Valid substitutions include" diag
+          (foundHole, expr) = T.breakOn "In the expression:" header
+          expectedType = TypeDef
+                       . T.strip
+                       . fst
+                       . T.breakOn "\n"
+                       . keepAfter "::"
+                       $ foundHole
+          bindingsBlock = T.dropWhile (== '\n')
+                        . keepAfter "Relevant bindings include"
+                        $ expr
+          substitutions = extractSignatures
+                        . T.dropWhile (== '\n')
+                        . fromMaybe ""
+                        . T.stripPrefix "Valid substitutions include"
+                        $ subsBlock
+          bindings = extractSignatures bindingsBlock
+      in Just (expectedType, ValidSubstitutions substitutions, Bindings bindings)
+  | otherwise = Nothing
+  where
+    keepAfter prefix = fromMaybe ""
+                     . T.stripPrefix prefix
+                     . snd
+                     . T.breakOn prefix
+
+    extractSignatures :: T.Text -> [FunctionSig]
+    extractSignatures tBlock = map nameAndSig
+                              . catMaybes
+                              . gatherLastGroup
+                              . mapAccumL (groupSignatures (countSpaces tBlock)) T.empty
+                              . T.lines
+                              $ tBlock
+
+    countSpaces = T.length . T.takeWhile (== ' ')
+
+    groupSignatures indentSize acc line
+      | "(" `T.isPrefixOf` T.strip line = (acc, Nothing)
+      | countSpaces line == indentSize && acc /= T.empty = (T.strip line, Just acc)
+      | otherwise = (acc <> " " <> T.strip line, Nothing)
+
+    gatherLastGroup :: (T.Text, [Maybe T.Text]) -> [Maybe T.Text]
+    gatherLastGroup ("", groupped) = groupped
+    gatherLastGroup (lastGroup, groupped) = groupped ++ [Just lastGroup]
+
+    nameAndSig :: T.Text -> FunctionSig
+    nameAndSig t = FunctionSig extractName extractSig
+      where
+        extractName = T.strip . fst . T.breakOn "::" $ t
+        extractSig = TypeDef
+                   . T.strip
+                   . fst
+                   . T.breakOn "(bound at"
+                   . keepAfter "::"
+                   $ t
 
 -- ---------------------------------------------------------------------
 

test/functional/CodeActionsSpec.hs → test/functional/FunctionalCodeActionsSpec.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module CodeActionsSpec where
+module FunctionalCodeActionsSpec where
 
 import Control.Applicative.Combinators
 import Control.Lens hiding (List)
@@ -17,6 +17,7 @@ import qualified Language.Haskell.LSP.Types as LSP
 import qualified Language.Haskell.LSP.Types.Capabilities as C
 import Test.Hspec
 import TestUtils
+import Data.Monoid ((<>))
 
 spec :: Spec
 spec = describe "code actions" $ do
@@ -210,19 +211,28 @@ spec = describe "code actions" $ do
         \import Data.Maybe\n\
         \foo :: Int\n\
         \foo = fromJust (Just 3)\n"
-  
-  describe "typed hole code actions" $ 
-      it "works" $ when ghc84 $
+
+  describe "typed hole code actions" $ do
+      it "works" $
         runSession hieCommand fullCaps "test/testdata" $ do
           doc <- openDoc "TypedHoles.hs" "haskell"
           _ <- waitForDiagnosticsSource "ghcmod"
           cas <- map (\(CACodeAction x)-> x) <$> getAllCodeActions doc
 
-          liftIO $ map (^. title) cas `shouldMatchList`
-            [ "Substitute with undefined"
-            , "Substitute with maxBound"
-            , "Substitute with minBound"
-            ]
+          suggestion <-
+            if ghc84 then do
+              liftIO $ map (^. title) cas `shouldMatchList`
+                [ "Substitute hole (Int) with maxBound (forall a. Bounded a => a)"
+                , "Substitute hole (Int) with minBound (forall a. Bounded a => a)"
+                , "Substitute hole (Int) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)"
+                ]
+              return "maxBound"
+            else do
+              liftIO $ map (^. title) cas `shouldMatchList`
+                [ "Substitute hole (Int) with x ([Int])"
+                , "Substitute hole (Int) with foo ([Int] -> Int)"
+                ]
+              return "x"
 
           executeCodeAction $ head cas
 
@@ -231,7 +241,42 @@ spec = describe "code actions" $ do
           liftIO $ contents `shouldBe`
             "module TypedHoles where\n\
             \foo :: [Int] -> Int\n\
-            \foo x = maxBound"
+            \foo x = " <> suggestion
+
+      it "shows more suggestions" $
+        runSession hieCommand fullCaps "test/testdata" $ do
+          doc <- openDoc "TypedHoles2.hs" "haskell"
+          _ <- waitForDiagnosticsSource "ghcmod"
+          cas <- map (\(CACodeAction x)-> x) <$> getAllCodeActions doc
+
+          suggestion <-
+            if ghc84 then do
+              liftIO $ map (^. title) cas `shouldMatchList`
+                [ "Substitute hole (A) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)"
+                , "Substitute hole (A) with stuff (A -> A)"
+                , "Substitute hole (A) with x ([A])"
+                , "Substitute hole (A) with foo2 ([A] -> A)"
+                ]
+              return "undefined"
+          else do
+              liftIO $ map (^. title) cas `shouldMatchList`
+                [ "Substitute hole (A) with stuff (A -> A)"
+                , "Substitute hole (A) with x ([A])"
+                , "Substitute hole (A) with foo2 ([A] -> A)"
+                ]
+              return "stuff"
+
+          executeCodeAction $ head cas
+
+          contents <- documentContents doc
+
+          liftIO $ contents `shouldBe`
+            "module TypedHoles2 (foo2) where\n\
+            \newtype A = A Int\n\
+            \foo2 :: [A] -> A\n\
+            \foo2 x = " <> suggestion <> "\n\
+            \  where\n\
+            \    stuff (A a) = A (a + 1)\n"
 
 fromAction :: CAResult -> CodeAction
 fromAction (CACodeAction action) = action

test/functional/FunctionalSpec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=FunctionalSpec #-}

test/functional/Main.hs

@@ -1,10 +1,10 @@
 module Main where
 
 import Test.Hspec
-import qualified Spec
+import qualified FunctionalSpec
 import TestUtils
 
 main :: IO ()
 main = do
   setupStackFiles
-  withFileLogging "functional.log" $ hspec Spec.spec
+  withFileLogging "functional.log" $ hspec FunctionalSpec.spec

test/testdata/TypedHoles2.hs

@@ -0,0 +1,6 @@
+module TypedHoles2 (foo2) where
+newtype A = A Int
+foo2 :: [A] -> A
+foo2 x = _
+  where
+    stuff (A a) = A (a + 1)

test/testdata/typedHoleDiag2.txt

@@ -0,0 +1,17 @@
+• Found hole: _ :: A
+• In the expression: _
+  In an equation for ‘foo2’:
+      foo2 x
+        = _
+        where
+            stuff (A a) = A (a + 1)
+• Relevant bindings include
+    stuff :: A -> A (bound at test/testdata/TypedHoles2.hs:6:5)
+    x :: [A] (bound at test/testdata/TypedHoles2.hs:4:6)
+    foo2 :: [A] -> A (bound at test/testdata/TypedHoles2.hs:4:1)
+  Valid substitutions include
+    undefined :: forall (a :: TYPE r).
+                 GHC.Stack.Types.HasCallStack =>
+                 a
+      (imported from ‘Prelude’ at test/testdata/TypedHoles2.hs:1:8-18
+       (and originally defined in ‘GHC.Err’))

test/testdata/typedHoleDiag3.txt

@@ -0,0 +1,37 @@
+• Found hole: _ :: t -> FilePath
+  Where: ‘t’ is a rigid type variable bound by
+           the inferred type of
+             lintDockerfile :: [IgnoreRule]
+                               -> t
+                               -> IO (Either Language.Docker.Parser.Error [Rules.RuleCheck])
+           at app/Main.hs:(229,5)-(235,47)
+• In the expression: _
+  In the first argument of ‘Docker.parseFile’, namely
+    ‘(_ dockerFile)’
+  In a stmt of a 'do' block: ast <- Docker.parseFile (_ dockerFile)
+• Relevant bindings include
+    processedFile :: Either Language.Docker.Parser.Error Dockerfile
+                     -> Either Language.Docker.Parser.Error [Rules.RuleCheck]
+      (bound at app/Main.hs:233:9)
+    processRules :: Dockerfile -> [Rules.RuleCheck]
+      (bound at app/Main.hs:234:9)
+    ignoredRules :: Rules.RuleCheck -> Bool
+      (bound at app/Main.hs:235:9)
+    dockerFile :: t (bound at app/Main.hs:229:32)
+    ignoreRules :: [IgnoreRule] (bound at app/Main.hs:229:20)
+    lintDockerfile :: [IgnoreRule]
+                      -> t -> IO (Either Language.Docker.Parser.Error [Rules.RuleCheck])
+      (bound at app/Main.hs:229:5)
+    (Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)
+  Valid substitutions include
+    mempty :: forall a. Monoid a => a
+      (imported from ‘Prelude’ at app/Main.hs:5:8-11
+       (and originally defined in ‘GHC.Base’))
+    undefined :: forall (a :: TYPE r).
+                 GHC.Stack.Types.HasCallStack =>
+                 a
+      (imported from ‘Prelude’ at app/Main.hs:5:8-11
+       (and originally defined in ‘GHC.Err’))
+    idm :: forall m. Monoid m => m
+      (imported from ‘Options.Applicative’ at app/Main.hs:21:1-46
+       (and originally defined in ‘Options.Applicative.Builder’))