Skip to content

Commit 50b3b5f

Browse files
wz1000wz1000
authored
Merge pull request #1 from peterwicksstringfield/write_hls_unit_tests_for_get_references
Write hls unit tests for get references
2 parents 53035c9 + 4d3ea8b commit 50b3b5f

File tree

24 files changed

+462
-146
lines changed

24 files changed

+462
-146
lines changed

‎ghcide/exe/Main.hs‎

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,23 @@ import HIE.Bios.Environment (getRuntimeGhcLibDir)
7676
import DynFlags
7777

7878

79+
import HieDb.Create
80+
import HieDb.Types
81+
import HieDb.Utils
82+
import Database.SQLite.Simple
83+
import qualified Data.ByteString.Char8 as B
84+
import qualified Crypto.Hash.SHA1 as H
85+
import Control.Concurrent.Async
86+
import Control.Exception
87+
import System.Directory
88+
import Data.ByteString.Base16
89+
import HieDb.Run (Options(..), runCommand)
90+
import Maybes (MaybeT(runMaybeT))
91+
import HIE.Bios.Types (CradleLoadResult(..))
92+
import HIE.Bios.Environment (getRuntimeGhcLibDir)
93+
import DynFlags
94+
95+
7996
ghcideVersion :: IO String
8097
ghcideVersion = do
8198
path <- getExecutablePath
@@ -162,6 +179,7 @@ runIde dir Arguments{..} hiedb hiechan = do
162179
let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
163180
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
164181

182+
165183
whenJust argsCwd IO.setCurrentDirectory
166184

167185
dir <- IO.getCurrentDirectory
@@ -278,7 +296,7 @@ runIde dir Arguments{..} hiedb hiechan = do
278296

279297
unless (null failed) (exitWith $ ExitFailure (length failed))
280298

281-
{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-}
299+
{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-}
282300

283301
expandFiles :: [FilePath] -> IO [FilePath]
284302
expandFiles = concatMapM $ \x -> do

‎ghcide/src/Development/IDE/GHC/Compat.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ module Development.IDE.GHC.Compat(
4242
disableWarningsAsErrors,
4343
AvailInfo,
4444
tcg_exports,
45+
pattern FunTy,
4546

4647
#if MIN_GHC_API_VERSION(8,10,0)
4748
module GHC.Hs.Extension,
@@ -89,6 +90,7 @@ import HsExtension
8990
#endif
9091

9192
import qualified GHC
93+
import qualified TyCoRep
9294
import GHC hiding (
9395
ModLocation,
9496
HasSrcSpan,
@@ -283,3 +285,10 @@ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr
283285
#else
284286
pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr
285287
#endif
288+
289+
pattern FunTy :: Type -> Type -> Type
290+
#if MIN_GHC_API_VERSION(8, 10, 0)
291+
pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res}
292+
#else
293+
pattern FunTy arg res <- TyCoRep.FunTy arg res
294+
#endif

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Development.IDE.Plugin.Completions.Logic (
1414

1515
import Control.Applicative
1616
import Data.Char (isAlphaNum, isUpper)
17+
import Data.Either (fromRight)
1718
import Data.Generics
1819
import Data.List.Extra as List hiding (stripPrefix)
1920
import qualified Data.Map as Map

‎ghcide/src/Development/IDE/Spans/AtPoint.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,7 @@ import Development.IDE.Core.PositionMapping
3232
import Name
3333
import Outputable hiding ((<>))
3434
import SrcLoc
35-
import TyCoRep
35+
import TyCoRep hiding (FunTy)
3636
import TyCon
3737
import qualified Var
3838
import NameEnv

‎ghcide/test/exe/Main.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -125,10 +125,10 @@ initializeResponseTests = withResource acquire release tests where
125125
-- BUG in lsp-test, this test fails, just change the accepted response
126126
-- for now
127127
, chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True)
128-
, chk "NO find references" _referencesProvider Nothing
128+
, chk " find references" _referencesProvider (Just True)
129129
, chk " doc highlight" _documentHighlightProvider (Just True)
130130
, chk " doc symbol" _documentSymbolProvider (Just True)
131-
, chk "NO workspace symbol" _workspaceSymbolProvider Nothing
131+
, chk " workspace symbol" _workspaceSymbolProvider (Just True)
132132
, chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
133133
, chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
134134
, chk "NO doc formatting" _documentFormattingProvider Nothing
@@ -2433,7 +2433,7 @@ findDefinitionAndHoverTests = let
24332433
, testGroup "type-definition" typeDefinitionTests ]
24342434

24352435
typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"
2436-
, tst (getTypeDefinitions, checkDefs) opL16 (pure [ExpectNoDefinitions]) "Polymorphic variable"]
2436+
, tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"]
24372437

24382438
test runDef runHover look expect = testM runDef runHover look (return expect)
24392439

@@ -2447,6 +2447,7 @@ findDefinitionAndHoverTests = let
24472447
fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
24482448
fffL8 = Position 12 4 ;
24492449
fffL14 = Position 18 7 ;
2450+
aL20 = Position 19 15
24502451
aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
24512452
dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
24522453
dcL12 = Position 16 11 ;

