Skip to content

Commit 73c9b8f

Browse files
vidit-odvidit-od
committed
Typed rules tests
1 parent a75da01 commit 73c9b8f

4 files changed

Lines changed: 126 additions & 1 deletion

File tree

‎ghcide-test/exe/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -66,6 +66,7 @@ import RootUriTests
6666
import SafeTests
6767
import SymlinkTests
6868
import THTests
69+
import TypedRuleTests
6970
import UnitTests
7071
import WatchedFileTests
7172

@@ -87,6 +88,7 @@ main = do
8788
, PluginSimpleTests.tests
8889
, PreprocessorTests.tests
8990
, THTests.tests
91+
, TypedRuleTests.tests
9092
, SymlinkTests.tests
9193
, SafeTests.tests
9294
, UnitTests.tests

‎ghcide-test/exe/TypedRuleTests.hs‎

Lines changed: 113 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,113 @@
1+
module TypedRuleTests (tests) where
2+
3+
import Config (testWithDummyPluginEmpty')
4+
import Control.Monad (forM_)
5+
import Control.Monad.IO.Class (liftIO)
6+
import qualified Data.Text as T
7+
import Development.IDE.Core.InputPath
8+
import Development.IDE.Plugin.Test (ideResultSuccess)
9+
import Development.IDE.Test (waitForAction,
10+
waitForActionError)
11+
import Development.IDE.Types.Location
12+
import Language.LSP.Protocol.Types hiding
13+
(SemanticTokenAbsolute (..),
14+
SemanticTokenRelative (..),
15+
SemanticTokensEdit (..),
16+
mkRange)
17+
import System.Directory (createDirectoryIfMissing)
18+
import System.FilePath (takeDirectory, (</>))
19+
import Test.Tasty
20+
import Test.Tasty.HUnit
21+
22+
tests :: TestTree
23+
tests = testGroup "typed rules"
24+
[ testGroup "InputPath classifiers"
25+
[ testCase "dependency sources are not project Haskell inputs" $ do
26+
let dep = toNormalizedFilePath' "/work/.hls/dependencies/base/Data/Maybe.hs"
27+
toProjectHaskellInput dep @?= Nothing
28+
unInputPath (toAllHaskellInput dep) @?= dep
29+
30+
, testCase "project Haskell inputs can be generalized to all Haskell inputs" $ do
31+
let src = toNormalizedFilePath' "/work/src/Foo.hs"
32+
case toProjectHaskellInput src of
33+
Nothing -> assertFailure "Expected project source to classify"
34+
Just input -> unInputPath (generalizeProjectInput input) @?= src
35+
36+
, testCase "specific file classifiers reject unrelated paths" $ do
37+
let cabalFile = toNormalizedFilePath' "/work/pkg/pkg.cabal"
38+
stackYaml = toNormalizedFilePath' "/work/pkg/stack.yaml"
39+
source = toNormalizedFilePath' "/work/pkg/Foo.hs"
40+
(unInputPath <$> toCabalFileInput cabalFile) @?= Just cabalFile
41+
toCabalFileInput source @?= Nothing
42+
(unInputPath <$> toStackYamlInput stackYaml) @?= Just stackYaml
43+
toStackYamlInput source @?= Nothing
44+
45+
, testCase "bulk classifiers filter invalid paths" $ do
46+
let projectFile = toNormalizedFilePath' "/work/src/Foo.hs"
47+
depFile = toNormalizedFilePath' "/work/.hls/dependencies/pkg/Foo.hs"
48+
cabalFile = toNormalizedFilePath' "/work/pkg/pkg.cabal"
49+
stackYaml = toNormalizedFilePath' "/work/stack.yaml"
50+
files = [projectFile, depFile, cabalFile, stackYaml]
51+
nonDependencyFiles = [projectFile, cabalFile, stackYaml]
52+
fmap unInputPath (classifyProjectHaskellInputs files) @?=
53+
nonDependencyFiles
54+
fmap unInputPath (classifyCabalFileInputs files) @?= [cabalFile]
55+
fmap unInputPath (classifyStackYamlInputs files) @?= [stackYaml]
56+
57+
, testCase "dependency classifier does not match similar directory names" $ do
58+
let dep = toNormalizedFilePath' "/work/.hls/dependencies/base/Data/Maybe.hs"
59+
dep2 = toNormalizedFilePath' "/work/.hls/dependencies2/base/Data/Maybe.hs"
60+
dep3 = toNormalizedFilePath' "/work/.hls/dependencies-extra/Foo.hs"
61+
toProjectHaskellInput dep @?= Nothing
62+
assertBool "dependencies2 should remain a project file" (toProjectHaskellInput dep2 /= Nothing)
63+
assertBool "dependencies-extra should remain a project file" (toProjectHaskellInput dep3 /= Nothing)
64+
65+
, testCase "classifiers preserve ordering" $ do
66+
let a = toNormalizedFilePath' "/work/src/A.hs"
67+
b = toNormalizedFilePath' "/work/src/B.hs"
68+
c = toNormalizedFilePath' "/work/src/C.hs"
69+
70+
fmap unInputPath (classifyProjectHaskellInputs [a,b,c]) @?= [a,b,c]
71+
72+
, testCase "project source remains project source after generalization round trip" $ do
73+
let src = toNormalizedFilePath' "/work/src/Foo.hs"
74+
75+
case toProjectHaskellInput src of
76+
Nothing -> assertFailure "Expected project source"
77+
Just input -> unInputPath (generalizeProjectInput input) @?= src
78+
]
79+
80+
, testWithDummyPluginEmpty' "project-only rules reject dependency-source inputs" $ \dir -> do
81+
let dependencyFile = dir </> ".hls" </> "dependencies" </> "pkg" </> "Data" </> "Maybe.hs"
82+
dependencyDoc = TextDocumentIdentifier (filePathToUri dependencyFile)
83+
projectOnlyRules =
84+
[ "typecheck"
85+
, "getLocatedImports"
86+
, "getmodsummary"
87+
, "getmodsummarywithouttimestamps"
88+
, "getparsedmodule"
89+
, "ghcsession"
90+
, "ghcsessiondeps"
91+
]
92+
liftIO $ createDirectoryIfMissing True (takeDirectory dependencyFile)
93+
liftIO $ writeFile dependencyFile "module Data.Maybe where\n"
94+
95+
forM_ projectOnlyRules $ \rule -> do
96+
err <- waitForActionError rule dependencyDoc
97+
liftIO $ assertBool ("Unexpected error for " <> rule <> ": " <> T.unpack err) $
98+
"dependency file" `T.isInfixOf` err
99+
100+
-- Dependency source files still support all-Haskell/file-content rules.
101+
fileContents <- waitForAction "getFileContents" dependencyDoc
102+
liftIO $ assertBool "GetFileContents should accept dependency sources" $
103+
ideResultSuccess fileContents
104+
105+
, testWithDummyPluginEmpty' "all-haskell rules continue to accept dependency sources" $ \dir -> do
106+
let dependencyFile = dir </> ".hls" </> "dependencies" </> "pkg" </> "Foo.hs"
107+
dependencyDoc = TextDocumentIdentifier (filePathToUri dependencyFile)
108+
109+
liftIO $ createDirectoryIfMissing True (takeDirectory dependencyFile)
110+
liftIO $ writeFile dependencyFile "module Foo where\nx = 1\n"
111+
fileContents <- waitForAction "getFileContents" dependencyDoc
112+
liftIO $ assertBool "GetFileContents should succeed" (ideResultSuccess fileContents)
113+
]

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2177,6 +2177,7 @@ test-suite ghcide-tests
21772177
SafeTests
21782178
SymlinkTests
21792179
THTests
2180+
TypedRuleTests
21802181
UnitTests
21812182
WatchedFileTests
21822183

‎hls-test-utils/src/Development/IDE/Test.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
{-# LANGUAGE GADTs #-}
77
{-# LANGUAGE LambdaCase #-}
88
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE TypeApplications #-}
910

1011
module Development.IDE.Test
1112
( Cursor
@@ -24,6 +25,7 @@ module Development.IDE.Test
2425
, standardizeQuotes
2526
, flushMessages
2627
, waitForAction
28+
, waitForActionError
2729
, getInterfaceFilesDir
2830
, garbageCollectDirtyKeys
2931
, getFilesOfInterest
@@ -215,6 +217,14 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResul
215217
waitForAction key TextDocumentIdentifier{_uri} =
216218
callTestPlugin (WaitForIdeRule key _uri)
217219

220+
waitForActionError :: String -> TextDocumentIdentifier -> Session Text
221+
waitForActionError key TextDocumentIdentifier{_uri} = do
222+
res <- tryCallTestPlugin @WaitForIdeRuleResult (WaitForIdeRule key _uri)
223+
case res of
224+
Left (TResponseError _ err _) -> pure err
225+
Right _ -> liftIO $ assertFailure $
226+
"Expected rule " <> key <> " to fail for " <> show _uri
227+
218228
getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
219229
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)
220230

@@ -261,4 +271,3 @@ referenceReady pred = satisfyMaybe $ \case
261271
, symbolVal p == "ghcide/reference/ready"
262272
-> Just fp
263273
_ -> Nothing
264-

0 commit comments

Comments
 (0)