diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal --- a/hls-eval-plugin.cabal +++ b/hls-eval-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin -version: 1.4.0.0 +version: 1.5.0.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -37,10 +37,6 @@ location: https://github.com/haskell/haskell-language-server library - if impl(ghc >= 9.3) - buildable: False - else - buildable: True exposed-modules: Ide.Plugin.Eval Ide.Plugin.Eval.Types @@ -70,7 +66,7 @@ , ghc , ghc-boot-th , ghc-paths - , ghcide ^>=1.9 + , ghcide ^>=1.9 || ^>= 1.10 , hashable , hls-graph , hls-plugin-api ^>=1.6 @@ -101,10 +97,6 @@ TypeOperators test-suite tests - if impl(ghc >= 9.3) - buildable: False - else - buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs --- a/src/Ide/Plugin/Eval/Code.hs +++ b/src/Ide/Plugin/Eval/Code.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} -- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where import Control.Lens ((^.)) import Control.Monad.IO.Class @@ -80,12 +80,6 @@ ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] --- |GHC declarations required for expression evaluation -evalSetup :: Ghc () -evalSetup = do - preludeAsP <- parseImportDecl "import qualified Prelude as P" - context <- getContext - setContext (IIDecl preludeAsP : context) -- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) diff --git a/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs --- a/src/Ide/Plugin/Eval/CodeLens.hs +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-type-defaults -Wno-unused-imports #-} {- | A plugin inspired by the REPLoid feature of , 's Examples and Properties and . @@ -29,84 +29,81 @@ import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, join, +import Control.Monad (guard, void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (toJSON) import Data.Char (isSpace) -import Data.Default +import Data.Foldable (toList) import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, intercalate, intersperse) -import Data.Maybe (catMaybes, - fromMaybe) +import Data.Maybe (catMaybes) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (getCurrentTime) import Data.Typeable (Typeable) -import Development.IDE (GetDependencyInformation (..), - GetLinkable (..), - GetModSummary (..), - GhcSessionIO (..), - IdeState, - ModSummaryResult (..), - NeedsCompilation (NeedsCompilation), - VFSModified (..), - evalGhcEnv, - hscEnvWithImportPaths, - linkableHomeMod, - printOutputable, - runAction, - textToStringBuffer, - toNormalizedFilePath', - uriToFilePath', - useNoFile_, - useWithStale_, - use_, uses_) -import Development.IDE.Core.Rules (GhcSessionDepsConfig (..), - ghcSessionDepsDefinition) +import Development.IDE.Core.RuleTypes + ( NeedsCompilation(NeedsCompilation), + LinkableResult(linkableHomeMod), + tmrTypechecked, + TypeCheck(..)) +import Development.IDE.Core.Rules ( runAction, IdeState ) +import Development.IDE.Core.Shake + ( useWithStale_, + use_, + uses_ ) +import Development.IDE.GHC.Util + ( printOutputable, evalGhcEnv, modifyDynFlags ) +import Development.IDE.Types.Location + ( toNormalizedFilePath', uriToFilePath' ) import Development.IDE.GHC.Compat hiding (typeKind, unitState) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as SrcLoc import Development.IDE.GHC.Compat.Util (GhcException, OverridingBool (..)) import Development.IDE.Import.DependencyInformation (reachableModules) -import Development.IDE.Types.Options import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, GhcMonad, - LoadHowMuch (LoadAllTargets), NamedThing (getName), defaultFixity, execOptions, exprType, getInfo, getInteractiveDynFlags, - isImport, isStmt, - load, parseName, + isImport, isStmt, parseName, pprFamInst, pprInstance, - setTargets, typeKind) + + +import Development.IDE.Core.RuleTypes + ( ModSummaryResult(msrModSummary), + GetModSummary(GetModSummary), + GhcSessionDeps(GhcSessionDeps), + GetDependencyInformation(GetDependencyInformation), + GetLinkable(GetLinkable) ) +import Development.IDE.Core.Shake ( VFSModified(VFSUnmodified) ) +import Development.IDE.Types.HscEnvEq ( HscEnvEq(hscEnv) ) +import qualified Development.IDE.GHC.Compat.Core as Compat + ( InteractiveImport(IIModule) ) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc + ( unLoc, HasSrcSpan(getLoc) ) #if MIN_VERSION_ghc(9,2,0) -import GHC (Fixity) #endif import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Types.Shake (toKey) -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #endif import Ide.Plugin.Eval.Code (Statement, asStatements, - evalSetup, myExecStmt, propSetup, resultRange, @@ -137,16 +134,6 @@ import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText) -#if MIN_VERSION_ghc(9,2,0) -#elif MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Session (unitDatabases, - unitState) -import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) -#else -import DynFlags -#endif - - {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} @@ -230,112 +217,22 @@ let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri - -- enable codegen + -- enable codegen for the module which we need to evaluate. liftIO $ queueForEvaluation st nfp liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval" - - session <- runGetSession st nfp - - ms <- fmap msrModSummary $ - liftIO $ - runAction "runEvalCmd.getModSummary" st $ - use_ GetModSummary nfp - - now <- liftIO getCurrentTime - - let modName = moduleName $ ms_mod ms - thisModuleTarget = - Target - (TargetFile fp Nothing) - False - (Just (textToStringBuffer mdlText, now)) - - -- Setup environment for evaluation - hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do - env <- getSession - - -- Install the module pragmas and options - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - - -- Restore the original import paths - let impPaths = importPaths $ hsc_dflags env - df <- return df{importPaths = impPaths} - - -- Set the modified flags in the session - _lp <- setSessionDynFlags df - - -- property tests need QuickCheck - when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"] - dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests - dbg "QUICKCHECK HAS" $ hasQuickCheck df - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - df <- getSessionDynFlags - -- set the identical DynFlags as GHCi - -- Source: https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483 - -- This needs to be done manually since the default flags are not visible externally. - let df' = flip xopt_set LangExt.ExtendedDefaultRules - . flip xopt_unset LangExt.MonomorphismRestriction - $ idflags - setInteractiveDynFlags $ df' -#if MIN_VERSION_ghc(9,0,0) - { - packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } -#else - { pkgState = - pkgState - df - , pkgDatabase = - pkgDatabase - df - , packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } -#endif - - -- Load the module with its current content (as the saved module might not be up to date) - eSetTarget <- gStrictTry $ setTargets [thisModuleTarget] - dbg "setTarget" eSetTarget + -- Setup a session with linkables for all dependencies and GHCi specific options + final_hscEnv <- liftIO $ initialiseSessionForEval + (needsQuickCheck tests) + st nfp - -- load the module in the interactive environment - loadResult <- perf "loadModule" $ load LoadAllTargets - dbg "LOAD RESULT" $ printOutputable loadResult - case loadResult of - Failed -> liftIO $ do - let err = "" - dbg "load ERR" err - return $ Left err - Succeeded -> do - -- Evaluation takes place 'inside' the module - setContext [Compat.IIModule modName] - Right <$> getSession evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId - -- Get linkables for all modules below us - -- This can be optimised to only get the linkables for the symbols depended on by - -- the statement we are parsing - lbs <- liftIO $ runAction "eval: GetLinkables" st $ do - linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp - uses_ GetLinkable (filter (/= nfp) linkables_needed) -- We don't need the linkable for the current module - let hscEnv'' = hscEnv' { hsc_HPT = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] } - + -- Perform the evaluation of the command edits <- perf "edits" $ liftIO $ - evalGhcEnv hscEnv'' $ - runTests - evalCfg - (st, fp) - tests + evalGhcEnv final_hscEnv $ do + runTests evalCfg (st, fp) tests let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing @@ -345,6 +242,50 @@ withIndefiniteProgress "Evaluating" Cancellable $ response' cmd +-- | Create an HscEnv which is suitable for performing interactive evaluation. +-- All necessary home modules will have linkables and the current module will +-- also be loaded into the environment. +-- +-- The interactive context and interactive dynamic flags are also set appropiately. +initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv +initialiseSessionForEval needs_quickcheck st nfp = do + (ms, env1) <- runAction "runEvalCmd" st $ do + + ms <- msrModSummary <$> use_ GetModSummary nfp + deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + + linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp + linkables <- uses_ GetLinkable linkables_needed + -- We unset the global rdr env in mi_globals when we generate interfaces + -- See Note [Clearing mi_globals after generating an iface] + -- However, the eval plugin (setContext specifically) requires the rdr_env + -- for the current module - so get it from the Typechecked Module and add + -- it back to the iface for the current module. + rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp + let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc + addRdrEnv hmi + | iface <- hm_iface hmi + , ms_mod ms == mi_module iface + = hmi { hm_iface = iface { mi_globals = Just rdr_env } } + | otherwise = hmi + + return (ms, linkable_hsc) + -- Bit awkward we need to use evalGhcEnv here but setContext requires to run + -- in the Ghc monad + env2 <- evalGhcEnv env1 $ do + setContext [Compat.IIModule (moduleName (ms_mod ms))] + let df = flip xopt_set LangExt.ExtendedDefaultRules + . flip xopt_unset LangExt.MonomorphismRestriction + . flip gopt_set Opt_ImplicitImportQualified + . flip gopt_unset Opt_DiagnosticsShowCaret + $ (ms_hspp_opts ms) { + useColor = Never + , canUseColor = False } + modifyDynFlags (const df) + when needs_quickcheck $ void $ addPackages ["QuickCheck"] + getSession + return env2 + addFinalReturn :: Text -> [TextEdit] -> [TextEdit] addFinalReturn mdlText edits | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = @@ -374,6 +315,12 @@ ] type TEnv = (IdeState, String) +-- |GHC declarations required for expression evaluation +evalSetup :: Ghc () +evalSetup = do + preludeAsP <- parseImportDecl "import qualified Prelude as P" + context <- getContext + setContext (IIDecl preludeAsP : context) runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] runTests EvalConfig{..} e@(_st, _) tests = do @@ -387,7 +334,6 @@ processTest e@(st, fp) df (section, test) = do let dbg = logWith st let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) - rs <- runTest e df test dbg "TEST RESULTS" rs @@ -560,22 +506,6 @@ T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" <> " " <> SrcLoc.unLoc warnMsg -runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv -runGetSession st nfp = liftIO $ runAction "eval" st $ do - -- Create a new GHC Session rather than reusing an existing one - -- to avoid interfering with ghcide - -- UPDATE: I suspect that this doesn't really work, we always get the same Session - -- we probably cache hscEnvs in the Session state - IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - let fp = fromNormalizedFilePath nfp - ((_, res),_) <- liftIO $ loadSessionFun fp - let env = fromMaybe (error $ "Unknown file: " <> fp) res - ghcSessionDepsConfig = def - { checkForImportCycles = False - } - res <- fmap hscEnvWithImportPaths <$> ghcSessionDepsDefinition True ghcSessionDepsConfig env nfp - return $ fromMaybe (error $ "Unable to load file: " <> fp) res - needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) @@ -659,7 +589,7 @@ names <- GHC.parseName str mb_stuffs <- mapM (GHC.getInfo allInfo) names let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t) - (catMaybes mb_stuffs) + (catMaybes $ toList mb_stuffs) return $ vcat (intersperse (text "") $ map pprInfo filtered) filterOutChildren :: (a -> TyThing) -> [a] -> [a] @@ -698,20 +628,20 @@ doKindCmd False df arg = do let input = T.strip arg (_, kind) <- typeKind False $ T.unpack input - let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind + let kindText = text (T.unpack input) <+> "::" <+> pprSigmaType kind pure $ Just $ T.pack (showSDoc df kindText) doKindCmd True df arg = do let input = T.strip arg (ty, kind) <- typeKind True $ T.unpack input - let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind - tyDoc = "=" <+> pprTypeForUser ty + let kindDoc = text (T.unpack input) <+> "::" <+> pprSigmaType kind + tyDoc = "=" <+> pprSigmaType ty pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) doTypeCmd dflags arg = do let (emod, expr) = parseExprMode arg ty <- GHC.exprType emod $ T.unpack expr - let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty + let rawType = T.strip $ T.pack $ showSDoc dflags $ pprSigmaType ty broken = T.any (\c -> c == '\r' || c == '\n') rawType pure $ Just $ @@ -720,7 +650,7 @@ T.pack $ showSDoc dflags $ text (T.unpack expr) - $$ nest 2 ("::" <+> pprTypeForUser ty) + $$ nest 2 ("::" <+> pprSigmaType ty) else expr <> " :: " <> rawType <> "\n" parseExprMode :: Text -> (TcRnExprMode, T.Text) @@ -756,22 +686,3 @@ (':', rest) <- T.uncons $ T.stripStart input pure $ second T.strip $ T.break isSpace rest -setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags -setupDynFlagsForGHCiLike env dflags = do - let dflags3 = setInterpreterLinkerOptions dflags - platform = targetPlatform dflags3 - evalWays = Compat.hostFullWays - dflags3a = setWays evalWays dflags3 - dflags3b = - foldl gopt_set dflags3a $ - concatMap (Compat.wayGeneralFlags platform) evalWays - dflags3c = - foldl gopt_unset dflags3b $ - concatMap (Compat.wayUnsetGeneralFlags platform) evalWays - dflags4 = - dflags3c - `gopt_set` Opt_ImplicitImportQualified - `gopt_set` Opt_IgnoreOptimChanges - `gopt_set` Opt_IgnoreHpcChanges - `gopt_unset` Opt_DiagnosticsShowCaret - Compat.hsc_dflags <$> Compat.initializePlugins (Compat.hscSetFlags dflags4 env) diff --git a/src/Ide/Plugin/Eval/Rules.hs b/src/Ide/Plugin/Eval/Rules.hs --- a/src/Ide/Plugin/Eval/Rules.hs +++ b/src/Ide/Plugin/Eval/Rules.hs @@ -67,8 +67,13 @@ modifyIORef var (Set.insert nfp) #if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,5,0) +getAnnotations :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment] +getAnnotations (L _ m@(HsModule { hsmodExt = XModulePs {hsmodAnn = anns'}})) = +#else getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment] getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) = +#endif priorComments annComments <> getFollowingComments annComments <> concatMap getCommentsForDecl (hsmodImports m) <> concatMap getCommentsForDecl (hsmodDecls m) diff --git a/src/Ide/Plugin/Eval/Util.hs b/src/Ide/Plugin/Eval/Util.hs --- a/src/Ide/Plugin/Eval/Util.hs +++ b/src/Ide/Plugin/Eval/Util.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} -- |Debug utilities module Ide.Plugin.Eval.Util ( @@ -11,7 +13,7 @@ logWith, ) where -import Control.Exception (SomeException, evaluate) +import Control.Exception (SomeException, evaluate, fromException) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (Value (Null)) @@ -19,7 +21,8 @@ import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), ideLogger, logPriority) -import Development.IDE.GHC.Compat.Util (MonadCatch, catch) +import Development.IDE.GHC.Compat.Util (MonadCatch, catch, bagToList) +import Development.IDE.GHC.Compat.Outputable import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, @@ -36,7 +39,7 @@ _ <- out name (showDuration secs) return r --- |Log using hie logger, reports source position of logging statement +-- | Log using hie logger, reports source position of logging statement logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m () logWith state key val = liftIO . logPriority (ideLogger state) logLevel $ @@ -79,4 +82,22 @@ gevaluate = liftIO . evaluate showErr :: Monad m => SomeException -> m (Either String b) -showErr = return . Left . show +showErr e = +#if MIN_VERSION_ghc(9,3,0) + case fromException e of + -- On GHC 9.4+, the show instance adds the error message span + -- We don't want this for the plugin + -- So render without the span. + Just (SourceError msgs) -> return $ Left $ renderWithContext defaultSDocContext + $ vcat + $ bagToList + $ fmap (vcat . unDecorated + . diagnosticMessage +#if MIN_VERSION_ghc(9,5,0) + (defaultDiagnosticOpts @GhcMessage) +#endif + . errMsgDiagnostic) + $ getMessages msgs + _ -> +#endif + return . Left . show $ e diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -22,6 +22,7 @@ import qualified Ide.Plugin.Eval as Eval import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), testOutput) +import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Types.Lens (arguments, command, range, title) import System.FilePath (()) import Test.Hls @@ -73,29 +74,34 @@ evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $ if - | 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 >= 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 ‘+’" 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" - , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" ( + if ghcVersion >= GHC94 then "ghc94.expected" + else if ghcVersion >= GHC92 then "ghc92.expected" + else "expected" + ) + , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Returns a fully-instantiated type for :type" "T14" "hs" - , knownBrokenForGhcVersions [GHC92] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs" - , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Reports an error when given with unknown command" "T18" "hs" , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs" , expectFailBecause "known issue - see a note in P.R. #361" $ - goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , 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 >= 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).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", @@ -105,7 +111,7 @@ , 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 >= 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).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", @@ -124,17 +130,26 @@ , goldenWithEval "Transitive local dependency" "TTransitive" "hs" -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs" - , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , testCase ":set -fprint-explicit-foralls works" $ do evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" - (if ghcVersion == GHC92 + (if ghcVersion >= GHC92 then "-- id :: forall a. a -> a" else "-- id :: forall {a}. a -> a") , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" , goldenWithEval "Property checking" "TProperty" "hs" - , goldenWithEval "Property checking with exception" "TPropertyError" "hs" + , goldenWithEval' "Property checking with exception" "TPropertyError" "hs" ( + if ghcVersion >= GHC96 then + "ghc96.expected" + else if ghcVersion >= GHC94 && hostOS == Windows then + "windows-ghc94.expected" + else if ghcVersion >= GHC94 then + "ghc94.expected" + else + "expected" + ) , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs" , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs" diff --git a/test/testdata/T11.expected.hs b/test/testdata/T11.expected.hs --- a/test/testdata/T11.expected.hs +++ b/test/testdata/T11.expected.hs @@ -1,4 +1,4 @@ module T11 where --- >>> :kind! a --- Not in scope: type variable ‘a’ +-- >>> :kind! A +-- Not in scope: type constructor or class ‘A’ diff --git a/test/testdata/T11.ghc92.expected.hs b/test/testdata/T11.ghc92.expected.hs deleted file mode 100644 --- a/test/testdata/T11.ghc92.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T11 where - --- >>> :kind! a --- Not in scope: type variable `a' diff --git a/test/testdata/T11.ghc92_expected.hs b/test/testdata/T11.ghc92_expected.hs deleted file mode 100644 --- a/test/testdata/T11.ghc92_expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T11 where - --- >>> :kind! a --- Not in scope: type variable `a' diff --git a/test/testdata/T11.hs b/test/testdata/T11.hs --- a/test/testdata/T11.hs +++ b/test/testdata/T11.hs @@ -1,3 +1,3 @@ module T11 where --- >>> :kind! a +-- >>> :kind! A diff --git a/test/testdata/T13.expected.hs b/test/testdata/T13.expected.hs --- a/test/testdata/T13.expected.hs +++ b/test/testdata/T13.expected.hs @@ -1,4 +1,4 @@ module T13 where --- >>> :kind a --- Not in scope: type variable ‘a’ +-- >>> :kind A +-- Not in scope: type constructor or class ‘A’ diff --git a/test/testdata/T13.ghc92.expected.hs b/test/testdata/T13.ghc92.expected.hs --- a/test/testdata/T13.ghc92.expected.hs +++ b/test/testdata/T13.ghc92.expected.hs @@ -1,4 +1,4 @@ module T13 where --- >>> :kind a --- Not in scope: type variable `a' +-- >>> :kind A +-- Not in scope: type constructor or class `A' diff --git a/test/testdata/T13.hs b/test/testdata/T13.hs --- a/test/testdata/T13.hs +++ b/test/testdata/T13.hs @@ -1,3 +1,3 @@ module T13 where --- >>> :kind a +-- >>> :kind A diff --git a/test/testdata/TPropertyError.ghc94.expected.hs b/test/testdata/TPropertyError.ghc94.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPropertyError.ghc94.expected.hs @@ -0,0 +1,13 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! (after 1 test): +-- Exception: +-- Prelude.head: empty list +-- CallStack (from HasCallStack): +-- error, called at libraries/base/GHC/List.hs:1646:3 in base:GHC.List +-- errorEmptyList, called at libraries/base/GHC/List.hs:85:11 in base:GHC.List +-- badHead, called at libraries/base/GHC/List.hs:81:28 in base:GHC.List +-- head, called at :1:27 in interactive:Ghci2 +-- [] diff --git a/test/testdata/TPropertyError.windows-ghc94.expected.hs b/test/testdata/TPropertyError.windows-ghc94.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPropertyError.windows-ghc94.expected.hs @@ -0,0 +1,13 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! (after 1 test): +-- Exception: +-- Prelude.head: empty list +-- CallStack (from HasCallStack): +-- error, called at libraries\base\GHC\List.hs:1646:3 in base:GHC.List +-- errorEmptyList, called at libraries\base\GHC\List.hs:85:11 in base:GHC.List +-- badHead, called at libraries\base\GHC\List.hs:81:28 in base:GHC.List +-- head, called at :1:27 in interactive:Ghci2 +-- []