Typed rule inputs

ghcide/ghcide.cabal

@@ -135,6 +135,7 @@ library
     Development.IDE.Core.FileStore
     Development.IDE.Core.FileUtils
     Development.IDE.Core.IdeConfiguration
+    Development.IDE.Core.InputPath
     Development.IDE.Core.OfInterest
     Development.IDE.Core.PluginUtils
     Development.IDE.Core.PositionMapping

ghcide/session-loader/Development/IDE/Session.hs

@@ -125,6 +125,7 @@ import           GHC.Driver.Errors.Types
 import           GHC.Types.Error                     (errMsgDiagnostic,
                                                       singleMessage)
 import           GHC.Unit.State
+import Development.IDE.Core.InputPath (generalizeProjectInput, classifyProjectHaskellInputs)
 
 data Log
   = LogSettingInitialDynFlags
@@ -592,8 +593,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
           unless (null new_deps || not checkProject) $ do
                 cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
                 void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
-                    mmt <- uses GetModificationTime cfps'
-                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+                    let cfps'' = classifyProjectHaskellInputs cfps'
+                    mmt <- uses GetModificationTime $ generalizeProjectInput <$> cfps''
+                    let cs_exist = catMaybes (zipWith (<$) cfps'' mmt)
                     modIfaces <- uses GetModIface cs_exist
                     -- update exports map
                     shakeExtras <- getShakeExtras

ghcide/src/Development/IDE/Core/Actions.hs

@@ -32,6 +32,7 @@ import           Language.LSP.Protocol.Types          (DocumentHighlight (..),
                                                        SymbolInformation (..),
                                                        normalizedFilePathToUri,
                                                        uriToNormalizedFilePath)
+import Development.IDE.Core.InputPath (classifyProjectHaskellInputs, InputPath (InputPath))
 
 
 -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
@@ -59,12 +60,22 @@ getAtPoint file pos = runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
 
-  (hf, mapping) <- useWithStaleFastMT GetHieAst file
-  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
+  (hf, mapping) <- useWithStaleFastMT GetHieAst $ InputPath file
+  -- The HscEnv and DKMap are not strictly necessary for hover
+  -- to work, so we only calculate them for project files, not
+  -- for dependency files. They provide information that will
+  -- not be displayed in dependency files. See the atPoint
+  -- function in ghcide/src/Development/IDE/Spans/AtPoint.hs
+  -- for the specifics of how they are used.
+  (mEnv, mDkMap) <- case classifyProjectHaskellInputs [file] of
+    [] -> pure (Nothing, Nothing)
+    projectInput:_ -> do
+      env <- hscEnv . fst <$> useWithStaleFastMT GhcSession projectInput
+      dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap projectInput)
+      pure (Just env, Just dkMap)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos'
+  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf mDkMap mEnv pos'
 
 -- | Converts locations in the source code to their current positions,
 -- taking into account changes that may have occurred due to edits.
@@ -87,7 +98,7 @@ toCurrentLocation mapping file (Location uri range) =
   else do
     otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
       otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
-      useWithStaleFastMT GetHieAst otherLocationFile
+      useWithStaleFastMT GetHieAst $ InputPath otherLocationFile
     pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
   where
     nUri :: NormalizedUri
@@ -98,8 +109,10 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location,
 getDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file
-    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
+    (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst $ InputPath file
+    (ImportMap imports, _) <- case classifyProjectHaskellInputs [file] of
+      [] -> pure (ImportMap mempty, PositionMapping idDelta)
+      (projectInput: _) -> useWithStaleFastMT GetImportMap projectInput
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
     mapMaybeM (\(location, identifier) -> do
@@ -112,7 +125,7 @@ getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Locati
 getTypeDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useWithStaleFastMT GetHieAst file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst $ InputPath file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
     mapMaybeM (\(location, identifier) -> do
@@ -122,7 +135,7 @@ getTypeDefinition file pos = runMaybeT $ do
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do
-    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file
+    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst $ InputPath file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range
     mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'
@@ -132,7 +145,7 @@ refsAtPoint :: NormalizedFilePath -> Position -> Action [Location]
 refsAtPoint file pos = do
     ShakeExtras{withHieDb} <- getShakeExtras
     fs <- HM.keys <$> getFilesOfInterestUntracked
-    asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs
+    asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst (map InputPath fs)
     AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts)
 
 workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation])

ghcide/src/Development/IDE/Core/FileExists.hs

@@ -39,6 +39,8 @@ import           Language.LSP.Server                   hiding (getVirtualFile)
 import qualified StmContainers.Map                     as STM
 import qualified System.Directory                      as Dir
 import qualified System.FilePath.Glob                  as Glob
