Better docs for completions (#288)

* Remove JSON instances for completions, since we are not implementing "resolve"

* Remove completion resolve data from tests

* Better docs

* Fix tests

* Fix for 8.4

* Turn Haddock markup into Markdown

* Add types to completion items

* Make it work on 8.8 and 8.4

* Revert "Remove completion resolve data from tests"

This reverts commit 625d710f11db2215a886e0a75e35f646190d4b36.

* Revert "Remove JSON instances for completions, since we are not implementing "resolve""

This reverts commit 12ff27dce71d06ba2f74aa8b9695aea95368e1d2.

* Fix tests

* Require higher version of regex-pcre-builtin

* Replace Pandoc with direct conversion from Haddock to Markdown

* Show kinds of type constructors too

* A few fixed to Markdown conversion

* Check optNewColonConvention

* Fix build on 8.4 and 8.8

* More fixes for 8.4 and 8.8

* Check only the common part of the completion text

* Make icons consistent with Outline

* Test docs for completions

* Make constructors return the corresponding CompletionItem + tests for that behavior

* Make test work on 8.4

.hlint.yaml

@@ -83,6 +83,7 @@
     - Development.IDE.Import.FindImports
     - Development.IDE.LSP.CodeAction
     - Development.IDE.Spans.Calculate
+    - Development.IDE.Spans.Documentation
     - Main
 
 - flags:

ghcide.cabal

@@ -41,6 +41,7 @@ library
         extra,
         fuzzy,
         filepath,
+        haddock-library,
         hashable,
         haskell-lsp-types == 0.19.*,
         haskell-lsp == 0.19.*,

src/Development/IDE/Core/Completions.hs

@@ -7,7 +7,7 @@ module Development.IDE.Core.Completions (
 ) where
 
 import Control.Applicative
-import Data.Char (isSpace)
+import Data.Char (isSpace, isUpper)
 import Data.Generics
 import Data.List as List hiding (stripPrefix)
 import qualified Data.Map  as Map
@@ -33,6 +33,9 @@ import Language.Haskell.LSP.Types.Capabilities
 import qualified Language.Haskell.LSP.VFS as VFS
 import Development.IDE.Core.CompletionsTypes
 import Development.IDE.Spans.Documentation
+import Development.IDE.GHC.Util
+import Development.IDE.GHC.Error
+import Development.IDE.Types.Options
 
 -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
 
@@ -41,6 +44,12 @@ safeTyThingId (AnId i)                    = Just i
 safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
 safeTyThingId _                           = Nothing
 
+safeTyThingType :: TyThing -> Maybe Type
+safeTyThingType thing
+  | Just i <- safeTyThingId thing = Just (varType i)
+safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)
+safeTyThingType _                 = Nothing
+
 -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
 
 -- | A context of a declaration in the program
@@ -135,20 +144,26 @@ getCContext pos pm
           | otherwise = Nothing
         importInline _ _ = Nothing
 
-occNameToComKind :: OccName -> CompletionItemKind
-occNameToComKind oc
-  | isVarOcc  oc = CiFunction
-  | isTcOcc   oc = CiClass
+occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind
+occNameToComKind ty oc
+  | isVarOcc  oc = case occNameString oc of
+                     i:_ | isUpper i -> CiConstructor
+                     _               -> CiFunction
+  | isTcOcc   oc = case ty of
+                     Just t
+                       | "Constraint" `T.isSuffixOf` t 
+                       -> CiClass
+                     _ -> CiStruct
   | isDataOcc oc = CiConstructor
   | otherwise    = CiVariable
 
-mkCompl :: CompItem -> CompletionItem
-mkCompl CI{origName,importedFrom,thingType,label,isInfix,docs} =
-  CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)
-    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs)
+mkCompl :: IdeOptions -> CompItem -> CompletionItem
+mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
+  CompletionItem label kind ((colon <>) <$> typeText)
+    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
-  where kind = Just $ occNameToComKind $ occName origName
+  where kind = Just $ occNameToComKind typeText $ occName origName
         insertText = case isInfix of
             Nothing -> case getArgText <$> thingType of
                             Nothing -> label
@@ -159,6 +174,8 @@ mkCompl CI{origName,importedFrom,thingType,label,isInfix,docs} =
         typeText
           | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
           | otherwise = Nothing
+        docs' = ("*Defined in '" <> importedFrom <> "'*\n") : docs
+        colon = if optNewColonConvention then ": " else ":: "
 
 stripForall :: T.Text -> T.Text
 stripForall t
@@ -215,8 +232,8 @@ mkPragmaCompl label insertText =
     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
 
-cacheDataProducer :: DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
-cacheDataProducer dflags tm tcs = do
+cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
+cacheDataProducer packageState dflags tm tcs = do
   let parsedMod = tm_parsed_module tm
       curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
       Just (_,limports,_,_) = tm_renamed_source tm
@@ -242,42 +259,50 @@ cacheDataProducer dflags tm tcs = do
       rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm
       rdrElts = globalRdrEnvElts rdrEnv
 
