diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index d30c095217..a17e6c3d65 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -76,6 +76,23 @@ import HIE.Bios.Environment (getRuntimeGhcLibDir) import DynFlags +import HieDb.Create +import HieDb.Types +import HieDb.Utils +import Database.SQLite.Simple +import qualified Data.ByteString.Char8 as B +import qualified Crypto.Hash.SHA1 as H +import Control.Concurrent.Async +import Control.Exception +import System.Directory +import Data.ByteString.Base16 +import HieDb.Run (Options(..), runCommand) +import Maybes (MaybeT(runMaybeT)) +import HIE.Bios.Types (CradleLoadResult(..)) +import HIE.Bios.Environment (getRuntimeGhcLibDir) +import DynFlags + + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -162,6 +179,7 @@ runIde dir Arguments{..} hiedb hiechan = do let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg + whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory @@ -278,7 +296,7 @@ runIde dir Arguments{..} hiedb hiechan = do unless (null failed) (exitWith $ ExitFailure (length failed)) -{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-} +{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-} expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index f89703f725..8bfe757d9a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -42,6 +42,7 @@ module Development.IDE.GHC.Compat( disableWarningsAsErrors, AvailInfo, tcg_exports, + pattern FunTy, #if MIN_GHC_API_VERSION(8,10,0) module GHC.Hs.Extension, @@ -89,6 +90,7 @@ import HsExtension #endif import qualified GHC +import qualified TyCoRep import GHC hiding ( ModLocation, HasSrcSpan, @@ -283,3 +285,10 @@ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr #else pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif + +pattern FunTy :: Type -> Type -> Type +#if MIN_GHC_API_VERSION(8, 10, 0) +pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} +#else +pattern FunTy arg res <- TyCoRep.FunTy arg res +#endif diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 1f715cde85..7ae7f0e607 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -14,6 +14,7 @@ module Development.IDE.Plugin.Completions.Logic ( import Control.Applicative import Data.Char (isAlphaNum, isUpper) +import Data.Either (fromRight) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 92addbbaf4..558dd04d1c 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -32,7 +32,7 @@ import Development.IDE.Core.PositionMapping import Name import Outputable hiding ((<>)) import SrcLoc -import TyCoRep +import TyCoRep hiding (FunTy) import TyCon import qualified Var import NameEnv diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8ff86e513c..7685c7c6b3 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -125,10 +125,10 @@ initializeResponseTests = withResource acquire release tests where -- BUG in lsp-test, this test fails, just change the accepted response -- for now , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True) - , chk "NO find references" _referencesProvider Nothing + , chk " find references" _referencesProvider (Just True) , chk " doc highlight" _documentHighlightProvider (Just True) , chk " doc symbol" _documentSymbolProvider (Just True) - , chk "NO workspace symbol" _workspaceSymbolProvider Nothing + , chk " workspace symbol" _workspaceSymbolProvider (Just True) , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing , chk "NO doc formatting" _documentFormattingProvider Nothing @@ -2433,7 +2433,7 @@ findDefinitionAndHoverTests = let , testGroup "type-definition" typeDefinitionTests ] typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) opL16 (pure [ExpectNoDefinitions]) "Polymorphic variable"] + , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"] test runDef runHover look expect = testM runDef runHover look (return expect) @@ -2447,6 +2447,7 @@ findDefinitionAndHoverTests = let fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] fffL8 = Position 12 4 ; fffL14 = Position 18 7 ; + aL20 = Position 19 15 aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] dcL12 = Position 16 11 ; diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ceb89126bd..56c2a6b6e8 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -56,18 +56,25 @@ library autogen-modules: Paths_haskell_language_server hs-source-dirs: src build-depends: + , async + , base16-bytestring + , bytestring , containers + , cryptohash-sha1 , data-default , ghc , ghcide >=0.6.0.1 , gitrev , haskell-lsp ^>=0.22 + , hie-bios + , hiedb , hls-plugin-api >=0.5 , hslogger , optparse-applicative , optparse-simple , process , shake + , sqlite-simple , unordered-containers ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing @@ -274,9 +281,12 @@ executable haskell-language-server build-depends: , aeson + , async + , base16-bytestring , binary , bytestring , containers + , cryptohash-sha1 , deepseq , ghc , ghc-boot-th @@ -284,6 +294,8 @@ executable haskell-language-server , hashable , haskell-language-server , haskell-lsp ^>=0.22 + , hie-bios + , hiedb , lens , regex-tdfa , hslogger @@ -294,6 +306,7 @@ executable haskell-language-server , regex-tdfa , safe-exceptions , shake >=0.17.5 + , sqlite-simple , temporary , transformers , unordered-containers @@ -436,7 +449,3 @@ test-suite wrapper-test hs-source-dirs: test/wrapper main-is: Main.hs ghc-options: -Wall - - - - diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 9ffaaa30c7..45b9cfc82c 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -166,13 +166,15 @@ codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMayb . Just findClassIdentifier docPath range = do - (hieAst -> hf, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath - pure - $ head . head - $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) - ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo) - <=< nodeChildren - ) + (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath + case hieAstResult of + HAR {hieAst = hf} -> + pure + $ head . head + $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) + ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo) + <=< nodeChildren + ) findClassFromIdentifier docPath (Right name) = do (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath diff --git a/plugins/tactics/src/Ide/Plugin/Tactic.hs b/plugins/tactics/src/Ide/Plugin/Tactic.hs index e250401b3e..58eb812c37 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} @@ -250,36 +251,42 @@ judgementForHole state nfp range = do ((modsum,_), _) <- MaybeT $ runIde state $ useWithStale GetModSummaryWithoutTimestamps nfp let dflags = ms_hspp_opts modsum - (rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts $ hieAst asts) $ \fs ast -> - case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of - Nothing -> Nothing - Just ast' -> do - let info = nodeInfo ast' - ty <- listToMaybe $ nodeType info - guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info - pure (nodeSpan ast', ty) - - resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss - (tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp - let tcg = tmrTypechecked tcmod - tcs = tcg_binds tcg - ctx = mkContext - (mapMaybe (sequenceA . (occName *** coerce)) - $ getDefiningBindings binds rss) - tcg - top_provs = getRhsPosVals rss tcs - local_hy = spliceProvenance top_provs - $ hypothesisFromBindings rss binds - cls_hy = contextMethodHypothesis ctx - pure ( resulting_range - , mkFirstJudgement - (local_hy <> cls_hy) - (isRhsHole rss tcs) - goal - , ctx - , dflags - ) - + case asts of + (HAR _ hf _ kind) -> do + (rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of + Nothing -> Nothing + Just ast' -> do + let info = nodeInfo ast' + ty <- listToMaybe $ nodeType info + guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info + pure (nodeSpan ast', ty) + + resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss + (tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp + let tcg = tmrTypechecked tcmod + tcs = tcg_binds tcg + ctx = mkContext + (mapMaybe (sequenceA . (occName *** coerce)) + $ getDefiningBindings binds rss) + tcg + top_provs = getRhsPosVals rss tcs + local_hy = spliceProvenance top_provs + $ hypothesisFromBindings rss binds + cls_hy = contextMethodHypothesis ctx + case kind of + HieFromDisk hf' -> + -- TODO FIXME XXX. + fail undefined + HieFresh -> + pure ( resulting_range + , mkFirstJudgement + (local_hy <> cls_hy) + (isRhsHole rss tcs) + goal + , ctx + , dflags + ) spliceProvenance :: Map OccName Provenance @@ -365,4 +372,3 @@ getRhsPosVals rss tcs -- TODO(sandy): Make this more robust isHole :: OccName -> Bool isHole = isPrefixOf "_" . occNameString - diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 8291887b7e..505e0aee52 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -34,8 +34,8 @@ import Development.IDE.Core.Shake import Development.IDE.LSP.LanguageServer import Development.IDE.LSP.Protocol import Development.IDE.Plugin +import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions, cacheDir) import Development.IDE.Plugin.HLS -import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger as G @@ -57,7 +57,25 @@ import qualified System.Log.Logger as L import System.Time.Extra import Development.Shake (action) -ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) +import HieDb.Create +import HieDb.Types +import Database.SQLite.Simple +import qualified Data.ByteString.Char8 as B +import qualified Crypto.Hash.SHA1 as H +import Control.Concurrent.Async +import Control.Exception +import System.Directory +import Data.ByteString.Base16 + +-- --------------------------------------------------------------------- +-- ghcide partialhandlers +import Development.IDE.Plugin.CodeAction as CodeAction +import Development.IDE.Plugin.Completions as Completions +import Development.IDE.LSP.HoverDefinition as HoverDefinition + +-- --------------------------------------------------------------------- + +ghcIdePlugins :: T.Text -> IdePlugins -> (Plugin Config, [T.Text]) ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) defaultMain :: Arguments -> IdePlugins IdeState -> IO () @@ -84,21 +102,35 @@ defaultMain args idePlugins = do hPutStrLn stderr hlsVer runLspMode lspArgs idePlugins --- --------------------------------------------------------------------- - -hlsLogger :: G.Logger -hlsLogger = G.Logger $ \pri txt -> - case pri of - G.Telemetry -> logm (T.unpack txt) - G.Debug -> debugm (T.unpack txt) - G.Info -> logm (T.unpack txt) - G.Warning -> warningm (T.unpack txt) - G.Error -> errorm (T.unpack txt) +getHieDbLoc :: FilePath -> IO FilePath +getHieDbLoc dir = do + let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb" + dirHash = B.unpack $ encode $ H.hash $ B.pack dir + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + createDirectoryIfMissing True cDir + pure (cDir db) --- --------------------------------------------------------------------- - -runLspMode :: LspArguments -> IdePlugins IdeState -> IO () -runLspMode lspArgs@LspArguments{..} idePlugins = do +runLspMode :: LspArguments -> IdePlugins -> IO () +runLspMode lspArgs idePlugins = do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + runWithDb dbLoc $ runLspMode' lspArgs idePlugins + +runWithDb :: FilePath -> (HieDb -> HieWriterChan -> IO ()) -> IO () +runWithDb fp k = + withHieDb fp $ \writedb -> do + execute_ (getConn writedb) "PRAGMA journal_mode=WAL;" + initConn writedb + chan <- newChan + race_ (writerThread writedb chan) (withHieDb fp (flip k chan)) + where + writerThread db chan = forever $ do + k <- readChan chan + k db `catch` \e@SQLError{} -> do + hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e + +runLspMode' :: LspArguments -> IdePlugins -> HieDb -> HieWriterChan -> IO () +runLspMode' lspArgs@LspArguments{..} idePlugins hiedb hiechan = do LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -142,6 +174,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do debouncer <- newAsyncDebouncer initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event wProg wIndefProg hlsLogger debouncer options vfs + hiedb hiechan else do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 @@ -170,7 +203,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do debouncer <- newAsyncDebouncer let dummyWithProg _ _ f = f (const (pure ())) sessionLoader <- loadSession dir - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs hiedb hiechan putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 6b366dfbdd..735f15ec6b 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -17,24 +17,24 @@ ghc-options: "$everything": -haddock extra-deps: - - brittany-0.13.1.0 - - Cabal-3.0.2.0 - - clock-0.7.2 - - data-tree-print-0.1.0.2@rev:2 - - floskell-0.10.4 - - fourmolu-0.3.0.0 - - ghc-lib-8.10.3.20201220 - - ghc-lib-parser-8.10.3.20201220 - - heapsize-0.3.0 - - implicit-hie-cradle-0.3.0.2 - - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 - - monad-dijkstra-0.1.1.2 - - refinery-0.3.0.0 - - retrie-0.1.1.1 - - stylish-haskell-0.12.2.0 - - semigroups-0.18.5 - - temporary-1.2.1.1 +- brittany-0.13.1.0 +- Cabal-3.0.2.0 +- clock-0.7.2 +- data-tree-print-0.1.0.2@rev:2 +- floskell-0.10.4 +- fourmolu-0.3.0.0 +- heapsize-0.3.0 +- hiedb-0.1.0.0 +- implicit-hie-cradle-0.3.0.2 +- implicit-hie-0.1.2.5 +- lsp-test-0.11.0.6 +- monad-dijkstra-0.1.1.2 +- refinery-0.3.0.0 +- retrie-0.1.1.1 +- stylish-haskell-0.12.2.0 +- semigroups-0.18.5 +- temporary-1.2.1.1 + configure-options: ghcide: diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index fbe2ce2330..8672a36d20 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -1,35 +1,171 @@ module Reference (tests) where -import Control.Lens import Control.Monad.IO.Class -import Data.List +import Data.Tuple.Extra (first3) import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens +import System.FilePath (()) +import System.Time.Extra (sleep) import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit tests :: TestTree -tests = testGroup "references" [ - ignoreTestBecause "Broken" $ testCase "works with definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "References.hs" "haskell" - let pos = Position 2 7 -- foo = bar <-- - refs <- getReferences doc pos True - liftIO $ map (Location (doc ^. uri)) [ - mkRange 4 0 4 3 - , mkRange 8 11 8 14 - , mkRange 7 7 7 10 - , mkRange 4 14 4 17 - , mkRange 4 0 4 3 - , mkRange 2 6 2 9 - ] `isInfixOf` refs @? "Contains references" - -- TODO: Respect withDeclaration parameter - -- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do - -- doc <- openDoc "References.hs" "haskell" - -- let pos = Position 2 7 -- foo = bar <-- - -- refs <- getReferences doc pos False - -- liftIO $ refs `shouldNotContain` [Location (doc ^. uri) (mkRange 4 0 4 3)] +tests = testGroup "references" + [ testGroup "can get references to a symbol which is local to one module" + [ testCase "can get references to symbols" $ + referenceTest ("src/References.hs", 4, 7) + YesIncludeDeclaration + [ ("src/References.hs", 4, 6) + , ("src/References.hs", 6, 0) + , ("src/References.hs", 6, 14) + , ("src/References.hs", 9, 7) + , ("src/References.hs", 10, 11) + ] + + , testCase "can get references to data constructor" $ + referenceTest ("src/References.hs", 13, 2) + YesIncludeDeclaration + [ ("src/References.hs", 13, 2) + , ("src/References.hs", 16, 14) + , ("src/References.hs", 19, 21) + ] + + , testCase "getting references works in the other module" $ + referenceTest ("src/OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("src/OtherModule.hs", 6, 0) + , ("src/OtherModule.hs", 8, 16) + ] + + , testCase "getting references works in the Main module" $ + referenceTest ("exe/Main.hs", 9, 0) + YesIncludeDeclaration + [ ("exe/Main.hs", 9, 0) + , ("exe/Main.hs", 10, 4) + ] + + , testCase "getting references to main works" $ + referenceTest ("exe/Main.hs", 5, 0) + YesIncludeDeclaration + [ ("exe/Main.hs", 4, 0) + , ("exe/Main.hs", 5, 0) + ] + + , testCase "getting references in the other package" $ + referenceTest ("dependencyfoo/src/OtherModuleInDependency.hs", 2, 0) + YesIncludeDeclaration + [ ("dependencyfoo/src/OtherModuleInDependency.hs", 2, 0) + , ("dependencyfoo/src/OtherModuleInDependency.hs", 4, 13) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + testCase "works when we ask to exclude declarations" $ + referenceTest ("src/References.hs", 4, 7) + NoExcludeDeclaration + [ ("src/References.hs", 6, 0) + , ("src/References.hs", 6, 14) + , ("src/References.hs", 9, 7) + , ("src/References.hs", 10, 11) + ] + + , testCase "INCORRECTLY returns declarations when we ask to exclude them" $ + referenceTest ("src/References.hs", 4, 7) + NoExcludeDeclaration + [ ("src/References.hs", 4, 6) + , ("src/References.hs", 6, 0) + , ("src/References.hs", 6, 14) + , ("src/References.hs", 9, 7) + , ("src/References.hs", 10, 11) + ] + ] + + , testGroup "can get references to a symbol which is local to one package" + [ testCase "can get references to symbol defined in a module we import" $ + referenceTest ("src/References.hs", 22, 4) + YesIncludeDeclaration + [ ("src/References.hs", 22, 4) + , ("src/OtherModule.hs", 0, 20) + , ("src/OtherModule.hs", 4, 0) + ] + + , testCase "can get references in modules that import us to symbols we define" $ + referenceTest ("src/OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("src/References.hs", 22, 4) + , ("src/OtherModule.hs", 0, 20) + , ("src/OtherModule.hs", 4, 0) + ] + + , testCase "can get references to symbol defined in a module we import transitively" $ + referenceTest ("src/References.hs", 24, 4) + YesIncludeDeclaration + [ ("src/References.hs", 24, 4) + , ("src/OtherModule.hs", 0, 48) + , ("src/OtherOtherModule.hs", 2, 0) + ] + + , testCase "can get references in modules that import us transitively to symbols we define" $ + referenceTest ("src/OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("src/References.hs", 24, 4) + , ("src/OtherModule.hs", 0, 48) + , ("src/OtherOtherModule.hs", 2, 0) + ] + ] + + , testGroup "can get references to a symbol which is local to one project" + [ testCase "can get references to symbol defined in dependency" $ + referenceTest ("exe/Main.hs", 7, 6) + YesIncludeDeclaration + [ ("exe/Main.hs", 7, 6) + , ("dependencyfoo/src/ModuleInDependency.hs", 2, 0) + ] + + , testCase "can get references in our dependents to a symbol we define" $ + referenceTest ("dependencyfoo/src/ModuleInDependency.hs", 2, 0) + YesIncludeDeclaration + [ ("exe/Main.hs", 7, 6) + , ("dependencyfoo/src/ModuleInDependency.hs", 2, 0) + ] + ] ] - where mkRange sl sc el ec = Range (Position sl sc) (Position el ec) + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session [Location] +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referencesPath :: FilePath +referencesPath = "test/testdata/references" + +referenceTestSession :: Session a -> IO a +referenceTestSession f = runSession hlsCommand fullCaps referencesPath $ do + -- Preload all the files we need. + -- TODO: Something needs to change ... + -- These tests take forever anyway while HLS does stuff with cabal. + _ <- openDoc "exe/Main.hs" "haskell" + _ <- openDoc "src/OtherModule.hs" "haskell" + _ <- openDoc "src/OtherOtherModule.hs" "haskell" + _ <- openDoc "src/References.hs" "haskell" + _ <- openDoc "dependencyfoo/src/ModuleInDependency.hs" "haskell" + _ <- openDoc "dependencyfoo/src/OtherModuleInDependency.hs" "haskell" + liftIO $ sleep 2 + f + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> Assertion +referenceTest loc includeDeclaration expected = + referenceTestSession $ do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (referencesPath )) expected diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index f94ed27de1..aa9f0dec47 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -1,11 +1,9 @@ module TypeDefinition (tests) where -import Control.Lens ((^.)) import Control.Monad.IO.Class +import Data.Tuple.Extra (first3) import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L -import System.Directory import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -14,42 +12,36 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "type definitions" [ testCase "finds local definition of record variable" - $ getTypeDefinitionTest' (11, 23) 8 + $ getTypeDefinitionTest' 10 23 7 0 , testCase "finds local definition of newtype variable" - $ getTypeDefinitionTest' (16, 21) 13 + $ getTypeDefinitionTest' 15 21 12 0 , testCase "finds local definition of sum type variable" - $ getTypeDefinitionTest' (21, 13) 18 + $ getTypeDefinitionTest' 20 13 17 0 , knownBrokenForGhcVersions [GHC88] "Definition of sum type not found from data constructor in GHC 8.8.x" $ testCase "finds local definition of sum type constructor" - $ getTypeDefinitionTest' (24, 7) 18 + $ getTypeDefinitionTest' 23 7 17 0 , testCase "finds non-local definition of type def" - $ getTypeDefinitionTest' (30, 17) 27 + $ getTypeDefinitionTest' 29 17 26 0 , testCase "find local definition of type def" - $ getTypeDefinitionTest' (35, 16) 32 + $ getTypeDefinitionTest' 34 16 31 0 , testCase "find type-definition of type def in component" - $ getTypeDefinitionTest "src/Lib2.hs" (13, 20) "src/Lib.hs" 8 + $ getTypeDefinitionTest ("src/Lib2.hs", 12, 20) [("src/Lib.hs", 7, 0)] , testCase "find definition of parameterized data type" - $ getTypeDefinitionTest' (40, 19) 37 + $ getTypeDefinitionTest ("src/Lib.hs", 39, 19) [ ("src/Lib.hs", 36, 0) + , ("src/Lib.hs", 38, 0)] ] -getTypeDefinitionTest :: String -> (Int, Int) -> String -> Int -> Assertion -getTypeDefinitionTest symbolFile symbolPosition definitionFile definitionLine = - failIfSessionTimeout . runSession hlsCommand fullCaps "test/testdata/gototest" $ do - doc <- openDoc symbolFile "haskell" - _ <- openDoc definitionFile "haskell" - defs <- getTypeDefinitions doc $ toPos symbolPosition - fp <- liftIO $ canonicalizePath $ "test/testdata/gototest" definitionFile - liftIO $ do - length defs == 1 @? "Expecting a list containing one location, but got: " ++ show defs - let [def] = defs - def ^. L.uri @?= filePathToUri fp - def ^. L.range . L.start . L.line @?= definitionLine - 1 - def ^. L.range . L.end . L.line @?= definitionLine - 1 +definitionsPath :: FilePath +definitionsPath = "test/testdata/gototest" -getTypeDefinitionTest' :: (Int, Int) -> Int -> Assertion -getTypeDefinitionTest' symbolPosition definitionLine = - getTypeDefinitionTest "src/Lib.hs" symbolPosition "src/Lib.hs" definitionLine +getTypeDefinitionTest :: SymbolLocation -> [SymbolLocation] -> Assertion +getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations = + failIfSessionTimeout . runSession hlsCommand fullCaps definitionsPath $ do + doc <- openDoc symbolFile "haskell" + defs <- getTypeDefinitions doc $ Position symbolLine symbolCol + liftIO $ defs `expectSameLocations` map (first3 (definitionsPath )) definitionLocations ---NOTE: copied from Haskell.Ide.Engine.ArtifactMap -toPos :: (Int,Int) -> Position -toPos (l,c) = Position (l-1) (c-1) +getTypeDefinitionTest' :: Int -> Int -> Int -> Int -> Assertion +getTypeDefinitionTest' symbolLine symbolCol definitionLine definitionCol = + getTypeDefinitionTest ("src/Lib.hs", symbolLine, symbolCol) + [("src/Lib.hs", definitionLine, definitionCol)] diff --git a/test/testdata/References.hs b/test/testdata/References.hs deleted file mode 100644 index 34eb8c4e25..0000000000 --- a/test/testdata/References.hs +++ /dev/null @@ -1,9 +0,0 @@ -main = return () - -foo = bar - -bar = let x = bar 42 in const "hello" - -baz = do - x <- bar 23 - return $ bar 14 diff --git a/test/testdata/references/cabal.project b/test/testdata/references/cabal.project new file mode 100644 index 0000000000..f7ee9b8f81 --- /dev/null +++ b/test/testdata/references/cabal.project @@ -0,0 +1,2 @@ +packages: dependencyfoo/dependencyfoo.cabal + references.cabal diff --git a/test/testdata/references/dependencyfoo/dependencyfoo.cabal b/test/testdata/references/dependencyfoo/dependencyfoo.cabal new file mode 100644 index 0000000000..8a491a33ee --- /dev/null +++ b/test/testdata/references/dependencyfoo/dependencyfoo.cabal @@ -0,0 +1,12 @@ +cabal-version: >=1.10 + +name: dependencyfoo +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: ModuleInDependency + other-modules: OtherModuleInDependency + build-depends: base >=4.7 && <5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/testdata/references/dependencyfoo/src/ModuleInDependency.hs b/test/testdata/references/dependencyfoo/src/ModuleInDependency.hs new file mode 100644 index 0000000000..fc99118cac --- /dev/null +++ b/test/testdata/references/dependencyfoo/src/ModuleInDependency.hs @@ -0,0 +1,3 @@ +module ModuleInDependency where + +symbolDefinedInDependency = 3 diff --git a/test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs b/test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs new file mode 100644 index 0000000000..af1325bff9 --- /dev/null +++ b/test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs @@ -0,0 +1,5 @@ +module OtherModuleInDependency where + +symbolLocalToDependency = 4 + +someSymbol = symbolLocalToDependency diff --git a/test/testdata/references/exe/Main.hs b/test/testdata/references/exe/Main.hs new file mode 100644 index 0000000000..713f3808bf --- /dev/null +++ b/test/testdata/references/exe/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import ModuleInDependency + +main :: IO () +main = return () + +xxx = symbolDefinedInDependency + +a = 2 +b = a + 1 diff --git a/test/testdata/references/hie.yaml b/test/testdata/references/hie.yaml new file mode 100644 index 0000000000..8df59550ce --- /dev/null +++ b/test/testdata/references/hie.yaml @@ -0,0 +1,10 @@ +cradle: + cabal: + - path: "dependencyfoo/src" + component: "lib:dependencyfoo" + + - path: "src" + component: "lib:references" + + - path: "exe/Main.hs" + component: "references:exe:references" diff --git a/test/testdata/references/references.cabal b/test/testdata/references/references.cabal new file mode 100644 index 0000000000..35c290c58d --- /dev/null +++ b/test/testdata/references/references.cabal @@ -0,0 +1,18 @@ +cabal-version: >=1.10 + +name: references +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: OtherOtherModule, OtherModule, References + build-depends: base >=4.7 && <5 + hs-source-dirs: src + default-language: Haskell2010 + +executable references + main-is: Main.hs + build-depends: base >=4.7 && <5 + , dependencyfoo + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/test/testdata/references/src/OtherModule.hs b/test/testdata/references/src/OtherModule.hs new file mode 100644 index 0000000000..4840f46d8e --- /dev/null +++ b/test/testdata/references/src/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/test/testdata/references/src/OtherOtherModule.hs b/test/testdata/references/src/OtherOtherModule.hs new file mode 100644 index 0000000000..d567b8cb97 --- /dev/null +++ b/test/testdata/references/src/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/test/testdata/references/src/References.hs b/test/testdata/references/src/References.hs new file mode 100644 index 0000000000..ac76b4de40 --- /dev/null +++ b/test/testdata/references/src/References.hs @@ -0,0 +1,25 @@ +module References where + +import OtherModule + +foo = bar + +bar = let x = bar 42 in const "hello" + +baz = do + x <- bar 23 + return $ bar 14 + +data Account = + Checking + | Savings + +bobsAccount = Checking + +bobHasChecking = case bobsAccount of + Checking -> True + Savings -> False + +x = symbolDefinedInOtherModule + +y = symbolDefinedInOtherOtherModule diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 9fcd5331e9..f9c6873302 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -6,6 +6,7 @@ module Test.Hls.Util , expectCodeAction , expectDiagnostic , expectNoMoreDiagnostics + , expectSameLocations , failIfSessionTimeout , flushStackEnvironment , fromAction @@ -24,6 +25,7 @@ module Test.Hls.Util , logFilePath , noLogConfig , setupBuildToolFiles + , SymbolLocation , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout @@ -41,6 +43,7 @@ import Data.Default import Data.List (intercalate) import Data.List.Extra (find) import Data.Maybe +import qualified Data.Set as Set import qualified Data.Text as T import Language.Haskell.LSP.Core import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage)) @@ -59,7 +62,7 @@ import Test.Hspec.Runner import Test.Hspec.Core.Formatters hiding (Seconds) import Test.Tasty (TestTree) import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) -import Test.Tasty.HUnit (assertFailure) +import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal hiding (null) @@ -423,3 +426,20 @@ failIfSessionTimeout action = action `catch` errorHandler where errorHandler :: Test.SessionException -> IO a errorHandler e@(Test.Timeout _) = assertFailure $ show e errorHandler e = throwIO e + +-- | To locate a symbol, we provide a path to the file from the HLS root +-- directory, the line number, and the column number. (0 indexed.) +type SymbolLocation = (FilePath, Int, Int) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +actual `expectSameLocations` expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line + , location ^. L.range . L.start . L.character)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected'