diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -22,7 +22,9 @@ import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Options +import GHC.Stack (emptyCallStack) +import Ide.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Error, Info), @@ -33,16 +35,14 @@ layoutPretty, makeDefaultStderrRecorder, renderStrict) -import qualified Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Options -import GHC.Stack (emptyCallStack) +import qualified Ide.Logger as Logger import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) +import Language.LSP.Protocol.Message as LSP import Language.LSP.Server as LSP -import Language.LSP.Types as LSP import Paths_ghcide (version) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) @@ -101,7 +101,7 @@ -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback") - { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do env <- LSP.getLspEnv liftIO $ (cb1 <> cb2) env } diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 2.0.0.1 +version: 2.1.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -65,12 +65,12 @@ haddock-library >= 1.8 && < 1.12, hashable, hie-compat ^>= 0.3.0.0, - hls-plugin-api == 2.0.0.1, + hls-plugin-api == 2.1.0.0, lens, list-t, hiedb == 0.4.3.*, - lsp-types ^>= 1.6.0.0, - lsp ^>= 1.6.0.0 , + lsp-types ^>= 2.0.1.0, + lsp ^>= 2.1.0.0 , mtl, optparse-applicative, parallel, @@ -78,9 +78,10 @@ prettyprinter >= 1.7, random, regex-tdfa >= 1.3.1.0, + row-types, text-rope, safe-exceptions, - hls-graph == 2.0.0.1, + hls-graph == 2.1.0.0, sorted-list, sqlite-simple, stm, @@ -153,6 +154,7 @@ Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest + Development.IDE.Core.PluginUtils Development.IDE.Core.PositionMapping Development.IDE.Core.Preprocessor Development.IDE.Core.ProgressReporting @@ -196,7 +198,6 @@ Development.IDE.Types.HscEnvEq Development.IDE.Types.KnownTargets Development.IDE.Types.Location - Development.IDE.Types.Logger Development.IDE.Types.Monitoring Development.IDE.Monitoring.OpenTelemetry Development.IDE.Types.Options @@ -345,7 +346,8 @@ hls-plugin-api, lens, list-t, - lsp-test ^>= 0.14, + lsp-test ^>= 0.15.0.1, + mtl, monoid-subclasses, network-uri, QuickCheck, @@ -363,6 +365,7 @@ text, text-rope, unordered-containers, + row-types if impl(ghc < 9.2) build-depends: record-dot-preprocessor, @@ -381,6 +384,39 @@ HieDbRetry Development.IDE.Test Development.IDE.Test.Diagnostic + ExceptionTests + -- Tests that have been pulled out of the main file + BootTests + CodeLensTests + CompletionTests + CPPTests + CradleTests + DependentFileTest + DiagnosticTests + FindDefinitionAndHoverTests + HaddockTests + HighlightTests + IfaceTests + InitializeResponseTests + LogType + NonLspCommandLine + OutlineTests + PluginParsedResultTests + PluginSimpleTests + PositionMappingTests + PreprocessorTests + RootUriTests + SafeTests + SymlinkTests + TestUtils + THTests + UnitTests + WatchedFileTests + AsyncTests + ClientSettingsTests + ReferenceTests + GarbageCollectionTests + OpenCloseTest default-extensions: BangPatterns DeriveFunctor diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -43,6 +43,7 @@ import Data.List import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Proxy import qualified Data.Text as T import Data.Time.Clock import Data.Version @@ -64,13 +65,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Priority (Debug, Error, Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - nest, - toCologActionWithPrio, - vcat, viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -78,8 +72,15 @@ import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios import Hie.Implicit.Cradle (loadImplicitHieCradle) +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + nest, + toCologActionWithPrio, + vcat, viaShow, (<+>)) +import Language.LSP.Protocol.Message import Language.LSP.Server -import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath @@ -483,7 +484,25 @@ packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) + (df', targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) + let df = +#if MIN_VERSION_ghc(9,3,0) + case unitIdString (homeUnitId_ df') of + -- cabal uses main for the unit id of all executable packages + -- This makes multi-component sessions confused about what + -- options to use for that component. + -- Solution: hash the options and use that as part of the unit id + -- This works because there won't be any dependencies on the + -- executable unit. + "main" -> + let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts) + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in setHomeUnitId_ hashed_uid df' + _ -> df' +#else + df' +#endif + let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -498,6 +517,7 @@ -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. + new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info : maybe [] snd oldDeps -- Get all the unit-ids for things in this component @@ -632,7 +652,7 @@ lfp <- flip makeRelative cfp <$> getCurrentDirectory when optTesting $ mRunLspT lspEnv $ - sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) @@ -906,7 +926,7 @@ renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic renderCradleError nfp (CradleError _ _ec t) = - ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines (map T.pack t)) -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) @@ -1120,4 +1140,4 @@ renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -8,9 +8,7 @@ import Development.IDE.Core.Actions as X (getAtPoint, getDefinition, - getTypeDefinition, - useE, useNoFileE, - usesE) + getTypeDefinition) import Development.IDE.Core.FileExists as X (getFileExists) import Development.IDE.Core.FileStore as X (getFileContents) import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), @@ -55,4 +53,4 @@ hscEnv, hscEnvWithImportPaths) import Development.IDE.Types.Location as X -import Development.IDE.Types.Logger as X +import Ide.Logger as X diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -6,13 +6,11 @@ , getTypeDefinition , highlightAtPoint , refsAtPoint -, useE -, useNoFileE -, usesE , workspaceSymbols , lookupMod ) where +import Control.Monad.Extra (mapMaybeM) import Control.Monad.Reader import Control.Monad.Trans.Maybe import qualified Data.HashMap.Strict as HM @@ -20,6 +18,7 @@ import qualified Data.Text as T import Data.Tuple.Extra import Development.IDE.Core.OfInterest +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -30,8 +29,10 @@ import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb -import Language.LSP.Types (DocumentHighlight (..), - SymbolInformation (..)) +import Language.LSP.Protocol.Types (DocumentHighlight (..), + SymbolInformation (..), + normalizedFilePathToUri, + uriToNormalizedFilePath) -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the @@ -46,7 +47,7 @@ lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing --- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, +-- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined, -- so we can quickly answer as soon as the IDE is opened -- Even if we don't have persistent information on disk for these rules, the persistent rule -- should just return an empty result @@ -59,50 +60,67 @@ ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file - env <- hscEnv . fst <$> useE GhcSession file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) + (hf, mapping) <- useWithStaleFastMT GetHieAst file + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' + MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' -toCurrentLocations :: PositionMapping -> [Location] -> [Location] -toCurrentLocations mapping = mapMaybe go +-- | For each Loacation, determine if we have the PositionMapping +-- for the correct file. If not, get the correct position mapping +-- and then apply the position mapping to the location. +toCurrentLocations + :: PositionMapping + -> NormalizedFilePath + -> [Location] + -> IdeAction [Location] +toCurrentLocations mapping file = mapMaybeM go where - go (Location uri range) = Location uri <$> toCurrentRange mapping range - --- | useE is useful to implement functions that aren’t rules but need shortcircuiting --- e.g. getDefinition. -useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) -useE k = MaybeT . useWithStaleFast k - -useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v -useNoFileE _ide k = fst <$> useE k emptyFilePath - -usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)] -usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) + go :: Location -> IdeAction (Maybe Location) + go (Location uri range) = + -- The Location we are going to might be in a different + -- file than the one we are calling gotoDefinition from. + -- So we check that the location file matches the file + -- we are in. + if nUri == normalizedFilePathToUri file + -- The Location matches the file, so use the PositionMapping + -- we have. + then pure $ Location uri <$> toCurrentRange mapping range + -- The Location does not match the file, so get the correct + -- PositionMapping and use that instead. + else do + otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do + otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri + useWithStaleFastMT GetHieAst otherLocationFile + pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) + where + nUri :: NormalizedUri + nUri = toNormalizedUri uri -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useE GetHieAst file - (ImportMap imports, _) <- useE GetImportMap file + (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file + (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + MaybeT $ Just <$> toCurrentLocations mapping file locations getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + MaybeT $ Just <$> toCurrentLocations mapping file locations highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do - (HAR _ hf rf _ _,mapping) <- useE GetHieAst file + (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -34,6 +34,9 @@ , ml_core_file , coreFileToLinkable , TypecheckHelpers(..) + , sourceTypecheck + , sourceParser + , shareUsages ) where import Control.Monad.IO.Class @@ -64,6 +67,7 @@ import Data.List.Extra import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy(Proxy)) import qualified Data.Set as Set import Data.Maybe import qualified Data.Text as T @@ -98,8 +102,9 @@ import GHC.Serialized import HieDb import qualified Language.LSP.Server as LSP -import Language.LSP.Types (DiagnosticTag (..)) -import qualified Language.LSP.Types as LSP +import Language.LSP.Protocol.Types (DiagnosticTag (..)) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Message as LSP import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) @@ -132,6 +137,7 @@ import qualified GHC as G import GHC.Hs (LEpaComment) import qualified GHC.Types.Error as Error +import Development.IDE.Import.DependencyInformation #endif #if MIN_VERSION_ghc(9,5,0) @@ -139,6 +145,12 @@ import GHC.Core.Lint.Interactive #endif +--Simple constansts to make sure the source is consistently named +sourceTypecheck :: T.Text +sourceTypecheck = "typecheck" +sourceParser :: T.Text +sourceParser = "parser" + -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule :: IdeOptions @@ -182,13 +194,13 @@ case initialized of Left errs -> return (errs, Nothing) Right (modSummary', hsc) -> do - (warnings, etcm) <- withWarnings "typecheck" $ \tweak -> + (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak -> let session = tweak (hscSetFlags dflags hsc) -- TODO: maybe settings ms_hspp_opts is unnecessary? mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} in - catchSrcErrors (hsc_dflags hsc) "typecheck" $ do + catchSrcErrors (hsc_dflags hsc) sourceTypecheck $ do tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings @@ -351,6 +363,10 @@ #if MIN_VERSION_ghc(9,3,0) -- TODO: support backpack nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule + -- We shouldn't get boot files here, but to be safe, never map them to an installed module + -- because boot files don't have linkables we can load, and we will fail if we try to look + -- for them + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod IsBoot) uid)) = Nothing nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod nodeKeyToInstalledModule _ = Nothing moduleToNodeKey :: Module -> NodeKey @@ -458,6 +474,8 @@ #endif -- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 +-- Important to do this immediately after reading the unit before +-- anything else has a chance to read `mi_usages` shareUsages :: ModIface -> ModIface shareUsages iface = iface {mi_usages = usages} where usages = map go (mi_usages iface) @@ -611,7 +629,7 @@ source = "compile" catchErrs x = x `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] @@ -741,7 +759,7 @@ upgradeWarningToError :: FileDiagnostic -> FileDiagnostic upgradeWarningToError (nfp, sh, fd) = - (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where + (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" @@ -780,18 +798,15 @@ tagDiag (w@(Reason warning), (nfp, sh, fd)) #endif | Just tag <- requiresTag warning - = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) + = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) })) where requiresTag :: WarningFlag -> Maybe DiagnosticTag requiresTag Opt_WarnWarningsDeprecations - = Just DtDeprecated + = Just DiagnosticTag_Deprecated requiresTag wflag -- deprecation was already considered above | wflag `elem` unnecessaryDeprecationWarningFlags - = Just DtUnnecessary + = Just DiagnosticTag_Unnecessary requiresTag _ = Nothing - addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag) - addTag t Nothing = Just (List [t]) - addTag t (Just (List ts)) = Just (List (t : ts)) -- other diagnostics are left unaffected tagDiag t = t @@ -901,9 +916,10 @@ -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash unless newerScheduled $ do - pre optProgressStyle - withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') - post + -- Using bracket, so even if an exception happen during withHieDb call, + -- the `post` (which clean the progress indicator) will still be called. + bracket_ (pre optProgressStyle) post $ + withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') where mod_location = ms_location mod_summary targetPath = Compat.ml_hie_file mod_location @@ -918,12 +934,13 @@ case lspEnv se of Nothing -> pure Nothing Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique + u <- LSP.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.newUnique -- TODO: Wait for the progress create response to use the token - _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ - LSP.Begin $ LSP.WorkDoneProgressBeginParams - { _title = "Indexing" + _ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $ + toJSON $ LSP.WorkDoneProgressBegin + { _kind = LSP.AString @"begin" + , _title = "Indexing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing @@ -941,22 +958,25 @@ progressPct = floor $ 100 * progressFrac whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.Report $ + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $ + toJSON $ case style of - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + Percentage -> LSP.WorkDoneProgressReport + { _kind = LSP.AString @"report" + , _cancellable = Nothing , _message = Nothing , _percentage = Just progressPct } - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + Explicit -> LSP.WorkDoneProgressReport + { _kind = LSP.AString @"report" + , _cancellable = Nothing , _message = Just $ T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." , _percentage = Nothing } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + NoProgress -> LSP.WorkDoneProgressReport + { _kind = LSP.AString @"report" + , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } @@ -973,15 +993,17 @@ swapTVar indexCompleted 0 whenJust (lspEnv se) $ \env -> LSP.runLspT env $ when (coerce $ ideTesting se) $ - LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath srcPath whenJust mdone $ \done -> modifyVar_ indexProgressToken $ \tok -> do whenJust (lspEnv se) $ \env -> LSP.runLspT env $ whenJust tok $ \tok -> - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.End $ LSP.WorkDoneProgressEndParams - { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $ + toJSON $ + LSP.WorkDoneProgressEnd + { _kind = LSP.AString @"end" + , _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" } -- We are done with the current indexing cycle, so destroy the token pure Nothing @@ -1013,7 +1035,7 @@ handleGenerationErrors dflags source action = action >> return [] `catches` [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DsError (noSpan "") + , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] @@ -1021,7 +1043,7 @@ handleGenerationErrors' dflags source action = fmap ([],) action `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] @@ -1031,25 +1053,19 @@ -- Add the current ModSummary to the graph, along with the -- HomeModInfo's of all direct dependencies (by induction hypothesis all -- transitive dependencies will be contained in envs) +mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv +mergeEnvs env mg ms extraMods envs = do #if MIN_VERSION_ghc(9,3,0) -mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv -mergeEnvs env (ms, deps) extraMods envs = do let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) ifr = InstalledFound (ms_location ms) im curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr - -- Very important to force this as otherwise the hsc_mod_graph field is not - -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get - -- this new one, which in turn leads to the EPS referencing the HPT. - module_graph_nodes = - nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs) - newFinderCache <- concatFC curFinderCache (map hsc_FC envs) - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ + return $! loadModulesHome extraMods $ let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in (hscUpdateHUG (const newHug) env){ hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph module_graph_nodes - }) + hsc_mod_graph = mg + } where mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b @@ -1059,39 +1075,32 @@ combineModules a b | HsSrcFile <- mi_hsc_src (hm_iface a) = a | otherwise = b + + -- Prefer non-boot files over non-boot files + -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816 + -- if a boot file shadows over a non-boot file + combineModuleLocations a@(InstalledFound ml m) b | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a + combineModuleLocations _ b = b + concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache concatFC cur xs = do fcModules <- mapM (readIORef . fcModuleCache) xs fcFiles <- mapM (readIORef . fcFileCache) xs - fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv const) cur fcModules + fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules fcFiles' <- newIORef $! Map.unions fcFiles pure $ FinderCache fcModules' fcFiles' #else -mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv -mergeEnvs env ms extraMods envs = do prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) ifr = InstalledFound (ms_location ms) im - -- Very important to force this as otherwise the hsc_mod_graph field is not - -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get - -- this new one, which in turn leads to the EPS referencing the HPT. - module_graph_nodes = -#if MIN_VERSION_ghc(9,2,0) - -- We don't do any instantiation for backpack at this point of time, so it is OK to use - -- 'extendModSummaryNoDeps'. - -- This may have to change in the future. - map extendModSummaryNoDeps $ -#endif - nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs) - newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ + return $! loadModulesHome extraMods $ env{ hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph module_graph_nodes - }) + hsc_mod_graph = mg + } where mergeUDFM = plusUDFM_C combineModules @@ -1248,7 +1257,7 @@ let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of PFailedWithErrorMessages msgs -> - throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags + throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags POk pst rdr_module -> do let (warns, errs) = renderMessages $ getPsMessages pst dflags @@ -1262,9 +1271,9 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs + throwE $ diagFromErrMsgs sourceParser dflags errs - let warnings = diagFromErrMsgs "parser" dflags warns + let warnings = diagFromErrMsgs sourceParser dflags warns return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -1281,7 +1290,7 @@ dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of - PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags + PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags POk pst rdr_module -> let hpm_annotations = mkApiAnns pst @@ -1291,9 +1300,9 @@ let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module unless (null errs) $ - throwE $ diagFromStrings "parser" DsError errs + throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs - let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns + let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages let (warns, errs) = renderMessages msgs @@ -1307,7 +1316,7 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs + throwE $ diagFromErrMsgs sourceParser dflags errs -- To get the list of extra source files, we take the list @@ -1342,7 +1351,7 @@ srcs2 <- liftIO $ filterM doesFileExist srcs1 let pm = ParsedModule ms parsed' srcs2 hpm_annotations - warnings = diagFromErrMsgs "parser" dflags warns + warnings = diagFromErrMsgs sourceParser dflags warns pure (warnings ++ preproc_warnings, pm) loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile @@ -1465,11 +1474,28 @@ | source_version <= dest_version -> SourceUnmodified | otherwise -> SourceModified + old_iface <- case mb_old_iface of + Just iface -> pure (Just iface) + Nothing -> do + let ncu = hsc_NC sessionWithMsDynFlags + read_dflags = hsc_dflags sessionWithMsDynFlags +#if MIN_VERSION_ghc(9,3,0) + read_result <- liftIO $ readIface read_dflags ncu mod iface_file +#else + read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags + $ readIface mod iface_file +#endif + case read_result of + Util.Failed{} -> return Nothing + -- important to call `shareUsages` here before checkOldIface + -- consults `mi_usages` + Util.Succeeded iface -> return $ Just (shareUsages iface) + -- If mb_old_iface is nothing then checkOldIface will load it for us -- given that the source is unmodified (recomp_iface_reqd, mb_checked_iface) #if MIN_VERSION_ghc(9,3,0) - <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case + <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case UpToDateItem x -> pure (UpToDate, Just x) OutOfDateItem reason x -> pure (NeedsRecompile reason, x) #else @@ -1483,15 +1509,14 @@ regenerate linkableNeeded case (mb_checked_iface, recomp_iface_reqd) of - (Just iface', UpToDate) -> do - let iface = shareUsages iface' + (Just iface, UpToDate) -> do details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface -- parse the runtime dependencies from the annotations let runtime_deps | not (mi_used_th iface) = emptyModuleEnv | otherwise = parseRuntimeDeps (md_anns details) - -- Perform the fine grained recompilation check for TH - maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps + -- Peform the fine grained recompilation check for TH + maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps case maybe_recomp of Just msg -> do_regenerate msg Nothing @@ -1528,13 +1553,21 @@ -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH] -checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) -checkLinkableDependencies get_linkable_hashes graph runtime_deps = do - let hs_files = mapM go (moduleEnvToList runtime_deps) - go (mod, hash) = do - ms <- mgLookupModule graph mod - let hs = fromJust $ ml_hs_file $ ms_location ms - pure (toNormalizedFilePath' hs, hash) +checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) +checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do +#if MIN_VERSION_ghc(9,3,0) + moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env) +#else + moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env) +#endif + let go (mod, hash) = do + ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod) + case ifr of + InstalledFound loc _ -> do + hs <- ml_hs_file loc + pure (toNormalizedFilePath' hs,hash) + _ -> Nothing + hs_files = mapM go (moduleEnvToList runtime_deps) case hs_files of Nothing -> error "invalid module graph" Just fs -> do diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -27,14 +27,14 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Recorder, WithPriority, - cmapWithPrio) import Development.IDE.Types.Options import qualified Focus +import Ide.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Config (Config) +import Language.LSP.Protocol.Types import Language.LSP.Server hiding (getVirtualFile) -import Language.LSP.Types import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -117,16 +117,16 @@ -- See Note [Invalidating file existence results] -- flush previous values let (fileModifChanges, fileExistChanges) = - partition ((== FcChanged) . snd) changes + partition ((== FileChangeType_Changed) . snd) changes mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges return (io1 <> io2) fromChange :: FileChangeType -> Maybe Bool -fromChange FcCreated = Just True -fromChange FcDeleted = Just False -fromChange FcChanged = Nothing +fromChange FileChangeType_Created = Just True +fromChange FileChangeType_Deleted = Just False +fromChange FileChangeType_Changed = Nothing ------------------------------------------------------------------------------------- diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -54,29 +54,29 @@ #else #endif -import qualified Development.IDE.Types.Logger as L +import qualified Ide.Logger as L +import Data.Aeson (ToJSON (toJSON)) import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Priority (Info), Recorder, WithPriority, cmapWithPrio, logWith, viaShow, (<+>)) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), - FileChangeType (FcChanged), +import Language.LSP.Protocol.Message (toUntypedRegistration) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileSystemWatcher (..), - WatchKind (..), _watchers) -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import System.FilePath import System.IO.Unsafe @@ -162,14 +162,14 @@ -- | Reset the GetModificationTime state of watched files -- Assumes the list does not include any FOIs -resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () +resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO () resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions -- FOI filtering is done by the caller (LSP Notification handler) forM_ changes $ \(nfp, c) -> do case c of - FcChanged + LSP.FileChangeType_Changed -- already checked elsewhere | not $ HM.member nfp fois -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp @@ -268,26 +268,27 @@ if watchSupported then do let - regParams = LSP.RegistrationParams (List [LSP.SomeRegistration registration]) + regParams = LSP.RegistrationParams [toUntypedRegistration registration] -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). -- We could also use something like a random UUID, as some other servers do, but this works for -- our purposes. - registration = LSP.Registration "globalFileWatches" - LSP.SWorkspaceDidChangeWatchedFiles - regOptions + registration = LSP.TRegistration { _id ="globalFileWatches" + , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles + , _registerOptions = Just $ regOptions} regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + DidChangeWatchedFilesRegistrationOptions { _watchers = watchers } -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind - watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True} + -- WatchKind_Custom 7 is for create, change, and delete + watchKind = LSP.WatchKind_Custom 7 -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, -- followed by a file with an extension 'hs'. watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } -- We use multiple watchers instead of one using '{}' because lsp-test doesn't -- support that: https://github.com/bubba/lsp-test/issues/77 - watchers = [ watcher (Text.pack glob) | glob <- globs ] + watchers = [ watcher (LSP.GlobPattern (LSP.InL (LSP.Pattern (Text.pack glob)))) | glob <- globs ] - void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response + void $ LSP.sendRequest LSP.SMethod_ClientRegisterCapability regParams (const $ pure ()) -- TODO handle response return True else return False @@ -311,7 +312,7 @@ atomicModifyIORef' filePathMap $ \km -> let new_key = HashMap.lookup k km in case new_key of - Just v -> (km, v) + Just v -> (km, v) Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath #-} - + diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -13,6 +13,7 @@ where import Control.Concurrent.Strict +import Control.Lens ((^.)) import Control.Monad import Control.Monad.IO.Class import Data.Aeson.Types (Value) @@ -22,7 +23,7 @@ import Development.IDE.Core.Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Language.LSP.Types +import Language.LSP.Protocol.Types import System.FilePath (isRelative) -- | Lsp client relevant configuration details @@ -49,15 +50,15 @@ IdeConfiguration {..} where workspaceFolders = - foldMap (singleton . toNormalizedUri) _rootUri + foldMap (singleton . toNormalizedUri) (nullToMaybe _rootUri) <> (foldMap . foldMap) (singleton . parseWorkspaceFolder) - _workspaceFolders + (nullToMaybe =<< _workspaceFolders) clientSettings = hashed _initializationOptions parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri parseWorkspaceFolder WorkspaceFolder{_uri} = - toNormalizedUri (Uri _uri) + toNormalizedUri _uri modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -24,6 +24,7 @@ import Control.Monad.IO.Class import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Proxy import qualified Data.Text as T import Development.IDE.Graph @@ -39,14 +40,15 @@ import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Development.IDE.Types.Options (IdeTesting (..)) +import GHC.TypeLits (KnownSymbol) +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio, logDebug) -import Development.IDE.Types.Options (IdeTesting (..)) +import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP data Log = LogShake Shake.Log deriving Show @@ -130,12 +132,13 @@ kick = do files <- HashMap.keys <$> getFilesOfInterestUntracked ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras - let signal msg = when testing $ liftIO $ + let signal :: KnownSymbol s => Proxy s -> Action () + signal msg = when testing $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (LSP.SCustomMethod msg) $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ toJSON $ map fromNormalizedFilePath files - signal "kick/start" + signal (Proxy @"kick/start") liftIO $ progressUpdate progress KickStarted -- Update the exports map @@ -155,4 +158,4 @@ void garbageCollectDirtyKeys liftIO $ writeVar var False - signal "kick/done" + signal (Proxy @"kick/done") diff --git a/src/Development/IDE/Core/PluginUtils.hs b/src/Development/IDE/Core/PluginUtils.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/PluginUtils.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE GADTs #-} +module Development.IDE.Core.PluginUtils where + +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Reader (runReaderT) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Functor.Identity +import qualified Data.Text as T +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Shake (IdeAction, IdeRule, + IdeState (shakeExtras), + mkDelayedAction, + shakeEnqueue) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Types.Location (NormalizedFilePath) +import qualified Development.IDE.Types.Location as Location +import qualified Ide.Logger as Logger +import Ide.Plugin.Error +import qualified Language.LSP.Protocol.Types as LSP + +-- ---------------------------------------------------------------------------- +-- Action wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `runAction`, takes a ExceptT Action +runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a +runActionE herald ide act = + mapExceptT liftIO . ExceptT $ + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act) + +-- |MaybeT version of `runAction`, takes a MaybeT Action +runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a +runActionMT herald ide act = + mapMaybeT liftIO . MaybeT $ + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) + +-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure +useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v +useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k + +-- |MaybeT version of `use` +useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v +useMT k = MaybeT . Shake.use k + +-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure +usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v) +usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k + +-- |MaybeT version of `uses` +usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v) +usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs + +-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon +-- failure +useWithStaleE :: IdeRule k v + => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) +useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key + +-- |MaybeT version of `useWithStale` +useWithStaleMT :: IdeRule k v + => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) +useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) + +-- ---------------------------------------------------------------------------- +-- IdeAction wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction +runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a +runIdeActionE _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s + +-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction +runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a +runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ runMaybeT i) s + +-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon +-- failure +useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping) +useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k + +-- |MaybeT version of `useWithStaleFast` +useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) +useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k + +-- ---------------------------------------------------------------------------- +-- Location wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon +-- failure +uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath +uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <> show uri)) $ uriToFilePathMT uri + +-- |MaybeT version of `uriToFilePath` +uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath +uriToFilePathMT = MaybeT . pure . Location.uriToFilePath' + +-- ---------------------------------------------------------------------------- +-- PositionMapping wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState +-- upon failure +toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position +toCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentPosition"). toCurrentPositionMT mapping + +-- |MaybeT version of `toCurrentPosition` +toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position +toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping + +-- |ExceptT version of `fromCurrentPosition` that throws a +-- PluginInvalidUserState upon failure +fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position +fromCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentPosition") . fromCurrentPositionMT mapping + +-- |MaybeT version of `fromCurrentPosition` +fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position +fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping + +-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState +-- upon failure +toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range +toCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentRange") . toCurrentRangeMT mapping + +-- |MaybeT version of `toCurrentRange` +toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range +toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping + +-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState +-- upon failure +fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range +fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentRange") . fromCurrentRangeMT mapping + +-- |MaybeT version of `fromCurrentRange` +fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range +fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping @@ -28,11 +29,13 @@ import Data.Algorithm.Diff import Data.Bifunctor import Data.List -import qualified Data.Text as T -import qualified Data.Vector.Unboxed as V -import Language.LSP.Types (Position (Position), Range (Range), - TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), - UInt) +import Data.Row +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as V +import Language.LSP.Protocol.Types (Position (Position), + Range (Range), + TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), + UInt, type (|?) (InL)) -- | Either an exact position, or the range of text that was substituted data PositionResult a @@ -120,10 +123,12 @@ addDelta :: PositionDelta -> PositionMapping -> PositionMapping addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) +-- TODO: We currently ignore the right hand side (if there is only text), as +-- that was what was done with lsp* 1.6 packages applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta -applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta - { toDelta = toCurrent r t <=< toDelta - , fromDelta = fromDelta <=< fromCurrent r t +applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta + { toDelta = toCurrent (x .! #range) (x .! #text) <=< toDelta + , fromDelta = fromDelta <=< fromCurrent (x .! #range) (x .! #text) } applyChange posMapping _ = posMapping diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -8,9 +8,9 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util -import qualified Development.IDE.GHC.Util as Util import Development.IDE.GHC.CPP import Development.IDE.GHC.Orphans () +import qualified Development.IDE.GHC.Util as Util import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) @@ -133,7 +133,9 @@ _source = Just "CPP", _message = T.unlines $ cdMessage d, _relatedInformation = Nothing, - _tags = Nothing + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing } diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs --- a/src/Development/IDE/Core/ProgressReporting.hs +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -21,6 +21,7 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) +import Data.Aeson (ToJSON (toJSON)) import Data.Foldable (for_) import Data.Functor (($>)) import qualified Data.Text as T @@ -30,9 +31,10 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP import qualified StmContainers.Map as STM import System.Time.Extra import UnliftIO.Exception (bracket_) @@ -125,30 +127,32 @@ -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) liftIO $ sleep before - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique b <- liftIO newBarrier - void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b liftIO $ async $ do ready <- waitBarrier b LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) where - start id = LSP.sendNotification LSP.SProgress $ + start id = LSP.sendNotification SMethod_Progress $ LSP.ProgressParams { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" + , _value = toJSON $ WorkDoneProgressBegin + { _kind = AString @"begin" + , _title = "Processing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } } - stop id = LSP.sendNotification LSP.SProgress + stop id = LSP.sendNotification SMethod_Progress LSP.ProgressParams { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing + , _value = toJSON $ WorkDoneProgressEnd + { _kind = AString @"end" + , _message = Nothing } } loop _ _ | optProgressStyle == NoProgress = @@ -164,17 +168,19 @@ nextPct :: UInt nextPct = floor $ 100 * nextFrac when (nextPct /= prevPct) $ - LSP.sendNotification LSP.SProgress $ + LSP.sendNotification SMethod_Progress $ LSP.ProgressParams { _token = id - , _value = LSP.Report $ case optProgressStyle of - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + , _value = case optProgressStyle of + Explicit -> toJSON $ WorkDoneProgressReport + { _kind = AString @"report" + , _cancellable = Nothing , _message = Just $ T.pack $ show done <> "/" <> show todo , _percentage = Nothing } - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + Percentage -> toJSON $ WorkDoneProgressReport + { _kind = AString @"report" + , _cancellable = Nothing , _message = Nothing , _percentage = Just nextPct } diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -42,7 +42,7 @@ import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics import GHC.Serialized (Serialized) -import Language.LSP.Types (Int32, +import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) data LinkableType = ObjectLinkable | BCOLinkable @@ -69,11 +69,6 @@ -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule --- | The dependency information produced by following the imports recursively. --- This rule will succeed even if there is an error, e.g., a module could not be located, --- a module could not be parsed or an import cycle. -type instance RuleResult GetDependencyInformation = DependencyInformation - type instance RuleResult GetModuleGraph = DependencyInformation data GetKnownTargets = GetKnownTargets @@ -262,8 +257,8 @@ -- | Resolve the imports in a module to the file path of a module in the same package type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] --- | This rule is used to report import cycles. It depends on GetDependencyInformation. --- We cannot report the cycles directly from GetDependencyInformation since +-- | This rule is used to report import cycles. It depends on GetModuleGraph. +-- We cannot report the cycles directly from GetModuleGraph since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () @@ -400,11 +395,6 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable NeedsCompilation instance NFData NeedsCompilation - -data GetDependencyInformation = GetDependencyInformation - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetDependencyInformation -instance NFData GetDependencyInformation data GetModuleGraph = GetModuleGraph deriving (Eq, Show, Typeable, Generic) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -23,7 +23,6 @@ defineEarlyCutOffNoFile, mainRule, RulesConfig(..), - getDependencies, getParsedModule, getParsedModuleWithComments, getClientConfigAction, @@ -34,7 +33,6 @@ getParsedModuleRule, getParsedModuleWithCommentsRule, getLocatedImportsRule, - getDependencyInformationRule, reportImportCyclesRule, typeCheckRule, getDocMapRule, @@ -68,6 +66,7 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Safe +import Control.Exception (evaluate) import Control.Monad.Extra import Control.Monad.Reader import Control.Monad.State @@ -90,8 +89,10 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap 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 @@ -135,7 +136,8 @@ import qualified HieDb import Ide.Plugin.Config import qualified Language.LSP.Server as LSP -import Language.LSP.Types (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo)) +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) @@ -151,13 +153,14 @@ import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) +import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Control.Monad.IO.Unlift +import qualified Data.IntMap as IM #if MIN_VERSION_ghc(9,3,0) import GHC.Unit.Module.Graph import GHC.Unit.Env @@ -165,6 +168,8 @@ #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo #endif +import GHC (mgModSummaries) +import GHC.Fingerprint data Log = LogShake Shake.Log @@ -210,12 +215,6 @@ ------------------------------------------------------------ -- Exposed API ------------------------------------------------------------ --- | Get all transitive file dependencies of a given module. --- Does not include the file itself. -getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath]) -getDependencies file = - fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file - getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do (_, msource) <- getFileContents nfp @@ -314,7 +313,7 @@ -- 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 DsWarning, _message = fixMessage $ _message c}) + [ (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 @@ -420,17 +419,17 @@ execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act = execStateT act - ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty + ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty , IntMap.empty ) -- | Given a target file path, construct the raw dependency results by following -- imports recursively. -rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation +rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do (rdi, ss) <- execRawDepM (goPlural fs) let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss - return (rdi { rawBootMap = bm }) + return (rdi, bm) where goPlural ff = do mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff @@ -449,9 +448,9 @@ fId <- getFreshFid al -- Record this module and its location whenJust msum $ \ms -> - modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId) - (ShowableModuleName (moduleName $ ms_mod ms)) - (rawModuleNameMap rd)}) + modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId) + (ShowableModule $ ms_mod ms) + (rawModuleMap rd)}) -- Adding an edge to the bootmap so we can make sure to -- insert boot nodes before the real files. addBootMap al fId @@ -523,38 +522,37 @@ dropBootSuffix :: FilePath -> FilePath dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules () -getDependencyInformationRule recorder = - define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do - rawDepInfo <- rawDependencyInformation [file] - pure ([], Just $ processDependencyInformation rawDepInfo) - reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = - define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do - DependencyInformation{..} <- use_ GetDependencyInformation file - let fileId = pathToId depPathIdMap file - case IntMap.lookup (getFilePathId fileId) depErrorNodes of - Nothing -> pure [] - Just errs -> do - let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) - -- Convert cycles of files into cycles of module names - forM cycles $ \(imp, files) -> do - modNames <- forM files $ \fileId -> do - let file = idToPath depPathIdMap fileId - getModuleName file - pure $ toDiag imp $ sort modNames + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do + DependencyInformation{..} <- useNoFile_ GetModuleGraph + case pathToId depPathIdMap file of + -- The header of the file does not parse, so it can't be part of any import cycles. + Nothing -> pure [] + Just fileId -> + case IntMap.lookup (getFilePathId fileId) depErrorNodes of + Nothing -> pure [] + Just errs -> do + let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) + -- Convert cycles of files into cycles of module names + forM cycles $ \(imp, files) -> do + modNames <- forM files $ \fileId -> do + let file = idToPath depPathIdMap fileId + getModuleName file + pure $ toDiag imp $ sort modNames where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) cycleErrorInFile _ _ = Nothing toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic { _range = rng - , _severity = Just DsError + , _severity = Just DiagnosticSeverity_Error , _source = Just "Import cycle detection" , _message = "Cyclic module dependency between " <> showCycle mods , _code = Nothing , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) @@ -591,7 +589,7 @@ diagsWrite <- case isFoi of IsFOI Modified{firstOpen = False} -> do when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f pure [] _ | Just asts <- masts -> do @@ -677,11 +675,38 @@ pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () -getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do +getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets - rawDepInfo <- rawDependencyInformation (HashSet.toList fs) - pure $ processDependencyInformation rawDepInfo + dependencyInfoForFiles (HashSet.toList fs) +dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) +dependencyInfoForFiles fs = do + (rawDepInfo, bm) <- rawDependencyInformation fs + let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo + msrs <- uses GetModSummaryWithoutTimestamps all_fs + let mss = map (fmap msrModSummary) msrs +#if MIN_VERSION_ghc(9,3,0) + let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids + nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss + mns = catMaybes $ zipWith go mss deps + go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms + where this_dep_ids = mapMaybe snd xs + this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids + go (Just ms) _ = Just $ ModuleNode [] ms + go _ _ = Nothing + mg = mkModuleGraph mns +#else + let mg = mkModuleGraph $ +#if MIN_VERSION_ghc(9,2,0) + -- We don't do any instantiation for backpack at this point of time, so it is OK to use + -- 'extendModSummaryNoDeps'. + -- This may have to change in the future. + map extendModSummaryNoDeps $ +#endif + (catMaybes mss) +#endif + pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg) + -- This is factored out so it can be directly called from the GetModIface -- rule. Directly calling this rule means that on the initial load we can -- garbage collect all the intermediate typechecked modules rather than @@ -750,11 +775,11 @@ ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file newtype GhcSessionDepsConfig = GhcSessionDepsConfig - { checkForImportCycles :: Bool + { fullModuleGraph :: Bool } instance Default GhcSessionDepsConfig where def = GhcSessionDepsConfig - { checkForImportCycles = True + { fullModuleGraph = True } -- | Note [GhcSessionDeps] @@ -773,7 +798,7 @@ case mbdeps of Nothing -> return Nothing Just deps -> do - when checkForImportCycles $ void $ uses_ ReportImportCycles deps + when fullModuleGraph $ void $ use_ ReportImportCycles file ms <- msrModSummary <$> if fullModSummary then use_ GetModSummary file else use_ GetModSummaryWithoutTimestamps file @@ -781,21 +806,40 @@ depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces + mg <- do + if fullModuleGraph + then depModuleGraph <$> useNoFile_ GetModuleGraph + else do + let mgs = map hsc_mod_graph depSessions #if MIN_VERSION_ghc(9,3,0) - -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph - -- also points to all the direct descendants of the current module. To get the keys for the descendants - -- we must get their `ModSummary`s - !final_deps <- do - dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps - -- Don't want to retain references to the entire ModSummary when just the key will do - return $!! map (NodeKey_Module . msKey) dep_mss - let moduleNode = (ms, final_deps) + -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph + -- also points to all the direct descendants of the current module. To get the keys for the descendants + -- we must get their `ModSummary`s + !final_deps <- do + dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps + return $!! map (NodeKey_Module . msKey) dep_mss + let module_graph_nodes = + nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) #else - let moduleNode = ms + let module_graph_nodes = +#if MIN_VERSION_ghc(9,2,0) + -- We don't do any instantiation for backpack at this point of time, so it is OK to use + -- 'extendModSummaryNoDeps'. + -- This may have to change in the future. + map extendModSummaryNoDeps $ #endif - session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions + nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs) +#endif + liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes + return $ mkModuleGraph module_graph_nodes + session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions - Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' []) + -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new + -- ExportsMap when it is called. We only need to create the ExportsMap once per + -- session, while `ghcSessionDepsDefinition` will be called for each file we need + -- to compile. `updateHscEnvEq` will refresh the HscEnv (session') and also + -- generate a new Unique. + Just <$> liftIO (updateHscEnvEq env session') -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. @@ -855,7 +899,7 @@ -> do -- All good, the db has indexed the file when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f -- Not in db, must re-index _ -> do @@ -1192,8 +1236,16 @@ instance IsIdeGlobal CompiledLinkables data RulesConfig = RulesConfig - { -- | Disable import cycle checking for improved performance in large codebases - checkForImportCycles :: Bool + { -- | Share the computation for the entire module graph + -- We usually compute the full module graph for the project + -- and share it for all files. + -- However, in large projects it might not be desirable to wait + -- for computing the entire module graph before starting to + -- typecheck a particular file. + -- 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 -- | Disable TH for improved performance in large codebases , enableTemplateHaskell :: Bool -- | Warning to show when TH is not supported by the current HLS binary @@ -1206,8 +1258,8 @@ displayTHWarning :: LspT c IO () displayTHWarning | not isWindows && not hostIsDynamic = do - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo thWarningMessage + LSP.sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Info thWarningMessage | otherwise = return () thWarningMessage :: T.Text @@ -1227,11 +1279,10 @@ getParsedModuleRule recorder getParsedModuleWithCommentsRule recorder getLocatedImportsRule recorder - getDependencyInformationRule recorder reportImportCyclesRule recorder typeCheckRule recorder getDocMapRule recorder - loadGhcSession recorder def{checkForImportCycles} + loadGhcSession recorder def{fullModuleGraph} getModIfaceFromDiskRule recorder getModIfaceFromDiskAndIndexRule recorder getModIfaceRule recorder diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -23,16 +23,16 @@ import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, +import Development.IDE.Types.Options (IdeOptions (..)) +import Ide.Logger as Logger (Logger, Pretty (pretty), Priority (Debug), Recorder, WithPriority, cmapWithPrio) -import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -77,7 +77,7 @@ garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, Log(..), - VFSModified(..), getClientConfigAction + VFSModified(..), getClientConfigAction, ) where import Control.Concurrent.Async @@ -152,8 +152,6 @@ import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding (Priority) -import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Options import Development.IDE.Types.Shake @@ -161,16 +159,18 @@ import GHC.Fingerprint import GHC.Stack (HasCallStack) import HieDb.Types +import Ide.Logger hiding (Priority) +import qualified Ide.Logger as Logger import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (IdePlugins (IdePlugins), PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Capabilities import Language.LSP.VFS hiding (start) import qualified "list-t" ListT import OpenTelemetry.Eventlog @@ -303,7 +303,7 @@ type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) +type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32)) getShakeExtras :: Action ShakeExtras getShakeExtras = do @@ -344,7 +344,7 @@ -- This is called when we don't already have a result, or computing the rule failed. -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will -- be queued if the rule hasn't run before. -addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () +addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) @@ -639,7 +639,6 @@ actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv @@ -900,7 +899,7 @@ logDebug logger $ T.pack $ label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (SCustomMethod "ghcide/GC") + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) return garbage @@ -962,13 +961,23 @@ => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) useWithStale key file = runIdentity <$> usesWithStale key (Identity file) --- | Request a Rule result, it not available return the last computed result which may be stale. --- Errors out if none available. +-- |Request a Rule result, it not available return the last computed result +-- which may be stale. +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) --- | Plural version of 'useWithStale_' +-- |Plural version of 'useWithStale_' +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do res <- usesWithStale key files @@ -1042,12 +1051,24 @@ useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath +-- Requests a rule if available. +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `useE` instead. use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v use_ key file = runIdentity <$> uses_ key (Identity file) useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath +-- |Plural version of `use_` +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do res <- uses key files @@ -1128,7 +1149,7 @@ defineEarlyCutoff' :: forall k v. IdeRule k v - => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics + => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k @@ -1220,7 +1241,7 @@ updateFileDiagnostics :: MonadIO m => Recorder (WithPriority Log) -> NormalizedFilePath - -> TextDocumentVersion + -> Maybe Int32 -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results @@ -1254,15 +1275,15 @@ Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) - LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) + LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) ( newDiags) return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} | coerce ideTesting = c {_relatedInformation = - Just $ List [ + Just $ [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp) @@ -1297,7 +1318,7 @@ (forall a. String -> String -> a -> a) -> STMDiagnosticStore -> NormalizedUri -> - TextDocumentVersion -> + Maybe Int32 -> DiagnosticsBySource -> STM [LSP.Diagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource = @@ -1314,7 +1335,7 @@ setStageDiagnostics :: (forall a. String -> String -> a -> a) -> NormalizedUri - -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited + -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited -> T.Text -> [LSP.Diagnostic] -> STMDiagnosticStore @@ -1329,8 +1350,8 @@ getAllDiagnostics = fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = +updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = STM.focus (Focus.alter f) uri positionMapping where uri = toNormalizedUri _uri @@ -1341,8 +1362,5 @@ -- used which is evident in long running sessions. EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) zeroMapping - (EM.insert actual_version (shared_change, zeroMapping) mappingForUri) + (EM.insert _version (shared_change, zeroMapping) mappingForUri) shared_change = mkDelta changes - actual_version = case _version of - Nothing -> error "Nothing version from server" -- This is a violation of the spec - Just v -> v diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore #-} + module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction @@ -29,9 +30,9 @@ import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger)) +import Ide.Logger (Logger (Logger)) import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, +import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, beginSpan, endSpan, setTag, diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -39,6 +39,7 @@ lookupType, needWiredInHomeIface, loadWiredInHomeIface, + readIface, loadSysInterface, importDecl, #if MIN_VERSION_ghc(8,8,0) diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -50,50 +50,54 @@ filterInplaceUnits, FinderCache, showSDocForUser', + findImportedModule, ) where import Control.Monad -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map #if MIN_VERSION_ghc(9,3,0) import GHC.Unit.Home.ModInfo #endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Data.ShortText as ST +import qualified GHC.Data.ShortText as ST #if !MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (hsc_unit_dbs) +import GHC.Driver.Env (hsc_unit_dbs) #endif import GHC.Driver.Ppr import GHC.Unit.Env import GHC.Unit.External -import GHC.Unit.Finder +import GHC.Unit.Finder hiding + (findImportedModule) #else import GHC.Driver.Types #endif import GHC.Data.FastString -import qualified GHC.Driver.Session as DynFlags +import qualified GHC.Driver.Session as DynFlags import GHC.Types.Unique.Set -import qualified GHC.Unit.Info as UnitInfo -import GHC.Unit.State (LookupResult, UnitInfo, - UnitState (unitInfoMap)) -import qualified GHC.Unit.State as State -import GHC.Unit.Types hiding (moduleUnit, toUnitId) -import qualified GHC.Unit.Types as Unit +import qualified GHC.Unit.Info as UnitInfo +import GHC.Unit.State (LookupResult, UnitInfo, + UnitState (unitInfoMap)) +import qualified GHC.Unit.State as State +import GHC.Unit.Types hiding (moduleUnit, + toUnitId) +import qualified GHC.Unit.Types as Unit import GHC.Utils.Outputable #else import qualified DynFlags import FastString -import GhcPlugins (SDoc, showSDocForUser) +import GhcPlugins (SDoc, showSDocForUser) import HscTypes -import Module hiding (moduleUnitId) +import Module hiding (moduleUnitId) import qualified Module -import Packages (InstalledPackageInfo (haddockInterfaces, packageName), - LookupResult, PackageConfig, - PackageConfigMap, - PackageState, - getPackageConfigMap, - lookupPackage') +import Packages (InstalledPackageInfo (haddockInterfaces, packageName), + LookupResult, + PackageConfig, + PackageConfigMap, + PackageState, + getPackageConfigMap, + lookupPackage') import qualified Packages #endif @@ -101,12 +105,23 @@ import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Outputable #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) -import Data.Map (Map) +import Data.Map (Map) #endif import Data.Either import Data.Version import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) +#endif +#if MIN_VERSION_ghc(9,1,0) +import qualified GHC.Unit.Finder as GHC +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Finder as GHC +#else +import qualified Finder as GHC +#endif + #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId #if MIN_VERSION_ghc(9,2,0) @@ -407,3 +422,14 @@ #else showSDocForUser' env = showSDocForUser (hsc_dflags env) #endif + +findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module) +findImportedModule env mn = do +#if MIN_VERSION_ghc(9,3,0) + res <- GHC.findImportedModule env mn NoPkgQual +#else + res <- GHC.findImportedModule env mn Nothing +#endif + case res of + Found _ mod -> pure . pure $ mod + _ -> pure Nothing diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -44,7 +44,7 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import GHC -import Language.LSP.Types (isSubrangeOf) +import Language.LSP.Protocol.Types (isSubrangeOf) diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic @@ -57,6 +57,8 @@ , _code = Nothing , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } -- | Produce a GHC-style error from a source span and a message. @@ -132,13 +134,13 @@ toDSeverity SevOutput = Nothing toDSeverity SevInteractive = Nothing toDSeverity SevDump = Nothing -toDSeverity SevInfo = Just DsInfo -toDSeverity SevFatal = Just DsError +toDSeverity SevInfo = Just DiagnosticSeverity_Information +toDSeverity SevFatal = Just DiagnosticSeverity_Error #else toDSeverity SevIgnore = Nothing #endif -toDSeverity SevWarning = Just DsWarning -toDSeverity SevError = Just DsError +toDSeverity SevWarning = Just DiagnosticSeverity_Warning +toDSeverity SevError = Just DiagnosticSeverity_Error -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given @@ -186,7 +188,7 @@ diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] -diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "") (showGHCE dflags exc) +diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -40,6 +40,7 @@ import Data.Text (unpack) #if MIN_VERSION_ghc(9,0,0) import GHC.ByteCode.Types +import GHC (ModuleGraph) #else import ByteCodeTypes #endif @@ -215,6 +216,9 @@ instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) instance Show HomeModInfo where show = show . mi_module . hm_iface + +instance Show ModuleGraph where show _ = "ModuleGraph {..}" +instance NFData ModuleGraph where rnf = rwhnf instance NFData HomeModInfo where rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -12,7 +12,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics -import Language.LSP.Types (type (|?) (..)) +import Language.LSP.Protocol.Types (type (|?) (..)) -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -10,8 +10,9 @@ , TransitiveDependencies(..) , FilePathId(..) , NamedModuleDep(..) - , ShowableModuleName(..) - , PathIdMap + , ShowableModule(..) + , ShowableModuleEnv(..) + , PathIdMap (..) , emptyPathIdMap , getPathId , lookupPathToId @@ -23,7 +24,7 @@ , transitiveDeps , transitiveReverseDependencies , immediateReverseDependencies - + , lookupModuleFile , BootIdMap , insertBootId ) where @@ -53,6 +54,7 @@ import Development.IDE.Types.Location import GHC +import Development.IDE.GHC.Compat -- | The imports for a given module. newtype ModuleImports = ModuleImports @@ -103,8 +105,8 @@ insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } -pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId -pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path +pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId +pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap @@ -128,15 +130,14 @@ -- corresponding hs file. It is used when topologically sorting as we -- need to add edges between .hs-boot and .hs so that the .hs files -- appear later in the sort. - , rawBootMap :: !BootIdMap - , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName) + , rawModuleMap :: !(FilePathIdMap ShowableModule) } deriving Show data DependencyInformation = DependencyInformation { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly. - , depModuleNames :: !(FilePathIdMap ShowableModuleName) + , depModules :: !(FilePathIdMap ShowableModule) , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package. @@ -146,14 +147,25 @@ -- ^ Map from FilePath to FilePathId , depBootMap :: !BootIdMap -- ^ Map from hs-boot file to the corresponding hs file + , depModuleFiles :: !(ShowableModuleEnv FilePathId) + -- ^ Map from Module to the corresponding non-boot hs file + , depModuleGraph :: !ModuleGraph } deriving (Show, Generic) -newtype ShowableModuleName = - ShowableModuleName {showableModuleName :: ModuleName} +newtype ShowableModule = + ShowableModule {showableModule :: Module} deriving NFData -instance Show ShowableModuleName where show = moduleNameString . showableModuleName +newtype ShowableModuleEnv a = + ShowableModuleEnv {showableModuleEnv :: ModuleEnv a} +instance Show a => Show (ShowableModuleEnv a) where + show (ShowableModuleEnv x) = show (moduleEnvToList x) +instance NFData a => NFData (ShowableModuleEnv a) where + rnf = rwhnf + +instance Show ShowableModule where show = moduleNameString . moduleName . showableModule + reachableModules :: DependencyInformation -> [NormalizedFilePath] reachableModules DependencyInformation{..} = map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps @@ -215,15 +227,17 @@ SuccessNode _ <> ErrorNode errs = ErrorNode errs SuccessNode a <> SuccessNode _ = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> DependencyInformation -processDependencyInformation RawDependencyInformation{..} = +processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation +processDependencyInformation RawDependencyInformation{..} rawBootMap mg = DependencyInformation { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps , depReverseModuleDeps = reverseModuleDeps - , depModuleNames = rawModuleNameMap + , depModules = rawModuleMap , depPathIdMap = rawPathIdMap , depBootMap = rawBootMap + , depModuleFiles = ShowableModuleEnv reverseModuleMap + , depModuleGraph = mg } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph @@ -240,6 +254,7 @@ foldr (\(p, cs) res -> let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges + reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: @@ -328,7 +343,7 @@ -- | returns all transitive dependencies in topological order. transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do - let !fileId = pathToId depPathIdMap file + !fileId <- pathToId depPathIdMap file reachableVs <- -- Delete the starting node IntSet.delete (getFilePathId fileId) . @@ -350,6 +365,10 @@ boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]] vs = topSort g + +lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath +lookupModuleFile mod DependencyInformation{..} + = idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod newtype TransitiveDependencies = TransitiveDependencies { transitiveModuleDeps :: [NormalizedFilePath] diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -29,6 +29,7 @@ import System.FilePath #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual +import GHC.Unit.State #endif data Import @@ -135,25 +136,45 @@ #else Nothing -> do #endif + + mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName + case mbFile of + Nothing -> lookupInPackageDB env + Just (uid, file) -> toModLocation uid file + where + dflags = hsc_dflags env + import_paths = mapMaybe (mkImportDirs env) comp_info + other_imports = +#if MIN_VERSION_ghc(9,4,0) + -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units + -- this one depends on + -- This way if you have multiple units with the same module names, we won't get confused + -- For example if unit a imports module M from unit B, when there is also a module M in unit C, + -- and unit a only depends on unit b, without this logic there is the potential to get confused + -- about which module unit a imports. + -- Without multi-component support it is hard to recontruct the dependency environment so + -- unit a will have both unit b and unit c in scope. + map (\uid -> (uid, importPaths (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + ue = hsc_unit_env env + units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends units +#else + import_paths' +#endif + -- first try to find the module as a file. If we can't find it try to find it in the package -- database. -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - let import_paths' = + import_paths' = #if MIN_VERSION_ghc(9,3,0) import_paths #else map snd import_paths #endif - mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName - case mbFile of - Nothing -> lookupInPackageDB env - Just (uid, file) -> toModLocation uid file - where - dflags = hsc_dflags env - import_paths = mapMaybe (mkImportDirs env) comp_info toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) #if MIN_VERSION_ghc(9,0,0) @@ -180,7 +201,7 @@ mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where dfs = hsc_dflags env - mkError' = diagFromString "not found" DsError (Compat.getLoc modName) + mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer. diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -15,45 +15,47 @@ , wsSymbols ) where +import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) import Development.IDE.Core.Actions import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Ide.Logger +import Ide.Plugin.Error +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) -hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) -documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) -hover = request "Hover" getAtPoint Nothing foundHover -documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List +gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) +hover :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) +hover = request "Hover" getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ - case uriToFilePath' uri of - Just path -> do - let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ +references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences +references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do + nfp <- getNormalizedFilePathE uri + liftIO $ logDebug (ideLogger ide) $ "References request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) - Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing + " in file: " <> T.pack (show nfp) + InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) -wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do +wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol +wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query - runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover +foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = - Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange + InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange -- | Respond to and log a hover or go-to-definition request request @@ -63,12 +65,12 @@ -> (a -> b) -> IdeState -> TextDocumentPositionParams - -> LSP.LspM c (Either ResponseError b) + -> ExceptT PluginError (LSP.LspM c) b request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path Nothing -> pure Nothing - pure $ Right $ maybe notFound found mbResult + pure $ maybe notFound found mbResult logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -1,12 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StarIsType #-} - -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer @@ -26,8 +26,9 @@ import Development.IDE.LSP.Server import Development.IDE.Session (runWithDb) import Ide.Types (traceWithSpan) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types import System.IO import UnliftIO.Async import UnliftIO.Concurrent @@ -40,14 +41,13 @@ import Development.IDE.Core.Shake hiding (Log, Priority) import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger -import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) +import Ide.Logger +import qualified Ide.Logger as Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) import System.IO.Unsafe (unsafeInterleaveIO) - data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -92,7 +92,7 @@ -> config -> (config -> Value -> Either T.Text config) -> (MVar () - -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), + -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () @@ -107,7 +107,7 @@ { LSP.onConfigurationChange = onConfigurationChange , LSP.defaultConfig = defaultConfig , LSP.doInitialize = doInitialize - , LSP.staticHandlers = staticHandlers + , LSP.staticHandlers = (const staticHandlers) , LSP.interpretHandler = interpretHandler , LSP.options = modifyOptions options } @@ -133,7 +133,7 @@ -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () - -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), + -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do @@ -195,8 +195,8 @@ -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage - -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) +handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root @@ -233,11 +233,11 @@ case cancelOrRes of Left () -> do log Debug $ LogCancelledRequest _id - k $ ResponseError RequestCancelled "" Nothing + k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError InternalError (T.pack $ show e) Nothing + k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do putMVar dbMVar (WithHieDbShield withHieDb,hieChan) @@ -263,27 +263,30 @@ waitAnyCancel =<< traverse async [ io , readMVar mvar ] cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) -cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> - liftIO $ cancelRequest (SomeLspId _id) +cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> + liftIO $ cancelRequest (SomeLspId (toLspId _id)) + where toLspId :: (Int32 |? T.Text) -> LspId a + toLspId (InL x) = IdInt x + toLspId (InR y) = IdString y shutdownHandler :: IO () -> LSP.Handlers (ServerM c) -shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do +shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logDebug (ideLogger ide) "Received shutdown message" -- stop the reactor to free up the hiedb connection liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide - resp $ Right Empty + resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit +exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit modifyOptions :: LSP.Options -> LSP.Options -modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS +modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } where - tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} - origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x + tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing} + origTDS = fromMaybe tdsDefault $ LSP.optTextDocumentSync x tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -13,8 +13,9 @@ , ghcideNotificationsPluginPriority ) where -import Language.LSP.Types -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra @@ -36,8 +37,8 @@ import Development.IDE.Core.Shake hiding (Log, Priority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) +import Ide.Logger import Ide.Types import Numeric.Natural @@ -56,9 +57,9 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do - atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) [] whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open @@ -66,7 +67,7 @@ setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri - , mkPluginNotificationHandler LSP.STextDocumentDidChange $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do @@ -74,14 +75,14 @@ setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri - , mkPluginNotificationHandler LSP.STextDocumentDidSave $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do addFileOfInterest ide file OnDisk setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri - , mkPluginNotificationHandler LSP.STextDocumentDidClose $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do deleteFileOfInterest ide file @@ -90,8 +91,8 @@ setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg logDebug (ideLogger ide) msg - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ - \ide vfs _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ + \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and -- what we do with them -- filter out files of interest, since we already know all about those @@ -110,7 +111,7 @@ resetFileStore ide fileEvents' setSomethingModified (VFSModified vfs) ide [] msg - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do let add = S.union substract = flip S.difference @@ -118,14 +119,14 @@ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $ + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do let msg = Text.pack $ show cfg logDebug (ideLogger ide) $ "Configuration changed: " <> msg modifyClientSettings ide (const $ Just cfg) setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" - , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do + , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -22,26 +22,25 @@ realSrcSpanToRange) import Development.IDE.Types.Location import Development.IDE.GHC.Util (printOutputable) -import Language.LSP.Server (LspM) -import Language.LSP.Types (DocumentSymbol (..), +import Ide.Types +import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), - List (..), ResponseError, - SymbolInformation, - SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), + SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InL), uriToFilePath) + type (|?) (InL, InR), uriToFilePath) +import Language.LSP.Protocol.Message #if MIN_VERSION_ghc(9,2,0) import Data.List.NonEmpty (nonEmpty) #endif moduleOutline - :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) -moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol +moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) - pure $ Right $ case mb_decls of - Nothing -> InL (List []) + pure $ case mb_decls of + Nothing -> InL [] Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls @@ -49,7 +48,7 @@ (L (locA -> (RealSrcSpan l _)) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable m - , _kind = SkFile + , _kind = SymbolKind_File , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 } _ -> Nothing @@ -59,14 +58,14 @@ allSymbols = case moduleSymbol of Nothing -> importSymbols <> declSymbols Just x -> - [ x { _children = Just (List (importSymbols <> declSymbols)) + [ x { _children = Just (importSymbols <> declSymbols) } ] in - InL (List allSymbols) + InR (InL allSymbols) - Nothing -> pure $ Right $ InL (List []) + Nothing -> pure $ InL [] documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) @@ -77,7 +76,7 @@ t -> " " <> t ) , _detail = Just $ printOutputable fdInfo - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) @@ -86,13 +85,13 @@ "" -> "" t -> " " <> t ) - , _kind = SkInterface + , _kind = SymbolKind_Interface , _detail = Just "class" , _children = - Just $ List + Just $ [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkMethod + , _kind = SymbolKind_Method , _selectionRange = realSrcSpanToRange l' } | L (locA -> (RealSrcSpan l _)) (ClassOpSig _ False names _) <- tcdSigs @@ -102,15 +101,15 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable name - , _kind = SkStruct + , _kind = SymbolKind_Struct , _children = - Just $ List + Just $ [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkConstructor + , _kind = SymbolKind_Constructor , _selectionRange = realSrcSpanToRange l' #if MIN_VERSION_ghc(9,2,0) - , _children = List . toList <$> nonEmpty childs + , _children = toList <$> nonEmpty childs } | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con @@ -133,7 +132,7 @@ #else { _name = printOutputable (unLoc (rdrNameFieldOcc n)) #endif - , _kind = SkField + , _kind = SymbolKind_Field } cvtFld _ = Nothing #else @@ -145,10 +144,10 @@ } where -- | Extract the record fields of a constructor - conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List + conArgRecordFields (RecCon (L _ lcdfs)) = Just [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkField + , _kind = SymbolKind_Field } | L _ cdf <- lcdfs , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf @@ -157,12 +156,12 @@ #endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkTypeParameter + , _kind = SymbolKind_TypeParameter , _selectionRange = realSrcSpanToRange l' } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty - , _kind = SkInterface + , _kind = SymbolKind_Interface } #if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) @@ -177,7 +176,7 @@ printOutputable (unLoc feqn_tycon) <> " " <> T.unwords (map printOutputable feqn_pats) #endif - , _kind = SkInterface + , _kind = SymbolKind_Interface } #if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) @@ -192,23 +191,23 @@ printOutputable (unLoc feqn_tycon) <> " " <> T.unwords (map printOutputable feqn_pats) #endif - , _kind = SkInterface + , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs) name - , _kind = SkInterface + , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable name - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable pat_lhs - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just @@ -217,7 +216,7 @@ ForeignImport{} -> name ForeignExport{} -> name XForeignDecl{} -> "?" - , _kind = SkObject + , _kind = SymbolKind_Object , _detail = case x of ForeignImport{} -> Just "import" ForeignExport{} -> Just "export" @@ -240,15 +239,15 @@ in Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) { _name = "imports" - , _kind = SkModule - , _children = Just (List importSymbols) + , _kind = SymbolKind_Module + , _children = Just importSymbols } documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> printOutputable ideclName - , _kind = SkModule + , _kind = SymbolKind_Module , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } } documentSymbolForImport _ = Nothing @@ -258,7 +257,9 @@ _detail = Nothing _deprecated = Nothing _name = "" - _kind = SkUnknown 0 + -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1, + -- therefore, I am replacing it with SymbolKind_File, which is the type for 1 + _kind = SymbolKind_File _range = realSrcSpanToRange l _selectionRange = realSrcSpanToRange l _children = Nothing diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.LSP.Server ( ReactorMessage(..) , ReactorChan @@ -14,15 +10,14 @@ , requestHandler , notificationHandler ) where - -import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader import Development.IDE.Core.Shake import Development.IDE.Core.Tracing -import Ide.Types (HasTracing, traceWithSpan) -import Language.LSP.Server (Handlers, LspM) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types +import Ide.Types (HasTracing, traceWithSpan) +import Language.LSP.Protocol.Message +import Language.LSP.Server (Handlers, LspM) +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import UnliftIO.Chan @@ -35,25 +30,26 @@ deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler - :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => + :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) => SMethod m - -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) + -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c) -requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do +requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' = flip (runReaderT . unServerM) st . resp + let resp' :: Either ResponseError (MessageResult m) -> LspM c () + resp' = flip (runReaderT . unServerM) st . resp trace x = otTracedHandler "Request" (show _method) $ \sp -> do traceWithSpan sp _params x writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler - :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => + :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c) -notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do +notificationHandler m k = LSP.notificationHandler m $ \TNotificationMessage{_params,_method}-> do (chan,ide) <- ask env <- LSP.getLspEnv -- Take a snapshot of the VFS state on every notification diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -77,7 +77,7 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, +import Ide.Logger (Logger, Pretty (pretty), Priority (Info, Warning), Recorder, @@ -235,7 +235,7 @@ { optCheckProject = pure $ checkProject config , optCheckParents = pure $ checkParents config } - , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} + , argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."} , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc , argsDebouncer = newAsyncDebouncer @@ -293,7 +293,7 @@ let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin - options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } + options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands } argsOnConfigChange = getConfigFromNotification argsHlsPlugins rules = argsRules >> pluginRules plugins diff --git a/src/Development/IDE/Main/HeapStats.hs b/src/Development/IDE/Main/HeapStats.hs --- a/src/Development/IDE/Main/HeapStats.hs +++ b/src/Development/IDE/Main/HeapStats.hs @@ -6,11 +6,11 @@ import Control.Concurrent.Async import Control.Monad import Data.Word -import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), - Recorder, WithPriority, hsep, - logWith, (<+>)) import GHC.Stats -import Text.Printf (printf) +import Ide.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) +import Text.Printf (printf) data Log = LogHeapStatsPeriod !Int diff --git a/src/Development/IDE/Monitoring/EKG.hs b/src/Development/IDE/Monitoring/EKG.hs --- a/src/Development/IDE/Monitoring/EKG.hs +++ b/src/Development/IDE/Monitoring/EKG.hs @@ -1,14 +1,14 @@ {-# LANGUAGE CPP #-} module Development.IDE.Monitoring.EKG(monitoring) where -import Development.IDE.Types.Logger (Logger) import Development.IDE.Types.Monitoring (Monitoring (..)) +import Ide.Logger (Logger) #ifdef MONITORING_EKG import Control.Concurrent (killThread) import Control.Concurrent.Async (async, waitCatch) import Control.Monad (forM_) import Data.Text (pack) -import Development.IDE.Types.Logger (logInfo) +import Ide.Logger (logInfo) import qualified System.Metrics as Monitoring import qualified System.Remote.Monitoring.Wai as Monitoring diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -11,15 +11,18 @@ import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Lens ((&), (.~)) import Control.Monad.IO.Class -import Control.Lens ((&), (.~)) +import Control.Monad.Trans.Except (ExceptT (ExceptT), + withExceptT) +import Data.Aeson import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set -import Data.Aeson import Data.Maybe import qualified Data.Text as T -import Development.IDE.Core.PositionMapping import Development.IDE.Core.Compile +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log) @@ -27,24 +30,25 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Graph -import Development.IDE.Spans.Common -import Development.IDE.Spans.Documentation import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) +import Ide.Plugin.Error import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J -import qualified Language.LSP.VFS as VFS import Numeric.Natural import Text.Fuzzy.Parallel (Scored (..)) @@ -64,8 +68,8 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder - , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP - <> mkPluginHandler SCompletionItemResolve resolveCompletion + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP + <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } @@ -118,59 +122,50 @@ f x = x in f <$> iDecl -resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) -resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} - | Just resolveData <- _xdata - , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData - , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri - = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do - msess <- useWithStaleFast GhcSessionDeps file - case msess of - Nothing -> pure (Right comp) -- File doesn't compile, return original completion item - Just (sess,_) -> do - let nc = ideNc $ shakeExtras ide +resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve +resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = + do + file <- getNormalizedFilePathE uri + (sess,_) <- withExceptT (const PluginStaleResolve) + $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide) + $ useWithStaleFastE GhcSessionDeps file + let nc = ideNc $ shakeExtras ide #if MIN_VERSION_ghc(9,3,0) - name <- liftIO $ lookupNameCache nc mod occ + name <- liftIO $ lookupNameCache nc mod occ #else - name <- liftIO $ upNameCache nc (lookupNameCache mod occ) + name <- liftIO $ upNameCache nc (lookupNameCache mod occ) #endif - mdkm <- useWithStaleFast GetDocMap file - let (dm,km) = case mdkm of - Just (DKMap dm km, _) -> (dm,km) - Nothing -> (mempty, mempty) - doc <- case lookupNameEnv dm name of - Just doc -> pure $ spanDocToMarkdown doc - Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name - typ <- case lookupNameEnv km name of - _ | not needType -> pure Nothing - Just ty -> pure (safeTyThingType ty) - Nothing -> do - (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) - let det1 = case typ of - Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") - Nothing -> Nothing - doc1 = case _documentation of - Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) -> - CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc) - _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc - pure (Right $ comp & J.detail .~ (det1 <> _detail) - & J.documentation .~ Just doc1 - ) + mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file + let (dm,km) = case mdkm of + Just (DKMap dm km, _) -> (dm,km) + Nothing -> (mempty, mempty) + doc <- case lookupNameEnv dm name of + Just doc -> pure $ spanDocToMarkdown doc + Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name + typ <- case lookupNameEnv km name of + _ | not needType -> pure Nothing + Just ty -> pure (safeTyThingType ty) + Nothing -> do + (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) + let det1 = case typ of + Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") + Nothing -> Nothing + doc1 = case _documentation of + Just (InR (MarkupContent MarkupKind_Markdown old)) -> + InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) + _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc + pure (comp & L.detail .~ (det1 <> _detail) + & L.documentation .~ Just doc1) where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -resolveCompletion _ _ comp = pure (Right comp) -- | Generate code actions. -getCompletionsLSP - :: IdeState - -> PluginId - -> CompletionParams - -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) +getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position - ,_context=completionContext} = do + ,_context=completionContext} = ExceptT $ do contents <- LSP.getVirtualFile $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do @@ -213,17 +208,16 @@ let pfix = getCompletionPrefix position cnts case (pfix, completionContext) of ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (InL $ List []) + -> return (InL []) (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide config <- liftIO $ runAction "" ide $ getCompletionsConfig plId allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri - pure $ InL (List $ orderedCompletions allCompletions) - _ -> return (InL $ List []) - _ -> return (InL $ List []) - _ -> return (InL $ List []) + pure $ InL (orderedCompletions allCompletions) + _ -> return (InL []) + _ -> return (InL []) getCompletionsConfig :: PluginId -> Action CompletionsConfig getCompletionsConfig pId = diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -14,15 +15,19 @@ ) where import Control.Applicative +import Control.Lens hiding (Context) import Data.Char (isAlphaNum, isUpper) +import Data.Default (def) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map +import Data.Row import Data.Maybe (catMaybes, fromMaybe, - isJust, listToMaybe, - mapMaybe, isNothing) + isJust, isNothing, + listToMaybe, + mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy @@ -41,7 +46,7 @@ import Development.IDE.GHC.Compat hiding (ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.CoreFile (occNamePrefixes) +import Development.IDE.GHC.CoreFile (occNamePrefixes) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -64,8 +69,8 @@ import Ide.Types (CommandId (..), IdePlugins (..), PluginId) -import Language.LSP.Types -import Language.LSP.Types.Capabilities +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (score), original) @@ -76,7 +81,7 @@ import Development.IDE.Spans.AtPoint (pointCommand) #if MIN_VERSION_ghc(9,5,0) -import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.Basic #endif -- Chunk size used for parallelizing fuzzy matching @@ -172,11 +177,11 @@ occNameToComKind :: OccName -> CompletionItemKind occNameToComKind oc | isVarOcc oc = case occNameString oc of - i:_ | isUpper i -> CiConstructor - _ -> CiFunction - | isTcOcc oc = CiStruct - | isDataOcc oc = CiConstructor - | otherwise = CiVariable + i:_ | isUpper i -> CompletionItemKind_Constructor + _ -> CompletionItemKind_Function + | isTcOcc oc = CompletionItemKind_Struct + | isDataOcc oc = CompletionItemKind_Constructor + | otherwise = CompletionItemKind_Variable showModName :: ModuleName -> T.Text @@ -215,13 +220,15 @@ _sortText = Nothing, _filterText = Nothing, _insertText = Just insertText, - _insertTextFormat = Just Snippet, + _insertTextFormat = Just InsertTextFormat_Snippet, _insertTextMode = Nothing, _textEdit = Nothing, _additionalTextEdits = Nothing, _commitCharacters = Nothing, _command = mbCommand, - _xdata = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails} + _data_ = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails, + _labelDetails = Nothing, + _textEditText = Nothing} removeSnippetsWhen (isJust isInfix) ci where kind = Just compKind @@ -230,8 +237,8 @@ Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n" ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n" DefinedIn mod -> "*Defined in '" <> mod <> "'*\n" - documentation = Just $ CompletionDocMarkup $ - MarkupContent MkMarkdown $ + documentation = Just $ InR $ + MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator docs' pprLineCol :: SrcLoc -> T.Text pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs @@ -253,8 +260,8 @@ typeText = Nothing label = stripPrefix $ printOutputable origName insertText = case isInfix of - Nothing -> label - Just LeftSide -> label <> "`" + Nothing -> label + Just LeftSide -> label <> "`" Just Surrounded -> label additionalTextEdits = @@ -278,30 +285,32 @@ mkModCompl :: T.Text -> CompletionItem mkModCompl label = - CompletionItem label (Just CiModule) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel label) + { _kind = Just CompletionItemKind_Module } mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label = - CompletionItem label (Just CiFunction) Nothing (Just moduleName) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel label) + { _kind = Just CompletionItemKind_Function + , _detail = Just moduleName } mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = - CompletionItem m (Just CiModule) Nothing (Just label) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel m) + { _kind = Just CompletionItemKind_Module + , _detail = Just label } where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = - CompletionItem label (Just CiKeyword) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel label) + { _kind = Just CompletionItemKind_Keyword } +defaultCompletionItemWithLabel :: T.Text -> CompletionItem +defaultCompletionItemWithLabel label = + CompletionItem label def def def def def def def def def + def def def def def def def def def fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc id@IdentInfo{..} q = CI @@ -439,20 +448,20 @@ compls = concat [ case decl of SigD _ (TypeSig _ ids typ) -> - [mkComp id CiFunction (Just $ showForSnippet typ) | id <- ids] + [mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | id <- ids] ValD _ FunBind{fun_id} -> - [ mkComp fun_id CiFunction Nothing + [ mkComp fun_id CompletionItemKind_Function Nothing | not (hasTypeSig fun_id) ] ValD _ PatBind{pat_lhs} -> - [mkComp id CiVariable Nothing + [mkComp id CompletionItemKind_Variable Nothing | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} -> - mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) : - [ mkComp id CiFunction (Just $ showForSnippet typ) + mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) : + [ mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs , id <- ids] ++ - [ mkComp fdLName CiStruct (Just $ showForSnippet fdLName) + [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName) | L _ (FamilyDecl{fdLName}) <- tcdATs] TyClD _ x -> let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) @@ -464,16 +473,16 @@ -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls ForD _ ForeignImport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] + [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)] ForD _ ForeignExport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] + [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)] _ -> [] | L (locA -> pos) decl <- hsmodDecls, let mkComp = mkLocalComp pos ] mkLocalComp pos n ctyp ty = - CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CiStruct, CiInterface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True + CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CompletionItemKind_Struct, CompletionItemKind_Interface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True where occ = rdrNameOcc $ unLoc n pn = showForSnippet n @@ -520,7 +529,7 @@ removeSnippetsWhen (not $ enableSnippets && supported) where supported = - Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + Just True == (_textDocument >>= _completion >>= view L.completionItem >>= (\x -> x .! #snippetSupport)) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} @@ -531,7 +540,7 @@ if condition then x - { _insertTextFormat = Just PlainText, + { _insertTextFormat = Just InsertTextFormat_PlainText, _insertText = Nothing } else x @@ -613,7 +622,7 @@ -- to get the record's module, which isn't included in the type information used to get the fields. dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem) dotFieldSelectorToCompl recname label = (True, CI - { compKind = CiField + { compKind = CompletionItemKind_Field , insertText = label , provenance = DefinedIn recname , label = label @@ -790,7 +799,7 @@ mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r where r = CI { - compKind = CiSnippet + compKind = CompletionItemKind_Snippet , insertText = buildSnippet , provenance = importedFrom , typeText = Nothing diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types ) where @@ -22,12 +22,12 @@ import Development.IDE.Spans.Common import GHC.Generics (Generic) import Ide.Plugin.Properties -import Language.LSP.Types (CompletionItemKind (..), Uri) -import qualified Language.LSP.Types as J +import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) +import qualified Language.LSP.Protocol.Types as J #if MIN_VERSION_ghc(9,0,0) -import qualified GHC.Types.Name.Occurrence as Occ +import qualified GHC.Types.Name.Occurrence as Occ #else -import qualified OccName as Occ +import qualified OccName as Occ #endif -- | Produce completions info for a file @@ -178,7 +178,7 @@ parseNs (String "c") = pure dataName parseNs (String "t") = pure tcClsName parseNs (String "z") = pure tvName -parseNs _ = mempty +parseNs _ = mempty instance FromJSON NameDetails where parseJSON v@(Array _) @@ -204,9 +204,9 @@ -- We need the URI to be able to reconstruct the GHC environment -- in the file the completion was triggered in. data CompletionResolveData = CompletionResolveData - { itemFile :: Uri + { itemFile :: Uri , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item? - , itemName :: NameDetails + , itemName :: NameDetails } deriving stock Generic deriving anyclass (FromJSON, ToJSON) diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -6,75 +6,92 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , toResponseError , Log(..) ) where -import Control.Exception (SomeException) -import Control.Lens ((^.)) +import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad -import qualified Data.Aeson as J -import Data.Bifunctor (first) -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Aeson as A +import Data.Bifunctor (first) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Either -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map import Data.Some import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE.Core.Shake hiding (Log) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing -import Development.IDE.Graph (Rules) +import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin -import qualified Development.IDE.Plugin as P -import Development.IDE.Types.Logger +import qualified Development.IDE.Plugin as P +import Ide.Logger import Ide.Plugin.Config -import Ide.PluginUtils (getClientConfig) -import Ide.Types as HLS -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as LSP +import Ide.Plugin.Error +import Ide.PluginUtils (getClientConfig) +import Ide.Types as HLS +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP import Language.LSP.VFS -import Prettyprinter.Render.String (renderString) -import Text.Regex.TDFA.Text () -import UnliftIO (MonadUnliftIO) -import UnliftIO.Async (forConcurrently) -import UnliftIO.Exception (catchAny) +import Prettyprinter.Render.String (renderString) +import Text.Regex.TDFA.Text () +import UnliftIO (MonadUnliftIO, liftIO) +import UnliftIO.Async (forConcurrently) +import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- data Log - = LogPluginError PluginId ResponseError + = LogPluginError PluginId PluginError + | LogResponseError PluginId ResponseError | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier + | ExceptionInPlugin PluginId (Some SMethod) SomeException + instance Pretty Log where pretty = \case - LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err + LogPluginError (PluginId pId) err -> + pretty pId <> ":" <+> pretty err + LogResponseError (PluginId pId) err -> + pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" - + ExceptionInPlugin plId (Some method) exception -> + "Exception in plugin " <> viaShow plId <> " while processing " + <> viaShow method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty -- various error message specific builders prettyResponseError :: ResponseError -> Doc a prettyResponseError err = errorCode <> ":" <+> errorBody where - errorCode = pretty $ show $ err ^. LSP.code - errorBody = pretty $ err ^. LSP.message - -pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text -pluginNotEnabled method availPlugins = - "No plugin enabled for " <> T.pack (show method) <> ", available: " - <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) + errorCode = pretty $ show $ err ^. L.code + errorBody = pretty $ err ^. L.message +noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c) +noPluginEnabled recorder m fs' = do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing + msg = pluginNotEnabled m fs' + return $ Left err + where pluginNotEnabled :: SMethod m -> [PluginId] -> Text + pluginNotEnabled method availPlugins = + "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " + <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins) + pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -86,17 +103,21 @@ failedToParseArgs :: CommandId -- ^ command that failed to parse -> PluginId -- ^ Plugin that created the command -> String -- ^ The JSON Error message - -> J.Value -- ^ The Argument Values + -> A.Value -- ^ The Argument Values -> Text failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> ", arg = " <> T.pack (show arg) +exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text +exceptionInPlugin plId method exception = + "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception) + -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder p errCode msg = do let err = ResponseError errCode msg Nothing - logWith recorder Warning $ LogPluginError p err + logWith recorder Warning $ LogResponseError p err pure $ Left err -- | Map a set of plugins to the underlying ghcide engine. @@ -146,7 +167,7 @@ executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd +executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCommand execCmd where pluginMap = Map.fromListWith (++) ecs @@ -157,29 +178,29 @@ _ -> Nothing -- The parameters to the HLS command are always the first element - + execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) execCmd ide (ExecuteCommandParams _ cmdId args) = do - let cmdParams :: J.Value + let cmdParams :: A.Value cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null + Just ((x:_)) -> x + _ -> A.Null case parseCmdId cmdId of -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do + case A.fromJSON cmdParams of + A.Success (FallbackCodeActionParams mEdit mCmd) -> do -- Send off the workspace request if it has one forM_ mEdit $ \edit -> - LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) case mCmd of -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) + Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right J.Null + Nothing -> return $ Right $ InR Null - J.Error _str -> return $ Right J.Null + A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams @@ -187,16 +208,26 @@ -- Couldn't parse the command identifier _ -> do logWith recorder Warning LogInvalidCommandIdentifier - return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + return $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing + runPluginCommand :: IdeState -> PluginId -> CommandId -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) runPluginCommand ide p com arg = case Map.lookup p pluginMap of - Nothing -> logAndReturnError recorder p InvalidRequest (pluginDoesntExist p) + Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> logAndReturnError recorder p InvalidRequest (commandDoesntExist com p xs) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> logAndReturnError recorder p InvalidParams (failedToParseArgs com p err arg) - J.Success a -> f ide a + Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs) + Just (PluginCommand _ _ f) -> case A.fromJSON arg of + A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) + A.Success a -> do + res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins] + (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e)) + case res of + (Left (PluginRequestRefused _)) -> + liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs) + (Left pluginErr) -> do + liftIO $ logErrors recorder [(p, pluginErr)] + pure $ Left $ toResponseError (p, pluginErr) + (Right result) -> pure $ Right result -- --------------------------------------------------------------------- @@ -218,25 +249,25 @@ let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> do - logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError InvalidRequest msg Nothing - msg = pluginNotEnabled m fs' - return $ Left err + Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') Just fs -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs - es <- runConcurrently msg (show m) handlers ide params - + let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs + es <- runConcurrently exceptionInPlugin m handlers ide params + caps <- LSP.getClientCapabilities let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es - unless (null errs) $ forM_ errs $ \(pId, err) -> - logWith recorder Warning $ LogPluginError pId err + liftIO $ unless (null errs) $ logErrors recorder errs case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors $ map snd errs + Nothing -> do + let noRefused (_, PluginRequestRefused _) = False + noRefused (_, _) = True + filteredErrs = filter noRefused errs + case nonEmpty filteredErrs of + Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') + Just xs -> pure $ Left $ combineErrors xs Just xs -> do - caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs + -- --------------------------------------------------------------------- extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config @@ -260,35 +291,51 @@ Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs + mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params + `catchAny` -- See Note [Exception handling in plugins] + (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs + -- --------------------------------------------------------------------- runConcurrently :: MonadUnliftIO m - => (SomeException -> PluginId -> T.Text) - -> String -- ^ label - -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + => (PluginId -> SMethod method -> SomeException -> T.Text) + -> SMethod method -- ^ Method (used for errors and tracing) + -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d))) -- ^ Enabled plugin actions that we are allowed to run -> a -> b - -> m (NonEmpty(NonEmpty (Either ResponseError d))) -runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do - f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + -> m (NonEmpty(NonEmpty (Either PluginError d))) +runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do + f a b -- See Note [Exception handling in plugins] + `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: [ResponseError] -> ResponseError -combineErrors [x] = x -combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing +combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError +combineErrors (x NE.:| []) = toResponseError x +combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs +toResponseError :: (PluginId, PluginError) -> ResponseError +toResponseError (PluginId plId, err) = + ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing + where tPretty = T.pack . show . pretty + +logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () +logErrors recorder errs = do + forM_ errs $ \(pId, err) -> + logIndividualErrors pId err + where logIndividualErrors plId err = + logWith recorder (toPriority err) $ LogPluginError plId err + + -- | Combine the 'PluginHandler' for all plugins -newtype IdeHandler (m :: J.Method FromClient Request) - = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] +newtype IdeHandler (m :: Method ClientToServer Request) + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))] -- | Combine the 'PluginHandler' for all plugins -newtype IdeNotificationHandler (m :: J.Method FromClient Notification) +newtype IdeNotificationHandler (m :: Method ClientToServer Notification) = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] --- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()` +-- type NotificationHandler (m :: Method ClientToServer Notification) = MessageParams m -> IO ()` -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) @@ -307,3 +354,16 @@ go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b) instance Monoid IdeNotificationHandlers where mempty = IdeNotificationHandlers mempty + +{- Note [Exception handling in plugins] +Plugins run in LspM, and so have access to IO. This means they are likely to +throw exceptions, even if only by accident or through calling libraries that +throw exceptions. Ultimately, we're running a bunch of less-trusted IO code, +so we should be robust to it throwing. + +We don't want these to bring down HLS. So we catch and log exceptions wherever +we run a handler defined in a plugin. + +The flip side of this is that it's okay for plugins to throw exceptions as a +way of signalling failure! +-} diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -15,8 +15,8 @@ import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types -import Language.LSP.Server (LspM) -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Text.Regex.TDFA.Text () data Log @@ -43,29 +43,23 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentHover hover' - <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider - <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} -> + { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover' + <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline + <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> gotoDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> gotoTypeDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params) - <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params), + <> mkPluginHandler SMethod_TextDocumentReferences references + <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols, pluginConfigDescriptor = defaultConfigDescriptor } -- --------------------------------------------------------------------- -hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) +hover' :: PluginMethodHandler IdeState 'Method_TextDocumentHover hover' ideState _ HoverParams{..} = do liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState TextDocumentPositionParams{..} - --- --------------------------------------------------------------------- -symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) -symbolsProvider ide _ params = moduleOutline ide params - --- --------------------------------------------------------------------- diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -14,14 +14,18 @@ import Control.Concurrent (threadDelay) import Control.Monad +import Control.Monad.Except (ExceptT (..), throwError) import Control.Monad.IO.Class import Control.Monad.STM -import Data.Aeson -import Data.Aeson.Types +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Aeson (FromJSON (parseJSON), + ToJSON (toJSON), Value) +import qualified Data.Aeson.Types as A import Data.Bifunctor import Data.CaseInsensitive (CI, original) import qualified Data.HashMap.Strict as HM import Data.Maybe (isJust) +import Data.Proxy import Data.String import Data.Text (Text, pack) import Development.IDE.Core.OfInterest (getFilesOfInterest) @@ -43,9 +47,11 @@ import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) import Ide.Plugin.Config (CheckParents) +import Ide.Plugin.Error import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types import qualified "list-t" ListT import qualified StmContainers.Map as STM import System.Time.Extra @@ -73,26 +79,26 @@ plugin :: PluginDescriptor IdeState plugin = (defaultPluginDescriptor "test") { - pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ -> + pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \st _ -> testRequestHandler' st } where testRequestHandler' ide req - | Just customReq <- parseMaybe parseJSON req - = testRequestHandler ide customReq + | Just customReq <- A.parseMaybe parseJSON req + = ExceptT $ testRequestHandler ide customReq | otherwise - = return $ Left - $ ResponseError InvalidRequest "Cannot parse request" Nothing + = throwError + $ PluginInvalidParams "Cannot parse request" testRequestHandler :: IdeState -> TestRequest - -> LSP.LspM c (Either ResponseError Value) + -> LSP.LspM c (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs liftIO $ sleep secs - return (Right Null) + return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp @@ -105,12 +111,12 @@ atomically $ do n <- countQueue $ actionQueue $ shakeExtras s when (n>0) retry - return $ Right Null + return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success - return $ bimap mkResponseError toJSON res + return $ bimap PluginInvalidParams toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do keys <- getDatabaseKeys resultBuilt $ shakeDb s return $ Right $ toJSON $ map show keys @@ -144,9 +150,6 @@ step <- shakeGetBuildStep db return [ k | (k, res) <- keys, field res == Step step] -mkResponseError :: Text -> ResponseError -mkResponseError msg = ResponseError InvalidRequest msg Nothing - parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp @@ -170,6 +173,6 @@ blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _params = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null + lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null liftIO $ threadDelay maxBound - return (Right Null) + pure $ InR Null diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -18,19 +18,20 @@ import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson.Types (Value (..), toJSON) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Aeson.Types (Value, toJSON) import qualified Data.Aeson.Types as A -import qualified Data.HashMap.Strict as Map import Data.List (find) +import qualified Data.Map as Map import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, define, srcSpanToRange, - usePropertyAction, - useWithStale) + usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction) @@ -46,12 +47,13 @@ import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) import Development.IDE.Types.Location (Position (Position, _character, _line), Range (Range, _end, _start)) -import Development.IDE.Types.Logger (Pretty (pretty), +import GHC.Generics (Generic) +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) -import GHC.Generics (Generic) +import Ide.Plugin.Error import Ide.Plugin.Properties -import Ide.PluginUtils +import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), @@ -63,17 +65,18 @@ defaultPluginDescriptor, mkCustomConfig, mkPluginHandler) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeLens), + SMethod (..)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), - List (..), - Method (TextDocumentCodeLens), - SMethod (..), + Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit)) + WorkspaceEdit (WorkspaceEdit), + type (|?) (..)) +import qualified Language.LSP.Server as LSP import Text.Regex.TDFA ((=~), (=~~)) data Log = LogShake Shake.Log deriving Show @@ -88,7 +91,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -102,34 +105,28 @@ , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always -codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do +codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties - nfp <- getNormalizedFilePath uri - env <- hscEnv . fst - <$> (handleMaybeM "Unable to get GhcSession" - $ liftIO - $ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp) - ) - tmr <- fst <$> ( - handleMaybeM "Unable to TypeCheck" - $ liftIO - $ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp) - ) - bindings <- fst <$> ( - handleMaybeM "Unable to GetBindings" - $ liftIO - $ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp) - ) + nfp <- getNormalizedFilePathE uri + env <- hscEnv . fst <$> + runActionE "codeLens.GhcSession" ideState + (useWithStaleE GhcSession nfp) + + (tmr, _) <- runActionE "codeLens.TypeCheck" ideState + (useWithStaleE TypeCheck nfp) + + (bindings, _) <- runActionE "codeLens.GetBindings" ideState + (useWithStaleE GetBindings nfp) + (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- - handleMaybeM "Unable to GetGlobalBindingTypeSigs" - $ liftIO - $ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp) + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + (useWithStaleE GetGlobalBindingTypeSigs nfp) diag <- liftIO $ atomically $ getDiagnostics ideState hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ tedit) Nothing Nothing generateLensForGlobal mp sig@GlobalBindingTypeSig{gbRendered} = do range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig) tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp) @@ -144,7 +141,7 @@ ] -- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning, -- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh. - pure $ List $ case mode of + pure $ InL $ case mode of Always -> mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' <> generateLensFromDiags @@ -160,8 +157,8 @@ commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do - _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + pure $ InR Null -------------------------------------------------------------------------------- diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -1,9 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly. @@ -27,7 +28,8 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location -import Language.LSP.Types +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..)) -- compiler and infrastructure import Development.IDE.Core.PositionMapping @@ -178,8 +180,8 @@ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) highlightType s = if any (isJust . getScopeFromContext) s - then HkWrite - else HkRead + then DocumentHighlightKind_Write + else DocumentHighlightKind_Read gotoTypeDefinition :: MonadIO m @@ -212,21 +214,33 @@ -> DocAndKindMap -> HscEnv -> Position - -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo + -> IO (Maybe (Maybe Range, [T.Text])) +atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos = + listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data - hoverInfo ast = (Just range, prettyNames ++ pTypes) + hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text]) + hoverInfo ast = do + prettyNames <- mapM prettyName filteredNames + pure (Just range, prettyNames ++ pTypes) where + pTypes :: [T.Text] pTypes | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes | otherwise = map wrapHaskell prettyTypes + range :: Range range = realSrcSpanToRange $ nodeSpan ast + wrapHaskell :: T.Text -> T.Text wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + + info :: NodeInfo hietype info = nodeInfoH kind ast + + names :: [(Identifier, IdentifierDetails hietype)] names = M.assocs $ nodeIdentifiers info + -- Check for evidence bindings isInternal :: (Identifier, IdentifierDetails a) -> Bool isInternal (Right _, dets) = @@ -236,11 +250,12 @@ False #endif isInternal (Left _, _) = False + + filteredNames :: [(Identifier, IdentifierDetails hietype)] filteredNames = filter (not . isInternal) names - types = nodeType info - prettyNames :: [T.Text] - prettyNames = map prettyName filteredNames - prettyName (Right n, dets) = T.unlines $ + + prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text + prettyName (Right n, dets) = pure $ T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : maybeToList (pretty (definedAt n) (prettyPackageName n)) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n @@ -250,21 +265,48 @@ pretty (Just define) Nothing = Just $ define <> "\n" pretty Nothing (Just pkgName) = Just $ pkgName <> "\n" pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n" - prettyName (Left m,_) = printOutputable m + prettyName (Left m,_) = packageNameForImportStatement m + prettyPackageName :: Name -> Maybe T.Text prettyPackageName n = do m <- nameModule_maybe n + pkgTxt <- packageNameWithVersion m env + pure $ "*(" <> pkgTxt <> ")*" + + -- Return the module text itself and + -- the package(with version) this `ModuleName` belongs to. + packageNameForImportStatement :: ModuleName -> IO T.Text + packageNameForImportStatement mod = do + mpkg <- findImportedModule env mod :: IO (Maybe Module) + let moduleName = printOutputable mod + case mpkg >>= flip packageNameWithVersion env of + Nothing -> pure moduleName + Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion + + -- Return the package name and version of a module. + -- For example, given module `Data.List`, it should return something like `base-4.x`. + packageNameWithVersion :: Module -> HscEnv -> Maybe T.Text + packageNameWithVersion m env = do let pid = moduleUnit m conf <- lookupUnit env pid let pkgName = T.pack $ unitPackageNameString conf version = T.pack $ showVersion (unitPackageVersion conf) - pure $ "*(" <> pkgName <> "-" <> version <> ")*" + pure $ pkgName <> "-" <> version + -- Type info for the current node, it may contains several symbols + -- for one range, like wildcard + types :: [hietype] + types = nodeType info + + prettyTypes :: [T.Text] prettyTypes = map (("_ :: "<>) . prettyType) types + + prettyType :: hietype -> T.Text prettyType t = case kind of HieFresh -> printOutputable t HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + definedAt :: Name -> Maybe T.Text definedAt name = -- do not show "at " and similar messages -- see the code of 'pprNameDefnLoc' for more information @@ -391,13 +433,15 @@ defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) - = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing loc Nothing + = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing Nothing loc where kind - | isVarOcc defNameOcc = SkVariable - | isDataOcc defNameOcc = SkConstructor - | isTcOcc defNameOcc = SkStruct - | otherwise = SkUnknown 1 + | isVarOcc defNameOcc = SymbolKind_Variable + | isDataOcc defNameOcc = SymbolKind_Constructor + | isTcOcc defNameOcc = SymbolKind_Struct + -- This used to be (SkUnknown 1), buth there is no SymbolKind_Unknown. + -- Changing this to File, as that is enum representation of 1 + | otherwise = SymbolKind_File loc = Location file range file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile range = Range start end @@ -424,6 +468,7 @@ where sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1) sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + line :: UInt line = _line pos cha = _character pos diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -32,7 +32,7 @@ import System.Directory import System.FilePath -import Language.LSP.Types (filePathToUri, getUri) +import Language.LSP.Protocol.Types (filePathToUri, getUri) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.Unique.Map #endif diff --git a/src/Development/IDE/Spans/Pragmas.hs b/src/Development/IDE/Spans/Pragmas.hs --- a/src/Development/IDE/Spans/Pragmas.hs +++ b/src/Development/IDE/Spans/Pragmas.hs @@ -15,15 +15,16 @@ import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as Text -import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv) +import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Types as LSP import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT) +import Ide.Plugin.Error (PluginError) import Ide.Types (PluginId(..)) import qualified Data.Text as T -import Ide.PluginUtils (handleMaybeM) +import Development.IDE.Core.PluginUtils getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText = @@ -51,13 +52,11 @@ pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition -getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo -getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do - ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp +getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo +getFirstPragma (PluginId pId) state nfp = do + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents - Nothing -> pure Nothing + pure $ getNextPragmaInfo sessionDynFlags fileContents -- Pre-declaration comments parser ----------------------------------------------------- diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -11,12 +11,12 @@ where import Control.Concurrent.STM -import Data.Hashable (Hashable (..)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Unique (Unique) -import Development.IDE.Graph (Action) -import Development.IDE.Types.Logger +import Data.Hashable (Hashable (..)) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Unique (Unique) +import Development.IDE.Graph (Action) +import Ide.Logger import Numeric.Natural data DelayedAction a = DelayedAction diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -9,7 +9,6 @@ IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, - List(..), ideErrorText, ideErrorWithSource, showDiagnostics, @@ -17,20 +16,17 @@ IdeResultNoDiagnosticsEarlyCutoff) where import Control.DeepSeq -import Data.Maybe as Maybe -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color) -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal -import Data.Text.Prettyprint.Doc.Render.Text -import Language.LSP.Diagnostics -import Language.LSP.Types as LSP (Diagnostic (..), - DiagnosticSeverity (..), - DiagnosticSource, - List (..)) - -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) +import Data.Maybe as Maybe +import qualified Data.Text as T import Development.IDE.Types.Location +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Types as LSP (Diagnostic (..), + DiagnosticSeverity (..)) +import Prettyprinter +import Prettyprinter.Render.Terminal (Color (..), color) +import qualified Prettyprinter.Render.Terminal as Terminal +import Prettyprinter.Render.Text -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, @@ -49,10 +45,10 @@ type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) +ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) ideErrorWithSource - :: Maybe DiagnosticSource + :: Maybe T.Text -> Maybe DiagnosticSeverity -> a -> T.Text @@ -64,7 +60,9 @@ _source = source, _message = msg, _relatedInformation = Nothing, - _tags = Nothing + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing }) -- | Defines whether a particular diagnostic should be reported @@ -117,14 +115,14 @@ , slabel_ "Severity:" $ pretty $ show sev , slabel_ "Message: " $ case sev of - LSP.DsError -> annotate $ color Red - LSP.DsWarning -> annotate $ color Yellow - LSP.DsInfo -> annotate $ color Blue - LSP.DsHint -> annotate $ color Magenta + LSP.DiagnosticSeverity_Error -> annotate $ color Red + LSP.DiagnosticSeverity_Warning -> annotate $ color Yellow + LSP.DiagnosticSeverity_Information -> annotate $ color Blue + LSP.DiagnosticSeverity_Hint -> annotate $ color Magenta $ stringParagraphs _message ] where - sev = fromMaybe LSP.DsError _severity + sev = fromMaybe LSP.DiagnosticSeverity_Error _severity -- | Label a document. diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -4,6 +4,7 @@ hscEnvWithImportPaths, newHscEnvEqPreserveImportPaths, newHscEnvEqWithImportPaths, + updateHscEnvEq, envImportPaths, envPackageExports, envVisibleModuleNames, @@ -32,7 +33,8 @@ import System.FilePath -- | An 'HscEnv' with equality. Two values are considered equal --- if they are created with the same call to 'newHscEnvEq'. +-- if they are created with the same call to 'newHscEnvEq' or +-- 'updateHscEnvEq'. data HscEnvEq = HscEnvEq { envUnique :: !Unique , hscEnv :: !HscEnv @@ -50,6 +52,11 @@ -- So it's wrapped in IO here for error handling -- If Nothing, 'listVisibleModuleNames' panic } + +updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq +updateHscEnvEq oldHscEnvEq newHscEnv = do + let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv } + update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -39,9 +39,9 @@ import FastString import SrcLoc as GHC #endif -import Language.LSP.Types (Location (..), Position (..), +import Language.LSP.Protocol.Types (Location (..), Position (..), Range (..)) -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Types as LSP import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs deleted file mode 100644 --- a/src/Development/IDE/Types/Logger.hs +++ /dev/null @@ -1,335 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} --- | This is a compatibility module that abstracts over the --- concrete choice of logging framework so users can plug in whatever --- framework they want to. -module Development.IDE.Types.Logger - ( Priority(..) - , Logger(..) - , Recorder(..) - , logError, logWarning, logInfo, logDebug - , noLogging - , WithPriority(..) - , logWith - , cmap - , cmapIO - , cfilter - , withDefaultRecorder - , makeDefaultStderrRecorder - , makeDefaultHandleRecorder - , LoggingColumn(..) - , cmapWithPrio - , withBacklog - , lspClientMessageRecorder - , lspClientLogRecorder - , module PrettyPrinterModule - , renderStrict - , toCologActionWithPrio - ) where - -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Concurrent.STM (atomically, - flushTBQueue, - isFullTBQueue, - newTBQueueIO, newTVarIO, - readTVarIO, - writeTBQueue, writeTVar) -import Control.Exception (IOException) -import Control.Monad (unless, when, (>=>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Foldable (for_) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, - formatTime, - getCurrentTime) -import GHC.Stack (CallStack, HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), - callStack, getCallStack, - withFrozenCallStack) -import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), - MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), - ShowMessageParams (..)) -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) -#else -import Data.Text.Prettyprint.Doc as PrettyPrinterModule -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) -#endif -import Colog.Core (LogAction (..), - Severity, - WithSeverity (..)) -import qualified Colog.Core as Colog -import System.IO (Handle, - IOMode (AppendMode), - hClose, hFlush, - openFile, stderr) -import UnliftIO (MonadUnliftIO, - displayException, - finally, try) - -data Priority --- Don't change the ordering of this type or you will mess up the Ord --- instance - = Debug -- ^ Verbose debug logging. - | Info -- ^ Useful information in case an error has to be understood. - | Warning - -- ^ These error messages should not occur in a expected usage, and - -- should be investigated. - | Error -- ^ Such log messages must never occur in expected usage. - deriving (Eq, Show, Ord, Enum, Bounded) - --- | Note that this is logging actions _of the program_, not of the user. --- You shouldn't call warning/error if the user has caused an error, only --- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} - -instance Semigroup Logger where - l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t - -instance Monoid Logger where - mempty = Logger $ \_ _ -> pure () - -logError :: Logger -> T.Text -> IO () -logError x = logPriority x Error - -logWarning :: Logger -> T.Text -> IO () -logWarning x = logPriority x Warning - -logInfo :: Logger -> T.Text -> IO () -logInfo x = logPriority x Info - -logDebug :: Logger -> T.Text -> IO () -logDebug x = logPriority x Debug - -noLogging :: Logger -noLogging = Logger $ \_ _ -> return () - -data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor - --- | Note that this is logging actions _of the program_, not of the user. --- You shouldn't call warning/error if the user has caused an error, only --- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -newtype Recorder msg = Recorder - { logger_ :: forall m. (MonadIO m) => msg -> m () } - -logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () -logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg) - -instance Semigroup (Recorder msg) where - (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = - Recorder - { logger_ = \msg -> logger_1 msg >> logger_2 msg } - -instance Monoid (Recorder msg) where - mempty = - Recorder - { logger_ = \_ -> pure () } - -instance Contravariant Recorder where - contramap f Recorder{ logger_ } = - Recorder - { logger_ = logger_ . f } - -cmap :: (a -> b) -> Recorder b -> Recorder a -cmap = contramap - -cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a) -cmapWithPrio f = cmap (fmap f) - -cmapIO :: (a -> IO b) -> Recorder b -> Recorder a -cmapIO f Recorder{ logger_ } = - Recorder - { logger_ = (liftIO . f) >=> logger_ } - -cfilter :: (a -> Bool) -> Recorder a -> Recorder a -cfilter p Recorder{ logger_ } = - Recorder - { logger_ = \msg -> when (p msg) (logger_ msg) } - -textHandleRecorder :: Handle -> Recorder Text -textHandleRecorder handle = - Recorder - { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } - -makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a))) -makeDefaultStderrRecorder columns = do - lock <- liftIO newLock - makeDefaultHandleRecorder columns lock stderr - --- | If no path given then use stderr, otherwise use file. -withDefaultRecorder - :: MonadUnliftIO m - => Maybe FilePath - -- ^ Log file path. `Nothing` uses stderr - -> Maybe [LoggingColumn] - -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` - -> (Recorder (WithPriority (Doc d)) -> m a) - -- ^ action given a recorder - -> m a -withDefaultRecorder path columns action = do - lock <- liftIO newLock - let makeHandleRecorder = makeDefaultHandleRecorder columns lock - case path of - Nothing -> do - recorder <- makeHandleRecorder stderr - let message = "No log file specified; using stderr." - logWith recorder Info message - action recorder - Just path -> do - fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) - case fileHandle of - Left e -> do - recorder <- makeHandleRecorder stderr - let exceptionMessage = pretty $ displayException e - let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."] - logWith recorder Warning message - action recorder - Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) - -makeDefaultHandleRecorder - :: MonadIO m - => Maybe [LoggingColumn] - -- ^ built-in logging columns to display. Nothing uses the default - -> Lock - -- ^ lock to take when outputting to handle - -> Handle - -- ^ handle to output to - -> m (Recorder (WithPriority (Doc a))) -makeDefaultHandleRecorder columns lock handle = do - let Recorder{ logger_ } = textHandleRecorder handle - let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } - let loggingColumns = fromMaybe defaultLoggingColumns columns - let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder - pure (cmap docToText textWithPriorityRecorder) - where - docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) - -data LoggingColumn - = TimeColumn - | ThreadIdColumn - | PriorityColumn - | DataColumn - | SourceLocColumn - -defaultLoggingColumns :: [LoggingColumn] -defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn] - -textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text -textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do - textColumns <- mapM loggingColumnToText columns - pure $ Text.intercalate " | " textColumns - where - showAsText :: Show a => a -> Text - showAsText = Text.pack . show - - utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime - - priorityToText :: Priority -> Text - priorityToText = showAsText - - threadIdToText = showAsText - - callStackToSrcLoc :: CallStack -> Maybe SrcLoc - callStackToSrcLoc callStack = - case getCallStack callStack of - (_, srcLoc) : _ -> Just srcLoc - _ -> Nothing - - srcLocToText = \case - Nothing -> "" - Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } -> - Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol - - loggingColumnToText :: LoggingColumn -> IO Text - loggingColumnToText = \case - TimeColumn -> do - utcTime <- getCurrentTime - pure (utcTimeToText utcTime) - SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_ - ThreadIdColumn -> do - threadId <- myThreadId - pure (threadIdToText threadId) - PriorityColumn -> pure (priorityToText priority) - DataColumn -> pure payload - --- | Given a 'Recorder' that requires an argument, produces a 'Recorder' --- that queues up messages until the argument is provided using the callback, at which --- point it sends the backlog and begins functioning normally. -withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ()) -withBacklog recFun = do - -- Arbitrary backlog capacity - backlog <- newTBQueueIO 100 - let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do - -- If the queue is full just drop the message on the floor. This is most likely - -- to happen if the callback is just never going to be called; in which case - -- we want neither to build up an unbounded backlog in memory, nor block waiting - -- for space! - full <- isFullTBQueue backlog - unless full $ writeTBQueue backlog it - - -- The variable holding the recorder starts out holding the recorder that writes - -- to the backlog. - recVar <- newTVarIO backlogRecorder - -- The callback atomically swaps out the recorder for the final one, and flushes - -- the backlog to it. - let cb arg = do - let recorder = recFun arg - toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog - for_ toRecord (logger_ recorder) - - -- The recorder we actually return looks in the variable and uses whatever is there. - let varRecorder = Recorder $ \it -> do - r <- liftIO $ readTVarIO recVar - logger_ r it - - pure (varRecorder, cb) - --- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications. -lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) -lspClientMessageRecorder env = Recorder $ \WithPriority {..} -> - liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage - ShowMessageParams - { _xtype = priorityToLsp priority, - _message = payload - } - --- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications. -lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) -lspClientLogRecorder env = Recorder $ \WithPriority {..} -> - liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage - LogMessageParams - { _xtype = priorityToLsp priority, - _message = payload - } - -priorityToLsp :: Priority -> MessageType -priorityToLsp = - \case - Debug -> MtLog - Info -> MtInfo - Warning -> MtWarning - Error -> MtError - -toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg) -toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do - let priority = severityToPriority getSeverity - _logger $ WithPriority priority callStack getMsg - where - severityToPriority :: Severity -> Priority - severityToPriority Colog.Debug = Debug - severityToPriority Colog.Info = Info - severityToPriority Colog.Warning = Warning - severityToPriority Colog.Error = Error diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -2,7 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 -- | Options -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options ( IdeOptions(..) , IdePreprocessedSource(..) @@ -18,7 +19,7 @@ , OptHaddockParse(..) , ProgressReportingStyle(..) ) where - +import Control.Lens import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes @@ -27,8 +28,8 @@ import Development.IDE.Types.Diagnostics import Ide.Plugin.Config import Ide.Types (DynFlagsModifications) -import qualified Language.LSP.Types.Capabilities as LSP - +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings @@ -110,7 +111,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == - (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) + ((\x -> x ^. L.workDoneProgress) =<< LSP._window (caps :: LSP.ClientCapabilities)) defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs --- a/src/Text/Fuzzy/Parallel.hs +++ b/src/Text/Fuzzy/Parallel.hs @@ -1,9 +1,9 @@ -- | Parallel versions of 'filter' and 'simpleFilter' module Text.Fuzzy.Parallel -( filter, - simpleFilter, - match, +( filter, filter', + simpleFilter, simpleFilter', + match, defChunkSize, defMaxResults, Scored(..) ) where @@ -29,7 +29,6 @@ -- Just 5 -- {-# INLINABLE match #-} - match :: T.Text -- ^ Pattern in lowercase except for first character -> T.Text -- ^ The text to search in. -> Maybe Int -- ^ The score @@ -70,23 +69,14 @@ toLowerAscii w = if (w - 65) < 26 then w .|. 0x20 else w --- | The function to filter a list of values by fuzzy search on the text extracted from them. -filter :: Int -- ^ Chunk size. 1000 works well. - -> Int -- ^ Max. number of results wanted - -> T.Text -- ^ Pattern. - -> [t] -- ^ The list of values containing the text to search in. - -> (t -> T.Text) -- ^ The function to extract the text from the container. - -> [Scored t] -- ^ The list of results, sorted, highest score first. -filter chunkSize maxRes pattern ts extract = partialSortByAscScore maxRes perfectScore (concat vss) - where - -- Preserve case for the first character, make all others lowercase - pattern' = case T.uncons pattern of - Just (c, rest) -> T.cons c (T.toLower rest) - _ -> pattern - vss = map (mapMaybe (\t -> flip Scored t <$> match pattern' (extract t))) (chunkList chunkSize ts) - `using` parList (evalList rseq) - perfectScore = fromMaybe (error $ T.unpack pattern) $ match pattern' pattern' +-- | Sensible default value for chunk size to use when calling simple filter. +defChunkSize :: Int +defChunkSize = 1000 +-- | Sensible default value for the number of max results to use when calling simple filter. +defMaxResults :: Int +defMaxResults = 10 + -- | Return all elements of the list that have a fuzzy -- match against the pattern. Runs with default settings where -- nothing is added around the matches, as case insensitive. @@ -102,6 +92,52 @@ simpleFilter chunk maxRes pattern xs = filter chunk maxRes pattern xs id + +-- | The function to filter a list of values by fuzzy search on the text extracted from them, +-- using a custom matching function which determines how close words are. +filter' :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> (t -> T.Text) -- ^ The function to extract the text from the container. + -> (T.Text -> T.Text -> Maybe Int) + -- ^ Custom scoring function to use for calculating how close words are + -- When the function returns Nothing, this means the values are incomparable. + -> [Scored t] -- ^ The list of results, sorted, highest score first. +filter' chunkSize maxRes pattern ts extract match' = partialSortByAscScore maxRes perfectScore (concat vss) + where + -- Preserve case for the first character, make all others lowercase + pattern' = case T.uncons pattern of + Just (c, rest) -> T.cons c (T.toLower rest) + _ -> pattern + vss = map (mapMaybe (\t -> flip Scored t <$> match' pattern' (extract t))) (chunkList chunkSize ts) + `using` parList (evalList rseq) + perfectScore = fromMaybe (error $ T.unpack pattern) $ match' pattern' pattern' + +-- | The function to filter a list of values by fuzzy search on the text extracted from them, +-- using a custom matching function which determines how close words are. +filter :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> (t -> T.Text) -- ^ The function to extract the text from the container. + -> [Scored t] -- ^ The list of results, sorted, highest score first. +filter chunkSize maxRes pattern ts extract = + filter' chunkSize maxRes pattern ts extract match + +-- | Return all elements of the list that have a fuzzy match against the pattern, +-- the closeness of the match is determined using the custom scoring match function that is passed. +-- Runs with default settings where nothing is added around the matches, as case insensitive. +{-# INLINABLE simpleFilter' #-} +simpleFilter' :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern to look for. + -> [T.Text] -- ^ List of texts to check. + -> (T.Text -> T.Text -> Maybe Int) + -- ^ Custom scoring function to use for calculating how close words are + -> [Scored T.Text] -- ^ The ones that match. +simpleFilter' chunk maxRes pattern xs match' = + filter' chunk maxRes pattern xs id match' -------------------------------------------------------------------------------- chunkList :: Int -> [a] -> [[a]] diff --git a/test/exe/AsyncTests.hs b/test/exe/AsyncTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/AsyncTests.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} + +module AsyncTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (toJSON) +import Data.Proxy +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), + blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +-- | Test if ghcide asynchronously handles Commands and user Requests +tests :: TestTree +tests = testGroup "async" + [ + testSession "command" $ do + -- Execute a command that will block forever + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SMethod_WorkspaceExecuteCommand req + -- Load a file and check for code actions. Will only work if the command is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + , testSession "request" $ do + -- Execute a custom request that will block for 1000 seconds + void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000 + -- Load a file and check for code actions. Will only work if the request is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + ] diff --git a/test/exe/BootTests.hs b/test/exe/BootTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/BootTests.hs @@ -0,0 +1,55 @@ +module BootTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectNoMoreDiagnostics, + isReferenceReady) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "boot" + [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + -- We send a hover request then wait for either the hover response or + -- `ghcide/reference/ready` notification. + -- Once we receive one of the above, we wait for the other that we + -- haven't received yet. + -- If we don't wait for the `ready` notification it is possible + -- that the `getDefinitions` request/response in the outer ghcide + -- session will find no definitions. + let hoverParams = HoverParams cDoc (Position 4 3) Nothing + hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams + let parseReadyMessage = isReferenceReady cPath + let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId + hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) + _ <- skipManyTill anyMessage $ + case hoverResponseOrReadyMessage of + Left _ -> void parseReadyMessage + Right _ -> void parseHoverResponse + closeDoc cDoc + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do + _ <- openDoc (dir "A.hs") "haskell" + expectNoMoreDiagnostics 2 + ] diff --git a/test/exe/CPPTests.hs b/test/exe/CPPTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/CPPTests.hs @@ -0,0 +1,56 @@ +module CPPTests (tests) where + +import Control.Exception (catch) +import qualified Data.Text as T +import Development.IDE.Test (Cursor, expectDiagnostics, + expectNoMoreDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = + testGroup "cpp" + [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + let content = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Testing where", + "#ifdef FOO", + "foo = 42" + ] + -- The error locations differ depending on which C-preprocessor is used. + -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either + -- of them. + (run $ expectError content (2, maxBound)) + `catch` ( \e -> do + let _ = e :: HUnitFailure + run $ expectError content (2, 1) + ) + , testSessionWait "cpp-ghcide" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + ["{-# LANGUAGE CPP #-}" + ,"main =" + ,"#ifdef __GHCIDE__" + ," worked" + ,"#else" + ," failed" + ,"#endif" + ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, cursor, "error: unterminated")] + ) + ] + expectNoMoreDiagnostics 0.5 diff --git a/test/exe/ClientSettingsTests.hs b/test/exe/ClientSettingsTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/ClientSettingsTests.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +module ClientSettingsTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Data.Aeson (toJSON) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testGroup "client settings handling" + [ testSession "ghcide restarts shake session on config changes" $ do + void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability + void $ createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + sendNotification SMethod_WorkspaceDidChangeConfiguration + (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) + skipManyTill anyMessage restartingBuildSession + + ] + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message diff --git a/test/exe/CodeLensTests.hs b/test/exe/CodeLensTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/CodeLensTests.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE GADTs #-} + +module CodeLensTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "code lenses" + [ addSigLensesTests + ] + + +addSigLensesTests :: TestTree +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + doc <- createDoc "Sigs.hs" "haskell" originalCode + waitForProgressDone + codeLenses <- getCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("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 <> ")") + , ("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") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + ] + , testSession "keep stale lens" $ do + let content = T.unlines + [ "module Stale where" + , "f = _" + ] + doc <- createDoc "Stale.hs" "haskell" content + oldLens <- getCodeLenses doc + liftIO $ length oldLens @?= 1 + let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` + _ <- applyEdit doc edit + 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/test/exe/CompletionTests.hs b/test/exe/CompletionTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/CompletionTests.hs @@ -0,0 +1,576 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module CompletionTests (tests) where + +import Control.Lens ((^.)) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.List.Extra +import Data.Maybe +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Test (waitForTypecheck) +import Development.IDE.Types.Location +import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests + = testGroup "completion" + [ + testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests + , testGroup "local" localCompletionTests + , testGroup "package" packageCompletionTests + , testGroup "project" projectCompletionTests + , testGroup "other" otherCompletionTests + , testGroup "doc" completionDocTests + ] + +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getAndResolveCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] + (Position 0 9) + [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], + completionTest + "class" + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] + (Position 0 9) + [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), + ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), + ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) + ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) + ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) + ], + completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" + ] + (Position 4 14) + [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) + ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ], + testSessionWait "incomplete entries" $ do + let src a = "data Data = " <> a + doc <- createDoc "A.hs" "haskell" $ src "AAA" + void $ waitForTypecheck doc + let editA rhs = + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs] + editA "AAAA" + void $ waitForTypecheck doc + editA "AAAAA" + void $ waitForTypecheck doc + + compls <- getCompletions doc (Position 0 15) + liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] + pure () + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ brokenForWinGhc $ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CompletionItemKind_Function, "head", True, True, Nothing)], + completionTest + "constructor" + ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] + (Position 2 8) + [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) + ], + brokenForWinGhc $ completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] + (Position 2 8) + [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = permu"] + (Position 3 9) + [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + where + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], + + testSession "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ take 2 compls' @?= ["member"], + + testSessionWait "maxCompletions" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = Prelude." + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + liftIO $ length compls @?= maxCompletions def + ] + +packageCompletionTests :: [TestTree] +packageCompletionTests = + [ testSession' "fromList" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) ( + [ "'Data.List.NonEmpty" + , "'GHC.Exts" + ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) + + , testSessionWait "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWait "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + filter + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (InR (MarkupContent MarkupKind_Markdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ length duplicate @?= 1 + + , testSessionWait "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList"] + ] + +projectCompletionTests :: [TestTree] +projectCompletionTests = + [ testSession' "from hiedb" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "b = anidenti" + ] + compls <- getCompletions doc (Position 1 10) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "anidentifier" + ] + liftIO $ compls' @?= ["Defined in 'A"], + testSession' "auto complete project imports" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls + liftIO $ do + item ^. L.label @?= "ALocalModule", + testSession' "auto complete functions from qualified imports without alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A", + "A." + ] + compls <- getCompletions doc (Position 2 2) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier", + testSession' "auto complete functions from qualified imports with alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A as Alias", + "foo = Alias." + ] + compls <- getCompletions doc (Position 2 12) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier" + ] + +completionDocTests :: [TestTree] +completionDocTests = + [ testSession "local define" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + let expected = "*Defined at line 2, column 1 in this module*\n" + test doc (Position 2 8) "foo" Nothing [expected] + , testSession "local empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] + , testSession "local single line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- |docdoc" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] + , testSession "local multi line doc with newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] + , testSession "local multi line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "--def" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] + , testSession "extern empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = od" + ] + 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 + 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 + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + , testSession "extern defined doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + ] + where + brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9" + 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" + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> do + if isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls + , _label == label + ] + liftIO $ compls' @?= expected diff --git a/test/exe/CradleTests.hs b/test/exe/CradleTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/CradleTests.hs @@ -0,0 +1,219 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module CradleTests (tests) where + +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.Util +import Development.IDE.Test (expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + isReferenceReady, + waitForAction) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.IO.Extra hiding (withTempDir) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import GHC.TypeLits (symbolVal) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSession' "implicit" implicit + , testSession' "direct" direct + ] + where + direct dir = do + liftIO $ writeFileUTF8 (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + test dir + implicit dir = test dir + test _dir = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + +retryFailedCradle :: TestTree +retryFailedCradle = testSession' "retry failed" $ \dir -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = dir "hie.yaml" + liftIO $ writeFile hiePath hieContents + let aPath = dir "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess + + -- Fix the cradle and typecheck again + let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" + liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] + + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: String +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do + let srcPath = dir "IgnoreFatal.hs" + src <- liftIO $ readFileUtf8 srcPath + _ <- createDoc srcPath "haskell" src + expectNoMoreDiagnostics 5 + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let mainPath = dir "a/src/Main.hs" + mainSource <- liftIO $ readFileUtf8 mainPath + _mdoc <- createDoc mainPath "haskell" mainSource + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + expectNoMoreDiagnostics 0.5 + +simpleMultiTest :: TestTree +simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: TestTree +simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Now with 3 components +simpleMultiTest3 :: TestTree +simpleMultiTest3 = + testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + cPath = dir "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in component 'a' in a separate session +simpleMultiDefTest :: TestTree +simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- liftIO $ runInDir dir $ do + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + skipManyTill anyMessage $ isReferenceReady aPath + closeDoc adoc + pure adoc + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSession' + "session-deps-are-picked-up" + $ \dir -> do + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "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")])] + -- Update hie.yaml to enable OverloadedStrings. + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] + -- Send change event. + let change = + TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0) + .+ #rangeLength .== Nothing + .+ #text .== "\n" + changeDoc doc [change] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] diff --git a/test/exe/DependentFileTest.hs b/test/exe/DependentFileTest.hs new file mode 100644 --- /dev/null +++ b/test/exe/DependentFileTest.hs @@ -0,0 +1,62 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module DependentFileTest (tests) where + +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.Test (expectDiagnostics) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testGroup "addDependentFile" + [testGroup "file-changed" [testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + let depFilePath = dir "dep-file.txt" + liftIO $ writeFile depFilePath "A" + let fooContent = T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Foo where" + , "import Language.Haskell.TH.Syntax" + , "foo :: Int" + , "foo = 1 + $(do" + , " qAddDependentFile \"dep-file.txt\"" + , " f <- qRunIO (readFile \"dep-file.txt\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + 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")])] + -- Now modify the dependent file + liftIO $ writeFile depFilePath "B" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] + + -- Modifying Baz will now trigger Foo to be rebuilt as well + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6) + .+ #rangeLength .== Nothing + .+ #text .== "f = ()" + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] diff --git a/test/exe/DiagnosticTests.hs b/test/exe/DiagnosticTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/DiagnosticTests.hs @@ -0,0 +1,565 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module DiagnosticTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + flushMessages, waitForAction) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import System.IO.Extra hiding (withTempDir) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Control.Monad.Extra (whenJust) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import System.Time.Extra +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "diagnostics" + [ testSessionWait "fix syntax error" $ do + let content = T.unlines [ "module Testing wher" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19) + .+ #rangeLength .== Nothing + .+ #text .== "where" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testSessionWait "introduce syntax error" $ do + let content = T.unlines [ "module Testing where" ] + doc <- createDoc "Testing.hs" "haskell" content + void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18) + .+ #rangeLength .== Nothing + .+ #text .== "wher" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + , testSessionWait "update syntax error" $ do + let content = T.unlines [ "module Testing(missing) where" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16) + .+ #rangeLength .== Nothing + .+ #text .== "l" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] + , testSessionWait "variable not in scope" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int -> Int" + , "foo a _b = a + ab" + , "bar :: Int -> Int -> Int" + , "bar _a b = cd + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab") + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd") + ] + ) + ] + , testSessionWait "type error" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String -> Int" + , "foo a b = a + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + ) + ] + , testSessionWait "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A ()" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])] + deferralTest title binding msg = testSessionWait title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + + , testSessionWait "remove required module" $ do + let contentA = T.unlines [ "module ModuleA where" ] + docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20) + .+ #rangeLength .== Nothing + .+ #text .== "" + changeDoc docA [change] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] + , testSessionWait "add missing module" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , testCase "add missing module (non workspace)" $ + -- By default lsp-test sends FileWatched notifications for all files, which we don't want + -- as non workspace modules will not be watched by the LSP server. + -- To work around this, we tell lsp-test that our client doesn't have the + -- FileWatched capability, which is enough to disable the notifications + withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] + , testSessionWait "cyclic module dependency" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleA.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + , ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSession' "deeply nested cyclic module dependency" $ \path -> do + let contentA = unlines + [ "module ModuleA where" , "import ModuleB" ] + let contentB = unlines + [ "module ModuleB where" , "import ModuleA" ] + let contentC = unlines + [ "module ModuleC where" , "import ModuleB" ] + let contentD = T.unlines + [ "module ModuleD where" , "import ModuleC" ] + cradle = + "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" + liftIO $ writeFile (path "ModuleA.hs") contentA + liftIO $ writeFile (path "ModuleB.hs") contentB + liftIO $ writeFile (path "ModuleC.hs") contentC + liftIO $ writeFile (path "hie.yaml") cradle + _ <- createDoc "ModuleD.hs" "haskell" contentD + expectDiagnostics + [ ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "correct reference used with hs-boot" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import {-# SOURCE #-} ModuleA()" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB()" + , "x = 5" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + let contentC = T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "module ModuleC where" + , "import ModuleA" + -- this reference will fail if it gets incorrectly + -- resolved to the hs-boot file + , "y = x" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleC.hs" "haskell" contentC + expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "redundant import" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnosticsWithTags + [ ( "ModuleB.hs" + , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)] + ) + ] + , testSessionWait "redundant import even without warning" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial warning for testing purposes + , "foo = ()" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "package imports" $ do + let thisDataListContent = T.unlines + [ "module Data.List where" + , "x :: Integer" + , "x = 123" + ] + let mainContent = T.unlines + [ "{-# LANGUAGE PackageImports #-}" + , "module Main where" + , "import qualified \"this\" Data.List as ThisList" + , "import qualified \"base\" Data.List as BaseList" + , "useThis = ThisList.x" + , "useBase = BaseList.map" + , "wrong1 = ThisList.map" + , "wrong2 = BaseList.x" + , "main = pure ()" + ] + _ <- createDoc "Data/List.hs" "haskell" thisDataListContent + _ <- createDoc "Main.hs" "haskell" mainContent + expectDiagnostics + [ ( "Main.hs" + , [(DiagnosticSeverity_Error, (6, 9), + if ghcVersion >= GHC96 then + "Variable not in scope: ThisList.map" + else if ghcVersion >= GHC94 then + "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216ThisList.map\8217") + ,(DiagnosticSeverity_Error, (7, 9), + if ghcVersion >= GHC96 then + "Variable not in scope: BaseList.x" + else if ghcVersion >= GHC94 then + "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216BaseList.x\8217") + ] + ) + ] + , testSessionWait "unqualified warnings" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Foo where" + , "foo :: Ord a => a -> Int" + , "foo _a = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + -- The test is to make sure that warnings contain unqualified names + -- where appropriate. The warning should use an unqualified name 'Ord', not + -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- test this is fairly arbitrary. + , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") + ] + ) + ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (lower drive) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (lower drive) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + TNotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg :: T.Text = (head diags) ^. L.message + 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" + content = T.unlines + [ "module " <> name <> " where" + , "value :: Maybe ()" + , "value = [()]" + ] + _ <- createDoc (T.unpack name <> ".hs") "haskell" content + notification <- skipManyTill anyMessage diagnostic + let + offenders = + L.params . + L.diagnostics . + Lens.folded . + L.message . + Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) + failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg + Lens.mapMOf_ offenders failure notification + , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" + let fooContent = T.unlines + [ "module Foo where" + , "foo = ()" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:") + ] + ) + ] + , testSessionWait "-Werror in pragma is ignored" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wall -Werror #-}" + , "module Foo() where" + , "foo :: Int" + , "foo = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:") + ] + ) + ] + , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int + + bdoc <- createDoc bPath "haskell" bSource + _pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B which introduces a type error in A (imported from P) + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module B where", "y :: Bool", "y = undefined"]] + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ] + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] + + expectDiagnostics + [ ( "P.hs", + [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 + + , testSessionWait "deduplicate missing module diagnostics" $ do + let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module Foo() where" ] + expectDiagnostics [] + + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines + [ "module Foo() where" , "import MissingModule" ] ] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + + , testGroup "Cancellation" + [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc + , cancellationTestGroup "edit import" editImport noSession yesParse noTc + , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc + ] + ] + where + editPair x y = let p = Position x y ; p' = Position x (y+2) in + (TextDocumentContentChangeEvent $ InL $ #range .== Range p p + .+ #rangeLength .== Nothing + .+ #text .== "fd" + ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p' + .+ #rangeLength .== Nothing + .+ #text .== "") + editHeader = editPair 0 0 + editImport = editPair 2 10 + editBody = editPair 3 10 + + noParse = False + yesParse = True + + noSession = False + yesSession = True + + noTc = False + yesTc = True + +cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree +cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name + [ cancellationTemplate edits Nothing + , cancellationTemplate edits $ Just ("GetFileContents", True) + , cancellationTemplate edits $ Just ("GhcSession", True) + -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) + , cancellationTemplate edits $ Just ("GetModSummary", True) + , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) + -- getLocatedImports never fails + , cancellationTemplate edits $ Just ("GetLocatedImports", True) + , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) + , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) + , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) + , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) + ] + +cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree +cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do + doc <- createDoc "Foo.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module Foo where" + , "import Data.List()" + , "f0 x = (x,x)" + ] + + -- for the example above we expect one warning + let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + -- Now we edit the document and wait for the given key (if any) + changeDoc doc [edit] + whenJust mbKey $ \(key, expectedResult) -> do + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + liftIO $ ideResultSuccess @?= expectedResult + + -- The 2nd edit cancels the active session and unbreaks the file + -- wait for typecheck and check that the current diagnostics are accurate + changeDoc doc [undoEdit] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + expectNoMoreDiagnostics 0.5 + where + -- similar to run except it disables kick + runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s + + typeCheck doc = do + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ assertBool "The file should typecheck" ideResultSuccess + -- wait for the debouncer to publish diagnostics if the rule runs + liftIO $ sleep 0.2 + -- flush messages to ensure current diagnostics state is updated + flushMessages diff --git a/test/exe/ExceptionTests.hs b/test/exe/ExceptionTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/ExceptionTests.hs @@ -0,0 +1,155 @@ + +module ExceptionTests (tests) where + +import Control.Exception (ArithException (DivideByZero), + throwIO) +import Control.Lens +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.HLS (toResponseError) +import Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Options +import GHC.Base (coerce) +import Ide.Logger (Logger, Recorder, + WithPriority, cmapWithPrio) +import Ide.Plugin.Error +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import LogType (Log (..)) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: Recorder (WithPriority Log) -> Logger -> TestTree +tests recorder logger = do + testGroup "Exceptions and PluginError" [ + testGroup "Testing that IO Exceptions are caught in..." + [ testCase "PluginHandlers" $ do + let pluginId = "plugin-handler-exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + _ <- liftIO $ throwIO DivideByZero + pure (InL []) + ] + }] + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show lens + + , testCase "Commands" $ do + let pluginId = "command-exception" + commandId = CommandId "exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginCommands = + [ PluginCommand commandId "Causes an exception" $ \_ (_::Int) -> do + _ <- liftIO $ throwIO DivideByZero + pure (InR Null) + ] + }] + testIde recorder (testingLite recorder logger plugins) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) + execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments) + (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams + case res of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show res + + , testCase "Notification Handlers" $ do + let pluginId = "notification-exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ throwIO DivideByZero + ] + , pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + pure (InL []) + ] + }] + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Right (InL []) -> + -- We don't get error responses from notification handlers, so + -- we can only make sure that the server is still responding + pure () + _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] + + , testGroup "Testing PluginError order..." + [ pluginOrderTestCase recorder logger "InternalError over InvalidParams" PluginInternalError PluginInvalidParams + , pluginOrderTestCase recorder logger "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState + , pluginOrderTestCase recorder logger "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused + ] + ] + +testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments +testingLite recorder logger plugins = + let + arguments@IDE.Arguments{ argsIdeOptions } = + IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) logger plugins + hlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc plugins + ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = + let + defOptions = argsIdeOptions config sessionLoader + in + defOptions{ optTesting = IdeTesting True } + in + arguments + { IDE.argsHlsPlugins = hlsPlugins + , IDE.argsIdeOptions = ideOptions + } + +pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree +pluginOrderTestCase recorder logger msg err1 err2 = + testCase msg $ do + let pluginId = "error-order-test" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ err1 "error test" + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ err2 "error test" + ] + }] + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left re | toResponseError (pluginId, err1 "error test") == re -> pure () + | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!" + _ -> liftIO $ assertFailure $ show lens diff --git a/test/exe/FindDefinitionAndHoverTests.hs b/test/exe/FindDefinitionAndHoverTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/FindDefinitionAndHoverTests.hs @@ -0,0 +1,252 @@ + +{-# LANGUAGE MultiWayIf #-} + +module FindDefinitionAndHoverTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectDiagnostics, + standardizeQuotes) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.Info.Extra (isWindows) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Regex.TDFA ((=~)) + +tests :: TestTree +tests = let + + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree + tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do + + -- Dirty the cache to check that definitions work even in the presence of iface files + liftIO $ runInDir dir $ do + let fooPath = dir "Foo.hs" + fooSource <- liftIO $ readFileUtf8 fooPath + fooDoc <- createDoc fooPath "haskell" fooSource + _ <- getHover fooDoc $ Position 4 3 + closeDoc fooDoc + + doc <- openTestDataDoc (dir sfp) + waitForProgressDone + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) + ] + , testGroup "type-definition" typeDefinitionTests + , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + recordDotSyntaxTests + | ghcVersion >= GHC92 = + [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + ] + | otherwise = [] + + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM runDef runHover look expect title = + ( runDef $ tst def look sourceFilePath expect title + , runHover $ tst hover look sourceFilePath expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aL20 = Position 19 15 + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] + cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] + import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]] + 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" + , 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 + , test yes yes dcL7 tcDC "data constructor record #1029" + , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 + , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes xtcL5 xtc "type constructor external #717,1028" + , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes clL23 cls "class in instance declaration #1027" + , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes eclL15 ecls "external class in signature #717,1027" + , test yes yes dnbL29 dnb "do-notation bind #1073" + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind #1073" + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" + , if ghcVersion >= GHC810 then + test yes yes spaceL37 space "top-level fn on space #1002" + else + test yes broken spaceL37 space "top-level fn on space #1002" + , test no yes docL41 doc "documentation #1129" + , test no yes eitL40 kindE "kind of Either #1017" + , test no yes intL40 kindI "kind of Int #1017" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no broken intL41 litI "literal Int in hover info #1016" + , test no broken chrL36 litC "literal Char in hover info #1016" + , 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 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 -> + -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 + testM no yes reexported reexportedSig "Imported symbol (reexported)" + | otherwise -> + 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 yes yes import310 pkgTxt "show package name and its version" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + skip = const Nothing -- unreliable, don't run + +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + diag diff --git a/test/exe/FuzzySearch.hs b/test/exe/FuzzySearch.hs --- a/test/exe/FuzzySearch.hs +++ b/test/exe/FuzzySearch.hs @@ -1,6 +1,5 @@ module FuzzySearch (tests) where -import Control.Monad (guard) import Data.Char (toLower) import Data.Maybe (catMaybes) import qualified Data.Monoid.Textual as T @@ -8,12 +7,10 @@ import qualified Data.Text as Text import Prelude hiding (filter) import System.Directory (doesFileExist) -import System.Info.Extra (isWindows) import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck import Test.Tasty import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) import qualified Text.Fuzzy as Fuzzy import Text.Fuzzy (Fuzzy (..)) diff --git a/test/exe/GarbageCollectionTests.hs b/test/exe/GarbageCollectionTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/GarbageCollectionTests.hs @@ -0,0 +1,94 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module GarbageCollectionTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE.Test (expectCurrentDiagnostics, + getStoredKeys, waitForGC, + waitForTypecheck) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Printf (printf) + +tests :: TestTree +tests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + doc <- generateGarbage "A" dir + closeDoc doc + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + + , testSession' "are deleted from the state" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + keys0 <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keys1 <- getStoredKeys + liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) + + , testSession' "are not regenerated unless needed" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir + + -- garbage collect A keys + keysBeforeGC <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keysAfterGC <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" + (length keysAfterGC < length keysBeforeGC) + + -- re-typecheck B and check that the keys for A have not materialized back + _docB <- generateGarbage "B" dir + keysB <- getStoredKeys + let regeneratedKeys = Set.filter (not . isExpected) $ + Set.intersection (Set.fromList garbage) (Set.fromList keysB) + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + let edit = T.unlines + [ "module A where" + , "a :: Bool" + , "a = ()" + ] + doc <- generateGarbage "A" dir + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit] + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] + ] + ] + where + isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] + + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + return doc diff --git a/test/exe/HaddockTests.hs b/test/exe/HaddockTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/HaddockTests.hs @@ -0,0 +1,90 @@ + +module HaddockTests (tests) where + +import Development.IDE.Spans.Common +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + , testCase "ordered list" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt diff --git a/test/exe/HieDbRetry.hs b/test/exe/HieDbRetry.hs --- a/test/exe/HieDbRetry.hs +++ b/test/exe/HieDbRetry.hs @@ -1,22 +1,21 @@ {-# LANGUAGE MultiWayIf #-} module HieDbRetry (tests) where -import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, - withVar) -import Control.Exception (ErrorCall (ErrorCall), evaluate, - throwIO, tryJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Tuple.Extra (dupe) -import qualified Database.SQLite.Simple as SQLite -import Development.IDE.Session (retryOnException, - retryOnSqliteBusy) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger (Recorder (Recorder, logger_), - WithPriority (WithPriority, payload), - cmapWithPrio) -import qualified System.Random as Random -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, + withVar) +import Control.Exception (ErrorCall (ErrorCall), evaluate, + throwIO, tryJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Tuple.Extra (dupe) +import qualified Database.SQLite.Simple as SQLite +import Development.IDE.Session (retryOnException, retryOnSqliteBusy) +import qualified Development.IDE.Session as Session +import Ide.Logger (Recorder (Recorder, logger_), + WithPriority (WithPriority, payload), + cmapWithPrio) +import qualified System.Random as Random +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) data Log = LogSession Session.Log diff --git a/test/exe/HighlightTests.hs b/test/exe/HighlightTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/HighlightTests.hs @@ -0,0 +1,85 @@ + +module HighlightTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 2) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "type" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 8) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "local" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 6 5) + liftIO $ highlights @?= + [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) + ] + , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96] "Ghc9 highlights the constructor and not just this field" $ + testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= + -- Span is just the .. on 8.10, but Rec{..} before + [ if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) + else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + -- Span is just the .. on 8.10, but Rec{..} before + , if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) + else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Read) + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] diff --git a/test/exe/IfaceTests.hs b/test/exe/IfaceTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/IfaceTests.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module IfaceTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Util +import Development.IDE.Test (configureCheckProject, + expectDiagnostics, + expectNoMoreDiagnostics, + getInterfaceFilesDir) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import System.IO.Extra hiding (withTempDir) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "Interface loading tests" + [ -- https://github.com/haskell/ghcide/pull/645/ + ifaceErrorTest + , ifaceErrorTest2 + , ifaceErrorTest3 + , ifaceTHTest + ] + + +-- | test that TH reevaluates across interfaces +ifaceTHTest :: TestTree +ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () + _bSource <- liftIO $ readFileUtf8 bPath -- a :: () + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + cdoc <- createDoc cPath "haskell" cSource + + -- Change [TH]a from () to Bool + liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) + + -- Check that the change propagates to C + 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")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do + configureCheckProject True + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + -- save so that we can that the error propagates to A + sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) + + + -- Check that the error propagates to A + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + + -- Check that we wrote the interfaces for B when we saved + hidir <- getInterfaceFilesDir bdoc + hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" + liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists + + pdoc <- openDoc pPath "haskell" + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ] + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + -- This is clearly inconsistent, and the expected outcome a bit surprising: + -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics + -- - P is being typechecked with the last successful artifacts for A. + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +ifaceErrorTest2 :: TestTree +ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- Add a new definition to P + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + expectDiagnostics + -- As in the other test, P is being typechecked with the last successful artifacts for A + -- (ot thanks to -fdeferred-type-errors) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")]) + ] + + expectNoMoreDiagnostics 2 + +ifaceErrorTest3 :: TestTree +ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- P should not typecheck, as there are no last valid artifacts for A + _pdoc <- createDoc pPath "haskell" pSource + + -- In this example the interface file for A should not exist (modulo the cache folder) + -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 diff --git a/test/exe/InitializeResponseTests.hs b/test/exe/InitializeResponseTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/InitializeResponseTests.hs @@ -0,0 +1,97 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} + +module InitializeResponseTests (tests) where + +import Control.Monad +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (TResponseMessage Method_Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InL True) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InL True) + , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider (Just $ InL False) + , chk " find references" _referencesProvider (Just $ InL True) + , chk " doc highlight" _documentHighlightProvider (Just $ InL True) + , chk " doc symbol" _documentSymbolProvider (Just $ InL True) + , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) + , chk " code action" _codeActionProvider (Just $ InL False) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) + , chk "NO doc range formatting" + _documentRangeFormattingProvider (Just $ InL False) + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ InL False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" (^. L.colorProvider) (Just $ InL False) + , chk "NO folding range" _foldingRangeProvider (Just $ InL False) + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) + , chk "NO experimental" (^. L.experimental) Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir + commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (TResponseMessage Method_Initialize) + acquire = run initializeResponse + + release :: TResponseMessage Method_Initialize -> IO () + release = const $ pure () + diff --git a/test/exe/LogType.hs b/test/exe/LogType.hs new file mode 100644 --- /dev/null +++ b/test/exe/LogType.hs @@ -0,0 +1,21 @@ +module LogType (Log(..)) where + +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide + +import Ide.Logger (Pretty (pretty)) +import Language.LSP.VFS (VfsLog) + +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + | LogVfs VfsLog + | LogNotifications Notifications.Log + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + LogVfs log -> pretty log + LogNotifications log -> pretty log diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -26,3603 +26,102 @@ Therefore, avoid mixing both progress reports and diagnostics in the same test -} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} - -module Main (main) where - -import Control.Applicative.Combinators -import Control.Concurrent -import Control.Exception (bracket_, catch, - finally) -import qualified Control.Lens as Lens -import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Default -import Data.Foldable -import Data.List.Extra -import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Utf16.Rope (Rope) -import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE.Core.PositionMapping (PositionResult (..), - fromCurrent, - positionResultToMaybe, - toCurrent) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) -import Development.IDE.GHC.Util -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test (Cursor, - canonicalizeUri, - configureCheckProject, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - flushMessages, - getInterfaceFilesDir, - getStoredKeys, - isReferenceReady, - referenceReady, - standardizeQuotes, - waitForAction, - waitForGC, - waitForTypecheck) -import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics -import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Plugin.Config -import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - mkRange) -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as Lens (label) -import qualified Language.LSP.Types.Lens as Lsp (diagnostics, - message, - params) -import Language.LSP.VFS (VfsLog, applyChange) -import Network.URI -import System.Directory -import System.Environment.Blank (getEnv, setEnv, - unsetEnv) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import System.Info.Extra (isMac, isWindows) -import qualified System.IO.Extra -import System.IO.Extra hiding (withTempDir) -import System.Mem (performGC) -import System.Process.Extra (CreateProcess (cwd), - createPipe, proc, - readCreateProcessWithExitCode) -import Test.QuickCheck --- import Test.QuickCheck.Instances () -import Control.Concurrent.Async -import Control.Lens (to, (.~), (^.)) -import Control.Monad.Extra (whenJust) -import Data.Function ((&)) -import Data.Functor.Identity (runIdentity) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef_) -import Data.String (IsString (fromString)) -import Data.Tuple.Extra -import Development.IDE.Core.FileStore (getModTime) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - WaitForIdeRuleResult (..), - blockCommandId) -import Development.IDE.Types.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, - cmapWithPrio, - makeDefaultStderrRecorder, - toCologActionWithPrio) -import qualified FuzzySearch -import GHC.Stack (emptyCallStack) -import qualified HieDbRetry -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Lens (didChangeWatchedFiles, - workspace) -import qualified Language.LSP.Types.Lens as L -import qualified Progress -import System.Time.Extra -import qualified Test.QuickCheck.Monadic as MonadicQuickCheck -import Test.QuickCheck.Monadic (forAllM, monadicIO) -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.QuickCheck -import Text.Printf (printf) -import Text.Regex.TDFA ((=~)) - -data Log - = LogGhcIde Ghcide.Log - | LogIDEMain IDE.Log - | LogVfs VfsLog - -instance Pretty Log where - pretty = \case - LogGhcIde log -> pretty log - LogIDEMain log -> pretty log - LogVfs log -> pretty log - --- | Wait for the next progress begin step -waitForProgressBegin :: Session () -waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () - _ -> Nothing - --- | Wait for the first progress end step --- Also implemented in hls-test-utils Test.Hls -waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - --- | Wait for all progress to be done --- Needs at least one progress done notification to return --- Also implemented in hls-test-utils Test.Hls -waitForAllProgressDone :: Session () -waitForAllProgressDone = loop - where - loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - done <- null <$> getIncompleteProgressSessions - unless done loop - -main :: IO () -main = do - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) - - let docWithFilteredPriorityRecorder@Recorder{ logger_ } = - docWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= Debug) - - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - - let recorder = docWithFilteredPriorityRecorder - & cmapWithPrio pretty - - -- We mess with env vars so run single-threaded. - defaultMainWithRerun $ testGroup "ghcide" - [ testSession "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) - waitForProgressBegin - closeDoc doc - waitForProgressDone - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeLensesTests - , outlineTests - , highlightTests - , findDefinitionAndHoverTests - , pluginSimpleTests - , pluginParsedResultTests - , preprocessorTests - , thTests - , symlinkTests - , safeTests - , unitTests recorder logger - , haddockTests - , positionMappingTests recorder - , watchedFilesTests - , cradleTests - , dependentFileTest - , nonLspCommandLine - , ifaceTests - , bootTests - , rootUriTests - , asyncTests - , clientSettingsTest - , referenceTests - , garbageCollectionTests - , HieDbRetry.tests - ] - -initializeResponseTests :: TestTree -initializeResponseTests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO (ResponseMessage Initialize) -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True)) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just $ InL True) - , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider (Just $ InL False) - , chk " find references" _referencesProvider (Just $ InL True) - , chk " doc highlight" _documentHighlightProvider (Just $ InL True) - , chk " doc symbol" _documentSymbolProvider (Just $ InL True) - , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) - , chk " code action" _codeActionProvider (Just $ InL False) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) - , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) - , chk "NO doc range formatting" - _documentRangeFormattingProvider (Just $ InL False) - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ InL False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" (^. L.colorProvider) (Just $ InL False) - , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) - , chk "NO experimental" (^. L.experimental) Nothing - ] where - - tds = Just (InL (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir - commandNames = (!! 2) . T.splitOn ":" <$> commands - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) - - innerCaps :: ResponseMessage Initialize -> ServerCapabilities - innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" - - acquire :: IO (ResponseMessage Initialize) - acquire = run initializeResponse - - release :: ResponseMessage Initialize -> IO () - release = const $ pure () - - -diagnosticTests :: TestTree -diagnosticTests = testGroup "diagnostics" - [ testSessionWait "fix syntax error" $ do - let content = T.unlines [ "module Testing wher" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 19)) - , _rangeLength = Nothing - , _text = "where" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testSessionWait "introduce syntax error" $ do - let content = T.unlines [ "module Testing where" ] - doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) - waitForProgressBegin - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 18)) - , _rangeLength = Nothing - , _text = "wher" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - , testSessionWait "update syntax error" $ do - let content = T.unlines [ "module Testing(missing) where" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 16)) - , _rangeLength = Nothing - , _text = "l" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] - , testSessionWait "variable not in scope" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int -> Int" - , "foo a _b = a + ab" - , "bar :: Int -> Int -> Int" - , "bar _a b = cd + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [ (DsError, (2, 15), "Variable not in scope: ab") - , (DsError, (4, 11), "Variable not in scope: cd") - ] - ) - ] - , testSessionWait "type error" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String -> Int" - , "foo a b = a + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] - ) - ] - , testSessionWait "typed hole" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String" - , "foo a = _ a" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] - ) - ] - - , testGroup "deferral" $ - let sourceA a = T.unlines - [ "module A where" - , "a :: Int" - , "a = " <> a] - sourceB = T.unlines - [ "module B where" - , "import A ()" - , "b :: Float" - , "b = True"] - bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DsError, (2,4), aMessage)]) - , ("B.hs", [(DsError, (3,4), bMessage)])] - deferralTest title binding msg = testSessionWait title $ do - _ <- createDoc "A.hs" "haskell" $ sourceA binding - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg - in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" - ] - - , testSessionWait "remove required module" $ do - let contentA = T.unlines [ "module ModuleA where" ] - docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 0) (Position 0 20)) - , _rangeLength = Nothing - , _text = "" - } - changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] - , testSessionWait "add missing module" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - expectDiagnostics [("ModuleB.hs", [])] - , testCase "add missing module (non workspace)" $ - -- By default lsp-test sends FileWatched notifications for all files, which we don't want - -- as non workspace modules will not be watched by the LSP server. - -- To work around this, we tell lsp-test that our client doesn't have the - -- FileWatched capability, which is enough to disable the notifications - withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir "ModuleB.hs", [])] - , testSessionWait "cyclic module dependency" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSession' "deeply nested cyclic module dependency" $ \path -> do - let contentA = unlines - [ "module ModuleA where" , "import ModuleB" ] - let contentB = unlines - [ "module ModuleB where" , "import ModuleA" ] - let contentC = unlines - [ "module ModuleC where" , "import ModuleB" ] - let contentD = T.unlines - [ "module ModuleD where" , "import ModuleC" ] - cradle = - "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" - liftIO $ writeFile (path "ModuleA.hs") contentA - liftIO $ writeFile (path "ModuleB.hs") contentB - liftIO $ writeFile (path "ModuleC.hs") contentC - liftIO $ writeFile (path "hie.yaml") cradle - _ <- createDoc "ModuleD.hs" "haskell" contentD - expectDiagnostics - [ ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "{-# OPTIONS -Wmissing-signatures#-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial diagnostic - , "foo = ()" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "correct reference used with hs-boot" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import {-# SOURCE #-} ModuleA()" - ] - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB()" - , "x = 5" - ] - let contentAboot = T.unlines - [ "module ModuleA where" - ] - let contentC = T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "module ModuleC where" - , "import ModuleA" - -- this reference will fail if it gets incorrectly - -- resolved to the hs-boot file - , "y = x" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot - _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "redundant import" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnosticsWithTags - [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] - ) - ] - , testSessionWait "redundant import even without warning" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial warning for testing purposes - , "foo = ()" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "package imports" $ do - let thisDataListContent = T.unlines - [ "module Data.List where" - , "x :: Integer" - , "x = 123" - ] - let mainContent = T.unlines - [ "{-# LANGUAGE PackageImports #-}" - , "module Main where" - , "import qualified \"this\" Data.List as ThisList" - , "import qualified \"base\" Data.List as BaseList" - , "useThis = ThisList.x" - , "useBase = BaseList.map" - , "wrong1 = ThisList.map" - , "wrong2 = BaseList.x" - , "main = pure ()" - ] - _ <- createDoc "Data/List.hs" "haskell" thisDataListContent - _ <- createDoc "Main.hs" "haskell" mainContent - expectDiagnostics - [ ( "Main.hs" - , [(DsError, (6, 9), - if ghcVersion >= GHC96 then - "Variable not in scope: ThisList.map" - else if ghcVersion >= GHC94 then - "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else - "Not in scope: \8216ThisList.map\8217") - ,(DsError, (7, 9), - if ghcVersion >= GHC96 then - "Variable not in scope: BaseList.x" - else if ghcVersion >= GHC94 then - "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else - "Not in scope: \8216BaseList.x\8217") - ] - ) - ] - , testSessionWait "unqualified warnings" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Foo where" - , "foo :: Ord a => a -> Int" - , "foo _a = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - -- The test is to make sure that warnings contain unqualified names - -- where appropriate. The warning should use an unqualified name 'Ord', not - -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to - -- test this is fairly arbitrary. - , [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") - ] - ) - ] - , testSessionWait "lower-case drive" $ do - let aContent = T.unlines - [ "module A.A where" - , "import A.B ()" - ] - bContent = T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A.B where" - , "import Data.List" - ] - uriB <- getDocUri "A/B.hs" - Just pathB <- pure $ uriToFilePath uriB - uriB <- pure $ - let (drive, suffix) = splitDrive pathB - in filePathToUri (joinDrive (lower drive) suffix) - liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent - uriA <- getDocUri "A/A.hs" - Just pathA <- pure $ uriToFilePath uriA - uriA <- pure $ - let (drive, suffix) = splitDrive pathA - in filePathToUri (joinDrive (lower drive) suffix) - let itemA = TextDocumentItem uriA "haskell" 0 aContent - let a = TextDocumentIdentifier uriA - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) - NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic - -- Check that if we put a lower-case drive in for A.A - -- the diagnostics for A.B will also be lower-case. - liftIO $ fileUri @?= uriB - let msg = head (toList diags) ^. L.message - 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" - , [(DsWarning, (2, 8), "Haddock parse error on input")] - ) - ] - , testSessionWait "strip file path" $ do - let - name = "Testing" - content = T.unlines - [ "module " <> name <> " where" - , "value :: Maybe ()" - , "value = [()]" - ] - _ <- createDoc (T.unpack name <> ".hs") "haskell" content - notification <- skipManyTill anyMessage diagnostic - let - offenders = - Lsp.params . - Lsp.diagnostics . - Lens.folded . - Lsp.message . - Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) - failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg - Lens.mapMOf_ offenders failure notification - , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" - let fooContent = T.unlines - [ "module Foo where" - , "foo = ()" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (1, 0), "Top-level binding with no type signature:") - ] - ) - ] - , testSessionWait "-Werror in pragma is ignored" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wall -Werror #-}" - , "module Foo() where" - , "foo :: Int" - , "foo = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (3, 0), "Defined but not used:") - ] - ) - ] - , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - aPath = dir "A.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int - - bdoc <- createDoc bPath "haskell" bSource - _pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B which introduces a type error in A (imported from P) - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module B where", "y :: Bool", "y = undefined"]] - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ] - - -- Open A and edit to fix the type error - adoc <- createDoc aPath "haskell" aSource - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - - expectDiagnostics - [ ( "P.hs", - [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DsWarning, (4, 0), "Top-level binding") - ] - ), - ("A.hs", []) - ] - expectNoMoreDiagnostics 1 - - , testSessionWait "deduplicate missing module diagnostics" $ do - let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] - expectDiagnostics [] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines - [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - , testGroup "Cancellation" - [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc - , cancellationTestGroup "edit import" editImport noSession yesParse noTc - , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc - ] - ] - where - editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} - ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) - editHeader = editPair 0 0 - editImport = editPair 2 10 - editBody = editPair 3 10 - - noParse = False - yesParse = True - - noSession = False - yesSession = True - - noTc = False - yesTc = True - -cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree -cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name - [ cancellationTemplate edits Nothing - , cancellationTemplate edits $ Just ("GetFileContents", True) - , cancellationTemplate edits $ Just ("GhcSession", True) - -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) - , cancellationTemplate edits $ Just ("GetModSummary", True) - , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) - -- getLocatedImports never fails - , cancellationTemplate edits $ Just ("GetLocatedImports", True) - , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) - , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) - , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) - , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) - ] - -cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree -cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do - doc <- createDoc "Foo.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module Foo where" - , "import Data.List()" - , "f0 x = (x,x)" - ] - - -- for the example above we expect one warning - let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - -- Now we edit the document and wait for the given key (if any) - changeDoc doc [edit] - whenJust mbKey $ \(key, expectedResult) -> do - WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc - liftIO $ ideResultSuccess @?= expectedResult - - -- The 2nd edit cancels the active session and unbreaks the file - -- wait for typecheck and check that the current diagnostics are accurate - changeDoc doc [undoEdit] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - expectNoMoreDiagnostics 0.5 - where - -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s - - typeCheck doc = do - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ assertBool "The file should typecheck" ideResultSuccess - -- wait for the debouncer to publish diagnostics if the rule runs - liftIO $ sleep 0.2 - -- flush messages to ensure current diagnostics state is updated - flushMessages - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -watchedFilesTests :: TestTree -watchedFilesTests = testGroup "watched files" - [ testGroup "Subscriptions" - [ testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - , testSession' "non workspace file" $ \sessionDir -> do - tmpDir <- liftIO getTemporaryDirectory - let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" - liftIO $ writeFile (sessionDir "hie.yaml") yaml - _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - -- TODO add a test for didChangeWorkspaceFolder - ] - , testGroup "Changes" - [ - testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Bool" - ,"b = False"] - _doc <- createDoc "A.hs" "haskell" $ T.unlines - ["module A where" - ,"import B" - ,"a :: ()" - ,"a = b" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] - -- modify B off editor - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Int" - ,"b = 0"] - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ sessionDir "B.hs") FcChanged ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] - ] - ] - -addSigLensesTests :: TestTree -addSigLensesTests = - let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH exported = - T.unlines - [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" - , "module Sigs(" <> exported <> ") where" - , "import qualified Data.Complex as C" - , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" - , "data T1 a where" - , " MkT1 :: (Show b) => a -> b -> T1 a" - ] - before enableGHCWarnings exported (def, _) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others - after' enableGHCWarnings exported (def, sig) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others - createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] - sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do - let originalCode = before enableGHCWarnings exported def others - let expectedCode = after' enableGHCWarnings exported def others - sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode - doc <- createDoc "Sigs.hs" "haskell" originalCode - waitForProgressDone - codeLenses <- getCodeLenses doc - if not $ null $ snd def - then do - liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses - executeCommand $ fromJust $ head codeLenses ^. L.command - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses - cases = - [ ("abc = True", "abc :: Bool") - , ("foo a b = a + b", "foo :: Num a => a -> a -> a") - , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") - , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") - , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") - , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") - , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("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 <> ")") - , ("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") - , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") - ] - in testGroup - "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) - , testGroup - "diagnostics mode works" - [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] - ] - , testSession "keep stale lens" $ do - let content = T.unlines - [ "module Stale where" - , "f = _" - ] - doc <- createDoc "Stale.hs" "haskell" content - oldLens <- getCodeLenses doc - liftIO $ length oldLens @?= 1 - let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` - _ <- applyEdit doc edit - newLens <- getCodeLenses doc - liftIO $ newLens @?= oldLens - ] - -linkToLocation :: [LocationLink] -> [Location] -linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) - -checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () -checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where - check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange - check (ExpectLocation expectedLocation) = do - assertNDefinitionsFound 1 defs - liftIO $ do - canonActualLoc <- canonicalizeLocation (head defs) - canonExpectedLoc <- canonicalizeLocation expectedLocation - canonActualLoc @?= canonExpectedLoc - check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs - check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" - check _ = pure () -- all other expectations not relevant to getDefinition - - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) - - assertRangeCorrect Location{_range = foundRange} expectedRange = - liftIO $ expectedRange @=? foundRange - -canonicalizeLocation :: Location -> IO Location -canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree - tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - - -- Dirty the cache to check that definitions work even in the presence of iface files - liftIO $ runInDir dir $ do - let fooPath = dir "Foo.hs" - fooSource <- liftIO $ readFileUtf8 fooPath - fooDoc <- createDoc fooPath "haskell" fooSource - _ <- getHover fooDoc $ Position 4 3 - closeDoc fooDoc - - doc <- openTestDataDoc (dir sfp) - waitForProgressDone - found <- get doc pos - check found targetRange - - - - checkHover :: Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets - ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - assertNotFoundIn :: T.Text -> T.Text -> Assertion - assertNotFoundIn part whole = assertBool - (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) - (not . T.isInfixOf part $ whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")]) - ] - , testGroup "type-definition" typeDefinitionTests - , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] - - typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] - - recordDotSyntaxTests - | ghcVersion >= GHC92 = - [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" - , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" - , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" - ] - | otherwise = [] - - test runDef runHover look expect = testM runDef runHover look (return expect) - - testM runDef runHover look expect title = - ( runDef $ tst def look sourceFilePath expect title - , runHover $ tst hover look sourceFilePath expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - - -- search locations expectations on results - fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] - fffL8 = Position 12 4 ; - fffL14 = Position 18 7 ; - aL20 = Position 19 15 - aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] - dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] - dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] - tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] - vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] - opL16 = Position 20 15 ; op = [mkR 21 2 21 4] - opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] - aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] - b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] - xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] - clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] - clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] - dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] - dnbL30 = Position 34 23 - lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] - lclL33 = Position 37 22 - mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] - mclL37 = Position 41 1 - spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] - docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] - tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] - intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] - chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] - txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] - lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] - innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] - holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] - cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] - imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] - thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] - cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] - 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" - , 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 - , test yes yes dcL7 tcDC "data constructor record #1029" - , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 - , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes xtcL5 xtc "type constructor external #717,1028" - , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes clL23 cls "class in instance declaration #1027" - , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes eclL15 ecls "external class in signature #717,1027" - , test yes yes dnbL29 dnb "do-notation bind #1073" - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind #1073" - , test yes yes lclL33 lcb "listcomp lookup" - , test yes yes mclL36 mcl "top-level fn 1st clause" - , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" - , if ghcVersion >= GHC810 then - test yes yes spaceL37 space "top-level fn on space #1002" - else - test yes broken spaceL37 space "top-level fn on space #1002" - , test no yes docL41 doc "documentation #1129" - , test no yes eitL40 kindE "kind of Either #1017" - , test no yes intL40 kindI "kind of Int #1017" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" - , test no broken intL41 litI "literal Int in hover info #1016" - , test no broken chrL36 litC "literal Char in hover info #1016" - , 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 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 -> - -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 - testM no yes reexported reexportedSig "Imported symbol (reexported)" - | otherwise -> - 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" - ] - where yes, broken :: (TestTree -> Maybe TestTree) - yes = Just -- test should run and pass - broken = Just . (`xfail` "known broken") - no = const Nothing -- don't run this test at all - skip = const Nothing -- unreliable, don't run - -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - diag - - -pluginSimpleTests :: TestTree -pluginSimpleTests = - ignoreInWindowsForGHC810 $ - -- Build profile: -w ghc-9.4.2 -O1 - -- In order, the following will be built (use -v for more details): - -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) - -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) - -- - plugin-1.0.0 (lib) (first run) - -- Starting ghc-typelits-natnormalise-0.7.7 (lib) - -- Building ghc-typelits-natnormalise-0.7.7 (lib) - - -- Failed to build ghc-typelits-natnormalise-0.7.7. - -- Build log ( - -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log - -- ): - -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. - -- Building library for ghc-typelits-natnormalise-0.7.7.. - -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) - -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) - -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) - -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory - - -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is - -- required by plugin-1.0.0). See the build log above for details. - ignoreFor (BrokenForGHC [GHC96]) "fragile, frequently times out" $ - ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ - testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DsError, (9, 15), "Variable not in scope: c")] - ) - ] - -pluginParsedResultTests :: TestTree -pluginParsedResultTests = - ignoreInWindowsForGHC810 $ - ignoreForGHC92Plus "No need for this plugin anymore!" $ - testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do - _ <- openDoc (dir "RecordDot.hs") "haskell" - expectNoMoreDiagnostics 2 - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do - let content = - T.unlines - [ "{-# LANGUAGE CPP #-}", - "module Testing where", - "#ifdef FOO", - "foo = 42" - ] - -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either - -- of them. - (run $ expectError content (2, maxBound)) - `catch` ( \e -> do - let _ = e :: HUnitFailure - run $ expectError content (2, 1) - ) - , testSessionWait "cpp-ghcide" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 - -preprocessorTests :: TestTree -preprocessorTests = testSessionWait "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (2, 8), "Variable not in scope: z")] - ) - ] - - -safeTests :: TestTree -safeTests = - testGroup - "SafeHaskell" - [ -- Test for https://github.com/haskell/ghcide/issues/424 - testSessionWait "load" $ do - let sourceA = - T.unlines - ["{-# LANGUAGE Trustworthy #-}" - ,"module A where" - ,"import System.IO.Unsafe" - ,"import System.IO ()" - ,"trustWorthyId :: a -> a" - ,"trustWorthyId i = unsafePerformIO $ do" - ," putStrLn \"I'm safe\"" - ," return i"] - sourceB = - T.unlines - ["{-# LANGUAGE Safe #-}" - ,"module B where" - ,"import A" - ,"safeId :: a -> a" - ,"safeId = trustWorthyId" - ] - - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectNoMoreDiagnostics 1 ] - -thTests :: TestTree -thTests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "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", [(DsError, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "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 - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True - -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "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", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] - , 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, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] - ] - --- | Tests for projects that use symbolic links one way or another -symlinkTests :: TestTree -symlinkTests = - testGroup "Projects using Symlinks" - [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do - liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") - let fooPath = dir "src" "Foo.hs" - _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])] - pure () - ] - --- | 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", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - - -- Change th from () to Bool - let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] - - -- Check that the change propagates to C - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) - ] - - 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", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - - let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - - -- modify b too - let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] - waitForProgressBegin - waitForAllProgressDone - - expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")] - - closeDoc adoc - closeDoc bdoc - where - name = "th-linking-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ - testGroup "non local" nonLocalCompletionTests - , testGroup "topLevel" topLevelCompletionTests - , testGroup "local" localCompletionTests - , testGroup "package" packageCompletionTests - , testGroup "project" projectCompletionTests - , testGroup "other" otherCompletionTests - , testGroup "doc" completionDocTests - ] - -completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree -completionTest name src pos expected = testSessionWait name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - let emptyToMaybe x = if T.null x then Nothing else Just x - liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do - CompletionItem{..} <- - if expectedSig || expectedDocs - then do - rsp <- request SCompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - else pure item - when expectedSig $ - liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) - - -topLevelCompletionTests :: [TestTree] -topLevelCompletionTests = [ - completionTest - "variable" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) - ], - completionTest - "constructor" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) - ], - completionTest - "class method" - ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing)], - completionTest - "type" - ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] - (Position 0 9) - [("Xzz", CiStruct, "Xzz", False, True, Nothing)], - completionTest - "class" - ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] - (Position 0 9) - [("Xzz", CiInterface, "Xzz", False, True, Nothing)], - completionTest - "records" - ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] - (Position 1 19) - [("_personName", CiFunction, "_personName", False, True, Nothing), - ("_personAge", CiFunction, "_personAge", False, True, Nothing)], - completionTest - "recordsConstructor" - ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] - (Position 1 19) - [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), - ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] - ] - -localCompletionTests :: [TestTree] -localCompletionTests = [ - completionTest - "argument" - ["bar (Just abcdef) abcdefg = abcd"] - (Position 0 32) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "let" - ["bar = let (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ," in abcd" - ] - (Position 2 15) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "where" - ["bar = abcd" - ," where (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ] - (Position 0 10) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "do/1" - ["bar = do" - ," Just abcdef <- undefined" - ," abcd" - ," abcdefg <- undefined" - ," pure ()" - ] - (Position 2 6) - [("abcdef", CiFunction, "abcdef", True, False, Nothing) - ], - completionTest - "do/2" - ["bar abcde = do" - ," Just [(abcdef,_)] <- undefined" - ," abcdefg <- undefined" - ," let abcdefgh = undefined" - ," (Just [abcdefghi]) = undefined" - ," abcd" - ," where" - ," abcdefghij = undefined" - ] - (Position 5 8) - [("abcde", CiFunction, "abcde", True, False, Nothing) - ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) - ,("abcdef", CiFunction, "abcdef", True, False, Nothing) - ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) - ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) - ], - completionTest - "type family" - ["{-# LANGUAGE DataKinds, TypeFamilies #-}" - ,"type family Bar a" - ,"a :: Ba" - ] - (Position 2 7) - [("Bar", CiStruct, "Bar", True, False, Nothing) - ], - completionTest - "class method" - [ - "class Test a where" - , " abcd :: a -> ()" - , " abcde :: a -> Int" - , "instance Test Int where" - , " abcd = abc" - ] - (Position 4 14) - [("abcd", CiFunction, "abcd", True, False, Nothing) - ,("abcde", CiFunction, "abcde", True, False, Nothing) - ], - testSessionWait "incomplete entries" $ do - let src a = "data Data = " <> a - doc <- createDoc "A.hs" "haskell" $ src "AAA" - void $ waitForTypecheck doc - let editA rhs = - changeDoc doc [TextDocumentContentChangeEvent - { _range=Nothing - , _rangeLength=Nothing - , _text=src rhs}] - - editA "AAAA" - void $ waitForTypecheck doc - editA "AAAAA" - void $ waitForTypecheck doc - - compls <- getCompletions doc (Position 0 15) - liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] - pure () - ] - -nonLocalCompletionTests :: [TestTree] -nonLocalCompletionTests = - [ brokenForWinGhc $ completionTest - "variable" - ["module A where", "f = hea"] - (Position 1 7) - [("head", CiFunction, "head", True, True, Nothing)], - completionTest - "constructor" - ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] - (Position 2 8) - [ ("True", CiConstructor, "True", True, True, Nothing) - ], - brokenForWinGhc $ completionTest - "type" - ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] - (Position 2 8) - [ ("Bool", CiStruct, "Bool", True, True, Nothing) - ], - completionTest - "qualified" - ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] - (Position 2 15) - [ ("head", CiFunction, "head", True, True, Nothing) - ], - completionTest - "duplicate import" - ["module A where", "import Data.List", "import Data.List", "f = permu"] - (Position 3 9) - [ ("permutations", CiFunction, "permutations", False, False, Nothing) - ], - completionTest - "dont show hidden items" - [ "{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", - "import Control.Monad hiding (join)", - "f = joi" - ] - (Position 3 6) - [], - testGroup "ordering" - [completionTest "qualified has priority" - ["module A where" - ,"import qualified Data.ByteString as BS" - ,"f = BS.read" - ] - (Position 2 10) - [("readFile", CiFunction, "readFile", True, True, Nothing)] - ], - -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls - completionTest - "do not show pragma completions" - [ "{-# LANGUAGE ", - "{module A where}", - "main = return ()" - ] - (Position 0 13) - [] - ] - where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" - -otherCompletionTests :: [TestTree] -otherCompletionTests = [ - completionTest - "keyword" - ["module A where", "f = newty"] - (Position 1 9) - [("newtype", CiKeyword, "", False, False, Nothing)], - completionTest - "type context" - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "f = f", - "g :: Intege" - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - (Position 3 11) - [("Integer", CiStruct, "Integer", True, True, Nothing)], - - testSession "duplicate record fields" $ do - void $ - createDoc "B.hs" "haskell" $ - T.unlines - [ "{-# LANGUAGE DuplicateRecordFields #-}", - "module B where", - "newtype Foo = Foo { member :: () }", - "newtype Bar = Bar { member :: () }" - ] - docA <- - createDoc "A.hs" "haskell" $ - T.unlines - [ "module A where", - "import B", - "memb" - ] - _ <- waitForDiagnostics - compls <- getCompletions docA $ Position 2 4 - let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ take 2 compls' @?= ["member"], - - testSessionWait "maxCompletions" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = Prelude." - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - liftIO $ length compls @?= maxCompletions def - ] - -packageCompletionTests :: [TestTree] -packageCompletionTests = - [ testSession' "fromList" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 12) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "fromList" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) ( - [ "'Data.List.NonEmpty" - , "'GHC.Exts" - ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) - - , testSessionWait "Map" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a :: Map" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 7) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "Map" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) - [ "'Data.Map" - , "'Data.Map.Lazy" - , "'Data.Map.Strict" - ] - , testSessionWait "no duplicates" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let duplicate = - filter - (\case - CompletionItem - { _insertText = Just "fromList" - , _documentation = - Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) - } -> - "GHC.Exts" `T.isInfixOf` d - _ -> False - ) compls - liftIO $ length duplicate @?= 1 - - , testSessionWait "non-local before global" $ do - -- non local completions are more specific - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let compls' = - [_insertText - | CompletionItem {_label, _insertText} <- compls - , _label == "fromList" - ] - liftIO $ take 3 compls' @?= - map Just ["fromList"] - ] - -projectCompletionTests :: [TestTree] -projectCompletionTests = - [ testSession' "from hiedb" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "b = anidenti" - ] - compls <- getCompletions doc (Position 1 10) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "anidentifier" - ] - liftIO $ compls' @?= ["Defined in 'A"], - testSession' "auto complete project imports" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" - _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines - [ "module ALocalModule (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import ALocal" - ] - compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls - liftIO $ do - item ^. Lens.label @?= "ALocalModule", - testSession' "auto complete functions from qualified imports without alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A", - "A." - ] - compls <- getCompletions doc (Position 2 2) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier", - testSession' "auto complete functions from qualified imports with alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A as Alias", - "foo = Alias." - ] - compls <- getCompletions doc (Position 2 12) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier" - ] - -completionDocTests :: [TestTree] -completionDocTests = - [ testSession "local define" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - let expected = "*Defined at line 2, column 1 in this module*\n" - test doc (Position 2 8) "foo" Nothing [expected] - , testSession "local empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , testSession "local single line doc without newline" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- |docdoc" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] - , testSession "local multi line doc with newline" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] - , testSession "local multi line doc without newline" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "--def" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] - , testSession "extern empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = od" - ] - 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 - 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 - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - , testSession "extern defined doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - ] - where - brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9" - 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" - test doc pos label mn expected = do - _ <- waitForDiagnostics - compls <- getCompletions doc pos - rcompls <- forM compls $ \item -> do - rsp <- request SCompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - let compls' = [ - -- We ignore doc uris since it points to the local path which determined by specific machines - case mn of - Nothing -> txt - Just n -> T.take n txt - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- rcompls - , _label == label - ] - liftIO $ compls' @?= expected - -highlightTests :: TestTree -highlightTests = testGroup "highlight" - [ testSessionWait "value" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 0 2 3) (Just HkRead) - , DocumentHighlight (R 3 0 3 3) (Just HkWrite) - , DocumentHighlight (R 4 6 4 9) (Just HkRead) - , DocumentHighlight (R 5 22 5 25) (Just HkRead) - ] - , testSessionWait "type" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 7 2 10) (Just HkRead) - , DocumentHighlight (R 3 11 3 14) (Just HkRead) - ] - , testSessionWait "local" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= List - [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) - , DocumentHighlight (R 6 10 6 13) (Just HkRead) - , DocumentHighlight (R 7 12 7 15) (Just HkRead) - ] - , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96] "Ghc9 highlights the constructor and not just this field" $ - testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= List - -- Span is just the .. on 8.10, but Rec{..} before - [ if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkWrite) - else DocumentHighlight (R 4 4 4 11) (Just HkWrite) - , DocumentHighlight (R 4 14 4 20) (Just HkRead) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= List - [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) - -- Span is just the .. on 8.10, but Rec{..} before - , if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkRead) - else DocumentHighlight (R 4 4 4 11) (Just HkRead) - ] - ] - where - source = T.unlines - ["{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"foo :: Int" - ,"foo = 3 :: Int" - ,"bar = foo" - ," where baz = let x = foo in x" - ,"baz arg = arg + x" - ," where x = arg" - ] - recsource = T.unlines - ["{-# LANGUAGE RecordWildCards #-}" - ,"{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"data Rec = Rec { field1 :: Int, field2 :: Char }" - ,"foo Rec{..} = field2 + field1" - ] - -outlineTests :: TestTree -outlineTests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SkInterface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "type family" SkFunction (R 1 0 1 15) - , docSymbol "A ()" SkInterface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "data family" SkFunction (R 1 0 1 11) - , docSymbol "A ()" SkInterface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a" SkFunction (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "Just foo" SkFunction (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" - SkStruct - (R 0 0 0 10) - [docSymbol "C" SkConstructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SkField (R 1 2 1 3) - , docSymbol "y" SkField (R 2 4 2 5) - ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) - , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SkFile - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just $ List cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SkInterface - Nothing - Nothing - loc - loc - (Just $ List cc) - -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) - -ignoreInWindowsForGHC810 :: TestTree -> TestTree -ignoreInWindowsForGHC810 = - ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" - -ignoreForGHC92Plus :: String -> TestTree -> TestTree -ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96]) - -knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree -knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) - -data BrokenOS = Linux | MacOS | Windows deriving (Show) - -data IssueSolution = Broken | Ignore deriving (Show) - -data BrokenTarget = - BrokenSpecific BrokenOS [GhcVersion] - -- ^Broken for `BrokenOS` with `GhcVersion` - | BrokenForOS BrokenOS - -- ^Broken for `BrokenOS` - | BrokenForGHC [GhcVersion] - -- ^Broken for `GhcVersion` - deriving (Show) - --- | Ignore test for specific os and ghc with reason. -ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree -ignoreFor = knownIssueFor Ignore - --- | Known broken for specific os and ghc with reason. -knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree -knownBrokenFor = knownIssueFor Broken - --- | Deal with `IssueSolution` for specific OS and GHC. -knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree -knownIssueFor solution = go . \case - BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers - BrokenForOS bos -> isTargetOS bos - BrokenForGHC vers -> isTargetGhc vers - where - isTargetOS = \case - Windows -> isWindows - MacOS -> isMac - Linux -> not isWindows && not isMac - - isTargetGhc = elem ghcVersion - - go True = case solution of - Broken -> expectFailBecause - Ignore -> ignoreTestBecause - go False = \_ -> id - -data Expect - = ExpectRange Range -- Both gotoDef and hover should report this range - | ExpectLocation Location --- | ExpectDefRange Range -- Only gotoDef should report this range - | ExpectHoverRange Range -- Only hover should report this range - | ExpectHoverText [T.Text] -- the hover message must contain these snippets - | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets - | ExpectHoverTextRegex T.Text -- the hover message must match this pattern - | ExpectExternFail -- definition lookup in other file expected to fail - | ExpectNoDefinitions - | ExpectNoHover --- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples - deriving Eq - -mkR :: UInt -> UInt -> UInt -> UInt -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect -mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn - -haddockTests :: TestTree -haddockTests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - , testCase "ordered list" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt - -cradleTests :: TestTree -cradleTests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ] - -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct - ] - where - direct dir = do - liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - test dir - implicit dir = test dir - test _dir = do - doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - -retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do - -- The false cradle always fails - let hieContents = "cradle: {bios: {shell: \"false\"}}" - hiePath = dir "hie.yaml" - liftIO $ writeFile hiePath hieContents - let aPath = dir "A.hs" - doc <- createDoc aPath "haskell" "main = return ()" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess - - -- Fix the cradle and typecheck again - let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" - liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess - - -dependentFileTest :: TestTree -dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [testSession' "test" test] - ] - where - test dir = do - -- If the file contains B then no type error - -- otherwise type error - let depFilePath = dir "dep-file.txt" - liftIO $ writeFile depFilePath "A" - let fooContent = T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module Foo where" - , "import Language.Haskell.TH.Syntax" - , "foo :: Int" - , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" - , " if f == \"B\" then [| 1 |] else lift f)" - ] - 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", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] - -- Now modify the dependent file - liftIO $ writeFile depFilePath "B" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri "dep-file.txt") FcChanged ] - - -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 2 0) (Position 2 6)) - , _rangeLength = Nothing - , _text = "f = ()" - } - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] - - -cradleLoadedMessage :: Session FromServerMessage -cradleLoadedMessage = satisfy $ \case - FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod - _ -> False - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - -ignoreFatalWarning :: TestTree -ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do - let srcPath = dir "IgnoreFatal.hs" - src <- liftIO $ readFileUtf8 srcPath - _ <- createDoc srcPath "haskell" src - expectNoMoreDiagnostics 5 - -simpleSubDirectoryTest :: TestTree -simpleSubDirectoryTest = - testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do - let mainPath = dir "a/src/Main.hs" - mainSource <- liftIO $ readFileUtf8 mainPath - _mdoc <- createDoc mainPath "haskell" mainSource - expectDiagnosticsWithTags - [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded - ] - expectNoMoreDiagnostics 0.5 - -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- openDoc aPath "haskell" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc - liftIO $ assertBool "A should typecheck" ideResultSuccess - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc - liftIO $ assertBool "B should typecheck" ideResultSuccess - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: TestTree -simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Now with 3 components -simpleMultiTest3 :: TestTree -simpleMultiTest3 = - testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - cPath = dir "c/C.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - cdoc <- openDoc cPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc - locs <- getDefinitions cdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in component 'a' in a separate session -simpleMultiDefTest :: TestTree -simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- liftIO $ runInDir dir $ do - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource - skipManyTill anyMessage $ isReferenceReady aPath - closeDoc adoc - pure adoc - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - -ifaceTests :: TestTree -ifaceTests = testGroup "Interface loading tests" - [ -- https://github.com/haskell/ghcide/pull/645/ - ifaceErrorTest - , ifaceErrorTest2 - , ifaceErrorTest3 - , ifaceTHTest - ] - -bootTests :: TestTree -bootTests = testGroup "boot" - [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - -- We send a hover request then wait for either the hover response or - -- `ghcide/reference/ready` notification. - -- Once we receive one of the above, we wait for the other that we - -- haven't received yet. - -- If we don't wait for the `ready` notification it is possible - -- that the `getDefinitions` request/response in the outer ghcide - -- session will find no definitions. - let hoverParams = HoverParams cDoc (Position 4 3) Nothing - hoverRequestId <- sendRequest STextDocumentHover hoverParams - let parseReadyMessage = isReferenceReady cPath - let parseHoverResponse = responseForId STextDocumentHover hoverRequestId - hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) - _ <- skipManyTill anyMessage $ - case hoverResponseOrReadyMessage of - Left _ -> void parseReadyMessage - Right _ -> void parseHoverResponse - closeDoc cDoc - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) - , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir "A.hs") "haskell" - expectNoMoreDiagnostics 2 - ] - --- | test that TH reevaluates across interfaces -ifaceTHTest :: TestTree -ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () - _bSource <- liftIO $ readFileUtf8 bPath -- a :: () - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - cdoc <- createDoc cPath "haskell" cSource - - -- Change [TH]a from () to Bool - liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) - - -- Check that the change propagates to C - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - closeDoc cdoc - -ifaceErrorTest :: TestTree -ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do - configureCheckProject True - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - -- save so that we can that the error propagates to A - sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) - - - -- Check that the error propagates to A - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] - - -- Check that we wrote the interfaces for B when we saved - hidir <- getInterfaceFilesDir bdoc - hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" - liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists - - pdoc <- openDoc pPath "haskell" - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ] - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - -- This is clearly inconsistent, and the expected outcome a bit surprising: - -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics - -- - P is being typechecked with the last successful artifacts for A. - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -ifaceErrorTest2 :: TestTree -ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - expectDiagnostics - -- As in the other test, P is being typechecked with the last successful artifacts for A - -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) - ] - - expectNoMoreDiagnostics 2 - -ifaceErrorTest3 :: TestTree -ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- P should not typecheck, as there are no last valid artifacts for A - _pdoc <- createDoc pPath "haskell" pSource - - -- In this example the interface file for A should not exist (modulo the cache folder) - -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' - "session-deps-are-picked-up" - $ \dir -> do - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "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", [(DsError, (3, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] - -- Update hie.yaml to enable OverloadedStrings. - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - -- Send change event. - let change = - TextDocumentContentChangeEvent - { _range = Just (Range (Position 4 0) (Position 4 0)), - _rangeLength = Nothing, - _text = "\n" - } - changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] - where - fooContent = - T.unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "foo = \"hello\"" - ] - --- A test to ensure that the command line ghcide workflow stays working -nonLspCommandLine :: TestTree -nonLspCommandLine = testGroup "ghcide command line" - [ testCase "works" $ withTempDir $ \dir -> do - ghcide <- locateGhcideExecutable - copyTestDataFiles dir "multi" - let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} - - setEnv "HOME" "/homeless-shelter" False - - (ec, _, _) <- readCreateProcessWithExitCode cmd "" - - ec @?= ExitSuccess - ] - --- | checks if we use InitializeParams.rootUri for loading session -rootUriTests :: TestTree -rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do - let bPath = dir "dirB/Foo.hs" - liftIO $ copyTestDataFiles dir "rootUri" - bSource <- liftIO $ readFileUtf8 bPath - _ <- createDoc "Foo.hs" "haskell" bSource - expectNoMoreDiagnostics 0.5 - where - -- similar to run' except we can configure where to start ghcide and session - runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) - --- | Test if ghcide asynchronously handles Commands and user Requests -asyncTests :: TestTree -asyncTests = testGroup "async" - [ - testSession "command" $ do - -- Execute a command that will block forever - let req = ExecuteCommandParams Nothing blockCommandId Nothing - void $ sendRequest SWorkspaceExecuteCommand req - -- Load a file and check for code actions. Will only work if the command is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - , testSession "request" $ do - -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 - -- Load a file and check for code actions. Will only work if the request is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - ] - - -clientSettingsTest :: TestTree -clientSettingsTest = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message SClientRegisterCapability - void $ createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - sendNotification SWorkspaceDidChangeConfiguration - (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) - skipManyTill anyMessage restartingBuildSession - - ] - where - restartingBuildSession :: Session () - restartingBuildSession = do - FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification - guard $ "Restarting build session" `T.isInfixOf` _message - -referenceTests :: TestTree -referenceTests = testGroup "references" - [ testGroup "can get references to FOIs" - [ referenceTest "can get references to symbols" - ("References.hs", 4, 7) - YesIncludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "can get references to data constructor" - ("References.hs", 13, 2) - YesIncludeDeclaration - [ ("References.hs", 13, 2) - , ("References.hs", 16, 14) - , ("References.hs", 19, 21) - ] - - , referenceTest "getting references works in the other module" - ("OtherModule.hs", 6, 0) - YesIncludeDeclaration - [ ("OtherModule.hs", 6, 0) - , ("OtherModule.hs", 8, 16) - ] - - , referenceTest "getting references works in the Main module" - ("Main.hs", 9, 0) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 10, 4) - ] - - , referenceTest "getting references to main works" - ("Main.hs", 5, 0) - YesIncludeDeclaration - [ ("Main.hs", 4, 0) - , ("Main.hs", 5, 0) - ] - - , referenceTest "can get type references" - ("Main.hs", 9, 9) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 9, 9) - , ("Main.hs", 10, 0) - ] - - , expectFailBecause "references provider does not respect includeDeclaration parameter" $ - referenceTest "works when we ask to exclude declarations" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - ] - - , testGroup "can get references to non FOIs" - [ referenceTest "can get references to symbol defined in a module we import" - ("References.hs", 22, 4) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references in modules that import us to symbols we define" - ("OtherModule.hs", 4, 0) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references to symbol defined in a module we import transitively" - ("References.hs", 24, 4) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get references in modules that import us transitively to symbols we define" - ("OtherOtherModule.hs", 2, 0) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get type references to other modules" - ("Main.hs", 12, 10) - YesIncludeDeclaration - [ ("Main.hs", 12, 7) - , ("Main.hs", 13, 0) - , ("References.hs", 12, 5) - , ("References.hs", 16, 0) - ] - ] - ] - --- | When we ask for all references to symbol "foo", should the declaration "foo --- = 2" be among the references returned? -data IncludeDeclaration = - YesIncludeDeclaration - | NoExcludeDeclaration - -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) -getReferences' (file, l, c) includeDeclaration = do - doc <- openDoc file "haskell" - getReferences doc (Position l c) $ toBool includeDeclaration - where toBool YesIncludeDeclaration = True - toBool NoExcludeDeclaration = False - -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - -- needed to build whole project indexing - configureCheckProject True - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f dir - closeDoc docid - --- | Given a location, lookup the symbol and all references to it. Make sure --- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree -referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do - List actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected - where - docs = map fst3 expected - -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line . to fromIntegral - , location ^. L.range . L.start . L.character . to fromIntegral)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - ----------------------------------------------------------------------- --- Utils ----------------------------------------------------------------------- - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree -testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix - -testSession' :: String -> (FilePath -> Session ()) -> TestTree -testSession' name = testCase name . run' - -testSessionWait :: HasCallStack => String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -mkRange :: UInt -> UInt -> UInt -> UInt -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = run' (const s) - -runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a -runWithExtraFiles prefix s = withTempDir $ \dir -> do - copyTestDataFiles dir prefix - runInDir dir (s dir) - -copyTestDataFiles :: FilePath -> FilePath -> IO () -copyTestDataFiles dir prefix = do - -- Copy all the test data files to the temporary workspace - testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] - for_ testDataFiles $ \f -> do - createDirectoryIfMissing True $ dir takeDirectory f - copyFile ("test/data" prefix f) (dir f) - -run' :: (FilePath -> Session a) -> IO a -run' s = withTempDir $ \dir -> runInDir dir (s dir) - -runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' dir "." "." [] - -withLongTimeout :: IO a -> IO a -withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") - --- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' = runInDir'' lspTestCaps - -runInDir'' - :: ClientCapabilities - -> FilePath - -> FilePath - -> FilePath - -> [String] - -> Session b - -> IO b -runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do - - ghcideExe <- locateGhcideExecutable - let startDir = dir startExeIn - let projDir = dir startSessionIn - - createDirectoryIfMissing True startDir - createDirectoryIfMissing True projDir - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ projDir ++ "/Data" - - shakeProfiling <- getEnv "SHAKE_PROFILING" - let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir - ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] - ] ++ extraOptions - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspCaps projDir $ do - configureCheckProject False - s - - -getConfigFromEnv :: IO SessionConfig -getConfigFromEnv = do - logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" - timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - return defaultConfig - { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride - , logColor - } - where - checkEnv :: String -> IO (Maybe Bool) - checkEnv s = fmap convertVal <$> getEnv s - convertVal "0" = False - convertVal _ = True - -lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - -lspTestCapsNoFileWatches :: ClientCapabilities -lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - createDoc path "haskell" source - -unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree -unitTests recorder logger = do - testGroup "Unit" - [ testCase "empty file path does NOT work with the empty String literal" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." - , testCase "empty file path works using toNormalizedFilePath'" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" - , testCase "empty path URI" $ do - Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) - uriScheme @?= "file:" - uriPath @?= "" - , testCase "from empty path URI" $ do - let uri = Uri "file://" - uriToFilePath' uri @?= Just "" - , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do - let diag = ("", Diagnostics.ShowDiag, Diagnostic - { _range = Range - { _start = Position{_line = 0, _character = 1} - , _end = Position{_line = 2, _character = 3} - } - , _severity = Nothing - , _code = Nothing - , _source = Nothing - , _message = "" - , _relatedInformation = Nothing - , _tags = Nothing - }) - let shown = T.unpack (Diagnostics.showDiagnostics [diag]) - let expected = "1:2-3:4" - assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ - expected `isInfixOf` shown - , testCase "notification handlers run in priority order" $ do - orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ - [ (priorityPluginDescriptor i) - { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> - liftIO $ atomicModifyIORef_ orderRef (i:) - ] - } - | i <- [1..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} - - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do - _ <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - actualOrder <- liftIO $ reverse <$> readIORef orderRef - - -- Handlers are run in priority descending order - liftIO $ actualOrder @?= [20, 19 .. 1] - , ignoreTestBecause "The test fails sometimes showing 10000us" $ - testCase "timestamps have millisecond resolution" $ do - resolution_us <- findResolution_us 1 - let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us - assertBool msg (resolution_us <= 1000) - , Progress.tests - , FuzzySearch.tests - ] - -garbageCollectionTests :: TestTree -garbageCollectionTests = testGroup "garbage collection" - [ testGroup "dirty keys" - [ testSession' "are collected" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - doc <- generateGarbage "A" dir - closeDoc doc - garbage <- waitForGC - liftIO $ assertBool "no garbage was found" $ not $ null garbage - - , testSession' "are deleted from the state" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - docA <- generateGarbage "A" dir - keys0 <- getStoredKeys - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keys1 <- getStoredKeys - liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) - - , testSession' "are not regenerated unless needed" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" - docA <- generateGarbage "A" dir - _docB <- generateGarbage "B" dir - - -- garbage collect A keys - keysBeforeGC <- getStoredKeys - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keysAfterGC <- getStoredKeys - liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" - (length keysAfterGC < length keysBeforeGC) - - -- re-typecheck B and check that the keys for A have not materialized back - _docB <- generateGarbage "B" dir - keysB <- getStoredKeys - let regeneratedKeys = Set.filter (not . isExpected) $ - Set.intersection (Set.fromList garbage) (Set.fromList keysB) - liftIO $ regeneratedKeys @?= mempty - - , testSession' "regenerate successfully" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - docA <- generateGarbage "A" dir - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "no garbage was found" $ not $ null garbage - let edit = T.unlines - [ "module A where" - , "a :: Bool" - , "a = ()" - ] - doc <- generateGarbage "A" dir - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] - builds <- waitForTypecheck doc - liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] - ] - ] - where - isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] - - generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier - generateGarbage modName dir = do - let fp = modName <> ".hs" - body = printf "module %s where" modName - doc <- createDoc fp "haskell" (T.pack body) - liftIO $ writeFile (dir fp) body - builds <- waitForTypecheck doc - liftIO $ assertBool "something is wrong with this test" builds - return doc - -findResolution_us :: Int -> IO Int -findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" -findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do - performGC - writeFile f "" - threadDelay delay_us - writeFile f' "" - t <- getModTime f - t' <- getModTime f' - if t /= t' then return delay_us else findResolution_us (delay_us * 10) - - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session - -positionMappingTests :: Recorder (WithPriority Log) -> TestTree -positionMappingTests recorder = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= PositionExact (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= PositionExact (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= PositionExact (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= PositionExact (Position 1 2) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 0 4) @?= PositionExact (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= PositionExact (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= PositionExact (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= PositionExact (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 2 1) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 1) - ] - , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" - [ testProperty "fromCurrent r t <=< toCurrent r t" $ do - -- Note that it is important to use suchThatMap on all values at once - -- instead of only using it on the position. Otherwise you can get - -- into situations where there is no position that can be mapped back - -- for the edit which will result in QuickCheck looping forever. - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - oldPos <- genPosition rope - pure (range, replacement, oldPos) - forAll - (suchThatMap gen - (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === PositionExact oldPos - , testProperty "toCurrent r t <=< fromCurrent r t" $ do - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - let newRope = runIdentity $ applyChange mempty rope - (TextDocumentContentChangeEvent (Just range) Nothing replacement) - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === PositionExact newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral row) r) - column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt - pure $ Position (fromIntegral row) (fromIntegral column) - -genRange :: Rope -> Gen Range -genRange r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine - endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral endLine) r) - endColumn <- - if fromIntegral startLine == endLine - then choose (fromIntegral startColumn, columns) - else choose (0, max 0 $ columns - 1) - `suchThat` inBounds @UInt - pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) - -inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool -inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> T.Text -nthLine i r - | Rope.null r = "" - | otherwise = Rope.lines r !! i - -getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] -getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) - return - [ args - | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs - ] - --- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path --- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or --- @/var@ -withTempDir :: (FilePath -> IO a) -> IO a -withTempDir f = System.IO.Extra.withTempDir $ \dir -> do - dir' <- canonicalizePath dir - f dir' - - --- | 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]" - --- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did -thDollarIdx :: UInt -thDollarIdx | ghcVersion >= GHC90 = 1 - | otherwise = 0 + + +module Main (main) where +-- import Test.QuickCheck.Instances () +import Data.Function ((&)) +import Ide.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, + cmapWithPrio, + makeDefaultStderrRecorder) +import GHC.Stack (emptyCallStack) +import qualified HieDbRetry +import Test.Tasty +import Test.Tasty.Ingredients.Rerun + +import LogType () +import OpenCloseTest +import InitializeResponseTests +import CompletionTests +import CPPTests +import DiagnosticTests +import CodeLensTests +import OutlineTests +import HighlightTests +import FindDefinitionAndHoverTests +import PluginSimpleTests +import PluginParsedResultTests +import PreprocessorTests +import THTests +import SymlinkTests +import SafeTests +import UnitTests +import HaddockTests +import PositionMappingTests +import WatchedFileTests +import CradleTests +import DependentFileTest +import NonLspCommandLine +import IfaceTests +import BootTests +import RootUriTests +import AsyncTests +import ClientSettingsTests +import ReferenceTests +import GarbageCollectionTests +import ExceptionTests + +main :: IO () +main = do + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) + + let recorder = docWithFilteredPriorityRecorder + & cmapWithPrio pretty + + -- We mess with env vars so run single-threaded. + defaultMainWithRerun $ testGroup "ghcide" + [ OpenCloseTest.tests + , InitializeResponseTests.tests + , CompletionTests.tests + , CPPTests.tests + , DiagnosticTests.tests + , CodeLensTests.tests + , OutlineTests.tests + , HighlightTests.tests + , FindDefinitionAndHoverTests.tests + , PluginSimpleTests.tests + , PluginParsedResultTests.tests + , PreprocessorTests.tests + , THTests.tests + , SymlinkTests.tests + , SafeTests.tests + , UnitTests.tests recorder logger + , HaddockTests.tests + , PositionMappingTests.tests + , WatchedFileTests.tests + , CradleTests.tests + , DependentFileTest.tests + , NonLspCommandLine.tests + , IfaceTests.tests + , BootTests.tests + , RootUriTests.tests + , AsyncTests.tests + , ClientSettingsTests.tests + , ReferenceTests.tests + , GarbageCollectionTests.tests + , HieDbRetry.tests + , ExceptionTests.tests recorder logger + ] diff --git a/test/exe/NonLspCommandLine.hs b/test/exe/NonLspCommandLine.hs new file mode 100644 --- /dev/null +++ b/test/exe/NonLspCommandLine.hs @@ -0,0 +1,27 @@ + +module NonLspCommandLine (tests) where + +import Development.IDE.Test.Runfiles +import System.Environment.Blank (setEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process.Extra (CreateProcess (cwd), proc, + readCreateProcessWithExitCode) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +-- A test to ensure that the command line ghcide workflow stays working +tests :: TestTree +tests = testGroup "ghcide command line" + [ testCase "works" $ withTempDir $ \dir -> do + ghcide <- locateGhcideExecutable + copyTestDataFiles dir "multi" + let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} + + setEnv "HOME" "/homeless-shelter" False + + (ec, _, _) <- readCreateProcessWithExitCode cmd "" + + ec @?= ExitSuccess + ] diff --git a/test/exe/OpenCloseTest.hs b/test/exe/OpenCloseTest.hs new file mode 100644 --- /dev/null +++ b/test/exe/OpenCloseTest.hs @@ -0,0 +1,18 @@ + +module OpenCloseTest (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Language.LSP.Protocol.Message +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + closeDoc doc + waitForProgressDone diff --git a/test/exe/OutlineTests.hs b/test/exe/OutlineTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/OutlineTests.hs @@ -0,0 +1,189 @@ + +module OutlineTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a _x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" + SymbolKind_Struct + (R 0 0 0 10) + [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) + , docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) + , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/test/exe/PluginParsedResultTests.hs b/test/exe/PluginParsedResultTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/PluginParsedResultTests.hs @@ -0,0 +1,17 @@ + +module PluginParsedResultTests (tests) where + +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + ignoreInWindowsForGHC810 $ + ignoreForGHC92Plus "No need for this plugin anymore!" $ + testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do + _ <- openDoc (dir "RecordDot.hs") "haskell" + expectNoMoreDiagnostics 2 diff --git a/test/exe/PluginSimpleTests.hs b/test/exe/PluginSimpleTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/PluginSimpleTests.hs @@ -0,0 +1,51 @@ + +module PluginSimpleTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + ignoreInWindowsForGHC810 $ + -- Build profile: -w ghc-9.4.2 -O1 + -- In order, the following will be built (use -v for more details): + -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) + -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) + -- - plugin-1.0.0 (lib) (first run) + -- Starting ghc-typelits-natnormalise-0.7.7 (lib) + -- Building ghc-typelits-natnormalise-0.7.7 (lib) + + -- Failed to build ghc-typelits-natnormalise-0.7.7. + -- Build log ( + -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log + -- ): + -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. + -- Building library for ghc-typelits-natnormalise-0.7.7.. + -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) + -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) + -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) + -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory + + -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is + -- required by plugin-1.0.0). See the build log above for details. + ignoreFor (BrokenForGHC [GHC96]) "fragile, frequently times out" $ + ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ + testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do + _ <- openDoc (dir "KnownNat.hs") "haskell" + liftIO $ writeFile (dir"hie.yaml") + "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" + + expectDiagnostics + [ ( "KnownNat.hs", + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] + ) + ] diff --git a/test/exe/PositionMappingTests.hs b/test/exe/PositionMappingTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/PositionMappingTests.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedLabels #-} + +module PositionMappingTests (tests) where + +import Data.Row +import qualified Data.Text as T +import Data.Text.Utf16.Rope (Rope) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE.Core.PositionMapping (PositionResult (..), + fromCurrent, + positionResultToMaybe, + toCurrent) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.VFS (applyChange) +import Test.QuickCheck +-- import Test.QuickCheck.Instances () +import Data.Functor.Identity (runIdentity) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup "position mapping" + [ testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= PositionExact (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= PositionExact (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= PositionExact (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= PositionExact (Position 1 2) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 0 4) @?= PositionExact (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= PositionExact (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= PositionExact (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= PositionExact (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 2 1) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 1) + ] + , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" + [ testProperty "fromCurrent r t <=< toCurrent r t" $ do + -- Note that it is important to use suchThatMap on all values at once + -- instead of only using it on the position. Otherwise you can get + -- into situations where there is no position that can be mapped back + -- for the edit which will result in QuickCheck looping forever. + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + oldPos <- genPosition rope + pure (range, replacement, oldPos) + forAll + (suchThatMap gen + (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === PositionExact oldPos + , testProperty "toCurrent r t <=< fromCurrent r t" $ do + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + let newRope = runIdentity $ applyChange mempty rope + (TextDocumentContentChangeEvent $ InL $ #range .== range + .+ #rangeLength .== Nothing + .+ #text .== replacement) + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === PositionExact newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral row) r) + column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt + pure $ Position (fromIntegral row) (fromIntegral column) + +genRange :: Rope -> Gen Range +genRange r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine + endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral endLine) r) + endColumn <- + if fromIntegral startLine == endLine + then choose (fromIntegral startColumn, columns) + else choose (0, max 0 $ columns - 1) + `suchThat` inBounds @UInt + pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) + +inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool +inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> T.Text +nthLine i r + | Rope.null r = "" + | otherwise = Rope.lines r !! i diff --git a/test/exe/PreprocessorTests.hs b/test/exe/PreprocessorTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/PreprocessorTests.hs @@ -0,0 +1,27 @@ + +module PreprocessorTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] + ) + ] diff --git a/test/exe/ReferenceTests.hs b/test/exe/ReferenceTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/ReferenceTests.hs @@ -0,0 +1,199 @@ + +module ReferenceTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import qualified Data.Set as Set +import Development.IDE.Test (configureCheckProject, + referenceReady) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location]) +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + -- needed to build whole project indexing + configureCheckProject True + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line . Lens.to fromIntegral + , location ^. L.range . L.start . L.character . Lens.to fromIntegral)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' diff --git a/test/exe/RootUriTests.hs b/test/exe/RootUriTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/RootUriTests.hs @@ -0,0 +1,26 @@ + +module RootUriTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +-- | checks if we use InitializeParams.rootUri for loading session +tests :: TestTree +tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do + let bPath = dir "dirB/Foo.hs" + liftIO $ copyTestDataFiles dir "rootUri" + bSource <- liftIO $ readFileUtf8 bPath + _ <- createDoc "Foo.hs" "haskell" bSource + expectNoMoreDiagnostics 0.5 + where + -- similar to run' except we can configure where to start ghcide and session + runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () + runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) diff --git a/test/exe/SafeTests.hs b/test/exe/SafeTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/SafeTests.hs @@ -0,0 +1,38 @@ + +module SafeTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test + +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/haskell/ghcide/issues/424 + testSessionWait "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO ()" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] diff --git a/test/exe/SymlinkTests.hs b/test/exe/SymlinkTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/SymlinkTests.hs @@ -0,0 +1,27 @@ + +module SymlinkTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.Test (expectDiagnosticsWithTags) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath + +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +-- | Tests for projects that use symbolic links one way or another +tests :: TestTree +tests = + testGroup "Projects using Symlinks" + [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do + liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") + let fooPath = dir "src" "Foo.hs" + _ <- openDoc fooPath "haskell" + expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] + pure () + ] diff --git a/test/exe/THTests.hs b/test/exe/THTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/THTests.hs @@ -0,0 +1,194 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module THTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +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 +import TestUtils + +tests :: TestTree +tests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/haskell/ghcide/pull/212 + testSessionWait "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")] ) ] + , testSessionWait "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 + , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 + , thLinkingTest False + , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True + , testSessionWait "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 ()")] ) ] + , 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")] ) ] + ] + + +-- | 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,thDollarIdx), "Top-level binding")])] + + -- Change th from () to Bool + let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] + -- generate an artificial warning to avoid timing out if the TH change does not propagate + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ 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'")]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")]) + ] + + 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,thDollarIdx), "Top-level binding")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource'] + waitForProgressBegin + waitForAllProgressDone + + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")] + + closeDoc adoc + closeDoc bdoc + where + name = "th-linking-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" diff --git a/test/exe/TestUtils.hs b/test/exe/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/exe/TestUtils.hs @@ -0,0 +1,329 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} + +module TestUtils where + +import Control.Applicative.Combinators +import Control.Concurrent.Async +import Control.Exception (bracket_, finally) +import Control.Lens ((.~)) +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Foldable +import Data.Function ((&)) +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import qualified Development.IDE.Main as IDE +import Development.IDE.Test (canonicalizeUri, + configureCheckProject, + expectNoMoreDiagnostics) +import Development.IDE.Test.Runfiles +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.Environment.Blank (getEnv, setEnv, unsetEnv) +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.Process.Extra (createPipe) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit + +import LogType + +-- | Wait for the next progress begin step +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just () + _ -> Nothing + +-- | Wait for the first progress end step +-- Also implemented in hls-test-utils Test.Hls +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () + _ -> Nothing + +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return +-- Also implemented in hls-test-utils Test.Hls +waitForAllProgressDone :: Session () +waitForAllProgressDone = loop + where + loop = do + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () + _ -> Nothing + done <- null <$> getIncompleteProgressSessions + unless done loop + +run :: Session a -> IO a +run s = run' (const s) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runInDir' dir "." "." [] + +-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. +runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a +runInDir' = runInDir'' lspTestCaps + +runInDir'' + :: ClientCapabilities + -> FilePath + -> FilePath + -> FilePath + -> [String] + -> Session b + -> IO b +runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do + + ghcideExe <- locateGhcideExecutable + let startDir = dir startExeIn + let projDir = dir startSessionIn + + createDirectoryIfMissing True startDir + createDirectoryIfMissing True projDir + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ projDir ++ "/Data" + + shakeProfiling <- getEnv "SHAKE_PROFILING" + let cmd = unwords $ + [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir + ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] + ] ++ extraOptions + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + conf <- getConfigFromEnv + runSessionWithConfig conf cmd lspCaps projDir $ do + configureCheckProject False + s + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +getConfigFromEnv :: IO SessionConfig +getConfigFromEnv = do + logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" + timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" + return defaultConfig + { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logColor + } + where + checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> getEnv s + convertVal "0" = False + convertVal _ = True + +testSessionWait :: HasCallStack => String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +ignoreInWindowsBecause :: String -> TestTree -> TestTree +ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) + +ignoreInWindowsForGHC810 :: TestTree -> TestTree +ignoreInWindowsForGHC810 = + ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" + +ignoreForGHC92Plus :: String -> TestTree -> TestTree +ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96]) + +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) + +data BrokenOS = Linux | MacOS | Windows deriving (Show) + +data IssueSolution = Broken | Ignore deriving (Show) + +data BrokenTarget = + BrokenSpecific BrokenOS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS BrokenOS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Known broken for specific os and ghc with reason. +knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree +knownBrokenFor = knownIssueFor Broken + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = \_ -> id + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets + | ExpectHoverTextRegex T.Text -- the hover message must match this pattern + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +mkR :: UInt -> UInt -> UInt -> UInt -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + + + +testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +testSession' :: String -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + + + +mkRange :: UInt -> UInt -> UInt -> UInt -> Range +mkRange a b c d = Range (Position a b) (Position c d) + + +runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") + + + +lspTestCapsNoFileWatches :: ClientCapabilities +lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "test/data" path + createDoc path "haskell" source + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () +checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where + check (ExpectRange expectedRange) = do + assertNDefinitionsFound 1 defs + assertRangeCorrect (head defs) expectedRange + check (ExpectLocation expectedLocation) = do + assertNDefinitionsFound 1 defs + liftIO $ do + canonActualLoc <- canonicalizeLocation (head defs) + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoDefinitions = do + assertNDefinitionsFound 0 defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertNDefinitionsFound :: Int -> [a] -> Session () + assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + +canonicalizeLocation :: Location -> IO Location +canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range + +defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] +defToLocation (InL (Definition (InL l))) = [l] +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 + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session diff --git a/test/exe/UnitTests.hs b/test/exe/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/UnitTests.hs @@ -0,0 +1,110 @@ + +module UnitTests (tests) where + +import Control.Concurrent +import Control.Monad.IO.Class (liftIO) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef_) +import Data.List.Extra +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE.Core.FileStore (getModTime) +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Types.Diagnostics as Diagnostics +import Development.IDE.Types.Location +import qualified FuzzySearch +import Ide.Logger (Logger, Recorder, + WithPriority, cmapWithPrio) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import LogType (Log (..)) +import Network.URI +import qualified Progress +import System.IO.Extra hiding (withTempDir) +import System.Mem (performGC) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils +import Text.Printf (printf) + +tests :: Recorder (WithPriority Log) -> Logger -> TestTree +tests recorder logger = do + testGroup "Unit" + [ testCase "empty file path does NOT work with the empty String literal" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." + , testCase "empty file path works using toNormalizedFilePath'" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" + , testCase "empty path URI" $ do + Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) + uriScheme @?= "file:" + uriPath @?= "" + , testCase "from empty path URI" $ do + let uri = Uri "file://" + uriToFilePath' uri @?= Just "" + , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do + let diag = ("", Diagnostics.ShowDiag, Diagnostic + { _codeDescription = Nothing + , _data_ = Nothing + , _range = Range + { _start = Position{_line = 0, _character = 1} + , _end = Position{_line = 2, _character = 3} + } + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = "" + , _relatedInformation = Nothing + , _tags = Nothing + }) + let shown = T.unpack (Diagnostics.showDiagnostics [diag]) + let expected = "1:2-3:4" + assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ + expected `isInfixOf` shown + , testCase "notification handlers run in priority order" $ do + orderRef <- newIORef [] + let plugins = pluginDescToIdePlugins $ + [ (priorityPluginDescriptor i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [1..20] + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} + + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + actualOrder <- liftIO $ reverse <$> readIORef orderRef + + -- Handlers are run in priority descending order + liftIO $ actualOrder @?= [20, 19 .. 1] + , ignoreTestBecause "The test fails sometimes showing 10000us" $ + testCase "timestamps have millisecond resolution" $ do + resolution_us <- findResolution_us 1 + let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us + assertBool msg (resolution_us <= 1000) + , Progress.tests + , FuzzySearch.tests + ] + +findResolution_us :: Int -> IO Int +findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" +findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do + performGC + writeFile f "" + threadDelay delay_us + writeFile f' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) diff --git a/test/exe/WatchedFileTests.hs b/test/exe/WatchedFileTests.hs new file mode 100644 --- /dev/null +++ b/test/exe/WatchedFileTests.hs @@ -0,0 +1,83 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} + +module WatchedFileTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "watched files" + [ testGroup "Subscriptions" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + , testSession' "non workspace file" $ \sessionDir -> do + tmpDir <- liftIO getTemporaryDirectory + let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" + liftIO $ writeFile (sessionDir "hie.yaml") yaml + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + -- TODO add a test for didChangeWorkspaceFolder + ] + , testGroup "Changes" + [ + testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Bool" + ,"b = False"] + _doc <- createDoc "A.hs" "haskell" $ T.unlines + ["module A where" + ,"import B" + ,"a :: ()" + ,"a = b" + ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] + -- modify B off editor + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Int" + ,"b = 0"] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] + ] + ] + +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + return + [ x + | Just TRequestMessage{_params = RegistrationParams regs} <- msgs + , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs + , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] + ] diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -43,20 +43,20 @@ import Data.Default import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic +import GHC.TypeLits ( symbolVal ) import Ide.Plugin.Config (CheckParents, checkProject) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Lens as Lsp import System.Directory (canonicalizePath) import System.FilePath (equalFilePath) import System.Time.Extra @@ -75,23 +75,23 @@ -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout = - expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. params . uri - actual = diagsNot ^. params . diagnostics - unless (actual == List []) $ liftIO $ + expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do + let fileUri = diagsNot ^. L.params . L.uri + actual = diagsNot ^. L.params . L.diagnostics + unless (actual == []) $ liftIO $ assertFailure $ "Got unexpected diagnostics for " <> show fileUri <> " got " <> show actual -expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () +expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session () expectMessages m timeout handle = do -- Give any further diagnostic messages time to arrive. liftIO $ sleep timeout -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount go cm i where @@ -102,7 +102,7 @@ flushMessages :: Session () flushMessages = do - let cm = SCustomMethod "non-existent-method" + let cm = SMethod_CustomMethod (Proxy @"non-existent-method") i <- sendRequest cm A.Null void (responseForId cm i) <|> ignoreOthers cm i where @@ -118,8 +118,8 @@ = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) -unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) +unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) +unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do @@ -130,13 +130,13 @@ expectDiagnosticsWithTags' :: (HasCallStack, MonadIO m) => - m (Uri, List Diagnostic) -> + m (Uri, [Diagnostic]) -> Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> m () expectDiagnosticsWithTags' next m | null m = do (_,actual) <- next case actual of - List [] -> + [] -> return () _ -> liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual @@ -178,19 +178,19 @@ checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] nuri = toNormalizedUri _uri - expectDiagnosticsWithTags' (return (_uri, List obtained)) expected' + expectDiagnosticsWithTags' (return (_uri, obtained)) expected' canonicalizeUri :: Uri -> IO Uri canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) -diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) -diagnostic = LspTest.message STextDocumentPublishDiagnostics +diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) tryCallTestPlugin cmd = do - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ case _result of Left e -> Left e Right json -> case A.fromJSON json of @@ -230,8 +230,8 @@ waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res waitForCustomMessage msg pred = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value}) - | lbl == msg -> pred value + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value}) + | symbolVal p == T.unpack msg -> pred value _ -> Nothing waitForGC :: Session [T.Text] @@ -242,7 +242,7 @@ configureCheckProject :: Bool -> Session () configureCheckProject overrideCheckProject = - sendNotification SWorkspaceDidChangeConfiguration + sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) @@ -252,9 +252,10 @@ referenceReady :: (FilePath -> Bool) -> Session FilePath referenceReady pred = satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params}) + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) | A.Success fp <- A.fromJSON _params , pred fp + , symbolVal p == "ghcide/reference/ready" -> Just fp _ -> Nothing diff --git a/test/src/Development/IDE/Test/Diagnostic.hs b/test/src/Development/IDE/Test/Diagnostic.hs --- a/test/src/Development/IDE/Test/Diagnostic.hs +++ b/test/src/Development/IDE/Test/Diagnostic.hs @@ -1,10 +1,10 @@ module Development.IDE.Test.Diagnostic where -import Control.Lens ((^.)) -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Language.LSP.Types -import Language.LSP.Types.Lens as Lsp +import Control.Lens ((^.)) +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Language.LSP.Protocol.Lens +import Language.LSP.Protocol.Types -- | (0-based line number, 0-based column number) type Cursor = (UInt, UInt) @@ -33,10 +33,10 @@ standardizeQuotes (T.toLower $ d ^. message) && hasTag expectedTag (d ^. tags) - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just tags) = actualTag `elem` tags standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let