Merge remote-tracking branch 'upstream/master' into opentelemetry

Author: pepeiborra

.azure/windows-stack.yml

@@ -14,8 +14,3 @@ allow-newer:
 	monoid-extras:base,
 	statestack:base,
 	svg-builder:base
-
--- To ensure the build get the version with the fix for
--- https://github.com/Avi-D-coder/implicit-hie/issues/17
-constraints: implicit-hie >= 0.1.2.3
-constraints: implicit-hie-cradle >= 0.3.0.0

azure-pipelines.yml

@@ -93,7 +93,7 @@ library
         ghc-paths,
         cryptohash-sha1 >=0.11.100 && <0.12,
         hie-bios >= 0.7.1 && < 0.8.0,
-        implicit-hie-cradle >= 0.3.0.0 && < 0.4,
+        implicit-hie-cradle >= 0.3.0.2 && < 0.4,
         base16-bytestring >=0.1.1 && <0.2
     if os(windows)
       build-depends:

cabal.project

@@ -72,11 +72,10 @@ produceCompletions = do
             (Just (ms,imps), Just sess) -> do
               let env = hscEnv sess
               -- We do this to be able to provide completions of items that are not restricted to the explicit list
-              let imps' = map dropListFromImportDecl imps
-              res <- liftIO $ tcRnImportDecls env imps'
+              res <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> imps)
               case res of
                   (_, Just rdrEnv) -> do
-                      cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps' parsedDeps
+                      cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps
                       return ([], Just cdata)
                   (_diag, _) ->
                       return ([], Nothing)

ghcide.cabal

@@ -1,6 +1,9 @@
 {-# LANGUAGE CPP #-}
 
 #include "ghc-api-version.h"
+#if MIN_GHC_API_VERSION (8,8,4)
+{-# LANGUAGE GADTs#-}
+#endif
 -- Mostly taken from "haskell-ide-engine"
 module Development.IDE.Plugin.Completions.Logic (
   CachedCompletions
@@ -11,7 +14,7 @@ module Development.IDE.Plugin.Completions.Logic (
 ) where
 
 import Control.Applicative
-import Data.Char (isUpper)
+import Data.Char (isAlphaNum, isUpper)
 import Data.Generics
 import Data.List.Extra as List hiding (stripPrefix)
 import qualified Data.Map  as Map
@@ -144,21 +147,44 @@ occNameToComKind ty oc
 showModName :: ModuleName -> T.Text
 showModName = T.pack . moduleNameString
 
+-- mkCompl :: IdeOptions -> CompItem -> CompletionItem
+-- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =
+--   CompletionItem label kind (List []) ((colon <>) <$> typeText)
+--     (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
+--     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
+--     Nothing Nothing Nothing Nothing Nothing
+
 mkCompl :: IdeOptions -> CompItem -> CompletionItem
-mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =
-  CompletionItem label kind (List []) ((colon <>) <$> typeText)
-    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
-    Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
-    Nothing Nothing Nothing Nothing Nothing
+mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} =
+  CompletionItem {_label = label,
+                  _kind = kind,
+                  _tags = List [],
+                  _detail = (colon <>) <$> typeText,
+                  _documentation = documentation,
+                  _deprecated = Nothing,
+                  _preselect = Nothing,
+                  _sortText = Nothing,
+                  _filterText = Nothing,
+                  _insertText = Just insertText,
+                  _insertTextFormat = Just Snippet,
+                  _textEdit = Nothing,
+                  _additionalTextEdits = List <$> additionalTextEdits,
+                  _commitCharacters = Nothing,
+                  _command = Nothing,
+                  _xdata = Nothing}
+
   where kind = Just compKind
         docs' = imported : spanDocToMarkdown docs
         imported = case importedFrom of
           Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"
           Right mod -> "*Defined in '" <> mod <> "'*\n"
         colon = if optNewColonConvention then ": " else ":: "
+        documentation = Just $ CompletionDocMarkup $
+                        MarkupContent MkMarkdown $
+                        T.intercalate sectionSeparator docs'
 
-mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> CompItem
-mkNameCompItem origName origMod thingType isInfix docs = CI{..}
+mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
+mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..}
   where
     compKind = occNameToComKind typeText $ occName origName
     importedFrom = Right $ showModName origMod
@@ -174,7 +200,7 @@ mkNameCompItem origName origMod thingType isInfix docs = CI{..}
     typeText
           | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
           | otherwise = Nothing
-
+    additionalTextEdits = imp >>= extendImportList (showGhc origName)
 
     stripForall :: T.Text -> T.Text
     stripForall t
@@ -236,11 +262,37 @@ mkPragmaCompl label insertText =
     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
 
+extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit]
+extendImportList name lDecl = let
+    f (Just range) ImportDecl {ideclHiding} = case ideclHiding of
+        Just (False, x)
+          | Set.notMember name (Set.fromList [show y| y <- unLoc x])
+          -> let
+            start_pos = _end range
+            new_start_pos = start_pos {_character = _character start_pos - 1}
+            -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules
+            new_range = Range new_start_pos new_start_pos
+            -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$)
+            alpha = all isAlphaNum $ filter (\c -> c /= '_') name
+            result = if alpha then name ++ ", "
+                else "(" ++ name ++ "), "
+            in Just [TextEdit new_range (T.pack result)]
+          | otherwise -> Nothing
+        _ -> Nothing  -- hiding import list and no list
+    f _ _ = Nothing
+    src_span = srcSpanToRange . getLoc $ lDecl
+    in f src_span . unLoc $ lDecl
+
+
 cacheDataProducer :: HscEnv -> Module -> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions
 cacheDataProducer packageState curMod rdrEnv limports deps = do
   let dflags = hsc_dflags packageState
       curModName = moduleName curMod
 