‎haskell-language-server.cabal‎

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -56,18 +56,25 @@ library
5656
autogen-modules: Paths_haskell_language_server
5757
hs-source-dirs: src
5858
build-depends:
59+
, async
60+
, base16-bytestring
61+
, bytestring
5962
, containers
63+
, cryptohash-sha1
6064
, data-default
6165
, ghc
6266
, ghcide >=0.6.0.1
6367
, gitrev
6468
, haskell-lsp ^>=0.22
69+
, hie-bios
70+
, hiedb
6571
, hls-plugin-api >=0.5
6672
, hslogger
6773
, optparse-applicative
6874
, optparse-simple
6975
, process
7076
, shake
77+
, sqlite-simple
7178
, unordered-containers
7279

7380
ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing
@@ -274,16 +281,21 @@ executable haskell-language-server
274281

275282
build-depends:
276283
, aeson
284+
, async
285+
, base16-bytestring
277286
, binary
278287
, bytestring
279288
, containers
289+
, cryptohash-sha1
280290
, deepseq
281291
, ghc
282292
, ghc-boot-th
283293
, ghcide
284294
, hashable
285295
, haskell-language-server
286296
, haskell-lsp ^>=0.22
297+
, hie-bios
298+
, hiedb
287299
, lens
288300
, regex-tdfa
289301
, hslogger
@@ -294,6 +306,7 @@ executable haskell-language-server
294306
, regex-tdfa
295307
, safe-exceptions
296308
, shake >=0.17.5
309+
, sqlite-simple
297310
, temporary
298311
, transformers
299312
, unordered-containers
@@ -436,7 +449,3 @@ test-suite wrapper-test
436449
hs-source-dirs: test/wrapper
437450
main-is: Main.hs
438451
ghc-options: -Wall
439-
440-
441-
442-

‎plugins/hls-class-plugin/src/Ide/Plugin/Class.hs‎

Lines changed: 9 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -166,13 +166,15 @@ codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMayb
166166
. Just
167167

168168
findClassIdentifier docPath range = do
169-
(hieAst -> hf, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
170-
pure
171-
$ head . head
172-
$ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
173-
( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo)
174-
<=< nodeChildren
175-
)
169+
(hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
170+
case hieAstResult of
171+
HAR {hieAst = hf} ->
172+
pure
173+
$ head . head
174+
$ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
175+
( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo)
176+
<=< nodeChildren
177+
)
176178

