Rule inputs polymorphic q

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/src/Development/IDE/Core/FileExists.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE OverloadedLists      #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -26,6 +27,7 @@ import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake            hiding (Log)
 import qualified Development.IDE.Core.Shake            as Shake
 import           Development.IDE.Graph
+import           Development.IDE.Graph.Internal.RuleInput
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           Development.IDE.Types.Shake           (toKey)
@@ -39,6 +41,7 @@ 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))
 
 {- Note [File existence cache and LSP file watchers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -133,7 +136,7 @@ fromChange FileChangeType_Changed = Nothing
 -------------------------------------------------------------------------------------
 
 -- | Returns True if the file exists
-getFileExists :: NormalizedFilePath -> Action Bool
+getFileExists :: HasInput i AllHaskellFiles => InputPath i -> Action Bool
 getFileExists fp = use_ GetFileExists fp
 
 {- Note [Which files should we watch?]
@@ -167,7 +170,7 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext
 -- | Installs the 'getFileExists' rules.
 --   Provides a fast implementation if client supports dynamic watched files.
 --   Creates a global state as a side effect in that case.
-fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules ()
+fileExistsRules :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules ()
 fileExistsRules recorder lspEnv = do
   supportsWatchedFiles <- case lspEnv of
     Nothing      -> pure False
@@ -189,15 +192,18 @@ fileExistsRules recorder lspEnv = do
         else const $ pure False
 
   if supportsWatchedFiles
-    then fileExistsRulesFast recorder isWatched
-    else fileExistsRulesSlow recorder
+    then fileExistsRulesFast @i recorder isWatched
+    else fileExistsRulesSlow @i recorder
 
-  fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched
+  fileStoreRules @i (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 :: forall i. HasInput i AllHaskellFiles => 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 i -> Action (Maybe BS.ByteString, Maybe Bool)
+      runGetFileExists GetFileExists (InputPath file) = do
         isWF <- isWatched file
         if isWF
             then fileExistsFast file
@@ -236,9 +242,12 @@ fileExistsFast file = do
 summarizeExists :: Bool -> Maybe BS.ByteString
 summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
 
-fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules ()
+fileExistsRulesSlow :: forall i. HasInput i AllHaskellFiles => 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 i -> 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(
@@ -42,6 +43,7 @@ import           Development.IDE.Core.Shake                   hiding (Log)
 import qualified Development.IDE.Core.Shake                   as Shake
 import           Development.IDE.GHC.Orphans                  ()
 import           Development.IDE.Graph
+import           Development.IDE.Graph.Internal.RuleInput
 import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
@@ -69,6 +71,7 @@ import           Language.LSP.VFS
 import           System.FilePath
 import           System.IO.Error
 import           System.IO.Unsafe
+import Development.IDE.Core.InputPath (InputPath (unInputPath), partitionInputs, PartitionedInputs (projectFiles, dependencyFiles))
 
 
 data Log
@@ -88,31 +91,35 @@ instance Pretty Log where
       <+> pretty (fmap (fmap show) reverseDepPaths)
     LogShake msg -> pretty msg
 
-addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
+addWatchedFileRule :: HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> (InputPath i -> 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 :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Rules ()
+getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule runGetModificationTimeImpl
+  where
+    runGetModificationTimeImpl :: GetModificationTime -> InputPath i -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
+    runGetModificationTimeImpl (GetModificationTime_ missingFileDiags) file =
+      getModificationTimeImpl missingFileDiags file
 
 getModificationTimeImpl
-  :: Bool
-  -> NormalizedFilePath
+  :: HasInput i AllHaskellFiles
+  => Bool
+  -> InputPath i
   -> 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 +131,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 +141,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))
@@ -170,23 +177,27 @@ modificationTime :: FileVersion -> Maybe UTCTime
 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 :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Rules ()
+getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) runGetFileContentsImpl
+  where
+    runGetFileContentsImpl :: GetFileContents -> InputPath i -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))
+    runGetFileContentsImpl GetFileContents file = getFileContentsImpl file
 
 getFileContentsImpl
-    :: NormalizedFilePath
+    :: HasInput i AllHaskellFiles
+    => InputPath i
     -> 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 :: HasInput i AllHaskellFiles => InputPath i -> Action (UTCTime, Maybe T.Text)
 getFileContents f = do
     (fv, txt) <- use_ GetFileContents f
     modTime <- case modificationTime fv of
@@ -196,14 +207,14 @@ 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 :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> (InputPath i -> Action Bool) -> Rules ()
 fileStoreRules recorder isWatched = do
-    getModificationTimeRule recorder
-    getFileContentsRule recorder
+    getModificationTimeRule @i recorder
+    getFileContentsRule @i recorder
     addWatchedFileRule recorder isWatched
 
 -- | Note that some buffer for a specific file has been modified but not
@@ -239,7 +250,9 @@ typecheckParentsAction recorder nfp = do
       Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp
       Just rs -> do
         logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs
-        void $ uses GetModIface rs
+        let partitionedInputs = partitionInputs rs
+        void $ uses GetModIface (projectFiles partitionedInputs)
+        void $ uses GetModIface (dependencyFiles partitionedInputs)
 
 -- | 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,59 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+module Development.IDE.Core.InputPath where
+
+import Control.DeepSeq
+import Data.Hashable
+import Data.List (isInfixOf)
+import Data.Typeable
+import Development.IDE.Types.Location (emptyFilePath)
+import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath)
+import System.FilePath (splitDirectories)
+
+data InputClass
+    = ProjectHaskellFiles
+    | AllHaskellFiles
+
+newtype InputPath (i :: InputClass) =
+    InputPath { unInputPath :: NormalizedFilePath }
+    deriving newtype (Eq, Hashable, NFData, Typeable, Show)
+
+class HasNormalizedFilePath input where
+    getNormalizedFilePath :: input -> NormalizedFilePath
+
+instance HasNormalizedFilePath (InputPath ProjectHaskellFiles) where
+    getNormalizedFilePath (InputPath nfp) = nfp
+
+instance HasNormalizedFilePath (InputPath AllHaskellFiles) where
+    getNormalizedFilePath (InputPath nfp) = nfp
+
+instance HasNormalizedFilePath () where
+    getNormalizedFilePath _ = emptyFilePath
+
+-- 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 ProjectHaskellFiles]
+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)