
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs     #-}

module CradleTests (tests) where

import           Config                          (checkDefs, dummyPlugin,
                                                  lspTestCaps, mkIdeTestFs, mkL,
                                                  runWithExtraFiles,
                                                  testWithDummyPluginEmpty')
import           Control.Applicative.Combinators
import           Control.Lens                    ((^.))
import           Control.Monad.IO.Class          (liftIO)
import qualified Data.Aeson                      as A
import           Data.Proxy                      (Proxy (..))
import qualified Data.Text                       as T
import           Development.IDE.GHC.Util
import           Development.IDE.Plugin.Test     (TestRequest (..),
                                                  WaitForIdeRuleResult (..))
import           Development.IDE.Test            (expectDiagnostics,
                                                  expectDiagnosticsWithTags,
                                                  expectNoMoreDiagnostics,
                                                  isReferenceReady,
                                                  waitForAction)
import           Development.IDE.Types.Location
import           GHC.TypeLits                    (symbolVal)
import           Ide.Types                       (Config (..),
                                                  SessionLoadingPreferenceConfig (..))
import qualified Language.LSP.Protocol.Lens      as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types     hiding
                                                 (SemanticTokenAbsolute (..),
                                                  SemanticTokenRelative (..),
                                                  SemanticTokensEdit (..),
                                                  mkRange)
import           Language.LSP.Test
import           System.FilePath
import           Test.Hls                        (TestConfig (..), def,
                                                  runSessionWithTestConfig,
                                                  waitForBuildQueue)
import           Test.Hls.FileSystem
import           Test.Hls.Util                   (EnvSpec (..), OS (..),
                                                  ignoreInEnv)
import           Test.Tasty
import           Test.Tasty.HUnit


tests :: TestTree
tests = testGroup "cradle"
    [testGroup "dependencies" [sessionDepsArePickedUp]
    ,testGroup "ignore-fatal" [ignoreFatalWarning]
    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
    ,testGroup "regression.batch" batchLoadRegressionTests
    ,testGroup "multi"   (multiTests "multi")
    ,testGroup "multi-unit" (multiTests "multi-unit")
    ,testGroup "sub-directory"   [simpleSubDirectoryTest]
    ,testGroup "multi-unit-rexport" [multiRexportTest]
    ]

loadCradleOnlyonce :: TestTree
loadCradleOnlyonce = testGroup "load cradle only once"
    [ testWithDummyPluginEmpty' "implicit" implicit
    , testWithDummyPluginEmpty' "direct"   direct
    ]
    where
        direct dir = do
            liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml")
                "cradle: {direct: {arguments: []}}"
            test dir
        implicit dir = test dir
        test _dir = do
            doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
            liftIO $ length msgs @?= 1
            changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ "module B where\nimport Data.Maybe"]
            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
            liftIO $ length msgs @?= 0
            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
            liftIO $ length msgs @?= 0

retryFailedCradle :: TestTree
retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
  -- The false cradle always fails
  let hieContents = "cradle: {bios: {shell: \"false\"}}"
      hiePath = dir </> "hie.yaml"
  liftIO $ atomicFileWriteString hiePath hieContents
  let aPath = dir </> "A.hs"
  doc <- createDoc aPath "haskell" "main = return ()"
  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
  liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess

  -- Fix the cradle and typecheck again
  let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"
  liftIO $ atomicFileWriteStringUTF8 hiePath $ T.unpack validCradle
  sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
         [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]

  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess


cradleLoadedMessage :: Session FromServerMessage
cradleLoadedMessage = satisfy $ \case
        FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod
        _                                            -> False

cradleLoadedMethod :: String
cradleLoadedMethod = "ghcide/cradle/loaded"

ignoreFatalWarning :: TestTree
ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
    let srcPath = dir </> "IgnoreFatal.hs"
    src <- liftIO $ readFileUtf8 srcPath
    _ <- createDoc srcPath "haskell" src
    expectNoMoreDiagnostics 5

simpleSubDirectoryTest :: TestTree
simpleSubDirectoryTest =
  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do
    let mainPath = dir </> "a/src/Main.hs"
    mainSource <- liftIO $ readFileUtf8 mainPath
    _mdoc <- createDoc mainPath "haskell" mainSource
    expectDiagnosticsWithTags
      [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Just "GHC-38417", Nothing)]) -- So that we know P has been loaded
      ]
    expectNoMoreDiagnostics 0.5

