Fix Completion document format (#2848)

* Fix doc display

* Fix doc display

* Add tests

* Fix broken tests

* Remove extra docs

* Rerun tests

* Add spanDocToMarkdown doc

* Fix tests

* Adjust test for broken target

* Fix test

* Fix broken tests

* Unify tests

* Update spanDocToMarkdown doc

Co-authored-by: Pepe Iborra <[email protected]>

Author: July541

ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -204,7 +204,7 @@ mkCompl
   where kind = Just compKind
         docs' = imported : spanDocToMarkdown docs
         imported = case provenance of
-          Local pos  -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n'"
+          Local pos  -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n"
           ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n"
           DefinedIn mod -> "*Defined in '" <> mod <> "'*\n"
         colon = if optNewColonConvention then ": " else ":: "

ghcide/src/Development/IDE/Spans/Common.hs

@@ -62,7 +62,9 @@ safeTyThingId _                                = Nothing
 -- Possible documentation for an element in the code
 data SpanDoc
   = SpanDocString HsDocString SpanDocUris
+    -- ^ Extern module doc
   | SpanDocText   [T.Text] SpanDocUris
+    -- ^ Local module doc
   deriving stock (Eq, Show, Generic)
   deriving anyclass NFData
 
@@ -76,13 +78,33 @@ data SpanDocUris =
 emptySpanDoc :: SpanDoc
 emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)
 
+-- | Convert `SpanDoc` to Markdown format.
+--
+-- Return a list `Text` includes haddock, document uri and source code uri,
+-- each item can be empty and must end with '\\n' if exist. This is to prevent
+-- subsequent render problem caused by the missing newline.
+--
+-- Example:
+--
+-- For return value ["xxxx","yyyy"], if we concat the list with inserting
+-- a separate line(note by "---\n"),
+-- it will result "xxxx---\nyyyy" and can't be rendered as a normal doc.
+-- Therefore we check every item in the value to make sure they all end with '\\n',
+-- this makes "xxxx\n---\nyyy\n" and can be rendered correctly.
 spanDocToMarkdown :: SpanDoc -> [T.Text]
-spanDocToMarkdown (SpanDocString docs uris)
-  = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]
-    <> ["\n"] <> spanDocUrisToMarkdown uris
-  -- Append the extra newlines since this is markdown --- to get a visible newline,
-  -- you need to have two newlines
-spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris
+spanDocToMarkdown = \case
+    (SpanDocString docs uris) ->
+        let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs
+        in  go [doc] uris
+    (SpanDocText txt uris) -> go txt uris
+  where
+    go [] uris = render <$> spanDocUrisToMarkdown uris
+    go txt uris = init txt <> [render (last txt)] <> (render <$> spanDocUrisToMarkdown uris)
+    -- If the doc is not end with an '\n', we append it.
+    render txt
+      | T.null txt = txt
+      | T.last txt == '\n' = txt
+      | otherwise = txt <> T.pack "\n"
 
 spanDocUrisToMarkdown :: SpanDocUris -> [T.Text]
 spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes

ghcide/test/exe/Main.hs

@@ -124,6 +124,7 @@ import           Ide.PluginUtils                          (pluginDescToIdePlugin
 import           Ide.Types
 import qualified Language.LSP.Types                       as LSP
 import qualified Language.LSP.Types.Lens                  as L
+import           Language.LSP.Types.Lens                  (workspace, didChangeWatchedFiles)
 import qualified Progress
 import           System.Time.Extra
 import           Test.Tasty
@@ -133,7 +134,6 @@ import           Test.Tasty.Ingredients.Rerun
 import           Test.Tasty.QuickCheck
 import           Text.Printf                              (printf)
 import           Text.Regex.TDFA                          ((=~))
-import Language.LSP.Types.Lens (workspace, didChangeWatchedFiles)
 
 data Log
   = LogGhcIde Ghcide.Log
@@ -4615,6 +4615,7 @@ completionTests
     , testGroup "package" packageCompletionTests
     , testGroup "project" projectCompletionTests
     , testGroup "other" otherCompletionTests
+    , testGroup "doc" completionDocTests
     ]
 
 completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree
@@ -5067,7 +5068,7 @@ packageCompletionTests =
         _ <- waitForDiagnostics
         compls <- getCompletions doc (Position 2 12)
         let compls' =
