
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
    , 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"

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"
