Update HLS

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

@@ -252,7 +252,7 @@ judgementForHole state nfp range = do
   let dflags = ms_hspp_opts modsum
 
   case asts of
-    (HAR _ hf _ kind) -> do
+    (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
@@ -276,8 +276,7 @@ judgementForHole state nfp range = do
           cls_hy = contextMethodHypothesis ctx
       case kind of
         HieFromDisk hf' ->
-          -- TODO FIXME XXX.
-          fail undefined
+          fail "Need a fresh hie file"
         HieFresh ->
           pure ( resulting_range
                , mkFirstJudgement

src/Ide/Main.hs

@@ -35,7 +35,7 @@ import Development.IDE.LSP.LanguageServer
 import Development.IDE.LSP.Protocol
 import Development.IDE.Plugin
 import Development.IDE.Plugin.HLS
-import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions, cacheDir)
+import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions, setInitialDynFlags, getHieDbLoc, runWithDb)
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger as G
@@ -57,24 +57,6 @@ import qualified System.Log.Logger as L
 import System.Time.Extra
 import Development.Shake (action)
 
-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 IdeState -> (Plugin Config, [T.Text])
 ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps)
 
@@ -116,36 +98,12 @@ hlsLogger = G.Logger $ \pri txt ->
 -- ---------------------------------------------------------------------
 
 runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
-runLspMode lspArgs@LspArguments{..} idePlugins = do
-
-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 -> 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' :: LspArguments -> IdePlugins IdeState -> HieDb -> IndexQueue -> IO ()
 runLspMode' lspArgs@LspArguments{..} idePlugins hiedb hiechan = do
     LSP.setupLogger argsLogFile ["hls", "hie-bios"]
       $ if argsDebugOn then L.DEBUG else L.INFO
@@ -159,6 +117,8 @@ runLspMode' lspArgs@LspArguments{..} idePlugins hiedb hiechan = do
 
     dir <- IO.getCurrentDirectory
 
+    libdir <- setInitialDynFlags
+
     pid <- T.pack . show <$> getProcessID
     let
         (plugins, commandIds) = ghcIdePlugins pid idePlugins