-      getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls)
-      getCompls = foldMap getComplsForOne
+      foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
+      foldMapM f xs = foldr step return xs mempty where
+        step x r z = f x >>= \y -> r $! z `mappend` y
+
+      getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)
+      getCompls = foldMapM getComplsForOne
 
-      getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls)
+      getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
       getComplsForOne (GRE n _ True _) =
         case lookupTypeEnv typeEnv n of
           Just tt -> case safeTyThingId tt of
-            Just var -> ([varToCompl var],mempty)
-            Nothing -> ([toCompItem curMod n],mempty)
-          Nothing -> ([toCompItem curMod n],mempty)
+            Just var -> (\x -> ([x],mempty)) <$> varToCompl var
+            Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n
+          Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n
       getComplsForOne (GRE n _ False prov) =
-        flip foldMap (map is_decl prov) $ \spec ->
+        flip foldMapM (map is_decl prov) $ \spec -> do
+          compItem <- toCompItem (is_mod spec) n
           let unqual
                 | is_qual spec = []
-                | otherwise = compItem
+                | otherwise = [compItem]
               qual
-                | is_qual spec = Map.singleton asMod compItem
-                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
-              compItem = [toCompItem (is_mod spec) n]
+                | is_qual spec = Map.singleton asMod [compItem]
+                | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]
               asMod = showModName (is_as spec)
               origMod = showModName (is_mod spec)
-          in (unqual,QualCompls qual)
-
-      varToCompl :: Var -> CompItem
-      varToCompl var = CI name (showModName curMod) typ label Nothing docs
-        where
-          typ = Just $ varType var
-          name = Var.varName var
-          label = T.pack $ showGhc name
-          docs = getDocumentation tcs name
-
-      toCompItem :: ModuleName -> Name -> CompItem
-      toCompItem mn n =
-        CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing (getDocumentation tcs n)
-
-      (unquals,quals) = getCompls rdrElts
+          return (unqual,QualCompls qual)
+
+      varToCompl :: Var -> IO CompItem
+      varToCompl var = do
+        let typ = Just $ varType var
+            name = Var.varName var
+            label = T.pack $ showGhc name
+        docs <- getDocumentationTryGhc packageState (tm:tcs) name
+        return $ CI name (showModName curMod) typ label Nothing docs
+
+      toCompItem :: ModuleName -> Name -> IO CompItem
+      toCompItem mn n = do
+        docs <- getDocumentationTryGhc packageState (tm:tcs) n
+        ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do
+                name' <- lookupName n
+                return $ name' >>= safeTyThingType
+        return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs
+
+  (unquals,quals) <- getCompls rdrElts
 
   return $ CC
     { allModNamesAsNS = allModNamesAsNS
@@ -297,8 +322,8 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
   where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
 
 -- | Returns the cached completions for the given module and position.
-getCompletions :: CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
-getCompletions CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
+getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
+getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
                tm prefixInfo caps withSnippets = do
   let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
       enteredQual = if T.null prefixModule then "" else prefixModule <> "."
@@ -382,7 +407,7 @@ getCompletions CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules
         = filtPragmaCompls (pragmaSuffix fullLine)
         | otherwise
         = filtModNameCompls ++ map (toggleSnippets caps withSnippets
-                                      . mkCompl . stripAutoGenerated) filtCompls
+                                      . mkCompl ideOpts . stripAutoGenerated) filtCompls
 
   return result
 

src/Development/IDE/Core/Rules.hs

@@ -311,10 +311,11 @@ produceCompletions =
         deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
         tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
         tm <- fmap fst <$> useWithStale TypeCheck file
