diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.4.0.2 +version: 1.4.0.3 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -59,8 +59,8 @@ hie-compat ^>= 0.2.0.0, hls-plugin-api ^>= 1.1.0.0, lens, - hiedb == 0.3.0.*, - lsp-types == 1.2.*, + hiedb == 0.4.0.*, + lsp-types >= 1.2 && < 1.4, lsp == 1.2.*, mtl, network-uri, @@ -343,7 +343,7 @@ hls-plugin-api, network-uri, lens, - lsp-test == 0.14.0.0, + lsp-test ^>= 0.14, optparse-applicative, process, QuickCheck, @@ -403,7 +403,7 @@ extra, filepath, ghcide, - lsp-test == 0.14.0.0, + lsp-test, optparse-applicative, process, safe-exceptions, diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -974,7 +974,7 @@ Just (LM obj_time _ _) -> obj_time > ms_hs_date ms if objUpToDate then do - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable + hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface{mi_globals=Nothing} linkable return ([], Just $ mkHiFileResult ms hmi) else regen linkableNeeded (_reason, _) -> regen linkableNeeded diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -19,24 +19,19 @@ import Control.Concurrent.Strict import Control.Monad import Control.Monad.IO.Class -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as T +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as T import Development.IDE.Graph -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import qualified Data.ByteString as BS -import Data.List.Extra (nubOrd) -import Data.Maybe (catMaybes) +import qualified Data.ByteString as BS +import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger -import Development.IDE.Types.Options newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar @@ -98,25 +93,13 @@ kick :: Action () kick = do files <- HashMap.keys <$> getFilesOfInterestUntracked - ShakeExtras{progress} <- getShakeExtras + ShakeExtras{exportsMap, progress} <- getShakeExtras liftIO $ progressUpdate progress KickStarted - -- Update the exports map for FOIs + -- Update the exports map results <- uses GenerateCore files <* uses GetHieAst files - - -- Update the exports map for non FOIs - -- We can skip this if checkProject is True, assuming they never change under our feet. - IdeOptions{ optCheckProject = doCheckProject } <- getIdeOptions - checkProject <- liftIO doCheckProject - ifaces <- if checkProject then return Nothing else runMaybeT $ do - deps <- MaybeT $ sequence <$> uses GetDependencies files - hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps) - return $ map hirModIface $ catMaybes hiResults - - ShakeExtras{exportsMap} <- getShakeExtras let mguts = catMaybes results !exportsMap' = createExportsMapMg mguts - !exportsMap'' = maybe mempty createExportsMap ifaces - void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>) + void $ liftIO $ modifyVar' exportsMap (exportsMap' <>) liftIO $ progressUpdate progress KickCompleted diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -152,6 +152,8 @@ import qualified Data.HashSet as HSet import Data.IORef.Extra (atomicModifyIORef'_, atomicModifyIORef_) +import Data.Text (pack) +import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS @@ -507,6 +509,12 @@ indexProgressToken <- newVar Nothing let hiedbWriter = HieDbWriter{..} exportsMap <- newVar mempty + -- lazily initialize the exports map with the contents of the hiedb + _ <- async $ do + logDebug logger "Initializing exports map from hiedb" + em <- createExportsMapHieDb hiedb + modifyVar' exportsMap (<> em) + logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" progress <- do let (before, after) = if testing then (0,0.1) else (0.1,0.1) diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -188,7 +188,7 @@ -- | (Needs parens, needs space) (All, All) needsParensSpace HsLam{} = (All False, All False) -needsParensSpace HsLamCase{} = (All False, All False) +needsParensSpace HsLamCase{} = (All False, All True) needsParensSpace HsApp{} = mempty needsParensSpace HsAppType{} = mempty needsParensSpace OpApp{} = mempty diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -804,6 +804,10 @@ = mod_srcspan >>= uncurry (suggestions hsmodImports binding) | otherwise = [] where + canUseDatacon = case extractNotInScopeName _message of + Just NotInScopeTypeConstructorOrClass{} -> False + _ -> True + suggestions decls binding mod srcspan | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of [s] -> let x = realSrcSpanToRange s @@ -823,7 +827,7 @@ -- Only for the situation that data constructor name is same as type constructor name, -- let ident with parent be in front of the one without. , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) - , idents <- filter (\ident -> moduleNameText ident == mod) sortedMatch + , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch , (not . null) idents -- Ensure fallback while `idents` is empty , ident <- head idents = Just ident @@ -1318,8 +1322,9 @@ hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True canUseIdent :: NotInScope -> IdentInfo -> Bool -canUseIdent NotInScopeDataConstructor{} = isDatacon -canUseIdent _ = const True +canUseIdent NotInScopeDataConstructor{} = isDatacon +canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon +canUseIdent _ = const True data NotInScope = NotInScopeDataConstructor T.Text diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -21,7 +21,7 @@ import qualified Data.Aeson.Types as A import qualified Data.HashMap.Strict as Map import Data.List (find) -import Data.Maybe (catMaybes, fromJust) +import Data.Maybe (catMaybes) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), @@ -36,7 +36,6 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes -import Development.IDE.Spans.Common (safeTyThingType) import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) import Development.IDE.Types.Location (Position (Position, _character, _line), Range (Range, _end, _start), @@ -46,8 +45,7 @@ import GhcPlugins (GlobalRdrEnv, HscEnv (hsc_dflags), SDoc, elemNameSet, getSrcSpan, - idName, lookupTypeEnv, - mkRealSrcLoc, + idName, mkRealSrcLoc, realSrcLocSpan, tidyOpenType) import HscTypes (mkPrintUnqualified) @@ -76,7 +74,12 @@ TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) import Outputable (showSDocForUser) -import PatSyn (patSynName) +import PatSyn (PatSyn, mkPatSyn, + patSynBuilder, + patSynFieldLabels, + patSynIsInfix, + patSynMatcher, patSynName, + patSynSig, pprPatSynType) import TcEnv (tcInitTidyEnv) import TcRnMonad (initTcWithGbl) import TcRnTypes (TcGblEnv (..)) @@ -279,10 +282,20 @@ pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) patToSig p = do let name = patSynName p - -- we don't use pprPatSynType, since it always prints forall - ty = fromJust $ lookupTypeEnv (tcg_type_env gblEnv) name >>= safeTyThingType - hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprPatSynTypeWithoutForalls p)) (name `elemNameSet` exports) (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) $ mapM bindToSig binds patterns <- catMaybes <$> mapM patToSig patSyns pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns gblBindingType _ _ = pure Nothing + +pprPatSynTypeWithoutForalls :: PatSyn -> SDoc +pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables + where + pWithoutTypeVariables = mkPatSyn name declared_infix ([], req_theta) ([], prov_theta) orig_args' orig_res_ty matcher builder field_labels + (_univ_tvs, req_theta, _ex_tvs, prov_theta, orig_args, orig_res_ty) = patSynSig p + name = patSynName p + declared_infix = patSynIsInfix p + matcher = patSynMatcher p + builder = patSynBuilder p + field_labels = patSynFieldLabels p + orig_args' = map scaledThing orig_args diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -7,12 +7,13 @@ createExportsMap, createExportsMapMg, createExportsMapTc -) where +,createExportsMapHieDb,size) where import Avail (AvailInfo (..)) import Control.DeepSeq (NFData (..)) +import Control.Monad import Data.Bifunctor (Bifunctor (second)) -import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict (HashMap, elems) import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet) import qualified Data.HashSet as Set @@ -23,6 +24,7 @@ import FieldLabel (flSelector) import GHC.Generics (Generic) import GhcPlugins (IfaceExport, ModGuts (..)) +import HieDb import Name import TcRnTypes (TcGblEnv (..)) @@ -30,6 +32,9 @@ {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)} deriving newtype (Monoid, NFData, Show) +size :: ExportsMap -> Int +size = sum . map length . elems . getExportsMap + instance Semigroup ExportsMap where ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b @@ -103,6 +108,22 @@ doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi) where mn = moduleName $ tcg_mod mi + +createExportsMapHieDb :: HieDb -> IO ExportsMap +createExportsMapHieDb hiedb = do + mods <- getAllIndexedMods hiedb + idents <- forM mods $ \m -> do + let mn = modInfoName $ hieModInfo m + mText = pack $ moduleNameString mn + fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn + return $ ExportsMap $ Map.fromListWith (<>) (concat idents) + where + wrap identInfo = (name identInfo, Set.fromList [identInfo]) + -- unwrap :: ExportRow -> IdentInfo + unwrap m ExportRow{..} = IdentInfo n n p exportIsDatacon m + where + n = pack (occNameString exportName) + p = pack . occNameString <$> exportParent unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])] unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} -- | Types and functions for working with source code locations. @@ -43,7 +44,11 @@ toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp emptyFilePath :: LSP.NormalizedFilePath +#if MIN_VERSION_lsp_types(1,3,0) +emptyFilePath = LSP.normalizedFilePath emptyPathUri "" +#else emptyFilePath = LSP.NormalizedFilePath emptyPathUri "" +#endif -- | We use an empty string as a filepath when we don’t have a file. -- However, haskell-lsp doesn’t support that in uriToFilePath and given diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -730,7 +730,7 @@ , typeWildCardActionTests , removeImportTests , extendImportTests - , suggesImportClassMethodTests + , suggestImportClassMethodTests , suggestImportTests , suggestHideShadowTests , suggestImportDisambiguationTests @@ -1436,6 +1436,25 @@ , "f :: Foo" , "f = Foo 1" ]) + , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo = Foo" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA()" + , "f :: Foo" + , "f = undefined" + ]) + (Range (Position 2 4) (Position 2 6)) + ["Add Foo to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = undefined" + ]) ] where codeActionTitle CodeAction{_title=x} = x @@ -1486,8 +1505,8 @@ template message expected = do liftIO $ matchRegExMultipleImports message @=? expected -suggesImportClassMethodTests :: TestTree -suggesImportClassMethodTests = +suggestImportClassMethodTests :: TestTree +suggestImportClassMethodTests = testGroup "suggest import class methods" [ testGroup @@ -1566,6 +1585,8 @@ , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" -- don't omit the parent data type of a constructor , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" + -- don't suggest data constructor when we only need the type + , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" ] , testGroup "want suggestion" [ wantWait [] "f = foo" [] "import Foo (foo)" @@ -2890,17 +2911,21 @@ addSigActionTests :: TestTree addSigActionTests = let - header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" - before def = T.unlines [header, moduleH, def] - after' def sig = T.unlines [header, moduleH, sig, def] + header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}" + , "module Sigs where" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before def = T.unlines $ header ++ [def] + after' def sig = T.unlines $ header ++ [sig, def] - def >:: sig = testSession (T.unpack def) $ do + def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do let originalCode = before def let expectedCode = after' def sig doc <- createDoc "Sigs.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound)) + actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -2914,6 +2939,15 @@ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" ] exportUnusedTests :: TestTree @@ -3377,10 +3411,12 @@ let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" moduleH exported = T.unlines - [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}" + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" , "module Sigs(" <> exported <> ") where" , "import qualified Data.Complex as C" , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" ] before enableGHCWarnings exported (def, _) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others @@ -3409,6 +3445,15 @@ , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") , ("head = 233", "head :: Integer") , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") @@ -3419,7 +3464,7 @@ ] in testGroup "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) , testGroup "diagnostics mode works"