-              [T.drop 1 $ T.dropEnd 10 d
+              [T.drop 1 $ T.dropEnd 3 d
               | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}
                 <- compls
               , _label == "fromList"
@@ -5087,7 +5088,7 @@ packageCompletionTests =
         _ <- waitForDiagnostics
         compls <- getCompletions doc (Position 2 7)
         let compls' =
-              [T.drop 1 $ T.dropEnd 10 d
+              [T.drop 1 $ T.dropEnd 3 d
               | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}
                 <- compls
               , _label == "Map"
@@ -5171,7 +5172,7 @@ projectCompletionTests =
             ]
         compls <- getCompletions doc (Position 1 10)
         let compls' =
-              [T.drop 1 $ T.dropEnd 10 d
+              [T.drop 1 $ T.dropEnd 3 d
               | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}
                 <- compls
               , _label == "anidentifier"
@@ -5230,6 +5231,97 @@ projectCompletionTests =
           item ^. L.label @?= "anidentifier"
     ]
 
+completionDocTests :: [TestTree]
+completionDocTests =
+  [ testSession "local define" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "foo = ()"
+        , "bar = fo"
+        ]
+      let expected = "*Defined at line 2, column 1 in this module*\n"
+      test doc (Position 2 8) "foo" Nothing [expected]
+  , testSession "local empty doc" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "foo = ()"
+        , "bar = fo"
+        ]
+      test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"]
+  , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "-- |docdoc"
+        , "foo = ()"
+        , "bar = fo"
+        ]
+      test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"]
+  , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "-- | abcabc"
+        , "--"
+        , "foo = ()"
+        , "bar = fo"
+        ]
+      test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"]
+  , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "-- |     abcabc"
+        , "--"
+        , "--def"
+        , "foo = ()"
+        , "bar = fo"
+        ]
+      test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n     abcabc\n\ndef\n"]
+  , testSession "extern empty doc" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "foo = od"
+        ]
+      let expected = "*Imported from 'Prelude'*\n"
+      test doc (Position 1 8) "odd" (Just $ T.length expected) [expected]
+  , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "foo = no"
+        ]
+      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n"
+      test doc (Position 1 8) "not" (Just $ T.length expected) [expected]
+  , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "foo = i"
+        ]
+      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n"
+      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]
+  , testSession "extern defined doc" $ do
+      doc <- createDoc "A.hs" "haskell" $ T.unlines
+        [ "module A where"
+        , "foo = i"
+        ]
+      let expected = "*Imported from 'Prelude'*\n"
+      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]
+  ]
+  where
+    brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92]) "Completion doc doesn't support ghc9"
+    brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2"
+    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903
+    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9"
+    test doc pos label mn expected = do
+      _ <- waitForDiagnostics
+      compls <- getCompletions doc pos
+      let compls' = [
+            -- We ignore doc uris since it points to the local path which determined by specific machines
+            case mn of
+                Nothing -> txt
+                Just n -> T.take n txt
+            | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls
+            , _label == label
+            ]
+      liftIO $ compls' @?= expected
+
 highlightTests :: TestTree
 highlightTests = testGroup "highlight"
   [ testSessionWait "value" $ do
@@ -5483,32 +5575,61 @@ xfail :: TestTree -> String -> TestTree
 xfail = flip expectFailBecause
 
 ignoreInWindowsBecause :: String -> TestTree -> TestTree
-ignoreInWindowsBecause
-    | isWindows = ignoreTestBecause
-    | otherwise = \_ x -> x
+ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)
 
 ignoreInWindowsForGHC88And810 :: TestTree -> TestTree
-ignoreInWindowsForGHC88And810
-    | ghcVersion `elem` [GHC88, GHC810] =
-        ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10"
-    | otherwise = id
+ignoreInWindowsForGHC88And810 =
+    ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10"
 
 ignoreForGHC92 :: String -> TestTree -> TestTree
-ignoreForGHC92 msg
-    | ghcVersion == GHC92 = ignoreTestBecause msg
-    | otherwise = id
+ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92])
 
 ignoreInWindowsForGHC88 :: TestTree -> TestTree
-ignoreInWindowsForGHC88
-    | ghcVersion == GHC88 =
-        ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8"
-    | otherwise = id
+ignoreInWindowsForGHC88 =
+    ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8"
 
 knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
-knownBrokenForGhcVersions ghcVers
-    | ghcVersion `elem` ghcVers = expectFailBecause
-    | otherwise = \_ x -> x
+knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)
+
+data BrokenOS = Linux | MacOS | Windows deriving (Show)
+
+data IssueSolution = Broken | Ignore deriving (Show)
+
+data BrokenTarget =
+    BrokenSpecific BrokenOS [GhcVersion]
+    -- ^Broken for `BrokenOS` with `GhcVersion`
+    | BrokenForOS BrokenOS
+    -- ^Broken for `BrokenOS`
+    | BrokenForGHC [GhcVersion]
+    -- ^Broken for `GhcVersion`
+    deriving (Show)
+
+-- | Ignore test for specific os and ghc with reason.
+ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree
+ignoreFor = knownIssueFor Ignore
+
+-- | Known broken for specific os and ghc with reason.
+knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree
+knownBrokenFor = knownIssueFor Broken
+
+-- | Deal with `IssueSolution` for specific OS and GHC.
+knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree
+knownIssueFor solution = go . \case
+    BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers
+    BrokenForOS bos -> isTargetOS bos
+    BrokenForGHC vers -> isTargetGhc vers
+    where
+        isTargetOS = \case
+            Windows -> isWindows
+            MacOS -> isMac
+            Linux -> not isWindows && not isMac
+
+        isTargetGhc = elem ghcVersion
 
+        go True = case solution of
+            Broken -> expectFailBecause
+            Ignore -> ignoreTestBecause
+        go False = \_ -> id
 
 data Expect
   = ExpectRange Range -- Both gotoDef and hover should report this range