Merge pull request #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