Merge pull request haskell#73 from alanz/rebase-ghcide-multi

Rebase on mpickering ghcide at wip/multi-rebase

Author: alanz

cabal.project

@@ -12,6 +12,10 @@ source-repository-package
  location: https://github.com/fendor/hie-bios.git
  tag: 89d28817716a1c8df7e191f3a43c4504bc6379eb
 
+source-repository-package
+ type: git
+ location: https://github.com/mpickering/shake
+ tag: 4d56fe9f09bd3bd63ead541c571c756995da490a
 
 tests: true
 documentation: false

exe/Arguments.hs

@@ -36,7 +36,7 @@ data Arguments = Arguments
  -- them to just change the name of the exe and still work.
  , argsDebugOn :: Bool
  , argsLogFile :: Maybe String
- , argsThread  :: Int
+ , argsThreads :: Int
  } deriving Show
 
 getArguments :: String -> IO Arguments

exe/Main.hs

@@ -13,6 +13,7 @@
 module Main(main) where
 
 import Arguments
+import Control.Concurrent.Async
 import Control.Concurrent.Extra
 import Control.Exception
 import Control.Monad.Extra
@@ -48,7 +49,7 @@ import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
-import Development.Shake (Action, action)
+import Development.Shake (Action)
 import DynFlags (gopt_set, gopt_unset,
  updOptLevel)
 import DynFlags (PackageFlag(..), PackageArg(..))
@@ -190,11 +191,11 @@ main = do
  { optReportProgress = clientSupportsProgress caps
  , optShakeProfiling = argsShakeProfiling
  , optTesting = argsTesting
+ , optThreads = argsThreads
  , optInterfaceLoadingDiagnostics = argsTesting
- , optThreads = argsThread
  }
  debouncer <- newAsyncDebouncer
- initialise caps (mainRule >> pluginRules plugins >> action kick)
+ initialise caps (mainRule >> pluginRules plugins)
  getLspId event hlsLogger debouncer options vfs
  else do
  -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -223,7 +224,7 @@ main = do
 
  putStrLn "\nStep 4/6: Type checking the files"
  setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
