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"