Write hls unit tests for get references

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

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

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

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

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  ;

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,16 +281,21 @@ executable haskell-language-server
 
   build-depends:
     , aeson
+    , async
+    , base16-bytestring
     , binary
     , bytestring
     , containers
+    , cryptohash-sha1
     , deepseq
     , ghc
     , ghc-boot-th
     , ghcide
     , 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
-
-
-
-

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

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
-

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