From 6ad2a6d82ebd719076c39c595bac319788aa8d44 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Jul 2019 12:55:16 +0530 Subject: [PATCH 1/7] Simplify completions - missing type info for non local names --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 134 +++++++------------- 1 file changed, 45 insertions(+), 89 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index c2cc1a085..aaf70ffa5 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -50,9 +50,11 @@ import FastString import Finder import GHC hiding (getContext) import GHC.Generics (Generic) +import TcRnTypes +import RdrName import qualified GhcMod as GM (splits',SplitResult(..)) -import qualified GhcModCore as GM (GhcModError(..), listVisibleModuleNames,runLightGhc, withMappedFile ) +import qualified GhcModCore as GM (GhcModError(..), listVisibleModuleNames, withMappedFile ) import Haskell.Ide.Engine.ArtifactMap import Haskell.Ide.Engine.Config @@ -194,16 +196,25 @@ safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc safeTyThingId _ = Nothing -- Associates a module's qualifier with its members -type QualCompls = Map.Map T.Text [CompItem] +newtype QualCompls = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] } + +instance Semigroup QualCompls where + (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b + +instance Monoid QualCompls where + mempty = QualCompls Map.empty data CachedCompletions = CC { allModNamesAsNS :: [T.Text] , unqualCompls :: [CompItem] , qualCompls :: QualCompls , importableModules :: [T.Text] - , cachedExtensions :: [T.Text] } deriving (Typeable) +-- The supported languages and extensions +languagesAndExts :: [T.Text] +languagesAndExts = map T.pack GHC.supportedLanguagesAndExtensions + instance ModuleCache CachedCompletions where cacheDataProducer tm _ = do let parsedMod = tm_parsed_module tm @@ -227,11 +238,32 @@ instance ModuleCache CachedCompletions where -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclerations - -- The supported languages and extensions - languagesAndExts = map T.pack GHC.supportedLanguagesAndExtensions - - typeEnv = md_types $ snd $ tm_internals_ tm - toplevelVars = mapMaybe safeTyThingId $ typeEnvElts typeEnv + typeEnv = tcg_type_env $ fst $ tm_internals_ tm + rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm + rdrElts = globalRdrEnvElts rdrEnv + + getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls) + getCompls = foldMap getComplsForOne + + getComplsForOne :: GlobalRdrElt -> ([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) + getComplsForOne (GRE n _ False prov) = + flip foldMap (map is_decl prov) $ \spec -> + let unqual + | is_qual spec = [] + | otherwise = compItem + qual + | is_qual spec = Map.singleton asMod compItem + | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)] + compItem = [toCompItem (is_mod spec) n] + 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 @@ -240,92 +272,16 @@ instance ModuleCache CachedCompletions where name = Var.varName var label = T.pack $ showGhc name - toplevelCompls :: [CompItem] - toplevelCompls = map varToCompl toplevelVars - toCompItem :: ModuleName -> Name -> CompItem toCompItem mn n = CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing - allImportsInfo :: [(Bool, T.Text, ModuleName, Maybe (Bool, [Name]))] - allImportsInfo = map getImpInfo importDeclerations - where - getImpInfo imp = - let modName = iDeclToModName imp - modQual = showModName (asNamespace imp) - isQual = ideclQualified imp - hasHiddsMembers = - case ideclHiding imp of - Nothing -> Nothing - Just (hasHiddens, L _ liens) -> - Just (hasHiddens, concatMap (ieNames . unLoc) liens) - in (isQual, modQual, modName, hasHiddsMembers) - - getModCompls :: GhcMonad m => HscEnv -> m ([CompItem], QualCompls) - getModCompls hscEnv = do - (unquals, qualKVs) <- foldM (orgUnqualQual hscEnv) ([], []) allImportsInfo - return (unquals, Map.fromListWith (++) qualKVs) - - orgUnqualQual hscEnv (prevUnquals, prevQualKVs) (isQual, modQual, modName, hasHiddsMembers) = - let - ifUnqual xs = if isQual then prevUnquals else prevUnquals ++ xs - setTypes = setComplsType hscEnv - in - case hasHiddsMembers of - Just (False, members) -> do - compls <- setTypes (map (toCompItem modName) members) - return - ( ifUnqual compls - , (modQual, compls) : prevQualKVs - ) - Just (True , members) -> do - let hiddens = map (toCompItem modName) members - allCompls <- getComplsFromModName modName - compls <- setTypes (allCompls List.\\ hiddens) - return - ( ifUnqual compls - , (modQual, compls) : prevQualKVs - ) - Nothing -> do - -- debugm $ "///////// Nothing " ++ (show modQual) - compls <- setTypes =<< getComplsFromModName modName - return - ( ifUnqual compls - , (modQual, compls) : prevQualKVs - ) - - getComplsFromModName :: GhcMonad m - => ModuleName -> m [CompItem] - getComplsFromModName mn = do - mminf <- getModuleInfo =<< findModule mn Nothing - return $ case mminf of - Nothing -> [] - Just minf -> map (toCompItem mn) $ modInfoExports minf - - setComplsType :: (Traversable t, MonadIO m) - => HscEnv -> t CompItem -> m (t CompItem) - setComplsType hscEnv xs = - liftIO $ forM xs $ \ci@CI{origName} -> do - mt <- (Just <$> lookupGlobal hscEnv origName) - `catch` \(_ :: SourceError) -> return Nothing - let typ = do - t <- mt - tyid <- safeTyThingId t - return $ varType tyid - return $ ci { thingType = typ } - - hscEnvRef <- ghcSession <$> readMTS - hscEnv <- liftIO $ traverse readIORef hscEnvRef - (unquals, quals) <- maybe - (pure ([], Map.empty)) - (\env -> GM.runLightGhc env (getModCompls env)) - hscEnv + (unquals,quals) = getCompls rdrElts return $ CC { allModNamesAsNS = allModNamesAsNS - , unqualCompls = toplevelCompls ++ unquals + , unqualCompls = unquals , qualCompls = quals , importableModules = moduleNames - , cachedExtensions = languagesAndExts } newtype WithSnippets = WithSnippets Bool @@ -355,7 +311,7 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = fullPrefix = enteredQual <> prefixText ifCachedModuleAndData file (IdeResultOk []) - $ \tm CachedInfo { newPosToOld } CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules, cachedExtensions } -> + $ \tm CachedInfo { newPosToOld } CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules } -> let -- default to value context if no explicit context context = fromMaybe ValueContext $ getContext pos (tm_parsed_module tm) @@ -423,7 +379,7 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = compls = if T.null prefixModule then unqualCompls - else Map.findWithDefault [] prefixModule qualCompls + else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls mkImportCompl label = (J.detail ?~ label) . mkModCompl $ fromMaybe @@ -456,7 +412,7 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = | "import " `T.isPrefixOf` fullLine = filtImportCompls | "{-# language" `T.isPrefixOf` T.toLower fullLine - = filtOptsCompls cachedExtensions + = filtOptsCompls languagesAndExts | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine = filtOptsCompls (map (T.pack . stripLeading '-') $ GHC.flagsForCompletion False) | "{-# " `T.isPrefixOf` fullLine From a8a62ead95cc178c17852c7096db37d2ff35f30e Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Jul 2019 20:19:44 +0530 Subject: [PATCH 2/7] Implement resolving to fill in type and insert text for non local names --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 171 +++++++++++++++---- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 22 +-- 2 files changed, 139 insertions(+), 54 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index aaf70ffa5..b64401da1 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -8,6 +8,7 @@ module Haskell.Ide.Engine.Support.HieExtras ( getDynFlags , WithSnippets(..) , getCompletions + , resolveCompletion , getTypeForName , getSymbolsAtPoint , getReferencesInDoc @@ -26,7 +27,7 @@ module Haskell.Ide.Engine.Support.HieExtras ) where import ConLike -import Control.Lens.Operators ( (^?), (?~), (&) ) +import Control.Lens.Operators ( (.~), (^.), (^?), (?~), (&) ) import Control.Lens.Prism ( _Just ) import Control.Lens.Setter ((%~)) import Control.Lens.Traversal (traverseOf) @@ -62,7 +63,8 @@ import Haskell.Ide.Engine.Context import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginUtils -import qualified Haskell.Ide.Engine.Support.Fuzzy as Fuzzy +import qualified Haskell.Ide.Engine.Support.Fuzzy as Fuzzy +import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle import HscTypes import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J @@ -74,9 +76,11 @@ import Outputable (Outputable) import qualified Outputable as GHC import Packages import SrcLoc -import TcEnv import Type import Var +import Unique +import UniqFM +import Module hiding (getModule) -- --------------------------------------------------------------------- @@ -124,6 +128,67 @@ occNameToComKind oc | otherwise = J.CiVariable type HoogleQuery = T.Text +data CompItemResolveData + = CompItemResolveData + { nameDetails :: Maybe NameDetails + , hoogleQuery :: HoogleQuery + } deriving (Eq,Generic) + +data NameDetails + = NameDetails Unique Module + deriving (Eq) + +instance FromJSON NameDetails where + parseJSON v@(Array _) + = do + [uchar,uint,modname,modid] <- parseJSON v + ch <- parseJSON uchar + i <- parseJSON uint + mn <- parseJSON modname + mid <- parseJSON modid + pure $ NameDetails (mkUnique ch i) (mkModule (stringToUnitId mid) (mkModuleName mn)) + parseJSON _ = mempty +instance ToJSON NameDetails where + toJSON (NameDetails uniq mdl) = toJSON [toJSON ch,toJSON uint,toJSON mname,toJSON mid] + where + (ch,uint) = unpkUnique uniq + mname = moduleNameString $ moduleName mdl + mid = unitIdString $ moduleUnitId mdl + +instance FromJSON CompItemResolveData where + parseJSON = genericParseJSON $ customOptions 2 +instance ToJSON CompItemResolveData where + toJSON = genericToJSON $ customOptions 2 + +resolveCompletion :: J.CompletionItem -> IdeM J.CompletionItem +resolveCompletion origCompl = + case fromJSON <$> origCompl ^. J.xdata of + Just (J.Success (CompItemResolveData dets query)) -> do + mdocs <- Hoogle.infoCmd' query + let docText = case mdocs of + Right x -> Just x + _ -> Nothing + markup = J.MarkupContent J.MkMarkdown <$> docText + docs = J.CompletionDocMarkup <$> markup + (detail,insert) <- case dets of + Nothing -> pure (Nothing,Nothing) + Just (NameDetails uniq mdl) -> do + mtyp <- getTypeForNameDirectly uniq mdl + case mtyp of + Nothing -> pure (Nothing, Nothing) + Just typ -> do + let label = origCompl ^. J.label + insertText = label <> " " <> getArgText typ + det = Just . stripForall $ T.pack (showGhc typ) <> "\n" + pure (det,Just insertText) + return $ origCompl & J.documentation .~ docs + & J.insertText .~ insert + & J.detail .~ (detail <> origCompl ^. J.detail) + Just (J.Error err) -> do + debugm $ "resolveCompletion: Decoding data failed because of: " ++ err + pure origCompl + _ -> pure origCompl + mkQuery :: T.Text -> T.Text -> HoogleQuery mkQuery name importedFrom = name <> " module:" <> importedFrom @@ -133,50 +198,62 @@ mkCompl :: CompItem -> J.CompletionItem mkCompl CI{origName,importedFrom,thingType,label,isInfix} = J.CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom) Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet) - Nothing Nothing Nothing Nothing hoogleQuery + Nothing Nothing Nothing Nothing resolveData where kind = Just $ occNameToComKind $ occName origName - hoogleQuery = Just $ toJSON $ mkQuery label importedFrom - argTypes = maybe [] getArgs thingType + resolveData = Just $ toJSON $ CompItemResolveData nameDets hoogleQuery + hoogleQuery = mkQuery label importedFrom insertText = case isInfix of - Nothing -> case argTypes of - [] -> label - _ -> label <> " " <> argText + Nothing -> case getArgText <$> thingType of + Nothing -> label + Just argText -> label <> " " <> argText Just LeftSide -> label <> "`" Just Surrounded -> label - - argText :: T.Text - argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes - stripForall t - | T.isPrefixOf "forall" t = - -- We drop 2 to remove the '.' and the space after it - T.drop 2 (T.dropWhile (/= '.') t) - | otherwise = t - snippet :: Int -> Type -> T.Text - snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}" typeText | Just t <- thingType = Just . stripForall $ T.pack (showGhc t) | otherwise = Nothing - getArgs :: Type -> [Type] - getArgs t - | isPredTy t = [] - | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTys t) - | isFunTy t = - let (args, ret) = splitFunTys t - in if isForAllTy ret - then getArgs ret - else filter (not . isDictTy) args - | isPiTy t = getArgs $ snd (splitPiTys t) - | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) - | otherwise = [] + nameDets = + case (thingType, nameModule_maybe origName) of + (Just _,_) -> Nothing + (Nothing, Nothing) -> Nothing + (Nothing, Just mdl) -> Just (NameDetails (nameUnique origName) mdl) + +stripForall :: T.Text -> T.Text +stripForall t + | T.isPrefixOf "forall" t = + -- We drop 2 to remove the '.' and the space after it + T.drop 2 (T.dropWhile (/= '.') t) + | otherwise = t + +getArgText :: Type -> T.Text +getArgText typ = argText + where + argTypes = getArgs typ + argText :: T.Text + argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes + snippet :: Int -> Type -> T.Text + snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}" + getArgs :: Type -> [Type] + getArgs t + | isPredTy t = [] + | isDictTy t = [] + | isForAllTy t = getArgs $ snd (splitForAllTys t) + | isFunTy t = + let (args, ret) = splitFunTys t + in if isForAllTy ret + then getArgs ret + else filter (not . isDictTy) args + | isPiTy t = getArgs $ snd (splitPiTys t) + | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) + | otherwise = [] mkModCompl :: T.Text -> J.CompletionItem mkModCompl label = J.CompletionItem label (Just J.CiModule) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing hoogleQuery - where hoogleQuery = Just $ toJSON $ "module:" <> label + Nothing Nothing Nothing Nothing (Just $ toJSON resolveData) + where hoogleQuery = "module:" <> label + resolveData = Just $ CompItemResolveData Nothing hoogleQuery mkExtCompl :: T.Text -> J.CompletionItem mkExtCompl label = @@ -445,16 +522,36 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = -- --------------------------------------------------------------------- getTypeForName :: Name -> IdeM (Maybe Type) -getTypeForName n = do +getTypeForName n = case nameModule_maybe n of + Nothing -> pure Nothing + Just mdl -> getTypeForNameDirectly (nameUnique n) mdl + +getTypeForNameDirectly :: Unique -> Module -> IdeM (Maybe Type) +getTypeForNameDirectly n m = do hscEnvRef <- ghcSession <$> readMTS mhscEnv <- liftIO $ traverse readIORef hscEnvRef case mhscEnv of Nothing -> return Nothing Just hscEnv -> do - mt <- liftIO $ (Just <$> lookupGlobal hscEnv n) - `catch` \(_ :: SomeException) -> return Nothing + mt <- liftIO $ lookupGlobalDirectly hscEnv n m return $ fmap varType $ safeTyThingId =<< mt +lookupTypeDirectly + :: HomePackageTable + -> PackageTypeEnv + -> Unique + -> Module + -> Maybe TyThing +lookupTypeDirectly hpt pte name mdl + = case lookupHptByModule hpt mdl of + Just hm -> lookupUFM_Directly (md_types (hm_details hm)) name + Nothing -> lookupUFM_Directly pte name + +lookupGlobalDirectly :: HscEnv -> Unique -> Module -> IO (Maybe TyThing) +lookupGlobalDirectly hsc_env name mdl = do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupTypeDirectly (hsc_HPT hsc_env) (eps_PTE eps) name mdl + -- --------------------------------------------------------------------- getSymbolsAtPoint :: Position -> CachedInfo -> [(Range,Name)] diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 59272dc42..3ec5bd81e 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -19,7 +19,7 @@ import Control.Concurrent import Control.Concurrent.STM.TChan import qualified Control.Exception as E import qualified Control.FoldDebounce as Debounce -import Control.Lens ( (^.), (.~) ) +import Control.Lens ( (^.) ) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -30,7 +30,6 @@ import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) import Data.Default import Data.Foldable -import Data.Function import qualified Data.Map as Map import Data.Maybe import Data.Semigroup (Semigroup(..), Option(..), option) @@ -649,22 +648,11 @@ reactor inp diagIn = do ReqCompletionItemResolve req -> do liftIO $ U.logs $ "reactor:got CompletionItemResolveRequest:" ++ show req let origCompl = req ^. J.params - mquery = case J.fromJSON <$> origCompl ^. J.xdata of - Just (J.Success q) -> Just q - _ -> Nothing - callback docText = do - let markup = J.MarkupContent J.MkMarkdown <$> docText - docs = J.CompletionDocMarkup <$> markup - rspMsg = Core.makeResponseMessage req $ - origCompl & J.documentation .~ docs + callback res = do + let rspMsg = Core.makeResponseMessage req $ res reactorSend $ RspCompletionItemResolve rspMsg - hreq = IReq tn (req ^. J.id) callback $ runIdeResultT $ case mquery of - Nothing -> return Nothing - Just query -> do - result <- lift $ lift $ Hoogle.infoCmd' query - case result of - Right x -> return $ Just x - _ -> return Nothing + hreq = IReq tn (req ^. J.id) callback $ runIdeResultT $ do + lift $ lift $ Hie.resolveCompletion origCompl makeRequest hreq -- ------------------------------- From d7e5da6b214050446c3d29cb19c9282c7a3b9cb9 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Jul 2019 22:20:45 +0530 Subject: [PATCH 3/7] Fix tests --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 4 +- test/functional/CompletionSpec.hs | 75 +++++++++++++++++---- test/testdata/completion/Completion.hs | 8 ++- 3 files changed, 70 insertions(+), 17 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index b64401da1..757212ba2 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -156,9 +156,9 @@ instance ToJSON NameDetails where mid = unitIdString $ moduleUnitId mdl instance FromJSON CompItemResolveData where - parseJSON = genericParseJSON $ customOptions 2 + parseJSON = genericParseJSON $ customOptions 0 instance ToJSON CompItemResolveData where - toJSON = genericToJSON $ customOptions 2 + toJSON = genericToJSON $ customOptions 0 resolveCompletion :: J.CompletionItem -> IdeM J.CompletionItem resolveCompletion origCompl = diff --git a/test/functional/CompletionSpec.hs b/test/functional/CompletionSpec.hs index e703b5923..68f130d54 100644 --- a/test/functional/CompletionSpec.hs +++ b/test/functional/CompletionSpec.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module CompletionSpec where import Control.Applicative.Combinators @@ -25,9 +26,47 @@ spec = describe "completions" $ do liftIO $ do item ^. label `shouldBe` "putStrLn" item ^. kind `shouldBe` Just CiFunction - item ^. detail `shouldBe` Just "String -> IO ()\nPrelude" - item ^. insertTextFormat `shouldBe` Just Snippet - item ^. insertText `shouldBe` Just "putStrLn ${1:String}" + item ^. detail `shouldBe` Just "Prelude" + resolvedRes <- request CompletionItemResolve item + let Just (resolved :: CompletionItem) = resolvedRes ^. result + liftIO $ do + resolved ^. label `shouldBe` "putStrLn" + resolved ^. kind `shouldBe` Just CiFunction + resolved ^. detail `shouldBe` Just "String -> IO ()\nPrelude" + resolved ^. insertTextFormat `shouldBe` Just Snippet + resolved ^. insertText `shouldBe` Just "putStrLn ${1:String}" + + it "does not pull in unnecessary modules until needed" $ + runSession hieCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- skipManyTill loggingNotification (count 2 noDiagnostics) + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "enum" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "enumFrom") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Just (resolved :: CompletionItem) = resolvedRes ^. result + liftIO $ do + resolved ^. label `shouldBe` "enumFrom" + resolved ^. kind `shouldBe` Just CiFunction + resolved ^. detail `shouldBe` Just "Prelude" + resolved ^. insertText `shouldBe` Nothing + + let te2 = TextEdit (Range (Position 5 7) (Position 5 11)) "putStrLn (enumFrom 'a')" + _ <- applyEdit doc te2 + _ <- skipManyTill loggingNotification (count 2 noDiagnostics) + + compls2 <- getCompletions doc (Position 5 22) + let item2 = head $ filter ((== "enumFrom") . (^. label)) compls2 + resolvedRes2 <- request CompletionItemResolve item2 + let Just (resolved2 :: CompletionItem) = resolvedRes2 ^. result + liftIO $ do + resolved2 ^. label `shouldBe` "enumFrom" + resolved2 ^. kind `shouldBe` Just CiFunction + resolved2 ^. detail `shouldBe` Just "Enum a => a -> [a]\nPrelude" + resolved2 ^. insertText `shouldBe` Just "enumFrom ${1:a}" it "completes imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -193,8 +232,10 @@ spec = describe "completions" $ do _ <- applyEdit doc te compls <- getCompletions doc (Position 5 9) let item = head $ filter ((== "id") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Just (resolved :: CompletionItem) = resolvedRes ^. result liftIO $ - item ^. detail `shouldBe` Just "a -> a\nPrelude" + resolved ^. detail `shouldBe` Just "a -> a\nPrelude" it "have implicit foralls with multiple type variables" $ runSession hieCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -203,8 +244,10 @@ spec = describe "completions" $ do _ <- applyEdit doc te compls <- getCompletions doc (Position 5 11) let item = head $ filter ((== "flip") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Just (resolved :: CompletionItem) = resolvedRes ^. result liftIO $ - item ^. detail `shouldBe` Just "(a -> b -> c) -> b -> a -> c\nPrelude" + resolved ^. detail `shouldBe` Just "(a -> b -> c) -> b -> a -> c\nPrelude" describe "snippets" $ do it "work for argumentless constructors" $ runSession hieCommand fullCaps "test/testdata/completion" $ do @@ -229,11 +272,13 @@ spec = describe "completions" $ do compls <- getCompletions doc (Position 5 11) let item = head $ filter ((== "foldl") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Just (resolved :: CompletionItem) = resolvedRes ^. result liftIO $ do - item ^. label `shouldBe` "foldl" - item ^. kind `shouldBe` Just CiFunction - item ^. insertTextFormat `shouldBe` Just Snippet - item ^. insertText `shouldBe` Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" + resolved ^. label `shouldBe` "foldl" + resolved ^. kind `shouldBe` Just CiFunction + resolved ^. insertTextFormat `shouldBe` Just Snippet + resolved ^. insertText `shouldBe` Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" it "work for complex types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -244,11 +289,13 @@ spec = describe "completions" $ do compls <- getCompletions doc (Position 5 11) let item = head $ filter ((== "mapM") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Just (resolved :: CompletionItem) = resolvedRes ^. result liftIO $ do - item ^. label `shouldBe` "mapM" - item ^. kind `shouldBe` Just CiFunction - item ^. insertTextFormat `shouldBe` Just Snippet - item ^. insertText `shouldBe` Just "mapM ${1:a -> m b} ${2:t a}" + resolved ^. label `shouldBe` "mapM" + resolved ^. kind `shouldBe` Just CiFunction + resolved ^. insertTextFormat `shouldBe` Just Snippet + resolved ^. insertText `shouldBe` Just "mapM ${1:a -> m b} ${2:t a}" it "work for infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" diff --git a/test/testdata/completion/Completion.hs b/test/testdata/completion/Completion.hs index d6480903b..2d778cf8d 100644 --- a/test/testdata/completion/Completion.hs +++ b/test/testdata/completion/Completion.hs @@ -6,4 +6,10 @@ main :: IO () main = putStrLn "hello" foo :: Either a b -> Either a b -foo = id \ No newline at end of file +foo = id + +bar :: Int +bar = foldl (-) 0 [1,2,3] + +baz :: [String] +baz = mapM head [["a"]] From 2007d6549835b9274ab797031fa7000653d17af4 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 23 Jul 2019 17:47:33 +0530 Subject: [PATCH 4/7] Fix compilation on 8.2, lookup types from interface file when requested --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 85 ++++++++++++--------- test/functional/CompletionSpec.hs | 32 -------- test/testdata/completion/Completion.hs | 8 +- 3 files changed, 50 insertions(+), 75 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 757212ba2..41bdccad0 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -26,6 +26,7 @@ module Haskell.Ide.Engine.Support.HieExtras , getFormattingPlugin ) where +import Data.Semigroup (Semigroup) import ConLike import Control.Lens.Operators ( (.~), (^.), (^?), (?~), (&) ) import Control.Lens.Prism ( _Just ) @@ -72,14 +73,14 @@ import qualified Language.Haskell.LSP.VFS as VFS import Language.Haskell.Refact.API (showGhc) import Language.Haskell.Refact.Utils.MonadFunctions import Name +import NameCache import Outputable (Outputable) import qualified Outputable as GHC import Packages import SrcLoc +import TcEnv import Type import Var -import Unique -import UniqFM import Module hiding (getModule) -- --------------------------------------------------------------------- @@ -135,25 +136,41 @@ data CompItemResolveData } deriving (Eq,Generic) data NameDetails - = NameDetails Unique Module + = NameDetails Module OccName deriving (Eq) +nsJSON :: NameSpace -> Value +nsJSON ns + | isVarNameSpace ns = String "v" + | isDataConNameSpace ns = String "c" + | isTcClsNameSpace ns = String "t" + | isTvNameSpace ns = String "z" + | otherwise = error "namespace not recognized" + +parseNs :: Value -> J.Parser NameSpace +parseNs (String "v") = pure Name.varName +parseNs (String "c") = pure dataName +parseNs (String "t") = pure tcClsName +parseNs (String "z") = pure tvName +parseNs _ = mempty + instance FromJSON NameDetails where parseJSON v@(Array _) = do - [uchar,uint,modname,modid] <- parseJSON v - ch <- parseJSON uchar - i <- parseJSON uint + [modname,modid,namesp,occname] <- parseJSON v mn <- parseJSON modname mid <- parseJSON modid - pure $ NameDetails (mkUnique ch i) (mkModule (stringToUnitId mid) (mkModuleName mn)) + ns <- parseNs namesp + occn <- parseJSON occname + pure $ NameDetails (mkModule (stringToUnitId mid) (mkModuleName mn)) (mkOccName ns occn) parseJSON _ = mempty instance ToJSON NameDetails where - toJSON (NameDetails uniq mdl) = toJSON [toJSON ch,toJSON uint,toJSON mname,toJSON mid] + toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs] where - (ch,uint) = unpkUnique uniq mname = moduleNameString $ moduleName mdl mid = unitIdString $ moduleUnitId mdl + ns = occNameSpace occ + occs = occNameString occ instance FromJSON CompItemResolveData where parseJSON = genericParseJSON $ customOptions 0 @@ -172,8 +189,8 @@ resolveCompletion origCompl = docs = J.CompletionDocMarkup <$> markup (detail,insert) <- case dets of Nothing -> pure (Nothing,Nothing) - Just (NameDetails uniq mdl) -> do - mtyp <- getTypeForNameDirectly uniq mdl + Just nd -> do + mtyp <- getTypeForNameDetails nd case mtyp of Nothing -> pure (Nothing, Nothing) Just typ -> do @@ -216,7 +233,7 @@ mkCompl CI{origName,importedFrom,thingType,label,isInfix} = case (thingType, nameModule_maybe origName) of (Just _,_) -> Nothing (Nothing, Nothing) -> Nothing - (Nothing, Just mdl) -> Just (NameDetails (nameUnique origName) mdl) + (Nothing, Just mdl) -> Just (NameDetails mdl (nameOccName origName)) stripForall :: T.Text -> T.Text stripForall t @@ -280,6 +297,7 @@ instance Semigroup QualCompls where instance Monoid QualCompls where mempty = QualCompls Map.empty + mappend = (<>) data CachedCompletions = CC { allModNamesAsNS :: [T.Text] @@ -522,35 +540,30 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = -- --------------------------------------------------------------------- getTypeForName :: Name -> IdeM (Maybe Type) -getTypeForName n = case nameModule_maybe n of - Nothing -> pure Nothing - Just mdl -> getTypeForNameDirectly (nameUnique n) mdl +getTypeForName n = do + hscEnvRef <- ghcSession <$> readMTS + mhscEnv <- liftIO $ traverse readIORef hscEnvRef + case mhscEnv of + Nothing -> pure Nothing + Just hscEnv -> liftIO $ getTypeForName_ hscEnv n -getTypeForNameDirectly :: Unique -> Module -> IdeM (Maybe Type) -getTypeForNameDirectly n m = do +getTypeForNameDetails :: NameDetails -> IdeM (Maybe Type) +getTypeForNameDetails (NameDetails mdl occ) = do hscEnvRef <- ghcSession <$> readMTS mhscEnv <- liftIO $ traverse readIORef hscEnvRef case mhscEnv of - Nothing -> return Nothing + Nothing -> pure Nothing Just hscEnv -> do - mt <- liftIO $ lookupGlobalDirectly hscEnv n m - return $ fmap varType $ safeTyThingId =<< mt - -lookupTypeDirectly - :: HomePackageTable - -> PackageTypeEnv - -> Unique - -> Module - -> Maybe TyThing -lookupTypeDirectly hpt pte name mdl - = case lookupHptByModule hpt mdl of - Just hm -> lookupUFM_Directly (md_types (hm_details hm)) name - Nothing -> lookupUFM_Directly pte name - -lookupGlobalDirectly :: HscEnv -> Unique -> Module -> IO (Maybe TyThing) -lookupGlobalDirectly hsc_env name mdl = do - eps <- readIORef (hsc_EPS hsc_env) - return $! lookupTypeDirectly (hsc_HPT hsc_env) (eps_PTE eps) name mdl + nc <- liftIO $ readIORef $ hsc_NC hscEnv + case lookupOrigNameCache (nsNames nc) mdl occ of + Nothing -> pure Nothing + Just n -> liftIO $ getTypeForName_ hscEnv n + +getTypeForName_ :: HscEnv -> Name -> IO (Maybe Type) +getTypeForName_ hscEnv n = do + mt <- (Just <$> lookupGlobal hscEnv n) + `catch` \(_ :: SomeException) -> return Nothing + pure $ fmap varType $ safeTyThingId =<< mt -- --------------------------------------------------------------------- diff --git a/test/functional/CompletionSpec.hs b/test/functional/CompletionSpec.hs index 68f130d54..136fdb5c1 100644 --- a/test/functional/CompletionSpec.hs +++ b/test/functional/CompletionSpec.hs @@ -36,38 +36,6 @@ spec = describe "completions" $ do resolved ^. insertTextFormat `shouldBe` Just Snippet resolved ^. insertText `shouldBe` Just "putStrLn ${1:String}" - it "does not pull in unnecessary modules until needed" $ - runSession hieCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - _ <- skipManyTill loggingNotification (count 2 noDiagnostics) - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "enum" - _ <- applyEdit doc te - - compls <- getCompletions doc (Position 5 11) - let item = head $ filter ((== "enumFrom") . (^. label)) compls - resolvedRes <- request CompletionItemResolve item - let Just (resolved :: CompletionItem) = resolvedRes ^. result - liftIO $ do - resolved ^. label `shouldBe` "enumFrom" - resolved ^. kind `shouldBe` Just CiFunction - resolved ^. detail `shouldBe` Just "Prelude" - resolved ^. insertText `shouldBe` Nothing - - let te2 = TextEdit (Range (Position 5 7) (Position 5 11)) "putStrLn (enumFrom 'a')" - _ <- applyEdit doc te2 - _ <- skipManyTill loggingNotification (count 2 noDiagnostics) - - compls2 <- getCompletions doc (Position 5 22) - let item2 = head $ filter ((== "enumFrom") . (^. label)) compls2 - resolvedRes2 <- request CompletionItemResolve item2 - let Just (resolved2 :: CompletionItem) = resolvedRes2 ^. result - liftIO $ do - resolved2 ^. label `shouldBe` "enumFrom" - resolved2 ^. kind `shouldBe` Just CiFunction - resolved2 ^. detail `shouldBe` Just "Enum a => a -> [a]\nPrelude" - resolved2 ^. insertText `shouldBe` Just "enumFrom ${1:a}" - it "completes imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" _ <- skipManyTill loggingNotification (count 2 noDiagnostics) diff --git a/test/testdata/completion/Completion.hs b/test/testdata/completion/Completion.hs index 2d778cf8d..d6480903b 100644 --- a/test/testdata/completion/Completion.hs +++ b/test/testdata/completion/Completion.hs @@ -6,10 +6,4 @@ main :: IO () main = putStrLn "hello" foo :: Either a b -> Either a b -foo = id - -bar :: Int -bar = foldl (-) 0 [1,2,3] - -baz :: [String] -baz = mapM head [["a"]] +foo = id \ No newline at end of file From e90f2cd518fe7bd2de991abb21d90aad4989ef0f Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 23 Jul 2019 18:14:12 +0530 Subject: [PATCH 5/7] Actually fix compilation on 8.2 --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 41bdccad0..907fa1cbb 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -26,7 +26,7 @@ module Haskell.Ide.Engine.Support.HieExtras , getFormattingPlugin ) where -import Data.Semigroup (Semigroup) +import Data.Semigroup (Semigroup(..)) import ConLike import Control.Lens.Operators ( (.~), (^.), (^?), (?~), (&) ) import Control.Lens.Prism ( _Just ) From f537ef5565cd1b538d58af06ba8c918626e87175 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 23 Jul 2019 19:07:14 +0530 Subject: [PATCH 6/7] this time for real --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 907fa1cbb..5c5c7e603 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -41,7 +41,6 @@ import Data.IORef import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe -import Data.Monoid ( (<>) ) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable From 9af1f4c4cba11629e8c6b357b74236607c998c93 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 23 Jul 2019 19:51:20 +0530 Subject: [PATCH 7/7] burn all software --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 5c5c7e603..2b2867b32 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -179,14 +179,14 @@ instance ToJSON CompItemResolveData where resolveCompletion :: J.CompletionItem -> IdeM J.CompletionItem resolveCompletion origCompl = case fromJSON <$> origCompl ^. J.xdata of - Just (J.Success (CompItemResolveData dets query)) -> do - mdocs <- Hoogle.infoCmd' query + Just (J.Success compdata) -> do + mdocs <- Hoogle.infoCmd' $ hoogleQuery compdata let docText = case mdocs of Right x -> Just x _ -> Nothing markup = J.MarkupContent J.MkMarkdown <$> docText docs = J.CompletionDocMarkup <$> markup - (detail,insert) <- case dets of + (detail,insert) <- case nameDetails compdata of Nothing -> pure (Nothing,Nothing) Just nd -> do mtyp <- getTypeForNameDetails nd