multiTests :: FilePath -> [TestTree]
multiTests dir =
  [ simpleMultiTest dir
  , simpleMultiTest2 dir
  , simpleMultiTest3 dir
  , simpleMultiDefTest dir
  ]

multiTestName :: FilePath -> String -> String
multiTestName dir name = "simple-" ++ dir ++ "-" ++ name

simpleMultiTest :: FilePath -> TestTree
simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
    adoc <- openDoc aPath "haskell"
    bdoc <- openDoc bPath "haskell"
    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc
    liftIO $ assertBool "A should typecheck" ideResultSuccess
    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc
    liftIO $ assertBool "B should typecheck" ideResultSuccess
    locs <- getDefinitions bdoc (Position 2 7)
    let fooL = mkL (adoc ^. L.uri) 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

-- Like simpleMultiTest but open the files in the other order
simpleMultiTest2 :: FilePath -> TestTree
simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \dir -> do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
    bdoc <- openDoc bPath "haskell"
    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
    TextDocumentIdentifier auri <- openDoc aPath "haskell"
    skipManyTill anyMessage $ isReferenceReady aPath
    locs <- getDefinitions bdoc (Position 2 7)
    let fooL = mkL auri 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

-- Now with 3 components
simpleMultiTest3 :: FilePath -> TestTree
simpleMultiTest3 variant =
  testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
        cPath = dir </> "c/C.hs"
    bdoc <- openDoc bPath "haskell"
    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
    TextDocumentIdentifier auri <- openDoc aPath "haskell"
    skipManyTill anyMessage $ isReferenceReady aPath
    cdoc <- openDoc cPath "haskell"
    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
    locs <- getDefinitions cdoc (Position 2 7)
    let fooL = mkL auri 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

runRegressionMultiOpenAThenB :: FilePath -> Session ()
runRegressionMultiOpenAThenB dir = do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
    adoc <- openDoc aPath "haskell"
    bdoc <- openDoc bPath "haskell"
    _ <- waitForBuildQueue
    [aRes, bRes] <- waitForTypeChecksBatched [adoc, bdoc]
    liftIO $ assertBool "A should typecheck" (ideResultSuccess aRes)
    liftIO $ assertBool "B should typecheck" (ideResultSuccess bRes)
    locs <- getDefinitions bdoc (Position 2 7)
    let fooL = mkL (adoc ^. L.uri) 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

runRegressionMultiOpenBThenA :: FilePath -> Session ()
runRegressionMultiOpenBThenA dir = do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
    bdoc <- openDoc bPath "haskell"
    adoc <- openDoc aPath "haskell"
    _ <- waitForBuildQueue
    [bRes, aRes] <- waitForTypeChecksBatched [bdoc, adoc]
    liftIO $ assertBool "B should typecheck" (ideResultSuccess bRes)
    liftIO $ assertBool "A should typecheck" (ideResultSuccess aRes)
    locs <- getDefinitions bdoc (Position 2 7)
    let TextDocumentIdentifier auri = adoc
    let fooL = mkL auri 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

runRegressionMultiOpenBThenAThenC :: FilePath -> Session ()
runRegressionMultiOpenBThenAThenC dir = do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
        cPath = dir </> "c/C.hs"
    bdoc <- openDoc bPath "haskell"
    adoc <- openDoc aPath "haskell"
    cdoc <- openDoc cPath "haskell"
    _ <- waitForBuildQueue
    [bRes, aRes, cRes] <- waitForTypeChecksBatched [bdoc, adoc, cdoc]
    liftIO $ assertBool "B should typecheck" (ideResultSuccess bRes)
    liftIO $ assertBool "A should typecheck" (ideResultSuccess aRes)
    liftIO $ assertBool "C should typecheck" (ideResultSuccess cRes)
    locs <- getDefinitions cdoc (Position 2 7)
    let TextDocumentIdentifier auri = adoc
    let fooL = mkL auri 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

sendTestRequest :: TestRequest -> Session A.Value
sendTestRequest req = do
  let method = SMethod_CustomMethod (Proxy @"test")
  reqId <- sendRequest method (A.toJSON req)
  TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId method reqId
  case _result of
    Left err -> liftIO (assertFailure $ "test plugin request failed: " <> show err) >> pure A.Null
    Right val -> pure val

