Typed rules

bench/Main.hs

@@ -59,21 +59,22 @@ import           Development.Benchmark.Rules hiding (parallelism)
 import           Development.Shake           (Action,
                                               Change (ChangeModtimeAndDigestInput),
                                               CmdOption (Cwd, StdinBS),
-                                              RuleResult, Rules,
+                                              Rules,
                                               ShakeOptions (shakeChange, shakeThreads),
                                               actionBracket, addOracle,
                                               askOracle, command, command_,
                                               getDirectoryFiles, liftIO, need,
                                               newCache, shakeArgsWith,
                                               shakeOptions, versioned, want)
+import qualified Development.Shake            as Shake
 import           Development.Shake.Classes
 import           Experiments.Types           (Example (exampleName),
                                               exampleToOptions)
 import           GHC.Exts                    (toList)
 import           GHC.Generics                (Generic)
 import           HlsPlugins                  (idePlugins)
 import qualified Ide.Plugin.Config           as Plugin
-import           Ide.Types                   hiding (Config)
+import           Ide.Types                   hiding (Config, Rules)
 import           Numeric.Natural             (Natural)
 import           System.Console.GetOpt
 import           System.Directory
@@ -94,8 +95,8 @@ readConfigIO :: FilePath -> IO (Config BuildSystem)
 readConfigIO = decodeFileThrow
 
 instance IsExample Example where getExampleName = exampleName
-type instance RuleResult GetExample = Maybe Example
-type instance RuleResult GetExamples = [Example]
+type instance Shake.RuleResult GetExample = Maybe Example
+type instance Shake.RuleResult GetExamples = [Example]
 
 shakeOpts :: ShakeOptions
 shakeOpts =
@@ -185,7 +186,7 @@ disableAllPluginsBut pred = def {Plugin.plugins = pluginsMap} where
     IdePlugins plugins = idePlugins mempty
 
 newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
-type instance RuleResult GetSamples = Natural
+type instance Shake.RuleResult GetSamples = Natural
 
 --------------------------------------------------------------------------------
 

ghcide-test/exe/Main.hs

@@ -66,6 +66,7 @@ import           RootUriTests
 import           SafeTests
 import           SymlinkTests
 import           THTests
+import           TypedRuleTests
 import           UnitTests
 import           WatchedFileTests
 
@@ -87,6 +88,7 @@ main = do
     , PluginSimpleTests.tests
     , PreprocessorTests.tests
     , THTests.tests
+    , TypedRuleTests.tests
     , SymlinkTests.tests
     , SafeTests.tests
     , UnitTests.tests

ghcide-test/exe/TypedRuleTests.hs