- _ <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
+ _ <- runActionSync "TypecheckTest" ide $ uses TypeCheck (map toNormalizedFilePath' files)
 -- results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath' "src/Development/IDE/Core/Rules.hs"
 -- results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath' "exe/Main.hs"
  return ()
@@ -240,11 +241,13 @@ expandFiles = concatMapM $ \x -> do
  fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
  return files
 
-
+-- Running this every hover is too expensive, 0.2s on GHC for example
+{-
 kick :: Action ()
 kick = do
  files <- getFilesOfInterest
  void $ uses TypeCheck $ HashSet.toList files
+ -}
 
 -- | Print an LSP event.
 showEvent :: Lock -> FromServerMessage -> IO ()
@@ -408,7 +411,6 @@ loadSession dir = liftIO $ do
  return res
 
  lock <- newLock
- cradle_lock <- newLock
 
  -- This caches the mapping from hie.yaml + Mod.hs -> [String]
  sessionOpts <- return $ \(hieYaml, file) -> do
@@ -435,17 +437,39 @@ loadSession dir = liftIO $ do
  finished_barrier <- newBarrier
  -- fork a new thread here which won't be killed by shake
  -- throwing an async exception
- void $ forkIO $ withLock cradle_lock $ do
- putStrLn $ "Shelling out to cabal " <> show file
+ void $ forkIO $ do
+ putStrLn $ "Consulting the cradle for " <> show file
  cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
  opts <- cradleToSessionOpts cradle cfp
  print opts
  res <- fst <$> session (hieYaml, toNormalizedFilePath' cfp, opts)
  signalBarrier finished_barrier res
  waitBarrier finished_barrier
- return $ \file -> liftIO $ mask_ $ withLock lock $ do
- hieYaml <- cradleLoc file
- sessionOpts (hieYaml, file)
+
+ dummyAs <- async $ return (error "Uninitialised")
+ runningCradle <- newIORef dummyAs
+ -- The main function which gets options for a file. We only want one of these running
+ -- at a time.
+ let getOptions file = do
+ hieYaml <- cradleLoc file
+ sessionOpts (hieYaml, file)
+ -- The lock is on the `runningCradle` resource
+ return $ \file -> liftIO $ withLock lock $ do
+ as <- readIORef runningCradle
+ finished <- poll as
+ case finished of
+ Just {} -> do
+ as <- async $ getOptions file
+ writeIORef runningCradle as
+ wait as
+ -- If it's not finished then wait and then get options, this could of course be killed still
+ Nothing -> do
+ _ <- wait as
+ getOptions file
+
+
+
+
 
 checkDependencyInfo :: Map.Map FilePath (Maybe UTCTime) -> IO Bool
 checkDependencyInfo old_di = do

ghcide

@@ -133,6 +133,7 @@ executable haskell-language-server
  build-depends:
  base >=4.7 && <5
  , aeson
+ , async
  , base16-bytestring
  , binary
  , bytestring

haskell-language-server.cabal

@@ -125,7 +125,7 @@ codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier u
  logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ
  case uriToFilePath' uri of
  Just (toNormalizedFilePath -> filePath) -> do
- _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
+ _ <- runAction "Example.codeLens" ideState $ runMaybeT $ useE TypeCheck filePath
  _diag <- getDiagnostics ideState
  _hDiag <- getHiddenDiagnostics ideState
  let
@@ -190,7 +190,7 @@ logAndRunRequest label getResults ide pos path = do
  logInfo (ideLogger ide) $
  label <> " request at position " <> T.pack (showPosition pos) <>
  " in file: " <> T.pack path
- runAction ide $ getResults filePath pos
+ runAction "Example" ide $ getResults filePath pos
 
 -- ---------------------------------------------------------------------
 

src/Ide/Plugin/Example.hs

@@ -125,7 +125,7 @@ codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier u
  logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ
  case uriToFilePath' uri of
  Just (toNormalizedFilePath -> filePath) -> do
- _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
+ _ <- runAction (fromNormalizedFilePath filePath) ideState $ runMaybeT $ useE TypeCheck filePath
  _diag <- getDiagnostics ideState
  _hDiag <- getHiddenDiagnostics ideState
  let
@@ -187,7 +187,7 @@ logAndRunRequest label getResults ide pos path = do
  logInfo (ideLogger ide) $
  label <> " request at position " <> T.pack (showPosition pos) <>
  " in file: " <> T.pack path
- runAction ide $ getResults filePath pos
+ runAction "Example2" ide $ getResults filePath pos
 
 -- ---------------------------------------------------------------------
 

src/Ide/Plugin/Example2.hs

@@ -64,7 +64,7 @@ doFormatting lf providers ideState ft uri params = do
  Just provider ->
  case uriToFilePath uri of
  Just (toNormalizedFilePath -> fp) -> do
- (_, mb_contents) <- runAction ideState $ getFileContents fp
+ (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp
  case mb_contents of
  Just contents -> do
  logDebug (ideLogger ideState) $ T.pack $

src/Ide/Plugin/Formatter.hs

@@ -59,7 +59,7 @@ provider _lf ideState typ contents fp _ = do
  in
  return $ map DynOption $ pp <> pm <> ex
 
- m_parsed <- runAction ideState $ getParsedModule fp
+ m_parsed <- runAction "Ormolu" ideState $ getParsedModule fp
  fileOpts <- case m_parsed of
  Nothing -> return []
  Just pm -> fromDyn pm

src/Ide/Plugin/Ormolu.hs

@@ -14,7 +14,7 @@ extra-deps:
 - cabal-plan-0.5.0.0
 - constrained-dynamic-0.1.0.0
 # - ghcide-0.1.0
-- extra-1.6.18
+- extra-1.6.21
 - floskell-0.10.2
 - fuzzy-0.1.0.0
 - ghc-check-0.1.0.3
@@ -28,7 +28,7 @@ extra-deps:
 - haskell-src-exts-1.21.1
 # - hie-bios-0.4.0
 - github: fendor/hie-bios
- commit: 89d28817716a1c8df7e191f3a43c4504bc6379eb
+ commit: 87db34de1b10b03bb2c3d7f6bd3623bc1da96ba8
 - hlint-2.2.8
 - hoogle-5.0.17.11
 - hsimport-0.11.0
@@ -41,7 +41,9 @@ extra-deps:
 - regex-base-0.94.0.0
 - regex-tdfa-1.3.1.0
 - rope-utf16-splay-0.3.1.0
-- shake-0.18.5
+# - shake-0.18.5
+- github: mpickering/shake
+ commit: 4d56fe9f09bd3bd63ead541c571c756995da490a
 - syz-0.2.0.0
 - tasty-rerun-1.1.17
 - temporary-1.2.1.1