-        dflags <- fmap (hsc_dflags . hscEnv . fst) <$> useWithStale GhcSession file
-        case (tm, dflags) of
-            (Just tm', Just dflags') -> do
-                cdata <- liftIO $ cacheDataProducer dflags' (tmrModule tm') (map tmrModule tms)
+        packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
+        case (tm, packageState) of
+            (Just tm', Just packageState') -> do
+                cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')
+                                                    (tmrModule tm') (map tmrModule tms)
                 return ([], Just (cdata, tm'))
             _ -> return ([], Nothing)
 

src/Development/IDE/LSP/Completions.hs

@@ -27,15 +27,15 @@ getCompletionsLSP lsp ide CompletionParams{_textDocument=TextDocumentIdentifier
     case (contents, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath path
-        compls <- runAction ide (useWithStale ProduceCompletions npath)
+        (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)
         case compls of
           Just ((cci', tm'), mapping) -> do
             let position' = fromCurrentPosition mapping position
             pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
             case pfix of
               Just pfix' -> do
                 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
-                Completions . List <$> getCompletions cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
+                Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
               _ -> return (Completions $ List [])
           _ -> return (Completions $ List [])
       _ -> return (Completions $ List [])

src/Development/IDE/Spans/Documentation.hs

@@ -1,8 +1,12 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE CPP #-}
+#include "ghc-api-version.h"
+
 module Development.IDE.Spans.Documentation (
     getDocumentation
+  , getDocumentationTryGhc
   ) where
 
 import           Control.Monad
@@ -16,6 +20,28 @@ import           FastString
 import           GHC
 import SrcLoc
 
+#if MIN_GHC_API_VERSION(8,6,0)
+import           Data.Char (isSpace)
+import           Development.IDE.GHC.Util
+import qualified Documentation.Haddock.Parser as H
+import qualified Documentation.Haddock.Types as H
+#endif
+
+getDocumentationTryGhc
+  :: HscEnv
+  -> [TypecheckedModule]
+  -> Name
+  -> IO [T.Text]
+#if MIN_GHC_API_VERSION(8,6,0)
+getDocumentationTryGhc packageState tcs name = do
+  res <- runGhcEnv packageState $ catchSrcErrors "docs" $ getDocs name
+  case res of
+    Right (Right (Just docs, _)) -> return [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]
+    _ -> return $ getDocumentation tcs name
+#else
+getDocumentationTryGhc _packageState tcs name = do
+  return $ getDocumentation tcs name
+#endif
 
 getDocumentation
  :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
@@ -90,3 +116,81 @@ docHeaders = mapMaybe (\(L _ x) -> wrk x)
                             then Just $ T.pack s
                             else Nothing
     _ -> Nothing
+
+#if MIN_GHC_API_VERSION(8,6,0)
+-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
+haddockToMarkdown
+  :: H.DocH String String -> String
+
+haddockToMarkdown H.DocEmpty
+  = ""
+haddockToMarkdown (H.DocAppend d1 d2)
+  = haddockToMarkdown d1 <> haddockToMarkdown d2
+haddockToMarkdown (H.DocString s)
+  = s
+haddockToMarkdown (H.DocParagraph p)
+  = "\n\n" ++ haddockToMarkdown p
+haddockToMarkdown (H.DocIdentifier i)
+  = "`" ++ i ++ "`"
+haddockToMarkdown (H.DocIdentifierUnchecked i)
+  = "`" ++ i ++ "`"
+haddockToMarkdown (H.DocModule i)
+  = "`" ++ i ++ "`"
+haddockToMarkdown (H.DocWarning w)
+  = haddockToMarkdown w
+haddockToMarkdown (H.DocEmphasis d)
+  = "*" ++ haddockToMarkdown d ++ "*"
+haddockToMarkdown (H.DocBold d)
+  = "**" ++ haddockToMarkdown d ++ "**"
+haddockToMarkdown (H.DocMonospaced d)
+  = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"
+  where
+    escapeBackticks "" = ""
+    escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss
+    escapeBackticks (s  :ss) = s:escapeBackticks ss
+haddockToMarkdown (H.DocCodeBlock d)
+  = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"
+haddockToMarkdown (H.DocExamples es)
+  = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"
+  where
+    exampleToMarkdown (H.Example expr result)
+      = ">>> " ++ expr ++ "\n" ++ unlines result
+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
+  = "<" ++ url ++ ">"
+#if MIN_VERSION_haddock_library(1,8,0)
+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
+  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
+#else
+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
+  = "[" ++ label ++ "](" ++ url ++ ")"
+#endif
+haddockToMarkdown (H.DocPic (H.Picture url Nothing))
+  = "![](" ++ url ++ ")"
+haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
+  = "![" ++ label ++ "](" ++ url ++ ")"
+haddockToMarkdown (H.DocAName aname)
+  = "[" ++ aname ++ "]:"
+haddockToMarkdown (H.DocHeader (H.Header level title))
+  = replicate level '#' ++ " " ++ haddockToMarkdown title
+
+haddockToMarkdown (H.DocUnorderedList things)
+  = '\n' : (unlines $ map (\thing -> "+ " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
+haddockToMarkdown (H.DocOrderedList things)
+  = '\n' : (unlines $ map (\thing -> "1. " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
+haddockToMarkdown (H.DocDefList things)
+  = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
+
+-- we cannot render math by default
+haddockToMarkdown (H.DocMathInline _)
+  = "*cannot render inline math formula*"
+haddockToMarkdown (H.DocMathDisplay _)
+  = "\n\n*cannot render display math formula*\n\n"
+
+-- TODO: render tables
+haddockToMarkdown (H.DocTable _t)
+  = "\n\n*tables are not yet supported*\n\n"
+
+-- things I don't really know how to handle
+haddockToMarkdown (H.DocProperty _)
+  = ""  -- don't really know what to do
+#endif

stack.yaml

@@ -7,6 +7,7 @@ extra-deps:
 - lsp-test-0.10.0.0
 - hie-bios-0.3.2
 - fuzzy-0.1.0.0
+- regex-pcre-builtin-0.95.1.1.8.43
 - regex-base-0.94.0.0
 - regex-tdfa-1.3.1.0
 - parser-combinators-1.2.1

stack88.yaml

@@ -4,6 +4,7 @@ packages:
 extra-deps:
 - hie-bios-0.3.2
 - fuzzy-0.1.0.0
+- haddock-library-1.8.0
 allow-newer: true
 nix:
   packages: [zlib]