@@ -0,0 +1,113 @@
+module TypedRuleTests (tests) where
+
+import           Config                       (testWithDummyPluginEmpty')
+import           Control.Monad                (forM_)
+import           Control.Monad.IO.Class       (liftIO)
+import qualified Data.Text                    as T
+import           Development.IDE.Core.InputPath
+import           Development.IDE.Plugin.Test    (ideResultSuccess)
+import           Development.IDE.Test         (waitForAction,
+                                               waitForActionError)
+import           Development.IDE.Types.Location
+import           Language.LSP.Protocol.Types  hiding
+                                              (SemanticTokenAbsolute (..),
+                                               SemanticTokenRelative (..),
+                                               SemanticTokensEdit (..),
+                                               mkRange)
+import           System.Directory             (createDirectoryIfMissing)
+import           System.FilePath              (takeDirectory, (</>))
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "typed rules"
+    [ testGroup "InputPath classifiers"
+        [ testCase "dependency sources are not project Haskell inputs" $ do
+            let dep = toNormalizedFilePath' "/work/.hls/dependencies/base/Data/Maybe.hs"
+            toProjectHaskellInput dep @?= Nothing
+            unInputPath (toAllHaskellInput dep) @?= dep
+
+        , testCase "project Haskell inputs can be generalized to all Haskell inputs" $ do
+            let src = toNormalizedFilePath' "/work/src/Foo.hs"
+            case toProjectHaskellInput src of
+                Nothing -> assertFailure "Expected project source to classify"
+                Just input -> unInputPath (generalizeProjectInput input) @?= src
+
+        , testCase "specific file classifiers reject unrelated paths" $ do
+            let cabalFile = toNormalizedFilePath' "/work/pkg/pkg.cabal"
+                stackYaml = toNormalizedFilePath' "/work/pkg/stack.yaml"
+                source    = toNormalizedFilePath' "/work/pkg/Foo.hs"
+            (unInputPath <$> toCabalFileInput cabalFile) @?= Just cabalFile
+            toCabalFileInput source @?= Nothing
+            (unInputPath <$> toStackYamlInput stackYaml) @?= Just stackYaml
+            toStackYamlInput source @?= Nothing
+
+        , testCase "bulk classifiers filter invalid paths" $ do
+            let projectFile = toNormalizedFilePath' "/work/src/Foo.hs"
+                depFile = toNormalizedFilePath' "/work/.hls/dependencies/pkg/Foo.hs"
+                cabalFile = toNormalizedFilePath' "/work/pkg/pkg.cabal"
+                stackYaml = toNormalizedFilePath' "/work/stack.yaml"
+                files = [projectFile, depFile, cabalFile, stackYaml]
+                nonDependencyFiles = [projectFile, cabalFile, stackYaml]
+            fmap unInputPath (classifyProjectHaskellInputs files) @?=
+                nonDependencyFiles
+            fmap unInputPath (classifyCabalFileInputs files) @?= [cabalFile]
+            fmap unInputPath (classifyStackYamlInputs files) @?= [stackYaml]
+
+        , testCase "dependency classifier does not match similar directory names" $ do
+            let dep = toNormalizedFilePath' "/work/.hls/dependencies/base/Data/Maybe.hs"
+                dep2 = toNormalizedFilePath' "/work/.hls/dependencies2/base/Data/Maybe.hs"
+                dep3 = toNormalizedFilePath' "/work/.hls/dependencies-extra/Foo.hs"
+            toProjectHaskellInput dep @?= Nothing
+            assertBool "dependencies2 should remain a project file" (toProjectHaskellInput dep2 /= Nothing)
+            assertBool "dependencies-extra should remain a project file" (toProjectHaskellInput dep3 /= Nothing)
+
+        , testCase "classifiers preserve ordering" $ do
+            let a = toNormalizedFilePath' "/work/src/A.hs"
+                b = toNormalizedFilePath' "/work/src/B.hs"
+                c = toNormalizedFilePath' "/work/src/C.hs"
+
+            fmap unInputPath (classifyProjectHaskellInputs [a,b,c]) @?= [a,b,c]
+
+        , testCase "project source remains project source after generalization round trip" $ do
+            let src = toNormalizedFilePath' "/work/src/Foo.hs"
+
+            case toProjectHaskellInput src of
+                Nothing -> assertFailure "Expected project source"
+                Just input -> unInputPath (generalizeProjectInput input) @?= src
+        ]
+
+    , testWithDummyPluginEmpty' "project-only rules reject dependency-source inputs" $ \dir -> do
+        let dependencyFile = dir </> ".hls" </> "dependencies" </> "pkg" </> "Data" </> "Maybe.hs"
+            dependencyDoc = TextDocumentIdentifier (filePathToUri dependencyFile)
+            projectOnlyRules =
+                [ "typecheck"
+                , "getLocatedImports"
+                , "getmodsummary"
+                , "getmodsummarywithouttimestamps"
+                , "getparsedmodule"
+                , "ghcsession"
+                , "ghcsessiondeps"
+                ]
+        liftIO $ createDirectoryIfMissing True (takeDirectory dependencyFile)
+        liftIO $ writeFile dependencyFile "module Data.Maybe where\n"
+
+        forM_ projectOnlyRules $ \rule -> do
+            err <- waitForActionError rule dependencyDoc
+            liftIO $ assertBool ("Unexpected error for " <> rule <> ": " <> T.unpack err) $
+                "dependency file" `T.isInfixOf` err
+
+        -- Dependency source files still support all-Haskell/file-content rules.
+        fileContents <- waitForAction "getFileContents" dependencyDoc
+        liftIO $ assertBool "GetFileContents should accept dependency sources" $
+            ideResultSuccess fileContents
+
+    , testWithDummyPluginEmpty' "all-haskell rules continue to accept dependency sources" $ \dir -> do
+        let dependencyFile = dir </> ".hls" </> "dependencies" </> "pkg" </> "Foo.hs"
+            dependencyDoc = TextDocumentIdentifier (filePathToUri dependencyFile)
+
+        liftIO $ createDirectoryIfMissing True (takeDirectory dependencyFile)
+        liftIO $ writeFile dependencyFile "module Foo where\nx = 1\n"
+        fileContents <- waitForAction "getFileContents" dependencyDoc
+        liftIO $ assertBool "GetFileContents should succeed" (ideResultSuccess fileContents)
+    ]

ghcide/ghcide.cabal

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

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

@@ -42,6 +42,7 @@ import           Data.Maybe
 import           Data.Proxy
 import qualified Data.Text                           as T
 import           Data.Version
+import           Development.IDE.Core.InputPath
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake          hiding (Log, knownTargets,
                                                       withHieDb)
@@ -906,9 +907,9 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l
         unless (null new_components_info || not checkProject) $ do
             cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
             void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do
-                mmt <- uses GetModificationTime cfps'
+                mmt <- uses GetModificationTime $ classifyAllHaskellInputs cfps'
                 let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
-                modIfaces <- uses GetModIface cs_exist
+                modIfaces <- uses GetModIface $ classifyProjectHaskellInputs cs_exist
                 -- update exports map
                 shakeExtras <- getShakeExtras
                 let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces

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

@@ -24,6 +24,7 @@ import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
+import           Development.IDE.Core.InputPath
 import           Development.IDE.GHC.Compat           (DynFlags (..),
                                                        ms_hspp_opts)
 import           Development.IDE.Graph
@@ -49,13 +50,13 @@ getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [
 getAtPoint file pos = runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
-
-  (hf, mapping) <- useWithStaleFastMT GetHieAst file
+  input <- MaybeT $ pure $ toProjectHaskellInput file
+  (hf, mapping) <- useWithStaleFastMT GetHieAst $ generalizeProjectInput input
   shakeExtras <- lift askShake
 
-  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
-  modSummary <- fst <$> useWithStaleFastMT GetModSummary file
-  dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
+  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession input
+  modSummary <- fst <$> useWithStaleFastMT GetModSummary input
+  dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap input)
   let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary))
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
@@ -84,7 +85,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 $ toAllHaskellInput otherLocationFile
     pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
   where
     nUri :: NormalizedUri