+import Development.IDE.Core.InputPath (InputPath (InputPath))
+import Development.IDE.Graph.Internal.Rules (InputClass(AllHaskellFiles))
 
 {- Note [File existence cache and LSP file watchers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -133,7 +135,7 @@ fromChange FileChangeType_Changed = Nothing
 -------------------------------------------------------------------------------------
 
 -- | Returns True if the file exists
-getFileExists :: NormalizedFilePath -> Action Bool
+getFileExists :: InputPath AllHaskellFiles -> Action Bool
 getFileExists fp = use_ GetFileExists fp
 
 {- Note [Which files should we watch?]
@@ -192,12 +194,15 @@ fileExistsRules recorder lspEnv = do
     then fileExistsRulesFast recorder isWatched
     else fileExistsRulesSlow recorder
 
-  fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched
+  fileStoreRules (cmapWithPrio LogFileStore recorder) (\(InputPath f) -> isWatched f)
 
 -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.
 fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
 fileExistsRulesFast recorder isWatched =
-    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do
+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics runGetFileExists
+    where
+      runGetFileExists :: GetFileExists -> InputPath AllHaskellFiles -> Action (Maybe BS.ByteString, Maybe Bool)
+      runGetFileExists GetFileExists (InputPath file) = do
         isWF <- isWatched file
         if isWF
             then fileExistsFast file
@@ -238,7 +243,10 @@ summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
 
 fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules ()
 fileExistsRulesSlow recorder =
-  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file
+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics runGetFileExists
+  where
+    runGetFileExists :: GetFileExists -> InputPath AllHaskellFiles -> Action (Maybe BS.ByteString, Maybe Bool)
+    runGetFileExists GetFileExists (InputPath file) = fileExistsSlow file
 
 fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
 fileExistsSlow file = do

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -1,5 +1,6 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Development.IDE.Core.FileStore(
@@ -69,6 +70,8 @@ import           Language.LSP.VFS
 import           System.FilePath
 import           System.IO.Error
 import           System.IO.Unsafe
+import Development.IDE.Core.InputPath (InputPath (unInputPath), classifyProjectHaskellInputs)
+import Development.IDE.Graph.Internal.Rules (InputClass(AllHaskellFiles))
 
 
 data Log
@@ -88,31 +91,34 @@ instance Pretty Log where
       <+> pretty (fmap (fmap show) reverseDepPaths)
     LogShake msg -> pretty msg
 
-addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
+addWatchedFileRule :: Recorder (WithPriority Log) -> (InputPath AllHaskellFiles -> Action Bool) -> Rules ()
 addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do
   isAlreadyWatched <- isWatched f
-  isWp <- isWorkspaceFile f
+  isWp <- isWorkspaceFile $ unInputPath f
   if isAlreadyWatched then pure (Just True) else
     if not isWp then pure (Just False) else do
         ShakeExtras{lspEnv} <- getShakeExtras
         case lspEnv of
             Just env -> fmap Just $ liftIO $ LSP.runLspT env $
-                registerFileWatches [fromNormalizedFilePath f]
+                registerFileWatches [fromNormalizedFilePath (unInputPath f)]
             Nothing -> pure $ Just False
 
 
 getModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()
-getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
-    getModificationTimeImpl missingFileDiags file
+getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule runGetModificationTimeImpl
+  where
+    runGetModificationTimeImpl :: GetModificationTime -> InputPath AllHaskellFiles -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
+    runGetModificationTimeImpl (GetModificationTime_ missingFileDiags) input =
+      getModificationTimeImpl missingFileDiags input
 
 getModificationTimeImpl
   :: Bool
-  -> NormalizedFilePath
+  -> InputPath AllHaskellFiles
   -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
 getModificationTimeImpl missingFileDiags file = do
-    let file' = fromNormalizedFilePath file
+    let file' = fromNormalizedFilePath $ unInputPath file
     let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
-    mbVf <- getVirtualFile file
+    mbVf <- getVirtualFile $ unInputPath file
     case mbVf of
         Just (virtualFileVersion -> ver) -> do
             alwaysRerun
@@ -124,7 +130,7 @@ getModificationTimeImpl missingFileDiags file = do
                         -- but also need a dependency on IsFileOfInterest to reinstall
                         -- alwaysRerun when the file becomes VFS
                     void (use_ IsFileOfInterest file)
-                else if isInterface file
+                else if isInterface (unInputPath file)
                     then -- interface files are tracked specially using the closed world assumption
                         pure ()
                     else -- in all other cases we will need to freshly check the file system
@@ -134,7 +140,7 @@ getModificationTimeImpl missingFileDiags file = do
                 `catch` \(e :: IOException) -> do
                     let err | isDoesNotExistError e = "File does not exist: " ++ file'
                             | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
-                        diag = ideErrorText file (T.pack err)
+                        diag = ideErrorText (unInputPath file) (T.pack err)
                     if isDoesNotExistError e && not missingFileDiags
                         then return (Nothing, ([], Nothing))
                         else return (Nothing, ([diag], Nothing))
@@ -171,22 +177,25 @@ modificationTime VFSVersion{}             = Nothing
 modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix
 
 getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()
-getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file
+getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) runGetFileContentsImpl
+  where
+    runGetFileContentsImpl :: GetFileContents -> InputPath AllHaskellFiles -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
+    runGetFileContentsImpl GetFileContents input = getFileContentsImpl input
 
 getFileContentsImpl
-    :: NormalizedFilePath
+    :: InputPath AllHaskellFiles
     -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
 getFileContentsImpl file = do
     -- need to depend on modification time to introduce a dependency with Cutoff
     time <- use_ GetModificationTime file
     res <- do
-        mbVirtual <- getVirtualFile file
+        mbVirtual <- getVirtualFile $ unInputPath file
         pure $ virtualFileText <$> mbVirtual
     pure ([], Just (time, res))
 
 -- | Returns the modification time and the contents.
 --   For VFS paths, the modification time is the current time.
-getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)
+getFileContents :: InputPath AllHaskellFiles -> Action (UTCTime, Maybe T.Text)
 getFileContents f = do
     (fv, txt) <- use_ GetFileContents f
     modTime <- case modificationTime fv of
@@ -196,11 +205,11 @@ getFileContents f = do
         liftIO $ case foi of
           IsFOI Modified{} -> getCurrentTime
           _ -> do
-            posix <- getModTime $ fromNormalizedFilePath f
+            posix <- getModTime $ fromNormalizedFilePath $ unInputPath f
             pure $ posixSecondsToUTCTime posix
     return (modTime, txt)
 
-fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
+fileStoreRules :: Recorder (WithPriority Log) -> (InputPath AllHaskellFiles -> Action Bool) -> Rules ()
 fileStoreRules recorder isWatched = do
     getModificationTimeRule recorder
     getFileContentsRule recorder
@@ -239,7 +248,8 @@ typecheckParentsAction recorder nfp = do
       Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp
       Just rs -> do
         logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs
-        void $ uses GetModIface rs
+        let classifiedInputs = classifyProjectHaskellInputs rs
+        void $ uses GetModIface classifiedInputs
 
 -- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that

ghcide/src/Development/IDE/Core/InputPath.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+module Development.IDE.Core.InputPath where
+
+import Control.DeepSeq
+import Data.Hashable
+import Data.List (isInfixOf)
+import Data.Typeable
+import Development.IDE.Graph.Internal.Rules (InputClass(..))
+import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath)
+import System.FilePath (splitDirectories)
+
+newtype InputPath (i :: InputClass) =
+    InputPath { unInputPath :: NormalizedFilePath }
+    deriving newtype (Eq, Hashable, NFData, Typeable, Show)
+
+-- All Haskell files are valid, and we assume all
+-- files are Haskell files (for now) so there is
+-- no need to filter out any FilePaths.
+classifyAllHaskellInputs :: [NormalizedFilePath] -> [InputPath AllHaskellFiles]
+classifyAllHaskellInputs = map InputPath
+
+-- Dependency files should not be considered
+-- ProjectHaskellFiles, so we filter them out
+-- before classifying all other files as
+-- ProjectHaskellFiles.
+classifyProjectHaskellInputs :: [NormalizedFilePath] -> [InputPath ProjectHaskellFiles]
+classifyProjectHaskellInputs = foldr classifyInputPath []
+  where
+    classifyInputPath :: NormalizedFilePath -> [InputPath ProjectHaskellFiles] -> [InputPath ProjectHaskellFiles]
+    classifyInputPath nfp projectInputs =
+        case dependencyDirectory `isInfixOf` rawInput of
+            -- The input is a dependency, so don't include
+            -- it in the project inputs.
+            True -> projectInputs
+            -- The input is not a depencency, so include it
+            -- in the project inputs
+            False -> InputPath nfp : projectInputs
+        where
+            dependencyDirectory :: [FilePath]
+            dependencyDirectory = [".hls", "dependencies"]
+            rawInput :: [FilePath]
+            rawInput = splitDirectories (fromNormalizedFilePath nfp)
+
+generalizeProjectInput :: InputPath ProjectHaskellFiles -> InputPath AllHaskellFiles
+generalizeProjectInput = InputPath . unInputPath