
module THTests (tests) where

import           Config
import           Control.Monad.IO.Class      (liftIO)
import qualified Data.Text                   as T
import           Development.IDE.GHC.Compat  (GhcVersion (..), ghcVersion)
import           Development.IDE.GHC.Util
import           Development.IDE.Test        (expectCurrentDiagnostics,
                                              expectDiagnostics,
                                              expectNoMoreDiagnostics)
import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
                                              SemanticTokenRelative (..),
                                              SemanticTokensEdit (..), mkRange)
import           Language.LSP.Test
import           System.FilePath
import           Test.Tasty
import           Test.Tasty.HUnit

tests :: TestTree
tests =
  testGroup "TemplateHaskell" $
    [ -- Test for https://github.com/haskell/ghcide/pull/212
      testWithDummyPluginEmpty "load" $ do
        let sourceA =
              T.unlines
                [ "{-# LANGUAGE PackageImports #-}",
                  "{-# LANGUAGE TemplateHaskell #-}",
                  "module A where",
                  "import \"template-haskell\" Language.Haskell.TH",
                  "a :: Integer",
                  "a = $(litE $ IntegerL 3)"
                ]
            sourceB =
              T.unlines
                [ "{-# LANGUAGE PackageImports #-}",
                  "{-# LANGUAGE TemplateHaskell #-}",
                  "module B where",
                  "import A",
                  "import \"template-haskell\" Language.Haskell.TH",
                  "b :: Integer",
                  "b = $(litE $ IntegerL $ a) + n"
                ]
        _ <- createDoc "A.hs" "haskell" sourceA
        _ <- createDoc "B.hs" "haskell" sourceB
        expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n", Just "GHC-88464")] ) ]
    , testWithDummyPluginEmpty "newtype-closure" $ do
        let sourceA =
              T.unlines
                [ "{-# LANGUAGE DeriveDataTypeable #-}"
                  ,"{-# LANGUAGE TemplateHaskell #-}"
                  ,"module A (a) where"
                  ,"import Data.Data"
                  ,"import Language.Haskell.TH"
                  ,"newtype A = A () deriving (Data)"
                  ,"a :: ExpQ"
                  ,"a = [| 0 |]"]
        let sourceB =
              T.unlines
                [ "{-# LANGUAGE TemplateHaskell #-}"
                ,"module B where"
                ,"import A"
                ,"b :: Int"
                ,"b = $( a )" ]
        _ <- createDoc "A.hs" "haskell" sourceA
        _ <- createDoc "B.hs" "haskell" sourceB
        return ()
    , thReloadingTest False
    , thLoadingTest
    , thCoreTest
    , thReloadingTest True
    -- Regression test for https://github.com/haskell/haskell-language-server/issues/891
    , thLinkingTest False
    , thLinkingTest True
    , thStaleBytecodeTest
    , thStaleBytecodeDeepTest
    , testWithDummyPluginEmpty "findsTHIdentifiers" $ do
        let sourceA =
              T.unlines
                [ "{-# LANGUAGE TemplateHaskell #-}"
                , "module A (a) where"
                , "import Language.Haskell.TH (ExpQ)"
                , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic
                , "a = [| glorifiedID |]"
                , "glorifiedID :: a -> a"
                , "glorifiedID = id" ]
        let sourceB =
              T.unlines
                [ "{-# OPTIONS_GHC -Wall #-}"
                , "{-# LANGUAGE TemplateHaskell #-}"
                , "module B where"
                , "import A"
                , "main = $a (putStrLn \"success!\")"]
        _ <- createDoc "A.hs" "haskell" sourceA
        _ <- createDoc "B.hs" "haskell" sourceB
        expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()", Just "GHC-38417")] ) ]
    , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do

    -- This test defines a TH value with the meaning "data A = A" in A.hs
    -- Loads and export the template in B.hs
    -- And checks wether the constructor A can be loaded in C.hs
    -- This test does not fail when either A and B get manually loaded before C.hs
    -- or when we remove the seemingly unnecessary TH pragma from C.hs

    let cPath = dir </> "C.hs"
    _ <- openDoc cPath "haskell"
    expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A", Just "GHC-38417")] ) ]
    ]
    -- Regression test for GHC 9.14 ExplicitLevelImports.
    -- Without level-aware module graph edges, HLS crashes with
    -- `expectJust` in mgQueryZero when `import splice` is used.
    ++ if ghcVersion >= GHC914
       then
        [ testWithDummyPluginEmpty "ExplicitLevelImports-splice-import" $ do
            let sourceA =
                  T.unlines
                    [ "{-# LANGUAGE TemplateHaskell #-}"
                    , "module A (a) where"
                    , "import Language.Haskell.TH"
                    , "a :: ExpQ"
                    , "a = [| 42 :: Int |]"
                    ]
                sourceB =
                  T.unlines
                    [ "{-# OPTIONS_GHC -Wall #-}"
                    , "{-# LANGUAGE ExplicitLevelImports #-}"
                    , "{-# LANGUAGE TemplateHaskell #-}"
                    , "module B where"
                    , "import splice A (a)"
                    , "b :: Int"
                    , "b = $a"
                    , "dummy = 5 :: Int"
                    ]
            _ <- createDoc "A.hs" "haskell" sourceA
            _ <- createDoc "B.hs" "haskell" sourceB
            expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (7, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
        , testWithDummyPluginEmpty "ExplicitLevelImports-dual-import" $ do
            let sourceM =
                  T.unlines
                    [ "{-# LANGUAGE TemplateHaskell #-}"
                    , "module M (m) where"
                    , "import Language.Haskell.TH"
                    , "m :: ExpQ"
                    , "m = [| 100 :: Int |]"
                    ]
                sourceC =
                  T.unlines
                    [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
                    , "{-# LANGUAGE ExplicitLevelImports #-}"
                    , "{-# LANGUAGE TemplateHaskell #-}"
                    , "module C where"
                    , "import splice M (m)"
                    , "import M (m)" -- Normal import alongside splice import
                    , "c :: Int"
                    , "c = $m"
                    , "dummy = 5 :: Int"
                    ]
            _ <- createDoc "M.hs" "haskell" sourceM
            _ <- createDoc "C.hs" "haskell" sourceC
            expectDiagnostics [ ( "C.hs", [(DiagnosticSeverity_Warning, (8, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
        , testWithDummyPluginEmpty "ExplicitLevelImports-redundant-mix" $ do
            let sourceM =
                  T.unlines
                    [ "{-# LANGUAGE TemplateHaskell #-}"
                    , "module M (m) where"
                    , "import Language.Haskell.TH"
                    , "m :: ExpQ"
                    , "m = [| 1 :: Int |]"
                    ]
                sourceD =
                  T.unlines
                    [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
                    , "{-# LANGUAGE ExplicitLevelImports #-}"
                    , "{-# LANGUAGE TemplateHaskell #-}"
                    , "module D where"
                    , "import splice M"
                    , "import M"
                    , "import splice M" -- Redundant splice import
                    , "d :: Int"
                    , "d = $m"
                    , "dummy = 5 :: Int"
                    ]
            _ <- createDoc "M.hs" "haskell" sourceM
            _ <- createDoc "D.hs" "haskell" sourceD
            expectDiagnostics [ ( "D.hs", [(DiagnosticSeverity_Warning, (9, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
        , testWithDummyPluginEmpty "ExplicitLevelImports-transitive" $ do
            let sourceBase =
                  T.unlines
                    [ "{-# LANGUAGE TemplateHaskell #-}"
                    , "module BaseTH (baseMacro) where"
                    , "import Language.Haskell.TH"
                    , "baseMacro :: ExpQ"
                    , "baseMacro = [| 50 :: Int |]"
                    ]
                sourceInter =
                  T.unlines
                    [ "{-# LANGUAGE ExplicitLevelImports #-}"
                    , "{-# LANGUAGE TemplateHaskell #-}"
                    , "module Intermediate where"
                    , "import splice BaseTH" -- Splice import here
                    , "interVal :: Int"
                    , "interVal = $baseMacro"
                    ]
                sourceConsumer =
                  T.unlines
                    [ "{-# OPTIONS_GHC -Wall #-}"
                    , "module Consumer where"
                    , "import Intermediate" -- Normal import here
                    , "cons :: Int"
                    , "cons = interVal"
                    , "dummy = 5 :: Int"
                    ]
            _ <- createDoc "BaseTH.hs" "haskell" sourceBase
            _ <- createDoc "Intermediate.hs" "haskell" sourceInter
            _ <- createDoc "Consumer.hs" "haskell" sourceConsumer
            expectDiagnostics [ ( "Consumer.hs", [(DiagnosticSeverity_Warning, (5, 0), "Top-level binding with no type signature: dummy :: Int", Just "GHC-38417")] ) ]
        ]
       else []


-- | Test that all modules have linkables
thLoadingTest :: TestTree
thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do
    let thb = dir </> "THB.hs"
    _ <- openDoc thb "haskell"
    expectNoMoreDiagnostics 1

thCoreTest :: TestTree
thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do
    let thc = dir </> "THC.hs"
    _ <- openDoc thc "haskell"
    expectNoMoreDiagnostics 1

-- | test that TH is reevaluated on typecheck
thReloadingTest :: Bool -> TestTree
thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do

    let aPath = dir </> "THA.hs"
        bPath = dir </> "THB.hs"
        cPath = dir </> "THC.hs"

    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]
    bSource <- liftIO $ readFileUtf8 bPath --  $th
    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()

    adoc <- createDoc aPath "haskell" aSource
    bdoc <- createDoc bPath "haskell" bSource
    cdoc <- createDoc cPath "haskell" cSource

    expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])]

    -- Change th from () to Bool
    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]
    changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource']
    -- generate an artificial warning to avoid timing out if the TH change does not propagate
    changeDoc cdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ cSource <> "\nfoo=()"]

    -- Check that the change propagates to C
    expectDiagnostics
        [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])
        ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding", Just "GHC-38417")])
        ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])
        ]

    closeDoc adoc
    closeDoc bdoc
    closeDoc cdoc
  where
    name = "reloading-th-test" <> if unboxed then "-unboxed" else ""
    dir | unboxed = "THUnboxed"
        | otherwise = "TH"

-- | Test that a value change in a dependency without an interface change is
-- seen by splices: the loaded bytecode of the intermediate modules must be
-- relinked against the new leaf even though they are not recompiled.
--
-- The leaf and C are open; the intermediate modules are intentionally not, so
-- they stay non-FOI and are not recompiled when the leaf changes.
thStaleBytecodeTestFor :: String -> String -> FilePath -> T.Text -> TestTree
thStaleBytecodeTestFor name dataDir leafFile tag = testCase name $ runWithExtraFiles dataDir $ \dir -> do
    let aPath = dir </> leafFile
        cPath = dir </> "C.hs"

    aSource <- liftIO $ readFileUtf8 aPath -- <leaf> = 1
    cSource <- liftIO $ readFileUtf8 cPath -- c = $(reportWarning (tag ++ show <top>) >> [| <top> |])

    adoc <- createDoc aPath "haskell" aSource
    cdoc <- createDoc cPath "haskell" cSource

    expectDiagnostics [("C.hs", [(DiagnosticSeverity_Warning, (7, 5), tag <> " 1", Nothing)])]

    -- Change the value of the leaf without changing its interface, so the
    -- modules in between are not recompiled and only their loaded bytecode
    -- can go stale
    changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $
        T.replace "= 1" "= 2" aSource]
    -- sentinel warning so a stale splice result fails fast instead of timing out
    changeDoc cdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $
        cSource <> "foo=()"]

    expectDiagnostics
        [("C.hs", [ (DiagnosticSeverity_Warning, (7, 5), tag <> " 2", Nothing)
                  , (DiagnosticSeverity_Warning, (8, 0), "Top-level binding", Just "GHC-38417")
                  ])]

    closeDoc adoc
    closeDoc cdoc