waitForTypeChecksBatched :: [TextDocumentIdentifier] -> Session [WaitForIdeRuleResult]
waitForTypeChecksBatched docs = do
  let uris = map (\TextDocumentIdentifier{_uri} -> _uri) docs
  val <- sendTestRequest (WaitForIdeRules "TypeCheck" uris)
  case A.fromJSON val of
    A.Success res -> pure res
    A.Error parseErr -> liftIO (assertFailure $ "batched typecheck parse failed: " <> parseErr) >> pure []

batchLoadRegressionTests :: [TestTree]
batchLoadRegressionTests =
  -- Note [Batch regression scheduling semantics]
  -- `didOpen` alone does not enqueue session-loader pending files.
  -- Pending entries come from GhcSession demand. For these tests, the `test`
  -- plugin uses `WaitForIdeRules` plus a pending-size barrier in session-loader
  -- to force all requested files into pending before load begins.
  [ testCase "m1-open-a-then-b-batch-pending-and-success" $
      runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenAThenB
  , testCase "m2-open-b-then-a-batch-pending-and-success" $
      runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenA
  , testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $
      runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenAThenC
  , testCase "f1-batch-pending-failure-isolates-broken-file" $
      runWithExtraFilesMultiComponent "multi" regressionBatchFailureIsolatesBrokenFile
  , testCase "f2-failed-file-keeps-failing-until-cradle-fix" $
      runWithExtraFilesMultiComponent "multi" regressionFailedFileKeepsFailingUntilFix
  , testCase "r1-failed-file-recovers-after-cradle-fix" $
      runWithExtraFilesMultiComponent "multi" regressionFailedFileRecoversAfterFix
  , testCase "s1-no-stale-outcomes-across-restart-paths" $
      runWithExtraFilesMultiComponent "multi" regressionNoStaleOutcomesOnRestart
  ]

runWithExtraFilesMultiComponent :: String -> (FilePath -> Session a) -> IO a
runWithExtraFilesMultiComponent dirName action = do
  let vfs = mkIdeTestFs [copyDir dirName]
      lspConfig :: Config
      lspConfig = def { sessionLoading = PreferMultiComponentLoading }
      conf :: TestConfig ()
      conf = def
        { testPluginDescriptor = dummyPlugin
        , testDirLocation = Right vfs
        , testConfigCaps = lspTestCaps
        , testShiftRoot = True
        , testDisableKick = True
        , testLspConfig = lspConfig
        }
  runSessionWithTestConfig conf action

brokenMultiHieYaml :: T.Text
brokenMultiHieYaml = T.unlines
  [ "cradle:"
  , "  cabal:"
  , "    - path: \"./a\""
  , "      component: \"lib:a\""
  , "    - path: \"./b\""
  , "      component: \"lib:does-not-exist\""
  , "    - path: \"./c\""
  , "      component: \"lib:c\""
  ]

writeBrokenMultiHieYaml :: FilePath -> Session ()
writeBrokenMultiHieYaml dir =
  liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml") (T.unpack brokenMultiHieYaml)

notifyHieYamlChanged :: FilePath -> Session ()
notifyHieYamlChanged dir =
  sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
    [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed]

assertTypeCheckSuccess :: TextDocumentIdentifier -> String -> Session ()
assertTypeCheckSuccess doc msg = do
  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
  liftIO $ assertBool msg ideResultSuccess

assertTypeCheckFailure :: TextDocumentIdentifier -> String -> Session ()
assertTypeCheckFailure doc msg = do
  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
  liftIO $ assertBool msg (not ideResultSuccess)

regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session ()
regressionBatchFailureIsolatesBrokenFile dir = do
  writeBrokenMultiHieYaml dir
  let aPath = dir </> "a/A.hs"
      bPath = dir </> "b/B.hs"
  adoc <- openDoc aPath "haskell"
  bdoc <- openDoc bPath "haskell"
  _ <- waitForBuildQueue
  [aRes, bRes] <- waitForTypeChecksBatched [adoc, bdoc]
  liftIO $ assertBool "A should typecheck when B cradle mapping is broken" (ideResultSuccess aRes)
  liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes)

