Automatically pick up new dependencies (#408)

* Automatically pick up new dependencies

hie-bios's componentDependencies returns the dependencies of a cradle
that might change the cradle. Add those deps to the shake graph so that
the GHC session is newly created whenever they change.

For that, add a new rule type, GetHscEnvEq, to cache GHC sessions with
the key of GHC options and dependencies. And delete the optGhcSession
field from IdeOptions.

This is for https://github.com/digital-asset/ghcide/issues/50.

hie-bios's componentDependencies can return files that don't exist yet:
https://github.com/mpickering/hie-bios/blob/master/src/HIE/Bios/Types.hs#L90-L93.
This PR handles changes in the existing dependency files, but doesn't
handle newly created dependency files.

* address comments

* revert hie.yaml

* address more comments

* add test

* make direct cradles work; and use direct cradle in test

exe/Main.hs

@@ -3,14 +3,19 @@
 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
 {-# LANGUAGE CPP #-} -- To get precise GHC version
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Main(main) where
 
 import Arguments
+import Data.Binary (Binary)
+import Data.Dynamic (Typeable)
+import Data.Hashable (Hashable)
 import Data.Maybe
 import Data.List.Extra
 import System.FilePath
 import Control.Concurrent.Extra
+import Control.DeepSeq (NFData)
 import Control.Exception
 import Control.Monad.Extra
 import Control.Monad.IO.Class
@@ -39,20 +44,22 @@ import Language.Haskell.LSP.Types (LspId(IdInt))
 import Linker
 import Data.Version
 import Development.IDE.LSP.LanguageServer
-import System.Directory.Extra as IO
+import qualified System.Directory.Extra as IO
 import System.Environment
 import System.IO
 import System.Exit
 import Paths_ghcide
 import Development.GitRev
-import Development.Shake (Action, action)
+import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)
 import qualified Data.HashSet as HashSet
 import qualified Data.Map.Strict as Map
 
 import GHC hiding (def)
+import GHC.Generics (Generic)
 import qualified GHC.Paths
 
 import HIE.Bios
+import HIE.Bios.Cradle
 import HIE.Bios.Types
 
 -- Set the GHC libdir to the nix libdir if it's present.
@@ -84,9 +91,9 @@ main = do
     let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
             T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
 
-    whenJust argsCwd setCurrentDirectory
+    whenJust argsCwd IO.setCurrentDirectory
 
-    dir <- getCurrentDirectory
+    dir <- IO.getCurrentDirectory
 
     let plugins = Completions.plugin <> CodeAction.plugin
         onInitialConfiguration = const $ Right ()
@@ -99,14 +106,13 @@ main = do
         runLanguageServer def (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-            -- very important we only call loadSession once, and it's fast, so just do it before starting
-            session <- loadSession dir
-            let options = (defaultIdeOptions $ return session)
+            let options = (defaultIdeOptions $ loadSession dir)
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs
+            initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)
+                getLspId event (logger minBound) debouncer options vfs
     else do
         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
         putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
@@ -114,7 +120,7 @@ main = do
         putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
         files <- expandFiles (argFiles ++ ["." | null argFiles])
         -- LSP works with absolute file paths, so try and behave similarly
-        files <- nubOrd <$> mapM canonicalizePath files
+        files <- nubOrd <$> mapM IO.canonicalizePath files
         putStrLn $ "Found " ++ show (length files) ++ " files"
 
         putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
@@ -128,7 +134,8 @@ main = do
             cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
             when (isNothing x) $ print cradle
             putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
-            cradleToSession cradle
+            opts <- getComponentOptions cradle
+            createSession opts
 
         putStrLn "\nStep 5/6: Initializing the IDE"
         vfs <- makeVFSHandle
@@ -141,7 +148,7 @@ main = do
         let options =
               (defaultIdeOptions $ return $ return . grab)
                     { optShakeProfiling = argsShakeProfiling }
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
+        ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
@@ -163,7 +170,7 @@ expandFiles = concatMapM $ \x -> do
         let recurse "." = True
             recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
             recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
-        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
+        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
         when (null files) $
             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
         return files
@@ -182,16 +189,42 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
 showEvent lock e = withLock lock $ print e
 
 
-cradleToSession :: Cradle a -> IO HscEnvEq
-cradleToSession cradle = do
+-- Rule type for caching GHC sessions.
+type instance RuleResult GetHscEnv = HscEnvEq
+
+data GetHscEnv = GetHscEnv
+    { hscenvOptions :: [String]        -- componentOptions from hie-bios
+    , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios
+    }
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetHscEnv
+instance NFData   GetHscEnv
+instance Binary   GetHscEnv
+
+
+loadGhcSessionIO :: Rules ()
+loadGhcSessionIO =
+    -- This rule is for caching the GHC session. E.g., even when the cabal file
+    -- changed, if the resulting flags did not change, we would continue to use
+    -- the existing session.
+    defineNoFile $ \(GetHscEnv opts deps) ->
+        liftIO $ createSession $ ComponentOptions opts deps
+
+
+getComponentOptions :: Cradle a -> IO ComponentOptions
+getComponentOptions cradle = do
     let showLine s = putStrLn ("> " ++ s)
     cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
-    opts <- case cradleRes of
+    case cradleRes of
         CradleSuccess r -> pure r
         CradleFail err -> throwIO err
         -- TODO Rather than failing here, we should ignore any files that use this cradle.
         -- That will require some more changes.
         CradleNone -> fail "'none' cradle is not yet supported"
+
+
+createSession :: ComponentOptions -> IO HscEnvEq
+createSession opts = do
     libdir <- getLibdir
     env <- runGhc (Just libdir) $ do
         _targets <- initSession opts
@@ -200,19 +233,34 @@ cradleToSession cradle = do
     newHscEnvEq env
 
 
-loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
-loadSession dir = do
+cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq
+cradleToSession mbYaml cradle = do
+    cmpOpts <- liftIO $ getComponentOptions cradle
+    let opts = componentOptions cmpOpts
+        deps = componentDependencies cmpOpts
+        deps' = case mbYaml of
+                  -- For direct cradles, the hie.yaml file itself must be watched.
+                  Just yaml | isDirectCradle cradle -> yaml : deps
+                  _ -> deps
+    existingDeps <- filterM doesFileExist deps'
+    need existingDeps
+    useNoFile_ $ GetHscEnv opts deps
+
+
+loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
+loadSession dir = liftIO $ do
     cradleLoc <- memoIO $ \v -> do
         res <- findCradle v
         -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
         -- try and normalise that
         -- e.g. see https://github.com/digital-asset/ghcide/issues/126
-        res' <- traverse makeAbsolute res
+        res' <- traverse IO.makeAbsolute res
         return $ normalise <$> res'
-    session <- memoIO $ \file -> do
-        c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
-        cradleToSession c
-    return $ \file -> liftIO $ session =<< cradleLoc file
+    let session :: Maybe FilePath -> Action HscEnvEq
+        session file = do
+          c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
+          cradleToSession file c
+    return $ \file -> session =<< liftIO (cradleLoc file)
 
 
 -- | Memoize an IO function, with the characteristics:

ghcide.cabal

@@ -169,14 +169,17 @@ executable ghcide
     build-depends:
         hslogger,
         base == 4.*,
+        binary,
         containers,
         data-default,
+        deepseq,
         directory,
         extra,
         filepath,
         ghc-paths,
         ghc,
         gitrev,
+        hashable,
         haskell-lsp,
         hie-bios >= 0.4.0 && < 0.5,
         ghcide,
@@ -189,6 +192,7 @@ executable ghcide
         Paths_ghcide
 
     default-extensions:
+        DeriveGeneric
         RecordWildCards
         TupleSections
         ViewPatterns

src/Development/IDE/Core/Rules.hs

@@ -11,7 +11,7 @@
 --
 module Development.IDE.Core.Rules(
     IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
-    Priority(..),
+    Priority(..), GhcSessionIO(..), GhcSessionFun(..),
     priorityTypeCheck,
     priorityGenerateCore,
     priorityFilesOfInterest,
@@ -339,7 +339,7 @@ loadGhcSession :: Rules ()
 loadGhcSession = do
     defineNoFile $ \GhcSessionIO -> do
         opts <- getIdeOptions
-        liftIO $ GhcSessionFun <$> optGhcSession opts
+        GhcSessionFun <$> optGhcSession opts
     defineEarlyCutoff $ \GhcSession file -> do
         GhcSessionFun fun <- useNoFile_ GhcSessionIO
         val <- fun $ fromNormalizedFilePath file

src/Development/IDE/Types/Options.hs

@@ -25,12 +25,10 @@ data IdeOptions = IdeOptions
   { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
     -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
     --   and a list of errors, along with a new parse tree.
-  , optGhcSession :: IO (FilePath -> Action HscEnvEq)
+  , optGhcSession :: Action (FilePath -> Action HscEnvEq)
     -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
-    --   The 'IO' will be called once, then the resulting function will be applied once per file.
+    --   For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
     --   It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
-    --   You should not use 'newCacheIO' to get that caching, because of
-    --   https://github.com/ndmitchell/shake/issues/725.
   , optPkgLocationOpts :: IdePkgLocationOptions
     -- ^ How to locate source and @.hie@ files given a module name.
   , optExtensions :: [String]
@@ -73,7 +71,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
 clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
     LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)
 
-defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions
+defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions
 defaultIdeOptions session = IdeOptions
     {optPreprocessor = IdePreprocessedSource [] []
     ,optGhcSession = session

test/exe/Main.hs

@@ -64,6 +64,7 @@ main = defaultMain $ testGroup "HIE"
   , haddockTests
   , positionMappingTests
   , watchedFilesTests
+  , sessionDepsArePickedUp
   ]
 
 initializeResponseTests :: TestTree
@@ -1774,6 +1775,44 @@ haddockTests
   where
     checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
 
+
+sessionDepsArePickedUp :: TestTree
+sessionDepsArePickedUp = testSession'
+  "session-deps-are-picked-up"
+  $ \dir -> do
+    liftIO $
+      writeFileUTF8
+        (dir </> "hie.yaml")
+        "cradle: {direct: {arguments: []}}"
+    -- Open without OverloadedStrings and expect an error.
+    doc <- openDoc' "Foo.hs" "haskell" fooContent
+    expectDiagnostics
+      [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
+    -- Update hie.yaml to enable OverloadedStrings.
+    liftIO $
+      writeFileUTF8
+        (dir </> "hie.yaml")
+        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
+    -- Send change event.
+    let change =
+          TextDocumentContentChangeEvent
+            { _range = Just (Range (Position 4 0) (Position 4 0)),
+              _rangeLength = Nothing,
+              _text = "\n"
+            }
+    changeDoc doc [change]
+    -- Now no errors.
+    expectDiagnostics [("Foo.hs", [])]
+  where
+    fooContent =
+      T.unlines
+        [ "module Foo where",
+          "import Data.Text",
+          "foo :: Text",
+          "foo = \"hello\""
+        ]
+
+
 ----------------------------------------------------------------------
 -- Utils
 
@@ -1781,6 +1820,9 @@ haddockTests
 testSession :: String -> Session () -> TestTree
 testSession name = testCase name . run
 
+testSession' :: String -> (FilePath -> Session ()) -> TestTree
+testSession' name = testCase name . run'
+
 testSessionWait :: String -> Session () -> TestTree
 testSessionWait name = testSession name .
       -- Check that any diagnostics produced were already consumed by the test case.
@@ -1801,7 +1843,13 @@ mkRange :: Int -> Int -> Int -> Int -> Range
 mkRange a b c d = Range (Position a b) (Position c d)
 
 run :: Session a -> IO a
-run s = withTempDir $ \dir -> do
+run s = withTempDir $ \dir -> runInDir dir s
+
+run' :: (FilePath -> Session a) -> IO a
+run' s = withTempDir $ \dir -> runInDir dir (s dir)
+
+runInDir :: FilePath -> Session a -> IO a
+runInDir dir s = do
   ghcideExe <- locateGhcideExecutable
 
   -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56