+      importMap = Map.fromList [
+          (getLoc imp, imp)
+          | imp <- limports ]
+
       iDeclToModName :: ImportDecl name -> ModuleName
       iDeclToModName = unLoc . ideclName
 
@@ -266,10 +318,11 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
 
       getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
       getComplsForOne (GRE n _ True _) =
-          (, mempty) <$> toCompItem curMod curModName n
+          (, mempty) <$> toCompItem curMod curModName n Nothing
       getComplsForOne (GRE n _ False prov) =
         flip foldMapM (map is_decl prov) $ \spec -> do
-          compItem <- toCompItem curMod (is_mod spec) n
+          let originalImportDecl = Map.lookup (is_dloc spec) importMap
+          compItem <- toCompItem curMod (is_mod spec) n originalImportDecl
           let unqual
                 | is_qual spec = []
                 | otherwise = compItem
@@ -280,8 +333,8 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
               origMod = showModName (is_mod spec)
           return (unqual,QualCompls qual)
 
-      toCompItem :: Module -> ModuleName -> Name -> IO [CompItem]
-      toCompItem m mn n = do
+      toCompItem :: Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]
+      toCompItem m mn n imp' = do
         docs <- getDocumentationTryGhc packageState curMod deps n
         ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
                 name' <- lookupName packageState m n
@@ -294,10 +347,10 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
         let recordCompls = case either (const Nothing) id record_ty of
                 Just (ctxStr, flds) -> case flds of
                     [] -> []
-                    _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs]
+                    _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs imp']
                 Nothing -> []
 
-        return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs] ++
+        return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs imp'] ++
                  recordCompls
 
   (unquals,quals) <- getCompls rdrElts
@@ -360,19 +413,17 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
         ]
 
     mkComp n ctyp ty =
-        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass])
+        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing
       where
         pn = ppr n
         doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)
 
     thisModName = ppr hsmodName
 
-    --recordCompls = localRecordSnippetProducer pm thisModName
-
 findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]
 findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result
     where
-        result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc
+        result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing
                  | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn
                  , Just  con_details <- [getFlds con_args]
                  , let field_names = mapMaybe extract con_details
@@ -468,7 +519,7 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
           endLoc = upperRange oldPos
           localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
           localBindsToCompItem :: Name -> Maybe Type -> CompItem
-          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ)
+          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing
             where
               occ = nameOccName name
               ctyp = occNameToComKind Nothing occ
@@ -665,8 +716,8 @@ safeTyThingForRecord (AConLike dc) =
         Just (ctxStr, field_names)
 safeTyThingForRecord _ = Nothing
 
-mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> CompItem
-mkRecordSnippetCompItem ctxStr compl mn docs = r
+mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
+mkRecordSnippetCompItem ctxStr compl mn docs imp = r
   where
       r  = CI {
             compKind = CiSnippet
@@ -677,6 +728,7 @@ mkRecordSnippetCompItem ctxStr compl mn docs = r
           , isInfix = Nothing
           , docs = docs
           , isTypeCompl = False
+          , additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr)
           }
 
       placeholder_pairs = zip compl ([1..]::[Int])

src/Development/IDE/Plugin/Completions.hs

@@ -8,7 +8,7 @@ import qualified Data.Text as T
 import SrcLoc
 
 import Development.IDE.Spans.Common
-import Language.Haskell.LSP.Types (CompletionItemKind)
+import Language.Haskell.LSP.Types (TextEdit, CompletionItemKind)
 
 -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
 
@@ -25,6 +25,7 @@ data CompItem = CI
                                    -- in the context of an infix notation.
   , docs         :: SpanDoc        -- ^ Available documentation.
   , isTypeCompl  :: Bool
+  , additionalTextEdits :: Maybe [TextEdit]
   }
   deriving (Eq, Show)
 

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

@@ -30,8 +30,8 @@ extra-deps:
 - dual-tree-0.2.2.1
 - force-layout-0.4.0.6
 - statestack-0.3
-- implicit-hie-0.1.2.3
-- implicit-hie-cradle-0.3.0.0
+- implicit-hie-0.1.2.5
+- implicit-hie-cradle-0.3.0.2
 
 nix:
   packages: [zlib]

src/Development/IDE/Plugin/Completions/Types.hs

@@ -30,8 +30,8 @@ extra-deps:
 - dual-tree-0.2.2.1
 - force-layout-0.4.0.6
 - statestack-0.3
-- implicit-hie-0.1.2.3
-- implicit-hie-cradle-0.3.0.0
+- implicit-hie-0.1.2.5
+- implicit-hie-cradle-0.3.0.2
 
 nix:
   packages: [zlib]