regressionFailedFileKeepsFailingUntilFix :: FilePath -> Session ()
regressionFailedFileKeepsFailingUntilFix dir = do
  writeBrokenMultiHieYaml dir
  let aPath = dir </> "a/A.hs"
      bPath = dir </> "b/B.hs"
      cPath = dir </> "c/C.hs"
  bdoc <- openDoc bPath "haskell"
  assertTypeCheckFailure bdoc "B should fail with broken cradle mapping"

  bSource <- liftIO $ readFileUtf8 bPath
  changeDoc bdoc
    [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
  assertTypeCheckFailure bdoc "B should keep failing until the cradle is fixed"

  adoc <- openDoc aPath "haskell"
  cdoc <- openDoc cPath "haskell"
  assertTypeCheckSuccess adoc "A should still typecheck while B remains broken"
  assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken"

regressionFailedFileRecoversAfterFix :: FilePath -> Session ()
regressionFailedFileRecoversAfterFix dir = do
  let hiePath = dir </> "hie.yaml"
      bPath = dir </> "b/B.hs"
  validHie <- liftIO $ readFileUtf8 hiePath
  writeBrokenMultiHieYaml dir

  bdoc <- openDoc bPath "haskell"
  assertTypeCheckFailure bdoc "B should fail before fixing the cradle"

  liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
  notifyHieYamlChanged dir

  bSource <- liftIO $ readFileUtf8 bPath
  changeDoc bdoc
    [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
  assertTypeCheckSuccess bdoc "B should recover after restoring the cradle"

regressionNoStaleOutcomesOnRestart :: FilePath -> Session ()
regressionNoStaleOutcomesOnRestart dir = do
  let hiePath = dir </> "hie.yaml"
      aPath = dir </> "a/A.hs"
      bPath = dir </> "b/B.hs"
      cPath = dir </> "c/C.hs"
  validHie <- liftIO $ readFileUtf8 hiePath
  writeBrokenMultiHieYaml dir

  bdoc <- openDoc bPath "haskell"
  assertTypeCheckFailure bdoc "B should fail before cradle fix"

  adoc <- openDoc aPath "haskell"
  assertTypeCheckSuccess adoc "A should remain healthy while B is broken"

  liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
  notifyHieYamlChanged dir

  cdoc <- openDoc cPath "haskell"
  assertTypeCheckSuccess cdoc "C should typecheck after cradle restart"

  bSource <- liftIO $ readFileUtf8 bPath
  changeDoc bdoc
    [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
  assertTypeCheckSuccess bdoc "B should not keep stale failure after cradle restart"

-- Like simpleMultiTest but open the files in component 'a' in a separate session
simpleMultiDefTest :: FilePath -> TestTree
simpleMultiDefTest variant = ignoreForWindows $ testCase testName $
    runWithExtraFiles variant $ \dir -> do
    let aPath = dir </> "a/A.hs"
        bPath = dir </> "b/B.hs"
    adoc <- openDoc aPath "haskell"
    skipManyTill anyMessage $ isReferenceReady aPath
    closeDoc adoc
    bSource <- liftIO $ readFileUtf8 bPath
    bdoc <- createDoc bPath "haskell" bSource
    locs <- getDefinitions bdoc (Position 2 7)
    let fooL = mkL (adoc ^. L.uri) 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5
  where
    testName = multiTestName variant "def-test"
    ignoreForWindows
        | testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270"
        | otherwise = id

multiRexportTest :: TestTree
multiRexportTest =
  testCase "multi-unit-reexport-test"  $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do
    let cPath = dir </> "c/C.hs"
    cdoc <- openDoc cPath "haskell"
    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
    locs <- getDefinitions cdoc (Position 3 7)
    let aPath = dir </> "a/A.hs"
    let fooL = mkL (filePathToUri aPath) 2 0 2 3
    checkDefs locs (pure [fooL])
    expectNoMoreDiagnostics 0.5

sessionDepsArePickedUp :: TestTree
sessionDepsArePickedUp = testWithDummyPluginEmpty'
  "session-deps-are-picked-up"
  $ \dir -> do
    liftIO $
      atomicFileWriteStringUTF8
        (dir </> "hie.yaml")
        "cradle: {direct: {arguments: []}}"
    -- Open without OverloadedStrings and expect an error.
    doc <- createDoc "Foo.hs" "haskell" fooContent
    expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type", Just "GHC-83865")])]

    -- Update hie.yaml to enable OverloadedStrings.
    liftIO $
      atomicFileWriteStringUTF8
        (dir </> "hie.yaml")
        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
    sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
        [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]
    -- Send change event.
    let change =
          TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial
              { _range = Range (Position 4 0) (Position 4 0)
              , _rangeLength = Nothing
              , _text = "\n"
              }
    changeDoc doc [change]
    -- Now no errors.
    expectDiagnostics [("Foo.hs", [])]
  where
    fooContent =
      T.unlines
        [ "module Foo where",
          "import Data.Text",
          "foo :: Text",
          "foo = \"hello\""
        ]