-- | C splices a value from B, which imports it from A. A is edited.
thStaleBytecodeTest :: TestTree
thStaleBytecodeTest = thStaleBytecodeTestFor "th-stale-bytecode" "THUnload" "A.hs" "b is"

-- | C splices a6, whose value flows through the chain A6 <- ... <- A1. A1 is edited.
thStaleBytecodeDeepTest :: TestTree
thStaleBytecodeDeepTest = thStaleBytecodeTestFor "th-stale-bytecode-deep" "THUnloadDeep" "A1.hs" "a6 is"

thLinkingTest :: Bool -> TestTree
thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do

    let aPath = dir </> "THA.hs"
        bPath = dir </> "THB.hs"

    aSource <- liftIO $ readFileUtf8 aPath --  th_a = [d|a :: ()|]
    bSource <- liftIO $ readFileUtf8 bPath --  $th_a

    adoc <- createDoc aPath "haskell" aSource
    bdoc <- createDoc bPath "haskell" bSource

    expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])]

    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]
    changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource']

    -- modify b too
    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]
    changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource']
    _ <- waitForDiagnostics

    expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")]

    closeDoc adoc
    closeDoc bdoc
  where
    name = "th-linking-test" <> if unboxed then "-unboxed" else ""
    dir | unboxed = "THUnboxed"
        | otherwise = "TH"
