Do not show internal hole names (haskell/ghcide#852)

* Do not show internal hole names

* Better way to print holes as _

* Use suggestion by @alanz

* Remove unneeded import

* Give more time to suggestion tests

* Do not import GotoHover for testing suggestions

src/Development/IDE/Spans/AtPoint.hs

@@ -42,7 +42,6 @@ import           Data.List
 import qualified Data.Text as T
 import qualified Data.Map as M
 
-
 import Data.Either
 import Data.List.Extra (dropEnd1)
 
@@ -115,18 +114,22 @@ atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos ho
         prettyNames :: [T.Text]
         prettyNames = map prettyName names
         prettyName (Right n, dets) = T.unlines $
-          wrapHaskell (showName n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind))
+          wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind))
           : definedAt n
-          : catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
+          ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
                       ]
           where maybeKind = safeTyThingType =<< lookupNameEnv km n
         prettyName (Left m,_) = showName m
 
-
         prettyTypes = map (("_ :: "<>) . prettyType) types
         prettyType t = showName t
 
-        definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"
+        definedAt name =
+          -- do not show "at <no location info>" and similar messages
+          -- see the code of 'pprNameDefnLoc' for more information
+          case nameSrcLoc name of
+            UnhelpfulLoc {} | isInternalName name || isSystemName name -> []
+            _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"]
 
 typeLocationsAtPoint
   :: forall m

src/Development/IDE/Spans/Common.hs

@@ -6,6 +6,7 @@
 module Development.IDE.Spans.Common (
   showGhc
 , showName
+, showNameWithoutUniques
 , safeTyThingId
 , safeTyThingType
 , SpanDoc(..)
@@ -47,6 +48,13 @@ showName = T.pack . prettyprint
     prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
     style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
 
+showNameWithoutUniques :: Outputable a => a -> T.Text
+showNameWithoutUniques = T.pack . prettyprint
+  where
+    dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques
+    prettyprint x = renderWithStyle dyn (ppr x) style
+    style = mkUserStyle dyn neverQualify AllTheWay
+
 -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
 safeTyThingType :: TyThing -> Maybe Type
 safeTyThingType thing

test/data/hover/GotoHover.hs

@@ -55,3 +55,6 @@ outer = undefined inner where
 
 imported :: Bar
 imported = foo
+
+hole :: Int
+hole = _

test/exe/Main.hs

@@ -1115,7 +1115,7 @@ suggestImportTests = testGroup "suggest import actions"
     test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
       let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
           after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
-          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, GotoHover]}}"
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}"
       liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
       doc <- createDoc "Test.hs" "haskell" before
       void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
@@ -2184,7 +2184,9 @@ findDefinitionAndHoverTests = let
   mkFindTests tests = testGroup "get"
     [ testGroup "definition" $ mapMaybe fst tests
     , testGroup "hover"      $ mapMaybe snd tests
-    , checkFileCompiles sourceFilePath
+    , checkFileCompiles sourceFilePath $
+        expectDiagnostics
+          [ ( "GotoHover.hs", [(DsError, (59, 7), "Found hole: _")]) ]
     , testGroup "type-definition" typeDefinitionTests ]
 
   typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"
@@ -2234,6 +2236,7 @@ findDefinitionAndHoverTests = let
   lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]
   outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
   innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
+  holeL60 = Position 59 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]
   cccL17 = Position 17 11  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]]
   imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
   reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
@@ -2279,6 +2282,7 @@ findDefinitionAndHoverTests = let
   , test  no     broken docL41     constr        "type constraint in hover info   #283"
   , test  broken broken outL45     outSig        "top-level signature             #310"
   , test  broken broken innL48     innSig        "inner     signature             #310"
+  , test  no     yes    holeL60    hleInfo       "hole without internal name      #847"
   , test  no     yes    cccL17     docLink       "Haddock html links"
   , testM yes    yes    imported   importedSig   "Imported symbol"
   , testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"
@@ -2288,11 +2292,11 @@ findDefinitionAndHoverTests = let
         broken = Just . (`xfail` "known broken")
         no = const Nothing -- don't run this test at all
 
-checkFileCompiles :: FilePath -> TestTree
-checkFileCompiles fp =
+checkFileCompiles :: FilePath -> Session () -> TestTree
+checkFileCompiles fp diag =
   testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
     void (openTestDataDoc (dir </> fp))
-    expectNoMoreDiagnostics 0.5
+    diag
 
 pluginSimpleTests :: TestTree
 pluginSimpleTests =