module Main where
import Control.Monad (void)
import Data.Either (rights)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Ide.Plugin.ChangeTypeSignature (errorMessageRegexes)
import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature
import System.FilePath ((<.>), (</>))
import Test.Hls (CodeAction (..), Command,
GhcVersion (..),
PluginTestDescriptor,
Position (Position),
Range (Range), Session,
TestName, TestTree,
TextDocumentIdentifier,
assertFailure, def,
defaultTestRunner,
executeCodeAction,
getCodeActions,
goldenWithHaskellDoc,
knownBrokenForGhcVersions,
liftIO,
mkPluginTestDescriptor',
openDoc, runSessionWithServer,
testCase, testGroup, toEither,
type (|?),
waitForAllProgressDone,
waitForDiagnostics, (@?=))
import Text.Regex.TDFA ((=~))
main :: IO ()
main = defaultTestRunner test
changeTypeSignaturePlugin :: PluginTestDescriptor ()
changeTypeSignaturePlugin = mkPluginTestDescriptor' ChangeTypeSignature.descriptor "changeTypeSignature"
test :: TestTree
test = testGroup "changeTypeSignature" [
testRegexes
, codeActionTest "TExpectedActual" 4 11
, knownBrokenForGhcVersions [GHC92, GHC94, GHC96] "Error Message in 9.2/9.4 does not provide enough info" $ codeActionTest "TRigidType" 4 14
, codeActionTest "TRigidType2" 4 6
, codeActionTest "TLocalBinding" 7 22
, codeActionTest "TLocalBindingShadow1" 11 8
, codeActionTest "TLocalBindingShadow2" 7 22
, codeActionProperties "TErrorGivenPartialSignature" [(4, 13)] $ \actions -> liftIO $ length actions @?= 0
]
testRegexes :: TestTree
testRegexes = testGroup "Regex Testing" [
testRegexOne
, testRegexTwo
, testRegex921One
]
testRegexOne :: TestTree
testRegexOne = testGroup "Regex One" [
regexTest "error1.txt" regex True
, regexTest "error2.txt" regex True
, regexTest "error3.txt" regex False
, regexTest "error4.txt" regex True
, regexTest "error5.txt" regex True
]
where
regex = errorMessageRegexes !! 0
testRegexTwo :: TestTree
testRegexTwo = testGroup "Regex Two" [
regexTest "error1.txt" regex False
, regexTest "error2.txt" regex False
, regexTest "error3.txt" regex True
, regexTest "error4.txt" regex False
, regexTest "error5.txt" regex False
]
where
regex = errorMessageRegexes !! 1
-- test ghc-9.2 error message regex
testRegex921One :: TestTree
testRegex921One = testGroup "Regex One" [
regexTest "ghc921-error1.txt" regex True
, regexTest "ghc921-error2.txt" regex True
, regexTest "ghc921-error3.txt" regex True
]
where
regex = errorMessageRegexes !! 2
testDataDir :: FilePath
testDataDir = "test" </> "testdata"
goldenChangeSignature :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
goldenChangeSignature fp = goldenWithHaskellDoc def changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs"
codeActionTest :: FilePath -> Int -> Int -> TestTree
codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do
void $ waitForDiagnostics -- code actions are triggered from Diagnostics
void $ waitForAllProgressDone -- apparently some tests need this to get the CodeAction to show up
actions <- getCodeActions doc (pointRange line col)
foundActions <- findChangeTypeActions actions
liftIO $ length foundActions @?= 1
executeCodeAction (head foundActions)
codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree
codeActionProperties fp locs assertions = testCase fp $ do
runSessionWithServer def changeTypeSignaturePlugin testDataDir $ do
openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findChangeTypeActions >>= assertions
where
codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs
findChangeTypeActions :: [Command |? CodeAction] -> Session [CodeAction]
findChangeTypeActions = pure . filter isChangeTypeAction . rights . map toEither
where
isChangeTypeAction CodeAction{_kind} = case _kind of
Nothing -> False
Just kind -> case kind of
"quickfix.changeTypeSignature" -> True
_ -> False
regexTest :: FilePath -> Text -> Bool -> TestTree
regexTest fp regex shouldPass = testCase fp $ do
msg <- TIO.readFile (testDataDir </> fp)
case (msg =~ regex :: (Text, Text, Text, [Text]), shouldPass) of
((_, _, _, [_, _, _, _]), True) -> pure ()
((_, _, _, [_, _, _, _]), False) -> assertFailure $ "Unexpected match: " <> fp <> " with " <> T.unpack regex
(_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex
(_, False) -> pure ()
pointRange :: Int -> Int -> Range
pointRange
(subtract 1 -> fromIntegral -> line)
(subtract 1 -> fromIntegral -> col) =
Range (Position line col) (Position line $ col + 1)