diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 81345fdb80..d769ab30cd 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -60,14 +60,16 @@ module Development.IDE.Core.Rules( DisplayTHWarning(..), ) where -import Prelude hiding (mod) import Control.Applicative import Control.Concurrent.Async (concurrently) +import Control.Concurrent.STM.Stats (atomically) +import Control.Concurrent.STM.TVar import Control.Concurrent.Strict import Control.DeepSeq -import Control.Exception.Safe import Control.Exception (evaluate) +import Control.Exception.Safe import Control.Monad.Extra hiding (msum) +import Control.Monad.IO.Unlift import Control.Monad.Reader hiding (msum) import Control.Monad.State hiding (msum) import Control.Monad.Trans.Except (ExceptT, except, @@ -78,44 +80,53 @@ import qualified Data.Binary as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce +import Data.Default (Default, def) import Data.Foldable hiding (msum) +import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet -import Data.Hashable -import Data.IORef -import Control.Concurrent.STM.TVar import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +import Data.IORef import Data.List import Data.List.Extra (nubOrdOn) import qualified Data.Map as M import Data.Maybe import Data.Proxy -import qualified Data.Text.Utf16.Rope as Rope import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Utf16.Rope as Rope import Data.Time (UTCTime (..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra import Data.Typeable (cast) import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists hiding (LogShake, Log) +import Development.IDE.Core.FileExists hiding (Log, + LogShake) import Development.IDE.Core.FileStore (getFileContents, getModTime) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (LogShake, Log) +import Development.IDE.Core.OfInterest hiding (Log, + LogShake) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (LogShake, Log) -import Development.IDE.Core.Shake hiding (Log) -import Development.IDE.GHC.Compat.Env +import Development.IDE.Core.Service hiding (Log, + LogShake) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding - (vcat, nest, parseModule, - TargetId(..), - loadInterface, + (TargetId (..), Var, - (<+>), settings) -import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) + loadInterface, + nest, + parseModule, + settings, vcat, + (<+>)) +import qualified Development.IDE.GHC.Compat as Compat hiding + (nest, + vcat) +import Development.IDE.GHC.Compat.Env import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util hiding @@ -130,15 +141,18 @@ import Development.IDE.Types.Diagnostics as Diag import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options +import qualified Development.IDE.Types.Shake as Shake import qualified GHC.LanguageExtensions as LangExt +import HIE.Bios.Ghc.Gap (hostIsDynamic) import qualified HieDb +import Ide.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio, + logWith, nest, + vcat, (<+>)) +import qualified Ide.Logger as Logger import Ide.Plugin.Config -import qualified Language.LSP.Server as LSP -import Language.LSP.Protocol.Types (ShowMessageParams (ShowMessageParams), MessageType (MessageType_Info)) -import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) -import Language.LSP.VFS -import System.Directory (makeAbsolute, doesFileExist) -import Data.Default (def, Default) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, @@ -146,28 +160,28 @@ import Ide.Plugin.Properties (HasProperty, useProperty) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) -import Control.Concurrent.STM.Stats (atomically) -import Language.LSP.Server (LspT) -import System.Info.Extra (isWindows) -import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) -import qualified Development.IDE.Core.Shake as Shake -import qualified Ide.Logger as Logger -import qualified Development.IDE.Types.Shake as Shake -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Control.Monad.IO.Unlift +import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) +import Language.LSP.Protocol.Types (MessageType (MessageType_Info), + ShowMessageParams (ShowMessageParams)) +import Language.LSP.Server (LspT) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS +import Prelude hiding (mod) +import System.Directory (doesFileExist, + makeAbsolute) +import System.Info.Extra (isWindows) -import GHC.Fingerprint +import GHC.Fingerprint -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) -import GHC (mgModSummaries) +import GHC (mgModSummaries) #endif #if MIN_VERSION_ghc(9,3,0) -import qualified Data.IntMap as IM +import qualified Data.IntMap as IM #endif @@ -266,40 +280,7 @@ getParsedModuleRule recorder = -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information -- but we no longer need to parse with and without Haddocks separately for above GHC90. - res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 then - liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) - else do - let dflags = ms_hspp_opts ms - mainParse = getParsedModuleDefinition hsc opt file ms - - -- Parse again (if necessary) to capture Haddock parse errors - if gopt Opt_Haddock dflags - then - liftIO $ (fmap.fmap.fmap) reset_ms mainParse - else do - let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) - - -- parse twice, with and without Haddocks, concurrently - -- we cannot ignore Haddock parse errors because files of - -- non-interest are always parsed with Haddocks - -- If we can parse Haddocks, might as well use them - ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse - - -- Merge haddock and regular diagnostics so we can always report haddock - -- parse errors - let diagsM = mergeParseErrorsHaddock diags diagsh - case resh of - Just _ - | HaddockParse <- optHaddockParse opt - -> pure (diagsM, resh) - -- If we fail to parse haddocks, report the haddock diagnostics as well and - -- return the non-haddock parse. - -- This seems to be the correct behaviour because the Haddock flag is added - -- by us and not the user, so our IDE shouldn't stop working because of it. - _ -> pure (diagsM, res) - -- Add dependencies on included files - _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) - pure res + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) withOptHaddock :: ModSummary -> ModSummary withOptHaddock = withOption Opt_Haddock @@ -310,18 +291,6 @@ withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} withoutOption :: GeneralFlag -> ModSummary -> ModSummary withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} --- | Given some normal parse errors (first) and some from Haddock (second), merge them. --- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. -mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] -mergeParseErrorsHaddock normal haddock = normal ++ - [ (a,b,c{_severity = Just DiagnosticSeverity_Warning, _message = fixMessage $ _message c}) - | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations] - where - locations = Set.fromList $ map (Diag._range . thd3) normal - - fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x - | otherwise = "Haddock: " <> x - -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit. @@ -850,7 +819,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco let m_old = case old of Shake.Succeeded (Just old_version) v -> Just (v, old_version) Shake.Stale _ (Just old_version) v -> Just (v, old_version) - _ -> Nothing + _ -> Nothing recompInfo = RecompilationInfo { source_version = ver , old_value = m_old @@ -1023,22 +992,14 @@ regenerateHiFile sess f ms compNeeded = do -- Embed haddocks in the interface file (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) - (diags', mb_pm') <- - -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 - if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do - return (diags, mb_pm) - else do - -- if parsing fails, try parsing again with Haddock turned off - (diagsNoHaddock, mb_pm') <- liftIO $ getParsedModuleDefinition hsc opt f ms - return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm') - case mb_pm' of - Nothing -> return (diags', Nothing) + case mb_pm of + Nothing -> return (diags, Nothing) Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags'', mtmr) <- typeCheckRuleDefinition hsc pm + (diags', mtmr) <- typeCheckRuleDefinition hsc pm case mtmr of - Nothing -> pure (diags'', Nothing) + Nothing -> pure (diags', Nothing) Just tmr -> do let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr @@ -1046,7 +1007,7 @@ regenerateHiFile sess f ms compNeeded = do se <- getShakeExtras -- Bang pattern is important to avoid leaking 'tmr' - (diags''', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr + (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -1070,7 +1031,7 @@ regenerateHiFile sess f ms compNeeded = do pure (hiDiags <> gDiags <> concat wDiags) Nothing -> pure [] - return (diags' <> diags'' <> diags''' <> hiDiags, res) + return (diags <> diags' <> diags'' <> hiDiags, res) -- | HscEnv should have deps included already @@ -1233,9 +1194,9 @@ data RulesConfig = RulesConfig -- Disabling this drastically decreases sharing and is likely to -- increase memory usage if you have multiple files open -- Disabling this also disables checking for import cycles - fullModuleGraph :: Bool + fullModuleGraph :: Bool -- | Disable TH for improved performance in large codebases - , enableTemplateHaskell :: Bool + , enableTemplateHaskell :: Bool -- | Warning to show when TH is not supported by the current HLS binary , templateHaskellWarning :: LspT Config IO () } diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index ebc16ff30e..addfa53ff8 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -504,9 +504,7 @@ generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a) generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo data GhcVersion - = GHC810 - | GHC90 - | GHC92 + = GHC92 | GHC94 | GHC96 | GHC98 diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index c475baa50b..0e575421b6 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -83,7 +83,7 @@ addSigLensesTests = , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") , ("head = 233", "head :: Integer") - , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, String)") , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") @@ -112,10 +112,3 @@ addSigLensesTests = newLens <- getCodeLenses doc liftIO $ newLens @?= oldLens ] - --- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String -listOfChar :: T.Text -listOfChar | ghcVersion >= GHC90 = "String" - | otherwise = "[Char]" - - diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs index 471e0fd6be..cf3198e74d 100644 --- a/ghcide/test/exe/CompletionTests.hs +++ b/ghcide/test/exe/CompletionTests.hs @@ -261,7 +261,7 @@ nonLocalCompletionTests = [] ] where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason" + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason" otherCompletionTests :: [TestTree] otherCompletionTests = [ @@ -527,14 +527,14 @@ completionDocTests = ] let expected = "*Imported from 'Prelude'*\n" test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern single line doc without '\\n'" $ do + , brokenForMacGhc9 $ testSession "extern single line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = no" ] let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" test doc (Position 1 8) "not" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern mulit line doc" $ do + , brokenForMacGhc9 $ testSession "extern mulit line doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = i" @@ -550,9 +550,8 @@ completionDocTests = test doc (Position 1 7) "id" (Just $ T.length expected) [expected] ] where - brokenForWinGhc90 = knownBrokenFor (BrokenSpecific Windows [GHC90]) "Extern doc doesn't support Windows for ghc9.2" -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" + brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" test doc pos label mn expected = do _ <- waitForDiagnostics compls <- getCompletions doc pos diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 94d271b85b..a0a6cc364b 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -8,7 +8,7 @@ import Control.Applicative.Combinators import Control.Monad.IO.Class (liftIO) import Data.Row import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Compat (GhcVersion (..)) import Development.IDE.GHC.Util import Development.IDE.Test (expectDiagnostics, expectDiagnosticsWithTags, @@ -84,7 +84,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do -- Fix the cradle and typecheck again let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc @@ -211,17 +211,14 @@ sessionDepsArePickedUp = testSession' "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] - else [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match expected type")])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 (dir "hie.yaml") "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] -- Send change event. let change = diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index d78ad49a8a..3a6f9471de 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -44,14 +44,11 @@ tests = testGroup "addDependentFile" let bazContent = T.unlines ["module Baz where", "import Foo ()"] _ <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] - else [("Foo.hs", [(DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type")])] + expectDiagnostics + [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] -- Modifying Baz will now trigger Foo to be rebuilt as well diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 27a4d88323..4daab55efb 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -401,22 +401,6 @@ tests = testGroup "diagnostics" liftIO $ unless ("redundant" `T.isInfixOf` msg) $ assertFailure ("Expected redundant import but got " <> T.unpack msg) closeDoc a - , testSessionWait "haddock parse error" $ do - let fooContent = T.unlines - [ "module Foo where" - , "foo :: Int" - , "foo = 1 {-|-}" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - if ghcVersion >= GHC90 then - -- Haddock parse errors are ignored on ghc-9.0 - pure () - else - expectDiagnostics - [ ( "Foo.hs" - , [(DiagnosticSeverity_Warning, (2, 8), "Haddock parse error on input")] - ) - ] , testSessionWait "strip file path" $ do let name = "Testing" diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index 98789ab311..1b597bca0a 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -177,12 +177,8 @@ tests = let in mkFindTests -- def hover look expect - [ - if ghcVersion >= GHC90 then - -- It suggests either going to the constructor or to the field - test broken yes fffL4 fff "field in record definition" - else - test yes yes fffL4 fff "field in record definition" + [ -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" , test yes yes fffL8 fff "field in record construction #1102" , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 @@ -215,25 +211,19 @@ tests = let , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016" , test yes yes cmtL68 lackOfdEq "no Core symbols #3280" - , if ghcVersion >= GHC90 then - test no yes docL41 constr "type constraint in hover info #1012" - else - test no broken docL41 constr "type constraint in hover info #1012" + , test no yes docL41 constr "type constraint in hover info #1012" , test no yes outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" , test no yes holeL65 hleInfo2 "hole with variable" , test no yes cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" - , if | isWindows -> + , if isWindows then -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 testM no yes reexported reexportedSig "Imported symbol (reexported)" - | otherwise -> + else testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , if | ghcVersion == GHC90 && isWindows -> - test no broken thLocL57 thLoc "TH Splice Hover" - | otherwise -> - test no yes thLocL57 thLoc "TH Splice Hover" + , test no yes thLocL57 thLoc "TH Splice Hover" , test yes yes import310 pkgTxt "show package name and its version" ] where yes, broken :: (TestTree -> Maybe TestTree) diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs index 6d8dacfd4a..7fb5ca79a2 100644 --- a/ghcide/test/exe/HighlightTests.hs +++ b/ghcide/test/exe/HighlightTests.hs @@ -44,7 +44,7 @@ tests = testGroup "highlight" , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) ] - , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ testSessionWait "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 7aad572564..f4967a2656 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -55,7 +55,7 @@ ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource] expectDiagnostics [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] closeDoc cdoc ifaceErrorTest :: TestTree diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index 8b1d5a19c8..975b674549 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -138,7 +138,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do bdoc <- createDoc bPath "haskell" bSource cdoc <- createDoc cPath "haskell" cSource - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] -- Change th from () to Bool let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] @@ -150,7 +150,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do expectDiagnostics [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin")]) ] closeDoc adoc @@ -173,7 +173,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do adoc <- createDoc aPath "haskell" aSource bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] @@ -184,7 +184,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do waitForProgressBegin waitForAllProgressDone - expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")] + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")] closeDoc adoc closeDoc bdoc diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 92d332522f..78ad250ef9 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -304,11 +304,6 @@ defToLocation (InL (Definition (InR ls))) = ls defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink defToLocation (InR (InR Null)) = [] --- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did -thDollarIdx :: UInt -thDollarIdx | ghcVersion >= GHC90 = 1 - | otherwise = 0 - testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () testIde recorder arguments session = do config <- getConfigFromEnv diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs index 36a6fed50a..cbfaa30140 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs @@ -160,9 +160,9 @@ toBase conv header n | otherwise = header <> upper (conv n "") #if MIN_VERSION_base(4,17,0) -toOctal, toDecimal, toBinary, toHex :: Integral a => a -> String +toOctal, toBinary, toHex :: Integral a => a -> String #else -toOctal, toDecimal, toBinary, toHex:: (Integral a, Show a) => a -> String +toOctal, toBinary, toHex:: (Integral a, Show a) => a -> String #endif toBinary = toBase showBin_ "0b" @@ -172,10 +172,11 @@ toBinary = toBase showBin_ "0b" toOctal = toBase showOct "0o" -toDecimal = toBase showInt "" - toHex = toBase showHex "0x" +toDecimal :: Integral a => a -> String +toDecimal = toBase showInt "" + toFloatDecimal :: RealFloat a => a -> String toFloatDecimal val = showFFloat Nothing val "" diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 83d0045304..d7f5b42300 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -73,11 +73,12 @@ tests = , testCase "Semantic and Lexical errors are reported" $ do evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $ - if - | ghcVersion >= GHC96 -> "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" - | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" - | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’" - | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’" + if ghcVersion >= GHC96 then + "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + else + "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + + evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input" evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs" @@ -100,20 +101,14 @@ tests = , testCase ":type handles a multilined result properly" $ evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ "-- fun", - if - | ghcVersion >= GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." - | ghcVersion == GHC90 -> "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." - | otherwise -> "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", "-- Proxy k2 -> Proxy n -> Proxy a -> ()" ] , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs" , testCase ":type does \"dovetails\" for short identifiers" $ evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [ - if - | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." - | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." - | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", "-- Proxy k2 -> Proxy n -> Proxy a -> ()" ] diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 58926b0ab0..28de50efc8 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -1725,7 +1725,7 @@ suggestImportTests = testGroup "suggest import actions" suggestAddRecordFieldImportTests :: TestTree suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot" [ testGroup "The field is suggested when an instance resolution failure occurs" - [ ignoreForGhcVersions [GHC90, GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest + [ ignoreForGhcVersions [GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest ] ] where diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 2a34ab1a43..ffedf9c0e0 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -25,7 +25,7 @@ tests = testGroup "Rename" rename doc (Position 0 15) "Op" , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> rename doc (Position 2 1) "quux" - , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + , ignoreForGhcVersions [GHC92] recordConstructorIssue $ goldenWithRename "Field Puns" "FieldPuns" $ \doc -> rename doc (Position 7 13) "bleh" , goldenWithRename "Function argument" "FunctionArgument" $ \doc -> @@ -40,7 +40,7 @@ tests = testGroup "Rename" rename doc (Position 3 8) "baz" , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> rename doc (Position 0 22) "hiddenFoo" - , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + , ignoreForGhcVersions [GHC92] recordConstructorIssue $ goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc -> rename doc (Position 4 23) "blah" , goldenWithRename "Let expression" "LetExpression" $ \doc -> @@ -53,7 +53,7 @@ tests = testGroup "Rename" rename doc (Position 3 12) "baz" , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc -> rename doc (Position 0 2) "fooBarQuux" - , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + , ignoreForGhcVersions [GHC92] recordConstructorIssue $ goldenWithRename "Record field" "RecordField" $ \doc -> rename doc (Position 6 9) "number" , goldenWithRename "Shadowed name" "ShadowedName" $ \doc -> diff --git a/test/functional/Main.hs b/test/functional/Main.hs index 7dc4c82e4a..7adf499c05 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -12,8 +12,8 @@ main :: IO () main = defaultTestRunner $ testGroup "haskell-language-server" [ Config.tests , ConfigSchema.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests + , ignoreInEnv [HostOS Windows, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests , FunctionalBadProject.tests , HieBios.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Progress.tests + , ignoreInEnv [HostOS Windows] "Tests gets stuck in ci" $ Progress.tests ] diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs index 4879d23603..0fbfa76b7a 100644 --- a/test/wrapper/Main.hs +++ b/test/wrapper/Main.hs @@ -9,10 +9,16 @@ main = defaultTestRunner $ testGroup "haskell-language-server-wrapper" [projectG projectGhcVersionTests :: TestTree projectGhcVersionTests = testGroup "--project-ghc-version" - [ stackTest "9.2.8" + [ testCase "stack with global ghc" $ do + ghcVer <- ghcNumericVersion + let writeStackYaml = writeFile "stack.yaml" $ + -- Use system-ghc and install-ghc to avoid stack downloading ghc in CI + -- (and use ghcup-managed ghc instead) + "{resolver: ghc-" ++ ghcVer ++ ", system-ghc: true, install-ghc: false}" + testDir writeStackYaml "test/wrapper/testdata/stack-specific-ghc" ghcVer , testCase "cabal with global ghc" $ do - ghcVer <- trimEnd <$> readProcess "ghc" ["--numeric-version"] "" - testDir "test/wrapper/testdata/cabal-cur-ver" ghcVer + ghcVer <- ghcNumericVersion + testDir (pure ()) "test/wrapper/testdata/cabal-cur-ver" ghcVer , testCase "stack with existing cabal build artifact" $ do -- Should report cabal as existing build artifacts are more important than -- the existence of 'stack.yaml' @@ -20,12 +26,12 @@ projectGhcVersionTests = testGroup "--project-ghc-version" ("cradleOptsProg = CradleAction: Cabal" `isInfixOf`) ] where - stackTest ghcVer= testCase ("stack with ghc " ++ ghcVer) $ - testDir ("test/wrapper/testdata/stack-" ++ ghcVer) ghcVer + ghcNumericVersion = trimEnd <$> readProcess "ghc" ["--numeric-version"] "" -testDir :: FilePath -> String -> Assertion -testDir dir expectedVer = +testDir :: IO () -> FilePath -> String -> Assertion +testDir extraSetup dir expectedVer = withCurrentDirectoryInTmp dir $ do + extraSetup testExe <- fromMaybe "haskell-language-server-wrapper" <$> lookupEnv "HLS_WRAPPER_TEST_EXE" actualVer <- trimEnd <$> readProcess testExe ["--project-ghc-version"] "" diff --git a/test/wrapper/testdata/stack-9.2.8/stack.yaml b/test/wrapper/testdata/stack-9.2.8/stack.yaml deleted file mode 100644 index 4324da7693..0000000000 --- a/test/wrapper/testdata/stack-9.2.8/stack.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: ghc-9.2.8 diff --git a/test/wrapper/testdata/stack-9.2.8/Lib.hs b/test/wrapper/testdata/stack-specific-ghc/Lib.hs similarity index 100% rename from test/wrapper/testdata/stack-9.2.8/Lib.hs rename to test/wrapper/testdata/stack-specific-ghc/Lib.hs diff --git a/test/wrapper/testdata/stack-9.2.8/foo.cabal b/test/wrapper/testdata/stack-specific-ghc/foo.cabal similarity index 100% rename from test/wrapper/testdata/stack-9.2.8/foo.cabal rename to test/wrapper/testdata/stack-specific-ghc/foo.cabal