Merge pull request #79 from alanz/wip-az

Use mpickering/hls ghcide branch

Author: alanz

exe/Main.hs

@@ -195,7 +195,7 @@ main = do
                     , optInterfaceLoadingDiagnostics = argsTesting
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins)
+            fst <$> 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
@@ -218,15 +218,15 @@ main = do
         putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
         putStrLn "\nStep 3/6: Initializing the IDE"
         vfs <- makeVFSHandle
-
         debouncer <- newAsyncDebouncer
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSession dir) vfs
+        (ide, worker) <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSession dir) vfs
 
         putStrLn "\nStep 4/6: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
-        _ <- runActionSync "TypecheckTest" 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"
+        cancel worker
         return ()
 
 expandFiles :: [FilePath] -> IO [FilePath]
@@ -408,7 +408,7 @@ loadSession dir = liftIO $ do
         modifyVar_ fileToFlags $ \var -> do
             pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
 
-        return res
+        return (cs, res)
 
     lock <- newLock
 
@@ -432,7 +432,7 @@ loadSession dir = liftIO $ do
         case HM.lookup (toNormalizedFilePath' cfp) v of
             Just opts -> do
                 --putStrLn $ "Cached component of " <> show file
-                pure (fst opts)
+                pure ([], fst opts)
             Nothing-> do
                 finished_barrier <- newBarrier
                 -- fork a new thread here which won't be killed by shake
@@ -442,8 +442,8 @@ loadSession dir = liftIO $ do
                   cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
                   opts <- cradleToSessionOpts cradle cfp
                   print opts
-                  res <- fst <$> session (hieYaml, toNormalizedFilePath' cfp, opts)
-                  signalBarrier finished_barrier res
+                  (cs, res)<- session (hieYaml, toNormalizedFilePath' cfp, opts)
+                  signalBarrier finished_barrier (cs, fst res)
                 waitBarrier finished_barrier
 
     dummyAs <- async $ return (error "Uninitialised")
@@ -454,18 +454,30 @@ loadSession dir = liftIO $ 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
+    return $ \file -> do
+      (cs, opts) <-
+        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
+      let cfps = map fst cs
+      -- Delayed to avoid recursion and only run if something changed.
+      unless (null cs) (
+        delay "InitialLoad" ("InitialLoad" :: String, cfps) (void $ do
+          cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cfps
+          mmt <- uses GetModificationTime cfps'
+          let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+          uses GetModIface cs_exist))
+      return opts
+
 
 
 

ghcide

@@ -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 "Example.codeLens" ideState $ runMaybeT $ useE TypeCheck filePath
+        _ <- runIdeAction "Example.codeLens" ideState $ runMaybeT $ useE TypeCheck filePath
         _diag <- getDiagnostics ideState
         _hDiag <- getHiddenDiagnostics ideState
         let

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 (fromNormalizedFilePath filePath) ideState $ runMaybeT $ useE TypeCheck filePath
+        _ <- runIdeAction (fromNormalizedFilePath filePath) ideState $ runMaybeT $ useE TypeCheck filePath
         _diag <- getDiagnostics ideState
         _hDiag <- getHiddenDiagnostics ideState
         let

src/Ide/Plugin/Example2.hs

@@ -83,6 +83,7 @@ data PluginCommand = forall a. (FromJSON a) =>
                 , commandDesc :: T.Text
                 , commandFunc :: CommandFunction a
                 }
+
 -- ---------------------------------------------------------------------
 
 type CommandFunction a = LSP.LspFuncs Config

src/Ide/Types.hs

@@ -37,6 +37,7 @@ extra-deps:
 - monad-memo-0.4.1
 - multistate-0.8.0.1
 - ormolu-0.0.5.0
+- opentelemetry-0.3.0
 - parser-combinators-1.2.1
 - regex-base-0.94.0.0
 - regex-tdfa-1.3.1.0

stack-8.6.4.yaml

@@ -28,6 +28,7 @@ extra-deps:
 - indexed-profunctors-0.1
 - lsp-test-0.10.2.0
 - monad-dijkstra-0.1.1.2
+- opentelemetry-0.3.0
 - optics-core-0.2
 - optparse-applicative-0.15.1.0
 - ormolu-0.0.5.0

stack-8.6.5.yaml

@@ -27,6 +27,7 @@ extra-deps:
 - indexed-profunctors-0.1
 - lsp-test-0.10.2.0
 - monad-dijkstra-0.1.1.2
+- opentelemetry-0.3.0
 - optics-core-0.2
 - optparse-applicative-0.15.1.0
 - ormolu-0.0.5.0