@@ -95,8 +96,9 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location,
 getDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useWithStaleFastMT GetHieAst file
-    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
+    input <- MaybeT $ pure $ toProjectHaskellInput file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst $ generalizeProjectInput input
+    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap input
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
     mapMaybeM (\(location, identifier) -> do
@@ -109,7 +111,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 $ toAllHaskellInput file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
     mapMaybeM (\(location, identifier) -> do
@@ -121,14 +123,14 @@ getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Mayb
 getImplementationDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useWithStaleFastMT GetHieAst file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos'
     traverse (MaybeT . toCurrentLocation mapping file) locs
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do
-    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file
+    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput 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'
@@ -138,7 +140,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 (classifyAllHaskellInputs fs)
     AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts)
 
 workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation])

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

@@ -19,6 +19,7 @@ import           Control.Monad.IO.Class
 import qualified Data.ByteString                       as BS
 import           Data.List                             (partition)
 import           Data.Maybe
+import           Development.IDE.Core.InputPath
 import           Development.IDE.Core.FileStore        hiding (Log, LogShake)
 import qualified Development.IDE.Core.FileStore        as FileStore
 import           Development.IDE.Core.IdeConfiguration
@@ -133,7 +134,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?]
@@ -197,7 +198,8 @@ fileExistsRules recorder lspEnv = do
 -- 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 $ \GetFileExists input -> do
+        let file = unInputPath input
         isWF <- isWatched file
         if isWF
             then fileExistsFast file
@@ -238,7 +240,8 @@ 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 $ \GetFileExists input ->
+      fileExistsSlow (unInputPath input)
 
 fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)
 fileExistsSlow file = do