177179
findClassFromIdentifier docPath (Right name) = do
178180
(hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath

‎plugins/tactics/src/Ide/Plugin/Tactic.hs‎

Lines changed: 37 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE LambdaCase #-}
45
{-# LANGUAGE NumDecimals #-}
56
{-# LANGUAGE OverloadedStrings #-}
@@ -250,36 +251,42 @@ judgementForHole state nfp range = do
250251
((modsum,_), _) <- MaybeT $ runIde state $ useWithStale GetModSummaryWithoutTimestamps nfp
251252
let dflags = ms_hspp_opts modsum
252253

253-
(rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts $ hieAst asts) $ \fs ast ->
254-
case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of
255-
Nothing -> Nothing
256-
Just ast' -> do
257-
let info = nodeInfo ast'
258-
ty <- listToMaybe $ nodeType info
259-
guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info
260-
pure (nodeSpan ast', ty)
261-
262-
resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss
263-
(tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp
264-
let tcg = tmrTypechecked tcmod
265-
tcs = tcg_binds tcg
266-
ctx = mkContext
267-
(mapMaybe (sequenceA . (occName *** coerce))
268-
$ getDefiningBindings binds rss)
269-
tcg
270-
top_provs = getRhsPosVals rss tcs
271-
local_hy = spliceProvenance top_provs
272-
$ hypothesisFromBindings rss binds
273-
cls_hy = contextMethodHypothesis ctx
274-
pure ( resulting_range
275-
, mkFirstJudgement
276-
(local_hy <> cls_hy)
277-
(isRhsHole rss tcs)
278-
goal
279-
, ctx
280-
, dflags
281-
)
282-
254+
case asts of
255+
(HAR _ hf _ kind) -> do
256+
(rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
257+
case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of
258+
Nothing -> Nothing
259+
Just ast' -> do
260+
let info = nodeInfo ast'
261+
ty <- listToMaybe $ nodeType info
262+
guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info
263+
pure (nodeSpan ast', ty)
264+
265+
resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss
266+
(tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp
267+
let tcg = tmrTypechecked tcmod
268+
tcs = tcg_binds tcg
269+
ctx = mkContext
270+
(mapMaybe (sequenceA . (occName *** coerce))
271+
$ getDefiningBindings binds rss)
272+
tcg
273+
top_provs = getRhsPosVals rss tcs
274+
local_hy = spliceProvenance top_provs
275+
$ hypothesisFromBindings rss binds
276+
cls_hy = contextMethodHypothesis ctx
277+
case kind of
278+
HieFromDisk hf' ->
279+
-- TODO FIXME XXX.
280+
fail undefined
281+
HieFresh ->
282+
pure ( resulting_range
283+
, mkFirstJudgement
284+
(local_hy <> cls_hy)
285+
(isRhsHole rss tcs)
286+
goal
287+
, ctx
288+
, dflags
289+
)
283290

284291
spliceProvenance
285292
:: Map OccName Provenance
@@ -365,4 +372,3 @@ getRhsPosVals rss tcs
365372
-- TODO(sandy): Make this more robust
366373
isHole :: OccName -> Bool
367374
isHole = isPrefixOf "_" . occNameString
368-

‎src/Ide/Main.hs‎

Lines changed: 50 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -34,8 +34,8 @@ import Development.IDE.Core.Shake
3434
import Development.IDE.LSP.LanguageServer
3535
import Development.IDE.LSP.Protocol
3636
import Development.IDE.Plugin
37+
import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions, cacheDir)
3738
import Development.IDE.Plugin.HLS
38-
import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions)
3939
import Development.IDE.Types.Diagnostics
4040
import Development.IDE.Types.Location
4141
import Development.IDE.Types.Logger as G
@@ -57,7 +57,25 @@ import qualified System.Log.Logger as L
5757
import System.Time.Extra
5858
import Development.Shake (action)
5959

60-
ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text])
60+
import HieDb.Create
61+
import HieDb.Types
62+
import Database.SQLite.Simple
63+
import qualified Data.ByteString.Char8 as B
64+
import qualified Crypto.Hash.SHA1 as H
65+
import Control.Concurrent.Async
66+
import Control.Exception
67+
import System.Directory
68+
import Data.ByteString.Base16
69+
70+
-- ---------------------------------------------------------------------
71+
-- ghcide partialhandlers
72+
import Development.IDE.Plugin.CodeAction as CodeAction
73+
import Development.IDE.Plugin.Completions as Completions
74+
import Development.IDE.LSP.HoverDefinition as HoverDefinition
75+
76+
-- ---------------------------------------------------------------------
77+
78+
ghcIdePlugins :: T.Text -> IdePlugins -> (Plugin Config, [T.Text])
6179
ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps)
6280

6381
defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
@@ -84,21 +102,35 @@ defaultMain args idePlugins = do
84102
hPutStrLn stderr hlsVer
85103
runLspMode lspArgs idePlugins
86104

87-
-- ---------------------------------------------------------------------
88-
89-
hlsLogger :: G.Logger
90-
hlsLogger = G.Logger $ \pri txt ->
91-
case pri of
92-
G.Telemetry -> logm (T.unpack txt)
93-
G.Debug -> debugm (T.unpack txt)
94-
G.Info -> logm (T.unpack txt)
95-
G.Warning -> warningm (T.unpack txt)
96-
G.Error -> errorm (T.unpack txt)
105+
getHieDbLoc :: FilePath -> IO FilePath
106+
getHieDbLoc dir = do
107+
let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb"
108+
dirHash = B.unpack $ encode $ H.hash $ B.pack dir
109+
cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
110+
createDirectoryIfMissing True cDir
111+
pure (cDir </> db)
97112

98-
-- ---------------------------------------------------------------------
99-
100-
runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
101-
runLspMode lspArgs@LspArguments{..} idePlugins = do
113+
runLspMode :: LspArguments -> IdePlugins -> IO ()
114+
runLspMode lspArgs idePlugins = do
115+
dir <- IO.getCurrentDirectory
116+
dbLoc <- getHieDbLoc dir
117+
runWithDb dbLoc $ runLspMode' lspArgs idePlugins
118+
119+
runWithDb :: FilePath -> (HieDb -> HieWriterChan -> IO ()) -> IO ()
120+
runWithDb fp k =
121+
withHieDb fp $ \writedb -> do
122+
execute_ (getConn writedb) "PRAGMA journal_mode=WAL;"
123+
initConn writedb
124+
chan <- newChan
125+
race_ (writerThread writedb chan) (withHieDb fp (flip k chan))
126+
where
127+
writerThread db chan = forever $ do
128+
k <- readChan chan
129+
k db `catch` \e@SQLError{} -> do
130+
hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e
131+
132+
runLspMode' :: LspArguments -> IdePlugins -> HieDb -> HieWriterChan -> IO ()
133+
runLspMode' lspArgs@LspArguments{..} idePlugins hiedb hiechan = do
102134
LSP.setupLogger argsLogFile ["hls", "hie-bios"]
103135
$ if argsDebugOn then L.DEBUG else L.INFO
104136

@@ -142,6 +174,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do
142174
debouncer <- newAsyncDebouncer
143175
initialise caps (mainRule >> pluginRules plugins >> action kick)
144176
getLspId event wProg wIndefProg hlsLogger debouncer options vfs
177+
hiedb hiechan
145178
else do
146179
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
147180
hSetEncoding stdout utf8
@@ -170,7 +203,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do
170203
debouncer <- newAsyncDebouncer
171204
let dummyWithProg _ _ f = f (const (pure ()))
172205
sessionLoader <- loadSession dir
173-
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs
206+
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs hiedb hiechan
174207

175208
putStrLn "\nStep 4/4: Type checking the files"
176209
setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files

0 commit comments

Comments
 (0)