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.9.0.1 +version: 2.10.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -14,15 +14,10 @@ https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 || ==9.2.8 +tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 extra-source-files: CHANGELOG.md README.md - test/data/**/*.cabal - test/data/**/*.hs - test/data/**/*.hs-boot - test/data/**/*.project - test/data/**/*.yaml source-repository head type: git @@ -81,16 +76,18 @@ , hie-bios ^>=0.14.0 , hie-compat ^>=0.3.0.0 , hiedb ^>= 0.6.0.0 - , hls-graph == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , hls-graph == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens + , lens-aeson , list-t , lsp ^>=2.7 , lsp-types ^>=2.3 , mtl , opentelemetry >=0.6.1 , optparse-applicative + , os-string , parallel , prettyprinter >=1.7 , prettyprinter-ansi-terminal @@ -150,7 +147,9 @@ Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.CmdLine + Development.IDE.GHC.Compat.Driver Development.IDE.GHC.Compat.Env + Development.IDE.GHC.Compat.Error Development.IDE.GHC.Compat.Iface Development.IDE.GHC.Compat.Logger Development.IDE.GHC.Compat.Outputable @@ -208,20 +207,6 @@ if flag(pedantic) ghc-options: -Werror - -flag test-exe - description: Build the ghcide-test-preprocessor executable - default: True - -executable ghcide-test-preprocessor - import: warnings - default-language: GHC2021 - hs-source-dirs: test/preprocessor - main-is: Main.hs - build-depends: base >=4 && <5 - - if !flag(test-exe) - buildable: False flag executable description: Build the ghcide executable 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 @@ -8,7 +8,7 @@ (SessionLoadingOptions(..) ,CacheDirs(..) ,loadSessionWithOptions - ,setInitialDynFlags + ,getInitialGhcLibDirDefault ,getHieDbLoc ,retryOnSqliteBusy ,retryOnException @@ -62,8 +62,7 @@ import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, - newHscEnvEqPreserveImportPaths) +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) import Development.IDE.Types.Location import Development.IDE.Types.Options import GHC.ResponseFile @@ -101,36 +100,32 @@ import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set +import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Core.WorkerThread (awaitRunInThread, withWorkerQueue) +import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..), toNoFileKey) +import GHC.Data.Graph.Directed import HieDb.Create import HieDb.Types -import HieDb.Utils import Ide.PluginUtils (toAbsolute) import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if MIN_VERSION_ghc(9,3,0) -import qualified Data.Set as OS -import qualified Development.IDE.GHC.Compat.Util as Compat -import GHC.Data.Graph.Directed - -import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State + +#if MIN_VERSION_ghc(9,13,0) +import GHC.Driver.Make (checkHomeUnitsClosed) #endif data Log @@ -245,13 +240,6 @@ , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) -#if !MIN_VERSION_ghc(9,3,0) - , fakeUid :: UnitId - -- ^ unit id used to tag the internal component built by ghcide - -- To reuse external interface files the unit ids must match, - -- thus make sure to build them with `--this-unit-id` set to the - -- same value as the ghcide fake uid -#endif } instance Default SessionLoadingOptions where @@ -260,9 +248,6 @@ ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault -#if !MIN_VERSION_ghc(9,3,0) - ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") -#endif } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -303,15 +288,6 @@ logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone pure Nothing --- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) -setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do - libdir <- getInitialGhcLibDir recorder rootDir - dynFlags <- mapM dynFlagsForPrinting libdir - logWith recorder Debug LogSettingInitialDynFlags - mapM_ setUnsafeGlobalDynFlags dynFlags - pure libdir - -- | If the action throws exception that satisfies predicate then we sleep for -- a duration determined by the random exponential backoff formula, -- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try @@ -540,26 +516,17 @@ _inplace = map rawComponentUnitId $ NE.toList all_deps all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv -#if MIN_VERSION_ghc(9,3,0) - let (df2, uids) = (rawComponentDynFlags, []) -#else - let (df2, uids) = _removeInplacePackages fakeUid _inplace rawComponentDynFlags -#endif let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] - let hscComponents = sort $ map show uids - cacheDirOpts = hscComponents ++ componentOptions opts + let cacheDirOpts = componentOptions opts cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs df2 + processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded -- into the same component. pure $ ComponentInfo { componentUnitId = rawComponentUnitId , componentDynFlags = processed_df - , componentInternalUnits = uids , componentTargets = rawComponentTargets , componentFP = rawComponentFP , componentCOptions = rawComponentCOptions @@ -585,8 +552,8 @@ -- For GHC's supporting multi component sessions, we create a shared -- HscEnv but set the active component accordingly hscEnv <- emptyHscEnv ideNc _libDir - let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv - all_target_details <- new_cache old_deps new_deps rootDir + let new_cache = newComponentCache recorder optExtensions _cfp hscEnv + all_target_details <- new_cache old_deps new_deps this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) @@ -599,10 +566,11 @@ this_flags = (this_error_env, this_dep_info) this_error_env = ([this_error], Nothing) this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - $ T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ] + (T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ]) + Nothing void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) @@ -771,24 +739,13 @@ PreferSingleComponentLoading -> LoadFile PreferMultiComponentLoading -> LoadWithContext old_fps -#if MIN_VERSION_ghc(9,3,0) emptyHscEnv :: NameCache -> FilePath -> IO HscEnv -#else -emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv -#endif emptyHscEnv nc libDir = do -- We call setSessionDynFlags so that the loader is initialised -- We need to do this before we call initUnits. env <- runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession - -- On GHC 9.2 calling setSessionDynFlags caches the unit databases - -- for an empty environment. This prevents us from reading the - -- package database subsequently. So clear the unit db cache in - -- hsc_unit_dbs pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) -#if !MIN_VERSION_ghc(9,3,0) - {hsc_unit_dbs = Nothing} -#endif data TargetDetails = TargetDetails { @@ -826,23 +783,23 @@ [ (l, (targetEnv, targetDepends)) | l <- targetLocations] -#if MIN_VERSION_ghc(9,3,0) setNameCache :: NameCache -> HscEnv -> HscEnv -#else -setNameCache :: IORef NameCache -> HscEnv -> HscEnv -#endif setNameCache nc hsc = hsc { hsc_NC = nc } -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,13,0) +-- Moved back to implementation in GHC. +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] +checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue +#elif MIN_VERSION_ghc(9,3,0) -- This function checks the important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -- GHC had an implementation of this function, but it was horribly inefficient -- We should move back to the GHC implementation on compilers where -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included -checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) checkHomeUnitsClosed' ue home_id_set - | OS.null bad_unit_ids = [] - | otherwise = [singleMessage $ GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)] + | OS.null bad_unit_ids = Nothing + | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) where bad_unit_ids = upwards_closure OS.\\ home_id_set rootLoc = mkGeneralSrcSpan (Compat.fsLit "") @@ -865,7 +822,7 @@ where go rest this this_uis = plusUniqMap_C OS.union - (addToUniqMap_C OS.union external_depends this (OS.fromList $ this_deps)) + (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps)) rest where external_depends = mapUniqMap (OS.fromList . unitDepends) @@ -899,14 +856,12 @@ newComponentCache :: Recorder (WithPriority Log) -> [String] -- ^ File extensions to consider - -> Maybe FilePath -- ^ Path to cradle -> NormalizedFilePath -- ^ Path to file that caused the creation of this component -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components - -> FilePath -- ^ root dir, see Note [Root Directory] -> IO [ [TargetDetails] ] -newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do +newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, -- prefer the new one over the old. @@ -920,18 +875,22 @@ hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 Compat.initUnits dfs hsc_env -#if MIN_VERSION_ghc(9,3,0) - let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs + let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') + closure_err_to_multi_err err = + ideErrorWithSource + (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp + (T.pack (Compat.printWithoutUniques (singleMessage err))) +#if MIN_VERSION_ghc(9,5,0) + (Just (fmap GhcDriverMessage err)) +#else + Nothing +#endif + multi_errs = map closure_err_to_multi_err closure_errs bad_units = OS.fromList $ concat $ do - x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs + x <- map errMsgDiagnostic closure_errs DriverHomePackagesNotClosed us <- pure x pure us isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units -#else - let isBad = const False - multi_errs = [] -#endif -- Whenever we spin up a session on Linux, dynamically load libm.so.6 -- in. We need this in case the binary is statically linked, in which -- case the interactive session will fail when trying to load @@ -951,26 +910,12 @@ forM (Map.elems cis) $ \ci -> do let df = componentDynFlags ci - let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath thisEnv <- do -#if MIN_VERSION_ghc(9,3,0) -- In GHC 9.4 we have multi component support, and we have initialised all the units -- above. -- We just need to set the current unit here pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' -#else - -- This initializes the units for GHC 9.2 - -- Add the options for the current component to the HscEnv - -- We want to call `setSessionDynFlags` instead of `hscSetFlags` - -- because `setSessionDynFlags` also initializes the package database, - -- which we need for any changes to the package flags in the dynflags - -- to be visible. - -- See #2693 - evalGhcEnv hscEnv' $ do - _ <- setSessionDynFlags df - getSession -#endif - henv <- createHscEnvEq thisEnv (zip uids dfs) + henv <- newHscEnvEq thisEnv let targetEnv = (if isBad ci then multi_errs else [], Just henv) targetDepends = componentDependencyInfo ci logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) @@ -1076,10 +1021,6 @@ -- | Processed DynFlags. Does not contain inplace packages such as local -- libraries. Can be used to actually load this Component. , componentDynFlags :: DynFlags - -- | Internal units, such as local libraries, that this component - -- is loaded with. These have been extracted from the original - -- ComponentOptions. - , componentInternalUnits :: [UnitId] -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component @@ -1201,7 +1142,6 @@ initOne this_opts = do (dflags', targets') <- addCmdOpts this_opts dflags let dflags'' = -#if MIN_VERSION_ghc(9,3,0) case unitIdString (homeUnitId_ dflags') of -- cabal uses main for the unit id of all executable packages -- This makes multi-component sessions confused about what @@ -1210,13 +1150,10 @@ -- 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 $ this_opts) + let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) in setHomeUnitId_ hashed_uid dflags' _ -> dflags' -#else - dflags' -#endif let targets = makeTargetsAbsolute root targets' root = case workingDirectory dflags'' of @@ -1236,14 +1173,7 @@ Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory dflags'' - -- initPackages parses the -package flags and - -- sets up the visibility for each component. - -- Throws if a -package flag cannot be satisfied. - -- This only works for GHC <9.2 - -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which - -- is done later in newComponentCache - final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags''' - return (final_flags, targets) + return (dflags''', targets) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = @@ -1289,12 +1219,6 @@ instance Exception PackageSetupException --- | Wrap any exception as a 'PackageSetupException' -wrapPackageSetupException :: IO a -> IO a -wrapPackageSetupException = handleAny $ \case - e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE - e -> (throwIO . PackageSetupException . show) e - showPackageSetupException :: PackageSetupException -> String showPackageSetupException GhcVersionMismatch{..} = unwords ["ghcide compiled against GHC" @@ -1308,6 +1232,6 @@ , "failed to load packages:", message <> "." , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] -renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) +renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing diff --git a/session-loader/Development/IDE/Session/Diagnostics.hs b/session-loader/Development/IDE/Session/Diagnostics.hs --- a/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/session-loader/Development/IDE/Session/Diagnostics.hs @@ -2,6 +2,7 @@ module Development.IDE.Session.Diagnostics where import Control.Applicative +import Control.Lens import Control.Monad import qualified Data.Aeson as Aeson import Data.List @@ -27,11 +28,13 @@ Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp - | HieBios.isCabalCradle cradle = - let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in - (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) - | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage +renderCradleError (CradleError deps _ec ms) cradle nfp = + let noDetails = + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing + in + if HieBios.isCabalCradle cradle + then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} + else noDetails where absDeps = fmap (cradleRootDir cradle ) deps userFriendlyMessage :: [String] diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -10,7 +10,9 @@ getDefinition, getTypeDefinition) import Development.IDE.Core.FileExists as X (getFileExists) -import Development.IDE.Core.FileStore as X (getFileContents) +import Development.IDE.Core.FileStore as X (getFileContents, + getFileModTimeContents, + getUriContents) import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterestUntracked) @@ -50,7 +52,6 @@ import Development.IDE.Plugin as X import Development.IDE.Types.Diagnostics as X import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..), - hscEnv, - hscEnvWithImportPaths) + hscEnv) import Development.IDE.Types.Location 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 @@ -3,6 +3,7 @@ ( getAtPoint , getDefinition , getTypeDefinition +, getImplementationDefinition , highlightAtPoint , refsAtPoint , workspaceSymbols @@ -66,56 +67,68 @@ !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' --- | For each Location, 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 +-- | Converts locations in the source code to their current positions, +-- taking into account changes that may have occurred due to edits. +toCurrentLocation :: PositionMapping -> NormalizedFilePath - -> [Location] - -> IdeAction [Location] -toCurrentLocations mapping file = mapMaybeM go + -> Location + -> IdeAction (Maybe Location) +toCurrentLocation mapping file (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 - 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 + nUri :: NormalizedUri + nUri = toNormalizedUri uri -- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst file (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' - MaybeT $ Just <$> toCurrentLocations mapping file locations + locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + mapMaybeM (\(location, identifier) -> do + fixedLocation <- MaybeT $ toCurrentLocation mapping file location + pure $ Just (fixedLocation, identifier) + ) locationsWithIdentifier -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) + +getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' - MaybeT $ Just <$> toCurrentLocations mapping file locations + locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + mapMaybeM (\(location, identifier) -> do + fixedLocation <- MaybeT $ toCurrentLocation mapping file location + pure $ Just (fixedLocation, identifier) + ) locationsWithIdentifier + +getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getImplementationDefinition file pos = runMaybeT $ do + ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask + opts <- liftIO $ getIdeOptionsIO ide + (hf, mapping) <- useWithStaleFastMT GetHieAst file + !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) + locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos' + traverse (MaybeT . toCurrentLocation mapping file) locs highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do 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 @@ -36,103 +36,109 @@ , sourceTypecheck , sourceParser , shareUsages + , setNonHomeFCHook ) where -import Control.Concurrent.Extra -import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (NFData (..), force, rnf) -import Control.Exception (evaluate) +import Control.Concurrent.STM.Stats hiding (orElse) +import Control.DeepSeq (NFData (..), force, + rnf) +import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Lens hiding (List, pre, (<.>)) +import Control.Lens hiding (List, pre, + (<.>)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Except -import qualified Control.Monad.Trans.State.Strict as S -import Data.Aeson (toJSON) -import Data.Bifunctor (first, second) +import qualified Control.Monad.Trans.State.Strict as S +import Data.Aeson (toJSON) +import Data.Bifunctor (first, second) import Data.Binary -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.Coerce -import qualified Data.DList as DL +import qualified Data.DList as DL import Data.Functor import Data.Generics.Aliases import Data.Generics.Schemes -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) +import qualified Data.HashMap.Strict as HashMap +import Data.IntMap (IntMap) import Data.IORef import Data.List.Extra -import qualified Data.Map.Strict as Map +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Proxy (Proxy (Proxy)) -import qualified Data.Text as T -import Data.Time (UTCTime (..)) -import Data.Tuple.Extra (dupe) -import Data.Unique as Unique +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import Data.Time (UTCTime (..), getCurrentTime) +import Data.Tuple.Extra (dupe) import Debug.Trace -import Development.IDE.Core.FileStore (resetInterfaceStore) +import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor +import Development.IDE.Core.ProgressReporting (progressUpdate) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.GHC.Compat hiding (loadInterface, - parseHeader, parseModule, - tcRnModule, writeHieFile, assert) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as GHC -import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.GHC.Compat hiding (assert, + loadInterface, + parseHeader, + parseModule, + tcRnModule, + writeHieFile) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error -import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import Development.IDE.GHC.Warnings import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC (ForeignHValue, - GetDocsFailure (..), - parsedSource) -import qualified GHC.LanguageExtensions as LangExt +import GHC (ForeignHValue, + GetDocsFailure (..), + parsedSource, ModLocation (..)) +import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized -import HieDb hiding (withHieDb) -import qualified Language.LSP.Protocol.Message as LSP -import Language.LSP.Protocol.Types (DiagnosticTag (..)) -import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Server as LSP -import Prelude hiding (mod) +import HieDb hiding (withHieDb) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DiagnosticTag (..)) +import qualified Language.LSP.Server as LSP +import Prelude hiding (mod) import System.Directory import System.FilePath -import System.IO.Extra (fixIO, newTempFileWithin) +import System.IO.Extra (fixIO, + newTempFileWithin) -import qualified GHC as G +import qualified Data.Set as Set +import qualified GHC as G +import qualified GHC.Runtime.Loader as Loader import GHC.Tc.Gen.Splice +import GHC.Types.Error import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.TypeEnv -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import Data.Map (Map) -import GHC.Unit.Module.Graph (ModuleGraph) -import Unsafe.Coerce -#endif -#if MIN_VERSION_ghc(9,3,0) -import qualified Data.Set as Set -#endif - #if MIN_VERSION_ghc(9,5,0) import GHC.Core.Lint.Interactive import GHC.Driver.Config.CoreToStg.Prep #endif #if MIN_VERSION_ghc(9,7,0) -import Data.Foldable (toList) +import Data.Foldable (toList) import GHC.Unit.Module.Warnings #else -import Development.IDE.Core.FileStore (shareFilePath) +import Development.IDE.Core.FileStore (shareFilePath) #endif +import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics) + +import Development.IDE.Import.DependencyInformation +import GHC.Driver.Env ( hsc_all_home_unit_ids ) +import Development.IDE.Import.FindImports + --Simple constants to make sure the source is consistently named sourceTypecheck :: T.Text sourceTypecheck = "typecheck" @@ -160,13 +166,18 @@ -> IO (Either [FileDiagnostic] [UnitId]) computePackageDeps env pkg = do case lookupUnit env pkg of - Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ - T.pack $ "unknown package: " ++ show pkg] + Nothing -> + return $ Left + [ ideErrorText + (toNormalizedFilePath' noFilePath) + (T.pack $ "unknown package: " ++ show pkg) + ] Just pkgInfo -> return $ Right $ unitDepends pkgInfo -newtype TypecheckHelpers +data TypecheckHelpers = TypecheckHelpers { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files + , getModuleGraph :: IO DependencyInformation } typecheckModule :: IdeDefer @@ -178,24 +189,28 @@ let modSummary = pm_mod_summary pm dflags = ms_hspp_opts modSummary initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" - (initPlugins hsc modSummary) + (Loader.initializePlugins (hscSetFlags (ms_hspp_opts modSummary) hsc)) case initialized of Left errs -> return (errs, Nothing) - Right (modSummary', hscEnv) -> do - (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak -> + Right hscEnv -> do + etcm <- let - session = tweak (hscSetFlags dflags hscEnv) - -- TODO: maybe settings ms_hspp_opts is unnecessary? - mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} + -- TODO: maybe setting ms_hspp_opts is unnecessary? + mod_summary' = modSummary { ms_hspp_opts = hsc_dflags hscEnv} in catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do - tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} - let errorPipeline = unDefer . hideDiag dflags . tagDiag - diags = map errorPipeline warnings - deferredError = any fst diags + tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'} case etcm of - Left errs -> return (map snd diags ++ errs, Nothing) - Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) + Left errs -> return (errs, Nothing) + Right tcm -> + let addReason diag = + map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ + diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag + errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason + diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm + deferredError = any fst diags + in + return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -223,11 +238,7 @@ -- come from in the IORef,, as these are the modules on whose implementation -- we depend. compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr -#if MIN_VERSION_ghc(9,3,0) -> IO (ForeignHValue, [Linkable], PkgsLoaded) -#else - -> IO ForeignHValue -#endif compile_bco_hook var hsc_env srcspan ds_expr = do { let dflags = hsc_dflags hsc_env @@ -247,10 +258,8 @@ ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", -#if MIN_VERSION_ghc(9,3,0) ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file", ml_dyn_hi_file = panic "hscCompileCoreExpr':ml_dyn_hi_file", -#endif ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } ; let ictxt = hsc_IC hsc_env @@ -259,9 +268,7 @@ myCoreToStgExpr (hsc_logger hsc_env) (hsc_dflags hsc_env) ictxt -#if MIN_VERSION_ghc(9,3,0) True -- for bytecode -#endif (icInteractiveModule ictxt) iNTERACTIVELoc prepd_expr @@ -271,6 +278,9 @@ (icInteractiveModule ictxt) stg_expr [] Nothing +#if MIN_VERSION_ghc(9,11,0) + [] -- spt_entries +#endif -- Exclude wired-in names because we may not have read -- their interface files, so getLinkDeps will fail @@ -279,11 +289,7 @@ -- Find the linkables for the modules we need ; let needed_mods = mkUniqSet [ -#if MIN_VERSION_ghc(9,3,0) mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids -#else - moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same -#endif | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos , not (isWiredInName n) -- Exclude wired-in names @@ -291,51 +297,33 @@ , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set ] home_unit_ids = -#if MIN_VERSION_ghc(9,3,0) map fst (hugElts $ hsc_HUG hsc_env) -#else - [homeUnitId_ dflags] -#endif mods_transitive = getTransitiveMods hsc_env needed_mods -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same mods_transitive_list = -#if MIN_VERSION_ghc(9,3,0) mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive -#else - -- Non det OK as we will put it into maps later anyway - map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive -#endif -#if MIN_VERSION_ghc(9,3,0) - ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env) -#else - ; moduleLocs <- readIORef (hsc_FC hsc_env) -#endif - ; lbs <- getLinkables [toNormalizedFilePath' file + ; moduleLocs <- getModuleGraph + ; lbs <- getLinkables [file | installedMod <- mods_transitive_list - , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs installedMod - file = case ifr of - InstalledFound loc _ -> - fromJust $ ml_hs_file loc - _ -> panic "hscCompileCoreExprHook: module not found" + , let file = fromJust $ lookupModuleFile (installedMod { moduleUnit = RealUnit (Definite $ moduleUnit installedMod) }) moduleLocs ] ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env -#if MIN_VERSION_ghc(9,3,0) {- load it -} - ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos - ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs) +#if MIN_VERSION_ghc(9,11,0) + ; bco_time <- getCurrentTime + ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan $ + Linkable bco_time (icInteractiveModule ictxt) $ NE.singleton $ BCOs bcos #else - {- load it -} - ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos - ; let hval = expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs + ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos #endif + ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs, lbss, pkgs) ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb]) ; return hval } -#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 @@ -346,28 +334,13 @@ nodeKeyToInstalledModule _ = Nothing moduleToNodeKey :: Module -> NodeKey moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) -#endif -- Compute the transitive set of linkables required getTransitiveMods hsc_env needed_mods -#if MIN_VERSION_ghc(9,3,0) = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] ]) where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after -#else - = go emptyUniqSet needed_mods - where - hpt = hsc_HPT hsc_env - go seen new - | isEmptyUniqSet new = seen - | otherwise = go seen' new' - where - seen' = seen `unionUniqSets` new - new' = new_deps `minusUniqSet` seen' - new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info - | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] -#endif -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information @@ -408,12 +381,12 @@ let ms = pm_mod_summary pmod hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env - ((tc_gbl_env', mrn_info), splices, mod_env) + (((tc_gbl_env', mrn_info), warning_messages), splices, mod_env) <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp -> - do hscTypecheckRename hscEnvTmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } + do hscTypecheckRenameWithDiagnostics hscEnvTmp ms $ + HsParsedModule { hpm_module = parsedSource pmod + , hpm_src_files = pm_extra_src_files pmod + } let rn_info = case mrn_info of Just x -> x Nothing -> error "no renamed info tcRnModule" @@ -422,7 +395,7 @@ mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash) (moduleEnvToList mod_env) tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } - pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) + pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages) -- Note [Clearing mi_globals after generating an iface] @@ -442,12 +415,8 @@ -- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information -- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH] filterUsages :: [Usage] -> [Usage] -#if MIN_VERSION_ghc(9,3,0) filterUsages = filter $ \case UsageHomeModuleInterface{} -> False _ -> True -#else -filterUsages = id -#endif -- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 -- Important to do this immediately after reading the unit before @@ -473,7 +442,14 @@ details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv iface' <- mkIfaceTc hsc_env_tmp sf details ms Nothing tcGblEnv - let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface] + -- See Note [Clearing mi_globals after generating an iface] + let iface = iface' +#if MIN_VERSION_ghc(9,11,0) + & set_mi_top_env Nothing + & set_mi_usages (filterUsages (mi_usages iface')) +#else + { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } +#endif pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing mkHiFileResultCompile @@ -498,8 +474,9 @@ (cg_binds guts) #endif details -#if MIN_VERSION_ghc(9,3,0) ms +#if MIN_VERSION_ghc(9,11,0) + (tcg_import_decls (tmrTypechecked tcm)) #endif simplified_guts @@ -507,7 +484,17 @@ #if MIN_VERSION_ghc(9,4,2) Nothing #endif - let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface] +#if MIN_VERSION_ghc(9,11,0) + NoStubs [] +#endif + -- See Note [Clearing mi_globals after generating an iface] + let final_iface = final_iface' +#if MIN_VERSION_ghc(9,11,0) + & set_mi_top_env Nothing + & set_mi_usages (filterUsages (mi_usages final_iface')) +#else + {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} +#endif -- Write the core file now core_file <- do @@ -515,7 +502,7 @@ core_file = codeGutsToCoreFile iface_hash guts iface_hash = getModuleHash final_iface core_hash1 <- atomicFileWrite se core_fp $ \fp -> - writeBinCoreFile fp core_file + writeBinCoreFile (hsc_dflags session) fp core_file -- We want to drop references to guts and read in a serialized, compact version -- of the core file from disk (as it is deserialised lazily) -- This is because we don't want to keep the guts in memory for every file in @@ -552,17 +539,9 @@ -- Run corePrep first as we want to test the final version of the program that will -- get translated to STG/Bytecode -#if MIN_VERSION_ghc(9,3,0) prepd_binds -#else - (prepd_binds , _) -#endif <- corePrep unprep_binds data_tycons -#if MIN_VERSION_ghc(9,3,0) prepd_binds' -#else - (prepd_binds', _) -#endif <- corePrep unprep_binds' data_tycons let binds = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds' @@ -599,8 +578,14 @@ source = "compile" catchErrs x = x `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException + , Handler $ \diag -> + return + ( diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show @SomeException diag) + Nothing + , Nothing + ) ] -- | Whether we should run the -O0 simplifier when generating core. @@ -659,11 +644,7 @@ let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) target = platformDefaultBackend (hsc_dflags env') newFlags = setBackend target $ updOptLevel 0 $ setOutputFile -#if MIN_VERSION_ghc(9,3,0) (Just dot_o) -#else - dot_o -#endif $ hsc_dflags env' session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,4,2) @@ -674,18 +655,16 @@ (ms_location summary) fp obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) -#if MIN_VERSION_ghc(9,3,0) case obj of Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code" Just x -> pure x -#else - return obj -#endif - let unlinked = DotO dot_o_fp -- Need time to be the modification time for recompilation checking t <- liftIO $ getModificationTime dot_o_fp - let linkable = LM t mod [unlinked] - +#if MIN_VERSION_ghc(9,11,0) + let linkable = Linkable t mod (pure $ DotO dot_o_fp ModuleObject) +#else + let linkable = LM t mod [DotO dot_o_fp] +#endif pure (map snd warnings, linkable) newtype CoreFileTime = CoreFileTime UTCTime @@ -694,15 +673,22 @@ generateByteCode (CoreFileTime time) hscEnv summary guts = do fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do +#if MIN_VERSION_ghc(9,11,0) + (warnings, (_, bytecode)) <- +#else (warnings, (_, bytecode, sptEntries)) <- +#endif withWarnings "bytecode" $ \_tweak -> do let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) -- TODO: maybe settings ms_hspp_opts is unnecessary? summary' = summary { ms_hspp_opts = hsc_dflags session } hscInteractive session (mkCgInteractiveGuts guts) (ms_location summary') - let unlinked = BCOs bytecode sptEntries - let linkable = LM time (ms_mod summary) [unlinked] +#if MIN_VERSION_ghc(9,11,0) + let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode) +#else + let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries] +#endif pure (map snd warnings, linkable) demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule @@ -725,34 +711,23 @@ update_pm_mod_summary up pm = pm{pm_mod_summary = up $ pm_mod_summary pm} -#if MIN_VERSION_ghc(9,3,0) unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic) unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors) , fd) = (True, upgradeWarningToError fd) unDefer (Just (WarningWithFlag Opt_WarnTypedHoles) , fd) = (True, upgradeWarningToError fd) unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd) -#else -unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) -unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = (True, upgradeWarningToError fd) -unDefer (Reason Opt_WarnTypedHoles , fd) = (True, upgradeWarningToError fd) -unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd) -#endif unDefer ( _ , fd) = (False, fd) upgradeWarningToError :: FileDiagnostic -> FileDiagnostic -upgradeWarningToError (nfp, sh, fd) = - (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where +upgradeWarningToError = + fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag} + where warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" -#if MIN_VERSION_ghc(9,3,0) hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) -hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd)) -#else -hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd)) -#endif +hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd) | not (wopt warning originalFlags) - = (w, (nfp, HideDiag, fd)) + = (w, fd { fdShouldShowDiagnostic = HideDiag }) hideDiag _originalFlags t = t -- | Warnings which lead to a diagnostic tag @@ -773,29 +748,21 @@ ] -- | Add a unnecessary/deprecated tag to the required diagnostics. -#if MIN_VERSION_ghc(9,3,0) tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) -#else -tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -#endif #if MIN_VERSION_ghc(9,7,0) -tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd)) +tagDiag (w@(Just (WarningWithCategory cat)), fd) | cat == defaultWarningCategory -- default warning category is for deprecations - = (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) })) -tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd)) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) +tagDiag (w@(Just (WarningWithFlags warnings)), fd) | tags <- mapMaybe requiresTag (toList warnings) - = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) })) -#elif MIN_VERSION_ghc(9,3,0) -tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd)) - | Just tag <- requiresTag warning - = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) })) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) #else -tagDiag (w@(Reason warning), (nfp, sh, fd)) +tagDiag (w@(Just (WarningWithFlag warning)), fd) | Just tag <- requiresTag warning - = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) })) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) }) #endif - where + where requiresTag :: WarningFlag -> Maybe DiagnosticTag #if !MIN_VERSION_ghc(9,7,0) -- doesn't exist on 9.8, we use WarningWithCategory instead @@ -822,33 +789,43 @@ (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) `onException` cleanUp -generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) +generateHieAsts :: HscEnv -> TcModuleResult +#if MIN_VERSION_ghc(9,11,0) + -> IO ([FileDiagnostic], Maybe (HieASTs Type, NameEntityInfo)) +#else + -> IO ([FileDiagnostic], Maybe (HieASTs Type)) +#endif generateHieAsts hscEnv tcm = handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do -- These varBinds use unitDataConId but it could be anything as the id name is not used -- during the hie file generation process. It's a workaround for the fact that the hie modules -- don't export an interface which allows for additional information to be added to hie files. - let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm)) + let fake_splice_binds = +#if !MIN_VERSION_ghc(9,11,0) + Util.listToBag $ +#endif + map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm) real_binds = tcg_binds $ tmrTypechecked tcm + all_binds = +#if MIN_VERSION_ghc(9,11,0) + fake_splice_binds ++ real_binds +#else + fake_splice_binds `Util.unionBags` real_binds +#endif ts = tmrTypechecked tcm :: TcGblEnv top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon] - run ts $ -#if MIN_VERSION_ghc(9,3,0) - pure $ Just $ -#else - Just <$> + hie_asts = GHC.enrichHie all_binds (tmrRenamed tcm) top_ev_binds insts tcs + + pure $ Just $ +#if MIN_VERSION_ghc(9,11,0) + hie_asts (tcg_type_env ts) +#elif MIN_VERSION_ghc(9,3,0) + hie_asts #endif - GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs where dflags = hsc_dflags hscEnv - run _ts = -- ts is only used in GHC 9.2 -#if !MIN_VERSION_ghc(9,3,0) - fmap (join . snd) . liftIO . initDs hscEnv _ts -#else - id -#endif spliceExpressions :: Splices -> [LHsExpr GhcTc] spliceExpressions Splices{..} = @@ -890,7 +867,6 @@ -- indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do - IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do pending <- readTVar indexPending case HashMap.lookup srcPath pending of @@ -911,69 +887,14 @@ unless newerScheduled $ do -- 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 $ + bracket_ pre 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 HieDbWriter{..} = hiedbWriter se - -- Get a progress token to report progress and update it for the current file - pre style = do - tok <- modifyVar indexProgressToken $ fmap dupe . \case - x@(Just _) -> pure x - -- Create a token if we don't already have one - Nothing -> do - case lspEnv se of - Nothing -> pure Nothing - Just env -> LSP.runLspT env $ do - 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.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 - } - pure (Just u) - - (!done, !remaining) <- atomically $ do - done <- readTVar indexCompleted - remaining <- HashMap.size <$> readTVar indexPending - pure (done, remaining) - let - progressFrac :: Double - progressFrac = fromIntegral done / fromIntegral (done + remaining) - progressPct :: LSP.UInt - progressPct = floor $ 100 * progressFrac - - whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $ - LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $ - toJSON $ - case style of - Percentage -> LSP.WorkDoneProgressReport - { _kind = LSP.AString @"report" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Just progressPct - } - 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.WorkDoneProgressReport - { _kind = LSP.AString @"report" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - + pre = progressUpdate indexProgressReporting ProgressStarted -- Report the progress once we are done indexing this file post = do mdone <- atomically $ do @@ -988,20 +909,16 @@ when (coerce $ ideTesting se) $ 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 $ \token -> - LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $ - 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 + whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted -writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] +writeAndIndexHieFile + :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] +#if MIN_VERSION_ghc(9,11,0) + -> (HieASTs Type, NameEntityInfo) +#else + -> HieASTs Type +#endif + -> BS.ByteString -> IO [FileDiagnostic] writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = handleGenerationErrors dflags "extended interface write/compression" $ do hf <- runHsc hscEnv $ @@ -1028,16 +945,25 @@ handleGenerationErrors dflags source action = action >> return [] `catches` [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException + , Handler $ \(exception :: SomeException) -> return $ + diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show exception) + Nothing ] handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) handleGenerationErrors' dflags source action = fmap ([],) action `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException + , Handler $ \(exception :: SomeException) -> + return + ( diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show exception) + Nothing + , Nothing + ) ] @@ -1046,9 +972,46 @@ -- 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 + -> ModuleGraph + -> DependencyInformation + -> ModSummary + -> [HomeModInfo] + -> [HscEnv] + -> IO HscEnv +mergeEnvs env mg dep_info ms extraMods envs = do +#if MIN_VERSION_ghc(9,11,0) + return $! loadModulesHome extraMods $ + let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in + (hscUpdateHUG (const newHug) env){ + hsc_mod_graph = mg, + hsc_FC = (hsc_FC env) + { addToFinderCache = \gwib@(GWIB im _) val -> + if moduleUnit im `elem` hsc_all_home_unit_ids env + then pure () + else addToFinderCache (hsc_FC env) gwib val + , lookupFinderCache = \gwib@(GWIB im _) -> + if moduleUnit im `elem` hsc_all_home_unit_ids env + then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of + Nothing -> pure Nothing + Just fs -> let ml = fromJust $ do + id <- lookupPathToId (depPathIdMap dep_info) fs + artifactModLocation (idToModLocation (depPathIdMap dep_info) id) + in pure $ Just $ InstalledFound ml im + else lookupFinderCache (hsc_FC env) gwib + } + } + + where + mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b + mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) } + mergeUDFM = plusUDFM_C combineModules + + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b + +#elif MIN_VERSION_ghc(9,3,0) 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 @@ -1082,33 +1045,9 @@ fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules fcFiles' <- newIORef $! Map.unions fcFiles pure $ FinderCache fcModules' fcFiles' - -#else - 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 - newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr - return $! loadModulesHome extraMods $ - env{ - hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, - hsc_FC = newFinderCache, - hsc_mod_graph = mg - } - - where - mergeUDFM = plusUDFM_C combineModules - combineModules a b - | HsSrcFile <- mi_hsc_src (hm_iface a) = a - | otherwise = b - -- required because 'FinderCache': - -- 1) doesn't have a 'Monoid' instance, - -- 2) is abstract and doesn't export constructors - -- To work around this, we coerce to the underlying type - -- To remove this, I plan to upstream the missing Monoid instance - concatFC :: [FinderCache] -> FinderCache - concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult)) #endif + withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut withBootSuffix _ = id @@ -1152,24 +1091,16 @@ convImport (L _ i) = ( -#if !MIN_VERSION_ghc(9,3,0) - fmap sl_fs -#endif (ideclPkgQual i) , reLoc $ ideclName i) msrImports = implicit_imports ++ imps -#if MIN_VERSION_ghc(9,3,0) rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv) rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) srcImports = rn_imps $ map convImport src_idecls textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) ghc_prim_import = not (null _ghc_prim_imports) -#else - srcImports = map convImport src_idecls - textualImports = map convImport (implicit_imports ++ ordinary_imps) -#endif -- Force bits that might keep the string buffer and DynFlags alive unnecessarily @@ -1185,18 +1116,14 @@ let modl = mkHomeModule (hscHomeUnit ppEnv) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile - msrModSummary2 = + msrModSummary = ModSummary { ms_mod = modl , ms_hie_date = Nothing -#if MIN_VERSION_ghc(9,3,0) , ms_dyn_obj_date = Nothing , ms_ghc_prim_import = ghc_prim_import , ms_hs_hash = _src_hash -#else - , ms_hs_date = _modTime -#endif , ms_hsc_src = sourceType -- The contents are used by the GetModSummary rule , ms_hspp_buf = Just contents @@ -1210,8 +1137,8 @@ , ms_textual_imps = textualImports } - msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2 - (msrModSummary, msrHscEnv) <- liftIO $ initPlugins ppEnv msrModSummary2 + msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary + msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv) return ModSummaryResult{..} where -- Compute a fingerprint from the contents of `ModSummary`, @@ -1221,19 +1148,24 @@ put $ Util.uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do put $ Util.uniq $ moduleNameFS $ unLoc m -#if MIN_VERSION_ghc(9,3,0) case mb_p of - G.NoPkgQual -> pure () + G.NoPkgQual -> pure () G.ThisPkg uid -> put $ getKey $ getUnique uid G.OtherPkg uid -> put $ getKey $ getUnique uid -#else - whenJust mb_p $ put . Util.uniq -#endif return $! Util.fingerprintFingerprints $ [ Util.fingerprintString fp , fingerPrintImports + , modLocationFingerprint ms_location ] ++ map Util.fingerprintString opts + modLocationFingerprint :: ModLocation -> Util.Fingerprint + modLocationFingerprint ModLocation{..} = Util.fingerprintFingerprints $ + Util.fingerprintString <$> [ fromMaybe "" ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file] -- | Parse only the module header parseHeader @@ -1250,7 +1182,7 @@ let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of PFailedWithErrorMessages msgs -> - throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags + throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags POk pst rdr_module -> do let (warns, errs) = renderMessages $ getPsMessages pst @@ -1264,9 +1196,9 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs sourceParser dflags errs + throwE $ diagFromGhcErrorMessages sourceParser dflags errs - let warnings = diagFromErrMsgs sourceParser dflags warns + let warnings = diagFromGhcErrorMessages sourceParser dflags warns return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -1283,20 +1215,29 @@ 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 sourceParser dflags $ msgs dflags + PFailedWithErrorMessages msgs -> + throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags POk pst rdr_module -> let - hpm_annotations = mkApiAnns pst psMessages = getPsMessages pst in do - let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module + let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module + let attachNoStructuredError (span, msg) = (span, msg, Nothing) - unless (null errs) $ - throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs + unless (null preproc_errs) $ + throwE $ + diagFromStrings + sourceParser + DiagnosticSeverity_Error + (fmap attachNoStructuredError preproc_errs) - let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns - (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms hpm_annotations parsed psMessages + let preproc_warning_file_diagnostics = + diagFromStrings + sourceParser + DiagnosticSeverity_Warning + (fmap attachNoStructuredError preproc_warns) + (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms parsed psMessages let (warns, errors) = renderMessages msgs -- Just because we got a `POk`, it doesn't mean there @@ -1309,8 +1250,7 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errors) $ - throwE $ diagFromErrMsgs sourceParser dflags errors - + throwE $ diagFromGhcErrorMessages sourceParser dflags errors -- To get the list of extra source files, we take the list -- that the parser gave us, @@ -1323,11 +1263,7 @@ -- - filter out the .hs/.lhs source filename if we have one -- let n_hspp = normalise filename -#if MIN_VERSION_ghc(9,3,0) TempDir tmp_dir = tmpDir dflags -#else - tmp_dir = tmpDir dflags -#endif srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`)) $ filter (/= n_hspp) $ map normalise @@ -1343,9 +1279,9 @@ -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let pm = ParsedModule ms parsed' srcs2 hpm_annotations - warnings = diagFromErrMsgs sourceParser dflags warns - pure (warnings ++ preproc_warnings, pm) + let pm = ParsedModule ms parsed' srcs2 + warnings = diagFromGhcErrorMessages sourceParser dflags warns + pure (warnings ++ preproc_warning_file_diagnostics, pm) loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile loadHieFile ncu f = do @@ -1420,6 +1356,7 @@ , old_value :: Maybe (HiFileResult, FileVersion) , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString] + , get_module_graph :: m DependencyInformation , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface } @@ -1474,14 +1411,9 @@ -- ncu and read_dflags are only used in GHC >= 9.4 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 + Util.Failed{} -> return Nothing -- important to call `shareUsages` here before checkOldIface -- consults `mi_usages` Util.Succeeded iface -> return $ Just (shareUsages iface) @@ -1489,13 +1421,9 @@ -- 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 _old_iface >>= \case UpToDateItem x -> pure (UpToDate, Just x) OutOfDateItem reason x -> pure (NeedsRecompile reason, x) -#else - <- liftIO $ checkOldIface sessionWithMsDynFlags ms _sourceMod mb_old_iface -#endif let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do setTag "Module" $ moduleNameString $ moduleName mod @@ -1511,7 +1439,7 @@ | not (mi_used_th iface) = emptyModuleEnv | otherwise = parseRuntimeDeps (md_anns details) -- Peform the fine grained recompilation check for TH - maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps + maybe_recomp <- checkLinkableDependencies session get_linkable_hashes get_module_graph runtime_deps case maybe_recomp of Just msg -> do_regenerate msg Nothing @@ -1548,20 +1476,10 @@ -- 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 => 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 +checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) +checkLinkableDependencies hsc_env get_linkable_hashes get_module_graph runtime_deps = do + graph <- get_module_graph + let go (mod, hash) = (,hash) <$> lookupModuleFile mod graph hs_files = mapM go (moduleEnvToList runtime_deps) case hs_files of Nothing -> error "invalid module graph" @@ -1575,27 +1493,16 @@ recompBecause :: String -> RecompileRequired recompBecause = -#if MIN_VERSION_ghc(9,3,0) NeedsRecompile . -#endif RecompBecause -#if MIN_VERSION_ghc(9,3,0) . CustomReason -#endif -#if MIN_VERSION_ghc(9,3,0) data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show) -#endif showReason :: RecompileRequired -> String -showReason UpToDate = "UpToDate" -#if MIN_VERSION_ghc(9,3,0) -showReason (NeedsRecompile MustCompile) = "MustCompile" -showReason (NeedsRecompile s) = printWithoutUniques s -#else -showReason MustCompile = "MustCompile" -showReason (RecompBecause s) = s -#endif +showReason UpToDate = "UpToDate" +showReason (NeedsRecompile MustCompile) = "MustCompile" +showReason (NeedsRecompile s) = printWithoutUniques s mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails mkDetailsFromIface session iface = do @@ -1610,11 +1517,7 @@ this_mod = mi_module iface types_var <- newIORef (md_types details) let hsc_env' = hscUpdateHPT act (session { -#if MIN_VERSION_ghc(9,3,0) hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) -#else - hsc_type_env_var = Just (this_mod, types_var) -#endif }) core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file -- Implicit binds aren't saved, so we need to regenerate them ourselves. @@ -1622,11 +1525,13 @@ tyCons = typeEnvTyCons (md_types details) #if MIN_VERSION_ghc(9,5,0) -- In GHC 9.6, the implicit binds are tidied and part of core_binds - pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] -#elif MIN_VERSION_ghc(9,3,0) - pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] + pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty +#if !MIN_VERSION_ghc(9,11,0) + (emptyHpcInfo False) +#endif + Nothing [] #else - pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] + pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #endif coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) @@ -1643,45 +1548,23 @@ getDocsBatch :: HscEnv -> [Name] -#if MIN_VERSION_ghc(9,3,0) -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] -#else - -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] -#endif getDocsBatch hsc_env _names = do res <- initIfaceLoad hsc_env $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) Just mod -> do ModIface { -#if MIN_VERSION_ghc(9,3,0) mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr , docs_decls = dmap , docs_args = amap } -#else - mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap -#endif } <- loadSysInterface (text "getModuleInterface") mod -#if MIN_VERSION_ghc(9,3,0) if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap -#else - if isNothing mb_doc_hdr && Map.null dmap && null amap -#endif then pure (Left (NoDocsInIface mod $ compiled name)) else pure (Right ( -#if MIN_VERSION_ghc(9,3,0) lookupUniqMap dmap name, -#else - Map.lookup name dmap , -#endif -#if MIN_VERSION_ghc(9,3,0) lookupWithDefaultUniqMap amap mempty name)) -#else - Map.findWithDefault mempty name amap)) -#endif return $ map (first $ T.unpack . printOutputable) res where compiled n = @@ -1711,7 +1594,7 @@ res <- initIfaceLoad hsc_env $ importDecl name case res of Util.Succeeded x -> return (Just x) - _ -> return Nothing + _ -> return Nothing where exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing @@ -1721,6 +1604,22 @@ rep c | isPathSeparator c = '_' rep ':' = '_' rep c = c + +-- | Initialising plugins looks in the finder cache, but we know that the plugin doesn't come from a home module, so don't +-- error out when we don't find it +setNonHomeFCHook :: HscEnv -> HscEnv +setNonHomeFCHook hsc_env = +#if MIN_VERSION_ghc(9,11,0) + hsc_env { hsc_FC = (hsc_FC hsc_env) + { lookupFinderCache = \m@(GWIB im _) -> + if moduleUnit im `elem` hsc_all_home_unit_ids hsc_env + then pure (Just $ InstalledNotFound [] Nothing) + else lookupFinderCache (hsc_FC hsc_env) m + } + } +#else + hsc_env +#endif {- Note [Guidelines For Using CPP In GHCIDE Import Statements] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -3,7 +3,10 @@ {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.FileStore( + getFileModTimeContents, getFileContents, + getUriContents, + getVersionedTextDoc, setFileModified, setSomethingModified, fileStoreRules, @@ -18,12 +21,13 @@ isWatchSupported, registerFileWatches, shareFilePath, - Log(..) + Log(..), ) where import Control.Concurrent.STM.Stats (STM, atomically) import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Exception +import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.Binary as B @@ -33,6 +37,7 @@ import Data.IORef import qualified Data.Text as T import qualified Data.Text as Text +import Data.Text.Utf16.Rope.Mixed (Rope) import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.FileUtils @@ -56,13 +61,16 @@ logWith, viaShow, (<+>)) import qualified Ide.Logger as L -import Ide.Plugin.Config (CheckParents (..), - Config) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (toUntypedRegistration) import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileSystemWatcher (..), - _watchers) + TextDocumentIdentifier (..), + VersionedTextDocumentIdentifier (..), + _watchers, + uriToNormalizedFilePath) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Language.LSP.VFS @@ -175,20 +183,20 @@ getFileContentsImpl :: NormalizedFilePath - -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) + -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope)) getFileContentsImpl file = do -- need to depend on modification time to introduce a dependency with Cutoff time <- use_ GetModificationTime file res <- do mbVirtual <- getVirtualFile file - pure $ virtualFileText <$> mbVirtual + pure $ _file_text <$> mbVirtual pure ([], Just (time, res)) -- | Returns the modification time and the contents. -- For VFS paths, the modification time is the current time. -getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) -getFileContents f = do - (fv, txt) <- use_ GetFileContents f +getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope) +getFileModTimeContents f = do + (fv, contents) <- use_ GetFileContents f modTime <- case modificationTime fv of Just t -> pure t Nothing -> do @@ -198,8 +206,30 @@ _ -> do posix <- getModTime $ fromNormalizedFilePath f pure $ posixSecondsToUTCTime posix - return (modTime, txt) + return (modTime, contents) +getFileContents :: NormalizedFilePath -> Action (Maybe Rope) +getFileContents f = snd <$> use_ GetFileContents f + +getUriContents :: NormalizedUri -> Action (Maybe Rope) +getUriContents uri = + join <$> traverse getFileContents (uriToNormalizedFilePath uri) + +-- | Given a text document identifier, annotate it with the latest version. +-- +-- Like Language.LSP.Server.Core.getVersionedTextDoc, but gets the virtual file +-- from the Shake VFS rather than the LSP VFS. +getVersionedTextDoc :: TextDocumentIdentifier -> Action VersionedTextDocumentIdentifier +getVersionedTextDoc doc = do + let uri = doc ^. L.uri + mvf <- + maybe (pure Nothing) getVirtualFile $ + uriToNormalizedFilePath $ toNormalizedUri uri + let ver = case mvf of + Just (VirtualFile lspver _ _) -> lspver + Nothing -> 0 + return (VersionedTextDocumentIdentifier uri ver) + fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do getModificationTimeRule recorder @@ -303,4 +333,3 @@ Just v -> (km, v) Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath #-} - 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 @@ -29,6 +29,7 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar') import Data.Aeson (toJSON) +import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting @@ -141,7 +142,7 @@ toJSON $ map fromNormalizedFilePath files signal (Proxy @"kick/start") - liftIO $ progressUpdate progress KickStarted + liftIO $ progressUpdate progress ProgressNewStarted -- Update the exports map results <- uses GenerateCore files @@ -152,7 +153,7 @@ let mguts = catMaybes results void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) - liftIO $ progressUpdate progress KickCompleted + liftIO $ progressUpdate progress ProgressCompleted GarbageCollectVar var <- getIdeGlobalAction garbageCollectionScheduled <- liftIO $ readVar var diff --git a/src/Development/IDE/Core/PluginUtils.hs b/src/Development/IDE/Core/PluginUtils.hs --- a/src/Development/IDE/Core/PluginUtils.hs +++ b/src/Development/IDE/Core/PluginUtils.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} module Development.IDE.Core.PluginUtils -(-- Wrapped Action functions +(-- * Wrapped Action functions runActionE , runActionMT , useE @@ -9,13 +9,13 @@ , usesMT , useWithStaleE , useWithStaleMT --- Wrapped IdeAction functions +-- * Wrapped IdeAction functions , runIdeActionE , runIdeActionMT , useWithStaleFastE , useWithStaleFastMT , uriToFilePathE --- Wrapped PositionMapping functions +-- * Wrapped PositionMapping functions , toCurrentPositionE , toCurrentPositionMT , fromCurrentPositionE @@ -23,8 +23,16 @@ , toCurrentRangeE , toCurrentRangeMT , fromCurrentRangeE -, fromCurrentRangeMT) where +, fromCurrentRangeMT +-- * Diagnostics +, activeDiagnosticsInRange +, activeDiagnosticsInRangeMT +-- * Formatting handlers +, mkFormattingHandlers) where +import Control.Concurrent.STM +import Control.Lens ((^.)) +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader (runReaderT) @@ -32,7 +40,10 @@ import Control.Monad.Trans.Maybe import Data.Functor.Identity import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Core.FileStore import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (IdeAction, IdeRule, IdeState (shakeExtras), mkDelayedAction, @@ -40,11 +51,17 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Types.Diagnostics 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 Ide.PluginUtils (rangesOverlap) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as LSP +import Language.LSP.Protocol.Message (SMethod (..)) import qualified Language.LSP.Protocol.Types as LSP +import qualified StmContainers.Map as STM -- ---------------------------------------------------------------------------- -- Action wrappers @@ -162,3 +179,77 @@ -- |MaybeT version of `fromCurrentRange` fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping + +-- ---------------------------------------------------------------------------- +-- Diagnostics +-- ---------------------------------------------------------------------------- + +-- | @'activeDiagnosticsInRangeMT' shakeExtras nfp range@ computes the +-- 'FileDiagnostic' 's that HLS produced and overlap with the given @range@. +-- +-- This function is to be used whenever we need an authoritative source of truth +-- for which diagnostics are shown to the user. +-- These diagnostics can be used to provide various IDE features, for example +-- CodeActions, CodeLenses, or refactorings. +-- +-- However, why do we need this when computing 'CodeAction's? A 'CodeActionParam' +-- has the 'CodeActionContext' which already contains the diagnostics! +-- But according to the LSP docs, the server shouldn't rely that these Diagnostic +-- are actually up-to-date and accurately reflect the state of the document. +-- +-- From the LSP docs: +-- > An array of diagnostics known on the client side overlapping the range +-- > provided to the `textDocument/codeAction` request. They are provided so +-- > that the server knows which errors are currently presented to the user +-- > for the given range. There is no guarantee that these accurately reflect +-- > the error state of the resource. The primary parameter +-- > to compute code actions is the provided range. +-- +-- Thus, even when the client sends us the context, we should compute the +-- diagnostics on the server side. +activeDiagnosticsInRangeMT :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> MaybeT m [FileDiagnostic] +activeDiagnosticsInRangeMT ide nfp range = do + MaybeT $ liftIO $ atomically $ do + mDiags <- STM.lookup (LSP.normalizedFilePathToUri nfp) (Shake.publishedDiagnostics ide) + case mDiags of + Nothing -> pure Nothing + Just fileDiags -> do + pure $ Just $ filter diagRangeOverlaps fileDiags + where + diagRangeOverlaps = \fileDiag -> + rangesOverlap range (fileDiag ^. fdLspDiagnosticL . LSP.range) + +-- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details. +activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic]) +activeDiagnosticsInRange ide nfp range = runMaybeT (activeDiagnosticsInRangeMT ide nfp range) + +-- ---------------------------------------------------------------------------- +-- Formatting handlers +-- ---------------------------------------------------------------------------- + +-- `mkFormattingHandlers` was moved here from hls-plugin-api package so that +-- `mkFormattingHandlers` can refer to `IdeState`. `IdeState` is defined in the +-- ghcide package, but hls-plugin-api does not depend on ghcide, so `IdeState` +-- is not in scope there. + +mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState +mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting) + <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting) + where + provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m + provider m ide _pid params + | Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do + contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp + case contentsMaybe of + Just contents -> do + let (typ, mtoken) = case m of + SMethod_TextDocumentFormatting -> (FormatText, params ^. LSP.workDoneToken) + SMethod_TextDocumentRangeFormatting -> (FormatRange (params ^. LSP.range), params ^. LSP.workDoneToken) + _ -> Prelude.error "mkFormattingHandlers: impossible" + f ide mtoken typ (Rope.toText contents) nfp opts + Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + + | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + where + uri = params ^. LSP.textDocument . LSP.uri + opts = params ^. LSP.options 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 @@ -28,15 +28,11 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import qualified GHC.LanguageExtensions as LangExt +import qualified GHC.Runtime.Loader as Loader +import GHC.Utils.Logger (LogFlags (..)) import System.FilePath import System.IO.Extra --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Logger (LogFlags (..)) -#endif - -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv, Util.Fingerprint) @@ -88,11 +84,7 @@ where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do -#if MIN_VERSION_ghc(9,3,0) let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg -#else - let cppLog = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg -#endif modifyIORef cppLogs (cppLog :) @@ -112,7 +104,7 @@ diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs = - map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $ + map (\d -> ideErrorFromLspDiag (cppDiagToDiagnostic d) (toNormalizedFilePath' filename) Nothing) $ go [] logs where -- On errors, CPP calls logAction with a real span for the initial log and @@ -152,17 +144,13 @@ -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], HscEnv)) parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do -#if MIN_VERSION_ghc(9,3,0) let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp -#else - let opts = getOptions dflags0 contents fp -#endif -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - hsc_env' <- initializePlugins (hscSetFlags dflags env) + hsc_env' <- Loader.initializePlugins (hscSetFlags dflags env) return (map unLoc opts, hscSetFlags (disableWarningsAsErrors $ hsc_dflags hsc_env') hsc_env') where dflags0 = hsc_dflags env 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 @@ -1,17 +1,25 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + module Development.IDE.Core.ProgressReporting - ( ProgressEvent(..) - , ProgressReporting(..) - , noProgressReporting - , progressReporting - -- utilities, reexported for use in Core.Shake - , mRunLspT - , mRunLspTCallback - -- for tests - , recordProgress - , InProgressState(..) + ( ProgressEvent (..), + PerFileProgressReporting (..), + ProgressReporting, + noPerFileProgressReporting, + progressReporting, + progressReportingNoTrace, + -- utilities, reexported for use in Core.Shake + mRunLspT, + mRunLspTCallback, + -- for tests + recordProgress, + InProgressState (..), + progressStop, + progressUpdate ) - where +where +import Control.Concurrent.STM (STM) import Control.Concurrent.STM.Stats (TVar, atomically, atomicallyNamed, modifyTVar', newTVarIO, readTVar, retry) @@ -23,7 +31,6 @@ import Data.Functor (($>)) import qualified Data.Text as T import Development.IDE.GHC.Orphans () -import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus @@ -33,119 +40,197 @@ withProgress) import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM -import UnliftIO (Async, async, cancel) +import UnliftIO (Async, async, bracket, cancel) data ProgressEvent - = KickStarted - | KickCompleted + = ProgressNewStarted + | ProgressCompleted + | ProgressStarted -data ProgressReporting = ProgressReporting - { progressUpdate :: ProgressEvent -> IO () - , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a - , progressStop :: IO () +data ProgressReporting = ProgressReporting + { _progressUpdate :: ProgressEvent -> IO (), + _progressStop :: IO () + -- ^ we are using IO here because creating and stopping the `ProgressReporting` + -- is different from how we use it. } -noProgressReporting :: IO ProgressReporting -noProgressReporting = return $ ProgressReporting - { progressUpdate = const $ pure () - , inProgress = const id - , progressStop = pure () +data PerFileProgressReporting = PerFileProgressReporting + { + inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, + -- ^ see Note [ProgressReporting API and InProgressState] + progressReportingInner :: ProgressReporting } +class ProgressReporter a where + progressUpdate :: a -> ProgressEvent -> IO () + progressStop :: a -> IO () + +instance ProgressReporter ProgressReporting where + progressUpdate = _progressUpdate + progressStop = _progressStop + +instance ProgressReporter PerFileProgressReporting where + progressUpdate = _progressUpdate . progressReportingInner + progressStop = _progressStop . progressReportingInner + +{- Note [ProgressReporting API and InProgressState] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The progress of tasks can be tracked in two ways: + +1. `ProgressReporting`: we have an internal state that actively tracks the progress. + Changes to the progress are made directly to this state. + +2. `ProgressReporting`: there is an external state that tracks the progress. + The external state is converted into an STM Int for the purpose of reporting progress. + +The `inProgress` function is only useful when we are using `ProgressReporting`. +-} + +noProgressReporting :: ProgressReporting +noProgressReporting = ProgressReporting + { _progressUpdate = const $ pure (), + _progressStop = pure () + } +noPerFileProgressReporting :: IO PerFileProgressReporting +noPerFileProgressReporting = + return $ + PerFileProgressReporting + { inProgress = const id, + progressReportingInner = noProgressReporting + } + -- | State used in 'delayedProgressReporting' data State - = NotStarted - | Stopped - | Running (Async ()) + = NotStarted + | Stopped + | Running (Async ()) -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress updateState :: IO () -> Transition -> State -> IO State -updateState _ _ Stopped = pure Stopped -updateState start (Event KickStarted) NotStarted = Running <$> async start -updateState start (Event KickStarted) (Running job) = cancel job >> Running <$> async start -updateState _ (Event KickCompleted) (Running job) = cancel job $> NotStarted -updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running job) = cancel job $> Stopped -updateState _ StopProgress st = pure st +updateState _ _ Stopped = pure Stopped +updateState start (Event ProgressNewStarted) NotStarted = Running <$> async start +updateState start (Event ProgressNewStarted) (Running job) = cancel job >> Running <$> async start +updateState start (Event ProgressStarted) NotStarted = Running <$> async start +updateState _ (Event ProgressStarted) (Running job) = return (Running job) +updateState _ (Event ProgressCompleted) (Running job) = cancel job $> NotStarted +updateState _ (Event ProgressCompleted) st = pure st +updateState _ StopProgress (Running job) = cancel job $> Stopped +updateState _ StopProgress st = pure st -- | Data structure to track progress across the project -data InProgressState = InProgressState - { todoVar :: TVar Int -- ^ Number of files to do - , doneVar :: TVar Int -- ^ Number of files done - , currentVar :: STM.Map NormalizedFilePath Int - } +-- see Note [ProgressReporting API and InProgressState] +data InProgressState + = InProgressState + { -- | Number of files to do + todoVar :: TVar Int, + -- | Number of files done + doneVar :: TVar Int, + currentVar :: STM.Map NormalizedFilePath Int + } newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () -recordProgress InProgressState{..} file shift = do - (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar - atomicallyNamed "recordProgress2" $ do - case (prev,new) of - (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1) - (Nothing,_) -> modifyTVar' todoVar (+1) - (Just 0, 0) -> pure () - (Just 0, _) -> modifyTVar' doneVar pred - (Just _, 0) -> modifyTVar' doneVar (+1) - (Just _, _) -> pure () +recordProgress InProgressState {..} file shift = do + (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar + atomicallyNamed "recordProgress2" $ case (prev, new) of + (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1) + (Nothing, _) -> modifyTVar' todoVar (+ 1) + (Just 0, 0) -> pure () + (Just 0, _) -> modifyTVar' doneVar pred + (Just _, 0) -> modifyTVar' doneVar (+ 1) + (Just _, _) -> pure () where alterPrevAndNew = do - prev <- Focus.lookup - Focus.alter alter - new <- Focus.lookupWithDefault 0 - return (prev, new) + prev <- Focus.lookup + Focus.alter alter + new <- Focus.lookupWithDefault 0 + return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' -progressReporting - :: Maybe (LSP.LanguageContextEnv c) - -> ProgressReportingStyle - -> IO ProgressReporting -progressReporting Nothing _optProgressStyle = noProgressReporting -progressReporting (Just lspEnv) optProgressStyle = do - inProgressState <- newInProgress - progressState <- newVar NotStarted - let progressUpdate event = updateStateVar $ Event event - progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) - inProgress = updateStateForFile inProgressState - return ProgressReporting{..} - where - lspShakeProgressNew :: InProgressState -> IO () - lspShakeProgressNew InProgressState{..} = - LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0 - where - loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound - loop update prevPct = do - (todo, done, nextPct) <- liftIO $ atomically $ do - todo <- readTVar todoVar - done <- readTVar doneVar - let nextFrac :: Double - nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo - nextPct :: UInt - nextPct = floor $ 100 * nextFrac - when (nextPct == prevPct) retry - pure (todo, done, nextPct) - _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) - loop update nextPct - updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where - f shift = recordProgress inProgress file shift +-- | `progressReportingNoTrace` initiates a new progress reporting session. +-- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking. +-- Refer to Note [ProgressReporting API and InProgressState] for more details. +progressReportingNoTrace :: + STM Int -> + STM Int -> + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO ProgressReporting +progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting +progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do + progressState <- newVar NotStarted + let _progressUpdate event = liftIO $ updateStateVar $ Event event + _progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) + return ProgressReporting {..} -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () +-- | `progressReporting` initiates a new progress reporting session. +-- It necessitates the active tracking of progress using the `inProgress` function. +-- Refer to Note [ProgressReporting API and InProgressState] for more details. +progressReporting :: + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO PerFileProgressReporting +progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting +progressReporting (Just lspEnv) title optProgressStyle = do + inProgressState <- newInProgress + progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) + (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle + let + inProgress :: NormalizedFilePath -> IO a -> IO a + inProgress = updateStateForFile inProgressState + return PerFileProgressReporting {..} + where + updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const + where + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + + f = recordProgress inProgress file + +-- Kill this to complete the progress session +progressCounter :: + LSP.LanguageContextEnv c -> + T.Text -> + ProgressReportingStyle -> + STM Int -> + STM Int -> + IO () +progressCounter lspEnv title optProgressStyle getTodo getDone = + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 + where + loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound + loop update prevPct = do + (todo, done, nextPct) <- liftIO $ atomically $ do + todo <- getTodo + done <- getDone + let nextFrac :: Double + nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo + nextPct :: UInt + nextPct = floor $ 100 * nextFrac + when (nextPct == prevPct) retry + pure (todo, done, nextPct) + + _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + loop update nextPct + +mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f mRunLspT Nothing _ = pure () -mRunLspTCallback :: Monad m - => Maybe (LSP.LanguageContextEnv c) - -> (LSP.LspT c m a -> LSP.LspT c m a) - -> m a - -> m a +mRunLspTCallback :: + (Monad m) => + Maybe (LSP.LanguageContextEnv c) -> + (LSP.LspT c m a -> LSP.LspT c m a) -> + m a -> + m a mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) mRunLspTCallback Nothing _ g = g 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 @@ -24,7 +24,8 @@ import Data.Time.Clock.POSIX import Data.Typeable import Development.IDE.GHC.Compat hiding - (HieFileResult) + (HieFileResult, + assert) import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Util @@ -35,11 +36,12 @@ import GHC.Generics (Generic) import Data.ByteString (ByteString) -import Data.Text (Text) +import Data.Text.Utf16.Rope.Mixed (Rope) import Development.IDE.Import.FindImports (ArtifactsLocation) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics +import GHC.Driver.Errors.Types (WarningMessages) import GHC.Serialized (Serialized) import Ide.Logger (Pretty (..), viaShow) @@ -82,7 +84,7 @@ type instance RuleResult GenerateCore = ModGuts data GenerateCore = GenerateCore - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GenerateCore instance NFData GenerateCore @@ -102,12 +104,12 @@ rnf = rwhnf data GetLinkable = GetLinkable - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetLinkable instance NFData GetLinkable data GetImportMap = GetImportMap - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetImportMap instance NFData GetImportMap @@ -157,6 +159,8 @@ -- ^ Which modules did we need at runtime while compiling this file? -- Used for recompilation checking in the presence of TH -- Stores the hash of their core file + , tmrWarnings :: WarningMessages + -- ^ Structured warnings for this module. } instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -275,10 +279,12 @@ type instance RuleResult GetModIface = HiFileResult -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. -type instance RuleResult GetFileContents = (FileVersion, Maybe Text) +type instance RuleResult GetFileContents = (FileVersion, Maybe Rope) type instance RuleResult GetFileExists = Bool +type instance RuleResult GetFileHash = Fingerprint + type instance RuleResult AddWatchedFile = Bool @@ -329,16 +335,22 @@ instance NFData GetFileContents data GetFileExists = GetFileExists - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance NFData GetFileExists instance Hashable GetFileExists +data GetFileHash = GetFileHash + deriving (Eq, Show, Generic) + +instance NFData GetFileHash +instance Hashable GetFileHash + data FileOfInterestStatus = OnDisk | Modified { firstOpen :: !Bool -- ^ was this file just opened } - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable FileOfInterestStatus instance NFData FileOfInterestStatus @@ -346,7 +358,7 @@ pretty = viaShow data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult @@ -378,17 +390,17 @@ type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult data GetParsedModule = GetParsedModule - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetParsedModule instance NFData GetParsedModule data GetParsedModuleWithComments = GetParsedModuleWithComments - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetParsedModuleWithComments instance NFData GetParsedModuleWithComments data GetLocatedImports = GetLocatedImports - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetLocatedImports instance NFData GetLocatedImports @@ -396,42 +408,42 @@ type instance RuleResult NeedsCompilation = Maybe LinkableType data NeedsCompilation = NeedsCompilation - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable NeedsCompilation instance NFData NeedsCompilation data GetModuleGraph = GetModuleGraph - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModuleGraph instance NFData GetModuleGraph data ReportImportCycles = ReportImportCycles - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable ReportImportCycles instance NFData ReportImportCycles data TypeCheck = TypeCheck - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable TypeCheck instance NFData TypeCheck data GetDocMap = GetDocMap - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetDocMap instance NFData GetDocMap data GetHieAst = GetHieAst - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetHieAst instance NFData GetHieAst data GetBindings = GetBindings - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetBindings instance NFData GetBindings data GhcSession = GhcSession - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GhcSession instance NFData GhcSession @@ -440,7 +452,7 @@ -- Required for interactive evaluation, but leads to more cache invalidations fullModSummary :: Bool } - deriving newtype (Eq, Typeable, Hashable, NFData) + deriving newtype (Eq, Hashable, NFData) instance Show GhcSessionDeps where show (GhcSessionDeps_ False) = "GhcSessionDeps" @@ -450,45 +462,45 @@ pattern GhcSessionDeps = GhcSessionDeps_ False data GetModIfaceFromDisk = GetModIfaceFromDisk - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDisk instance NFData GetModIfaceFromDisk data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDiskAndIndex instance NFData GetModIfaceFromDiskAndIndex data GetModIface = GetModIface - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModIface instance NFData GetModIface data IsFileOfInterest = IsFileOfInterest - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable IsFileOfInterest instance NFData IsFileOfInterest data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData GetModSummaryWithoutTimestamps data GetModSummary = GetModSummary - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModSummary instance NFData GetModSummary -- See Note [Client configuration in Rules] -- | Get the client config stored in the ide state data GetClientSettings = GetClientSettings - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetClientSettings instance NFData GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) -data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic) +data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Generic) instance Hashable AddWatchedFile instance NFData AddWatchedFile @@ -508,7 +520,7 @@ instance Show IdeGhcSession where show _ = "IdeGhcSession" instance NFData IdeGhcSession where rnf !_ = () -data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) +data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Generic) instance Hashable GhcSessionIO instance NFData GhcSessionIO 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 @@ -64,6 +64,7 @@ import Control.DeepSeq import Control.Exception (evaluate) import Control.Exception.Safe +import Control.Lens ((%~), (&), (.~)) import Control.Monad.Extra import Control.Monad.IO.Unlift import Control.Monad.Reader @@ -91,6 +92,7 @@ import Data.Proxy import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Time (UTCTime (..)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra @@ -99,6 +101,7 @@ import Development.IDE.Core.FileExists hiding (Log, LogShake) import Development.IDE.Core.FileStore (getFileContents, + getFileModTimeContents, getModTime) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (Log, @@ -159,6 +162,7 @@ import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import Language.LSP.Protocol.Types (MessageType (MessageType_Info), ShowMessageParams (ShowMessageParams)) +import qualified Language.LSP.Protocol.Lens as JL import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP import Language.LSP.VFS @@ -167,19 +171,10 @@ import System.Info.Extra (isWindows) -import GHC.Fingerprint - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if !MIN_VERSION_ghc(9,3,0) -import GHC (mgModSummaries) -#endif - -#if MIN_VERSION_ghc(9,3,0) import qualified Data.IntMap as IM -#endif - +import GHC.Fingerprint +import GHC.Driver.Env (hsc_all_home_unit_ids) data Log = LogShake Shake.Log @@ -230,10 +225,10 @@ -- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do - (_, msource) <- getFileContents nfp + msource <- getFileContents nfp case msource of Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) - Just source -> pure $ T.encodeUtf8 source + Just source -> pure $ T.encodeUtf8 $ Rope.toText source -- | Parse the contents of a haskell file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) @@ -324,18 +319,11 @@ (KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file - let env = hscEnvWithImportPaths env_eq - let import_dirs = deps env_eq + let env = hscEnv env_eq + let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env let dflags = hsc_dflags env - isImplicitCradle = isNothing $ envImportPaths env_eq - let dflags' = if isImplicitCradle - then addRelativeImport file (moduleName $ ms_mod ms) dflags - else dflags opt <- getIdeOptions let getTargetFor modName nfp - | isImplicitCradle = do - itExists <- getFileExists nfp - return $ if itExists then Just nfp else Nothing | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do -- reuse the existing NormalizedFilePath in order to maximize sharing itExists <- getFileExists nfp' @@ -346,10 +334,11 @@ nfp' = HM.lookupDefault nfp nfp ttmap itExists <- getFileExists nfp' return $ if itExists then Just nfp' else Nothing - | otherwise - = return Nothing + | otherwise = do + itExists <- getFileExists nfp + return $ if itExists then Just nfp else Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule (hscSetFlags dflags' env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -500,17 +489,9 @@ where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) cycleErrorInFile _ _ = Nothing - toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic - { _range = rng - , _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 - } + toDiag imp mods = + ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing + & fdLspDiagnosticL %~ JL.range .~ rng where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do @@ -539,7 +520,12 @@ getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do - (diags, masts) <- liftIO $ generateHieAsts hsc tmr + (diags, masts') <- liftIO $ generateHieAsts hsc tmr +#if MIN_VERSION_ghc(9,11,0) + let masts = fst <$> masts' +#else + let masts = masts' +#endif se <- getShakeExtras isFoi <- use_ IsFileOfInterest f @@ -549,7 +535,7 @@ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f pure [] - _ | Just asts <- masts -> do + _ | Just asts <- masts' -> do source <- getSourceFileSource f let exports = tcg_exports $ tmrTypechecked tmr modSummary = tmrModSummary tmr @@ -630,6 +616,13 @@ fs <- knownTargets pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) +getFileHashRule :: Recorder (WithPriority Log) -> Rules () +getFileHashRule recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileHash file -> do + void $ use_ GetModificationTime file + fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath file) + return (Just (fingerprintToBS fileHash), ([], Just fileHash)) + getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets @@ -641,7 +634,6 @@ 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 @@ -651,14 +643,6 @@ go (Just ms) _ = Just $ ModuleNode [] ms go _ _ = Nothing mg = mkModuleGraph mns -#else - let mg = mkModuleGraph $ - -- 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 $ - 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 @@ -675,6 +659,7 @@ unlift <- askUnliftIO let dets = TypecheckHelpers { getLinkables = unliftIO unlift . uses_ GetLinkable + , getModuleGraph = unliftIO unlift $ useNoFile_ GetModuleGraph } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -776,7 +761,6 @@ 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 @@ -785,17 +769,10 @@ return $!! map (NodeKey_Module . msKey) dep_mss let module_graph_nodes = nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) -#else - let module_graph_nodes = - -- 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 $ - 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 + de <- useNoFile_ GetModuleGraph + session' <- liftIO $ mergeEnvs hsc mg de ms inLoadOrder depSessions -- 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 @@ -824,9 +801,11 @@ , old_value = m_old , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs + , get_module_graph = useNoFile_ GetModuleGraph , regenerate = regenerateHiFile session f ms } - r <- loadInterface (hscEnv session) ms linkableType recompInfo + hsc_env' <- setFileCacheHook (hscEnv session) + r <- loadInterface hsc_env' ms linkableType recompInfo case r of (diags, Nothing) -> return (Nothing, (diags, Nothing)) (diags, Just x) -> do @@ -894,23 +873,18 @@ defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal - let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' - (modTime, mFileContent) <- getFileContents f + let session = setNonHomeFCHook $ hscSetFlags (modify_dflags $ hsc_dflags session') session' -- TODO wz1000 + (modTime, mFileContent) <- getFileModTimeContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ - getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) + getModSummaryFromImports session fp modTime (textToStringBuffer . Rope.toText <$> mFileContent) case modS of Right res -> do -- Check for Template Haskell when (uses_th_qq $ msrModSummary res) $ do DisplayTHWarning act <- getIdeGlobalAction liftIO act -#if MIN_VERSION_ghc(9,3,0) let bufFingerPrint = ms_hs_hash (msrModSummary res) -#else - bufFingerPrint <- liftIO $ - fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res -#endif let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) @@ -921,9 +895,6 @@ case mbMs of Just res@ModSummaryResult{..} -> do let ms = msrModSummary { -#if !MIN_VERSION_ghc(9,3,0) - ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", -#endif ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } fp = fingerprintToBS msrFingerprint @@ -933,8 +904,9 @@ generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) generateCore runSimplifier file = do packageState <- hscEnv <$> use_ GhcSessionDeps file + hsc' <- setFileCacheHook packageState tm <- use_ TypeCheck file - liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) + liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder = @@ -949,14 +921,15 @@ tmr <- use_ TypeCheck f linkableType <- getLinkableType f hsc <- hscEnv <$> use_ GhcSessionDeps f + hsc' <- setFileCacheHook hsc let compile = fmap ([],) $ use GenerateCore f se <- getShakeExtras - (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr + (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr let fp = hiFileFingerPrint <$> mbHiFile hiDiags <- case mbHiFile of Just hiFile | OnDisk <- status - , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile + , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile _ -> pure [] return (fp, (diags++hiDiags, mbHiFile)) NotFOI -> do @@ -980,12 +953,21 @@ count <- getRebuildCountVar <$> getIdeGlobalAction liftIO $ atomically $ modifyTVar' count (+1) +setFileCacheHook :: HscEnv -> Action HscEnv +setFileCacheHook old_hsc_env = do +#if MIN_VERSION_ghc(9,11,0) + unlift <- askUnliftIO + return $ old_hsc_env { hsc_FC = (hsc_FC old_hsc_env) { lookupFileCache = unliftIO unlift . use_ GetFileHash . toNormalizedFilePath' } } +#else + return old_hsc_env +#endif + -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) regenerateHiFile sess f ms compNeeded = do - let hsc = hscEnv sess + hsc <- setFileCacheHook (hscEnv sess) opt <- getIdeOptions -- Embed haddocks in the interface file @@ -1081,10 +1063,16 @@ getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do - ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f - HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f - let obj_file = ml_obj_file (ms_location ms) - core_file = ml_core_file (ms_location ms) + HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f + let obj_file = ml_obj_file (ms_location hirModSummary) + core_file = ml_core_file (ms_location hirModSummary) +#if MIN_VERSION_ghc(9,11,0) + mkLinkable t mod l = Linkable t mod (pure l) + dotO o = DotO o ModuleObject +#else + mkLinkable t mod l = LM t mod [l] + dotO = DotO +#endif case hirCoreFp of Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f Just (bin_core, fileHash) -> do @@ -1097,7 +1085,7 @@ core_t <- liftIO $ getModTime core_file (warns, hmi) <- case linkableType of -- Bytecode needs to be regenerated from the core file - BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) + BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) -- Object code can be read from the disk ObjectLinkable -> do -- object file is up to date if it is newer than the core file @@ -1110,10 +1098,15 @@ else pure Nothing case mobj_time of Just obj_t - | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file])) - _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time") + | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) (dotO obj_file))) + _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time") -- Record the linkable so we know not to unload it, and unload old versions - whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) $ \(LM time mod _) -> do + whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) +#if MIN_VERSION_ghc(9,11,0) + $ \(Linkable time mod _) -> do +#else + $ \(LM time mod _) -> do +#endif compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction liftIO $ modifyVar compiledLinkables $ \old -> do let !to_keep = extendModuleEnv old mod time @@ -1127,7 +1120,9 @@ --just before returning it to be loaded. This has a substantial effect on recompile --times as the number of loaded modules and splices increases. -- - unload (hscEnv session) (map (\(mod', time') -> LM time' mod' []) $ moduleEnvToList to_keep) + --We use a dummy DotA linkable part to fake a NativeCode linkable. + --The unload function doesn't care about the exact linkable parts. + unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep) return (to_keep, ()) return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) @@ -1225,12 +1220,13 @@ reportImportCyclesRule recorder typeCheckRule recorder getDocMapRule recorder - loadGhcSession recorder GhcSessionDepsConfig{fullModuleGraph} + loadGhcSession recorder def{fullModuleGraph} getModIfaceFromDiskRule recorder getModIfaceFromDiskAndIndexRule recorder getModIfaceRule recorder getModSummaryRule templateHaskellWarning recorder getModuleGraphRule recorder + getFileHashRule recorder knownFilesRule recorder getClientSettingsRule recorder getHieAstsRule recorder 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 @@ -73,7 +73,8 @@ garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, - ThreadQueue(..) + ThreadQueue(..), + runWithSignal ) where import Control.Concurrent.Async @@ -82,7 +83,7 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) -import Control.Lens ((&), (?~)) +import Control.Lens ((%~), (&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader @@ -123,9 +124,14 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes +import Development.IDE.Types.Options as Options +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Server as LSP + import Development.IDE.Core.Tracing import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, + NameCacheUpdater, initNameCache, knownKeyNames) import Development.IDE.GHC.Orphans () @@ -146,25 +152,21 @@ import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location import Development.IDE.Types.Monitoring (Monitoring (..)) -import Development.IDE.Types.Options import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownSymbol) 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 Ide.Types import qualified Language.LSP.Protocol.Lens as L 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.VFS hiding (start) import qualified "list-t" ListT import OpenTelemetry.Eventlog hiding (addEvent) @@ -173,20 +175,9 @@ import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +import UnliftIO (MonadUnliftIO (withRunInIO)) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import Data.IORef -import Development.IDE.GHC.Compat (NameCacheUpdater (NCU), - mkSplitUniqSupply, - upNameCache) -#endif - -#if MIN_VERSION_ghc(9,3,0) -import Development.IDE.GHC.Compat (NameCacheUpdater) -#endif - data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int @@ -252,11 +243,10 @@ -- a worker thread. data HieDbWriter = HieDbWriter - { indexQueue :: IndexQueue - , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing - , indexCompleted :: TVar Int -- ^ to report progress - , indexProgressToken :: Var (Maybe LSP.ProgressToken) - -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock + { indexQueue :: IndexQueue + , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing + , indexCompleted :: TVar Int -- ^ to report progress + , indexProgressReporting :: ProgressReporting } -- | Actions to queue up on the index worker thread @@ -290,7 +280,7 @@ ,state :: Values ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore - ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] + ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. @@ -306,7 +296,7 @@ -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an -- accumulation to the current version. - ,progress :: ProgressReporting + ,progress :: PerFileProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession @@ -315,11 +305,7 @@ -> [DelayedAction ()] -> IO [Key] -> IO () -#if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache -#else - ,ideNc :: IORef NameCache -#endif -- | A mapping of module name to known target (or candidate targets, if missing) ,knownTargetsVar :: TVar (Hashed KnownTargets) -- | A mapping of exported identifiers for local modules. Updated on kick @@ -677,12 +663,7 @@ restartQueue = tRestartQueue threadQueue loaderQueue = tLoaderQueue threadQueue -#if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames -#else - us <- mkSplitUniqSupply 'r' - ideNc <- newIORef (initNameCache us knownKeyNames) -#endif shakeExtras <- do globals <- newTVarIO HMap.empty state <- STM.newIO @@ -697,7 +678,10 @@ indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 semanticTokensId <- newTVarIO 0 - indexProgressToken <- newVar Nothing + indexProgressReporting <- progressReportingNoTrace + (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted)) + (readTVar indexCompleted) + lspEnv "Indexing" optProgressStyle let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb @@ -710,8 +694,8 @@ progress <- if reportProgress - then progressReporting lspEnv optProgressStyle - else noProgressReporting + then progressReporting lspEnv "Processing" optProgressStyle + else noPerFileProgressReporting actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv @@ -775,6 +759,7 @@ for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + progressStop $ indexProgressReporting $ hiedbWriter shakeExtras stopMonitoring @@ -1080,13 +1065,8 @@ askShake = ask -#if MIN_VERSION_ghc(9,3,0) mkUpdater :: NameCache -> NameCacheUpdater mkUpdater = id -#else -mkUpdater :: IORef NameCache -> NameCacheUpdater -mkUpdater ref = NCU (upNameCache ref) -#endif -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } @@ -1192,7 +1172,7 @@ extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras diags defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do @@ -1211,7 +1191,7 @@ extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras diags defineEarlyCutoff' diagnostics (==) key file old mode $ op key file defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () @@ -1238,7 +1218,8 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions - (if optSkipProgress options key then id else inProgress progress file) $ do + let trans g x = withRunInIO $ \run -> g (run x) + (if optSkipProgress options key then id else trans (inProgress progress file)) $ do val <- case mbOld of Just old | mode == RunDependenciesSame -> do mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file @@ -1265,7 +1246,7 @@ (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) + pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing)) ver <- estimateFileVersionUnsafely key mbRes file (bs, res) <- case mbRes of @@ -1347,52 +1328,51 @@ -> Maybe Int32 -> Key -> ShakeExtras - -> [(ShowDiagnostic,Diagnostic)] -- ^ current results + -> [FileDiagnostic] -- ^ current results -> m () -updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = +updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) - let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current + let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current uri = filePathToUri' fp addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v - update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] + update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic] update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store - current = second diagsFromRule <$> current0 + current = map (fdLspDiagnosticL %~ diagsFromRule) current0 addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics - _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics + newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics + _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do - join $ mask_ $ do - lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics - let action = when (lastPublish /= newDiags) $ case lspEnv of + join $ mask_ $ do + lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics + let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) + logWith recorder Info $ LogDiagsDiffButNoLspEnv newDiags Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags - return action + LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags) + return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} | coerce ideTesting = c & L.relatedInformation ?~ - [ - DiagnosticRelatedInformation + [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp) _range ) (T.pack $ show k) - ] + ] | otherwise = c @@ -1403,26 +1383,28 @@ actionLogger = shakeRecorder <$> getShakeExtras -------------------------------------------------------------------------------- -type STMDiagnosticStore = STM.Map NormalizedUri StoreItem +type STMDiagnosticStore = STM.Map NormalizedUri StoreItem' +data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource +type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic) -getDiagnosticsFromStore :: StoreItem -> [Diagnostic] -getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags +getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic] +getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags updateSTMDiagnostics :: (forall a. String -> String -> a -> a) -> STMDiagnosticStore -> NormalizedUri -> Maybe Int32 -> - DiagnosticsBySource -> - STM [LSP.Diagnostic] + FileDiagnosticsBySource -> + STM [FileDiagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource = getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store where - update (Just(StoreItem mvs dbs)) + update (Just(StoreItem' mvs dbs)) | addTag "previous version" (show mvs) $ addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined - | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs)) - update _ = Just (StoreItem mv newDiagsBySource) + | mvs == mv = Just (StoreItem' mv (newDiagsBySource <> dbs)) + update _ = Just (StoreItem' mv newDiagsBySource) -- | Sets the diagnostics for a file and compilation step -- if you want to clear the diagnostics call this with an empty list @@ -1431,9 +1413,9 @@ -> NormalizedUri -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited -> T.Text - -> [LSP.Diagnostic] + -> [FileDiagnostic] -> STMDiagnosticStore - -> STM [LSP.Diagnostic] + -> STM [FileDiagnostic] setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags where !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags @@ -1442,7 +1424,7 @@ STMDiagnosticStore -> STM [FileDiagnostic] getAllDiagnostics = - fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT + fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = @@ -1464,3 +1446,19 @@ EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc))) zeroMapping (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri) + +-- | sends a signal whenever shake session is run/restarted +-- being used in cabal and hlint plugin tests to know when its time +-- to look for file diagnostics +kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action () +kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ + toJSON $ map fromNormalizedFilePath files + +-- | Add kick start/done signal to rule +runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action () +runWithSignal msgStart msgEnd files rule = do + ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras + kickSignal testing lspEnv files msgStart + void $ uses rule files + kickSignal testing lspEnv files msgEnd 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 @@ -61,7 +61,7 @@ -- | Returns a logger that produces telemetry events in a single span. telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a)) telemetryLogRecorder sp = Recorder $ \WithPriority {..} -> - liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact $ payload) + liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact payload) where -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX trim = T.take (fromIntegral(maxBound :: Word16) - 10) diff --git a/src/Development/IDE/Core/WorkerThread.hs b/src/Development/IDE/Core/WorkerThread.hs --- a/src/Development/IDE/Core/WorkerThread.hs +++ b/src/Development/IDE/Core/WorkerThread.hs @@ -10,10 +10,13 @@ (withWorkerQueue, awaitRunInThread) where -import Control.Concurrent.Async (withAsync) +import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled), + withAsync) import Control.Concurrent.STM import Control.Concurrent.Strict (newBarrier, signalBarrier, waitBarrier) +import Control.Exception.Safe (Exception (fromException), + SomeException, throwIO, try) import Control.Monad (forever) import Control.Monad.Cont (ContT (ContT)) @@ -42,13 +45,15 @@ workerAction l -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, --- and then blocks until the result is computed. +-- and then blocks until the result is computed. If the action throws an +-- non-async exception, it is rethrown in the calling thread. awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result awaitRunInThread q act = do -- Take an action from TQueue, run it and -- use barrier to wait for the result barrier <- newBarrier - atomically $ writeTQueue q $ do - res <- act - signalBarrier barrier res - waitBarrier barrier + atomically $ writeTQueue q $ try act >>= signalBarrier barrier + resultOrException <- waitBarrier barrier + case resultOrException of + Left e -> throwIO (e :: SomeException) + Right r -> return r diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -22,16 +22,16 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Pipeline as Pipeline -#endif - -#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,5,0) +#if !MIN_VERSION_ghc(9,5,0) import qualified GHC.Driver.Pipeline.Execute as Pipeline #endif #if MIN_VERSION_ghc(9,5,0) import qualified GHC.SysTools.Cpp as Pipeline +#endif + +#if MIN_VERSION_ghc(9,11,0) +import qualified GHC.SysTools.Tasks as Pipeline #endif #if MIN_VERSION_ghc(9,11,0) diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -98,20 +98,9 @@ extract_cons, recDotDot, -#if !MIN_VERSION_ghc(9,3,0) - Dependencies(dep_mods), - NameCacheUpdater(NCU), - extendModSummaryNoDeps, - emsModSummary, - nonDetNameEnvElts, - nonDetOccEnvElts, - upNameCache, -#endif -#if MIN_VERSION_ghc(9,3,0) Dependencies(dep_direct_mods), NameCacheUpdater, -#endif #if MIN_VERSION_ghc(9,5,0) XModulePs(..), @@ -180,6 +169,7 @@ import GHC.ByteCode.Types import GHC.CoreToStg import GHC.Data.Maybe +import GHC.Driver.Config.Stg.Pipeline import GHC.Driver.Env as Env import GHC.Iface.Env import GHC.Linker.Loader (loadDecls, loadExpr) @@ -192,24 +182,12 @@ import GHC.Types.SrcLoc (combineRealSrcSpans) import GHC.Unit.Home.ModInfo (HomePackageTable, lookupHpt) +import GHC.Unit.Module.Deps (Dependencies (dep_direct_mods), + Usage (..)) import GHC.Unit.Module.ModIface -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import Data.IORef -import GHC.Runtime.Interpreter -import GHC.Unit.Module.Deps (Dependencies (dep_mods), - Usage (..)) -import GHC.Unit.Module.ModSummary -#endif - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Config.Stg.Pipeline -import GHC.Unit.Module.Deps (Dependencies (dep_direct_mods), - Usage (..)) -#endif - #if !MIN_VERSION_ghc(9,5,0) import GHC.Core.Lint (lintInteractiveExpr) #endif @@ -234,35 +212,19 @@ nonDetFoldOccEnv = foldOccEnv #endif -#if !MIN_VERSION_ghc(9,3,0) -nonDetOccEnvElts :: OccEnv a -> [a] -nonDetOccEnvElts = occEnvElts -#endif type ModIfaceAnnotation = Annotation -#if !MIN_VERSION_ghc(9,3,0) -nonDetNameEnvElts :: NameEnv a -> [a] -nonDetNameEnvElts = nameEnvElts -#endif myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext -#if MIN_VERSION_ghc(9,3,0) -> Bool -#endif -> Module -> ModLocation -> CoreExpr -> IO ( Id -#if MIN_VERSION_ghc(9,3,0) ,[CgStgTopBinding] -- output program -#else - ,[StgTopBinding] -- output program -#endif , InfoTableProvMap , CollectedCCs ) myCoreToStgExpr logger dflags ictxt -#if MIN_VERSION_ghc(9,3,0) for_bytecode -#endif this_mod ml prepd_expr = do {- Create a temporary binding (just because myCoreToStg needs a binding for the stg2stg step) -} @@ -278,30 +240,20 @@ myCoreToStg logger dflags ictxt -#if MIN_VERSION_ghc(9,3,0) for_bytecode -#endif this_mod ml [NonRec bco_tmp_id prepd_expr] return (bco_tmp_id, stg_binds, prov_map, collected_ccs) myCoreToStg :: Logger -> DynFlags -> InteractiveContext -#if MIN_VERSION_ghc(9,3,0) -> Bool -#endif -> Module -> ModLocation -> CoreProgram -#if MIN_VERSION_ghc(9,3,0) -> IO ( [CgStgTopBinding] -- output program -#else - -> IO ( [StgTopBinding] -- output program -#endif , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) myCoreToStg logger dflags ictxt -#if MIN_VERSION_ghc(9,3,0) for_bytecode -#endif this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} @@ -321,7 +273,6 @@ stg_binds2 #endif <- {-# SCC "Stg2Stg" #-} -#if MIN_VERSION_ghc(9,3,0) stg2stg logger #if MIN_VERSION_ghc(9,5,0) (interactiveInScope ictxt) @@ -329,9 +280,6 @@ ictxt #endif (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds -#else - stg2stg logger dflags ictxt this_mod stg_binds -#endif return (stg_binds2, denv, cost_centre_info) @@ -342,11 +290,7 @@ #endif getDependentMods :: ModIface -> [ModuleName] -#if MIN_VERSION_ghc(9,3,0) getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps -#else -getDependentMods = map gwib_mod . dep_mods . mi_deps -#endif simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr #if MIN_VERSION_ghc(9,5,0) @@ -366,57 +310,48 @@ renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs = -#if MIN_VERSION_ghc(9,3,0) - let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs +#if MIN_VERSION_ghc(9,5,0) + let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs in (renderMsgs psWarnings, renderMsgs psErrors) #else - msgs + let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs + in (renderMsgs psWarnings, renderMsgs psErrors) #endif +#if MIN_VERSION_ghc(9,5,0) +pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a +#else pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a +#endif pattern PFailedWithErrorMessages msgs -#if MIN_VERSION_ghc(9,3,0) - <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) +#if MIN_VERSION_ghc(9,5,0) + <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs) #else - <- PFailed (const . fmap pprError . getErrorMessages -> msgs) + <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) #endif {-# COMPLETE POk, PFailedWithErrorMessages #-} hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if MIN_VERSION_ghc(9,3,0) type NameCacheUpdater = NameCache -#else -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) --- Lookup up the (Module,OccName) in the NameCache --- If you find it, return it; if not, allocate a fresh original name and extend --- the NameCache. --- Reason: this may the first occurrence of (say) Foo.bar we have encountered. --- If we need to explore its value we will load Foo.hi; but meanwhile all we --- need is a Name for it. -lookupNameCache mod occ name_cache = - case lookupOrigNameCache (nsNames name_cache) mod occ of { - Just name -> (name_cache, name); - Nothing -> - case takeUniqFromSupply (nsUniqs name_cache) of { - (uniq, us) -> - let - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache (nsNames name_cache) mod occ name - in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} - -upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -upNameCache = updNameCache -#endif - mkHieFile' :: ModSummary -> [Avail.AvailInfo] +#if MIN_VERSION_ghc(9,11,0) + -> (HieASTs Type, NameEntityInfo) +#else -> HieASTs Type +#endif -> BS.ByteString -> Hsc HieFile -mkHieFile' ms exports asts src = do +mkHieFile' ms exports +#if MIN_VERSION_ghc(9,11,0) + (asts, entityInfo) +#else + asts +#endif + src = do let Just src_file = ml_hs_file $ ms_location ms (asts',arr) = compressTypes asts return $ HieFile @@ -424,6 +359,9 @@ , hie_module = ms_mod ms , hie_types = arr , hie_asts = asts' +#if MIN_VERSION_ghc(9,11,0) + , hie_entity_infos = entityInfo +#endif -- mkIfaceExports sorts the AvailInfos for stability , hie_exports = mkIfaceExports exports , hie_hs_src = src @@ -515,18 +453,20 @@ generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo data GhcVersion - = GHC92 - | GHC94 + = GHC94 | GHC96 | GHC98 | GHC910 + | GHC912 deriving (Eq, Ord, Show, Enum) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,12,0,0) +ghcVersion = GHC912 +#elif MIN_VERSION_GLASGOW_HASKELL(9,10,0,0) ghcVersion = GHC910 #elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ghcVersion = GHC98 @@ -534,8 +474,6 @@ ghcVersion = GHC96 #elif MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) ghcVersion = GHC94 -#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) -ghcVersion = GHC92 #endif simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a @@ -568,16 +506,7 @@ -> HscEnv -> HscEnv loadModulesHome mod_infos e = -#if MIN_VERSION_ghc(9,3,0) hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) -#else - let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] - in e { hsc_HPT = new_modules - , hsc_type_env_var = Nothing - } - where - mod_name = moduleName . mi_module . hm_iface -#endif recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int recDotDot x = diff --git a/src/Development/IDE/GHC/Compat/CmdLine.hs b/src/Development/IDE/GHC/Compat/CmdLine.hs --- a/src/Development/IDE/GHC/Compat/CmdLine.hs +++ b/src/Development/IDE/GHC/Compat/CmdLine.hs @@ -13,26 +13,7 @@ , liftEwM ) where -#if MIN_VERSION_ghc(9,3,0) import GHC.Driver.CmdLine -import GHC.Driver.Session (CmdLineP (..), getCmdLineState, - processCmdLineP, putCmdLineState) -#else -import Control.Monad.IO.Class -import GHC (Located) -import GHC.Driver.CmdLine -#endif +import GHC.Driver.Session (CmdLineP (..), getCmdLineState, + processCmdLineP, putCmdLineState) -#if !MIN_VERSION_ghc(9,3,0) --- | A helper to parse a set of flags from a list of command-line arguments, handling --- response files. -processCmdLineP - :: forall s m. MonadIO m - => [Flag (CmdLineP s)] -- ^ valid flags to match against - -> s -- ^ current state - -> [Located String] -- ^ arguments to parse - -> m (([Located String], [Err], [Warn]), s) - -- ^ (leftovers, errors, warnings) -processCmdLineP activeFlags s0 args = - pure $ runCmdLine (processArgs activeFlags args) s0 -#endif 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 @@ -58,9 +58,6 @@ pattern ExposePackage, parseDynamicFlagsCmdLine, parseDynamicFilePragma, -#if !MIN_VERSION_ghc(9,3,0) - WarnReason(..), -#endif wWarningFlags, updOptLevel, -- slightly unsafe @@ -72,12 +69,14 @@ IfaceTyCon(..), ModIface, ModIface_(..), +#if MIN_VERSION_ghc(9,11,0) + pattern ModIface, + set_mi_top_env, + set_mi_usages, +#endif HscSource(..), WhereFrom(..), loadInterface, -#if !MIN_VERSION_ghc(9,3,0) - SourceModified(..), -#endif loadModuleInterface, RecompileRequired(..), mkPartialIface, @@ -236,7 +235,11 @@ ModuleOrigin(..), PackageName(..), -- * Linker +#if MIN_VERSION_ghc(9,11,0) + LinkablePart(..), +#else Unlinked(..), +#endif Linkable(..), unload, -- * Hooks @@ -359,7 +362,6 @@ module GHC.Parser.Header, module GHC.Parser.Lexer, module GHC.Utils.Panic, -#if MIN_VERSION_ghc(9,3,0) CompileReason(..), hsc_type_env_vars, hscUpdateHUG, hsc_HUG, @@ -372,7 +374,6 @@ module GHC.Unit.Finder.Types, module GHC.Unit.Env, module GHC.Driver.Phases, -#endif #if !MIN_VERSION_ghc(9,4,0) pattern HsFieldBind, hfbAnn, @@ -460,7 +461,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, MonadFix (..), MonadIO (..), allM, - anyM, concatMapM, mapMaybeM, + anyM, concatMapM, mapMaybeM, foldMapM, (<$>)) import GHC.Tc.Utils.TcType as TcType import qualified GHC.Types.Avail as Avail @@ -495,12 +496,15 @@ import Data.Foldable (toList) import GHC.Core.Multiplicity (scaledThing) import GHC.Data.Bag +import qualified GHC.Data.Strict as Strict +import qualified GHC.Driver.Config.Finder as GHC +import qualified GHC.Driver.Config.Tidy as GHC import GHC.Driver.Env -import GHC.Hs (HsModule (..)) -#if !MIN_VERSION_ghc(9,9,0) -import GHC.Hs (SrcSpanAnn') -#endif -import GHC.Hs.Decls hiding (FunDep) +import GHC.Driver.Env as GHCi +import GHC.Driver.Env.KnotVars +import GHC.Driver.Errors.Types +import GHC.Hs (HsModule (..)) +import GHC.Hs.Decls hiding (FunDep) import GHC.Hs.Doc import GHC.Hs.Expr import GHC.Hs.Extension @@ -524,73 +528,66 @@ import GHC.Types.Target (Target (..), TargetId (..)) import GHC.Types.TyThing import GHC.Types.TyThing.Ppr +import GHC.Types.Unique +import GHC.Types.Unique.Map +import GHC.Unit.Env import GHC.Unit.Finder hiding (mkHomeModLocation) +import qualified GHC.Unit.Finder as GHC +import GHC.Unit.Finder.Types import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.Graph import GHC.Unit.Module.Imported import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts +#if !MIN_VERSION_ghc(9,9,0) +import GHC.Hs (SrcSpanAnn') +#endif import GHC.Unit.Module.ModIface (IfaceExport, ModIface, - ModIface_ (..), mi_fix) + ModIface_ (..), mi_fix +#if MIN_VERSION_ghc(9,11,0) + , pattern ModIface + , set_mi_top_env + , set_mi_usages +#endif + ) import GHC.Unit.Module.ModSummary (ModSummary (..)) +import GHC.Utils.Error (mkPlainErrorMsgEnvelope) +import GHC.Utils.Panic +import GHC.Utils.TmpFs import Language.Haskell.Syntax hiding (FunDep) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Types.SourceFile (SourceModified (..)) -import qualified GHC.Unit.Finder as GHC -import GHC.Unit.Module.Graph (mkModuleGraph) -#endif +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Data.Strict as Strict -import qualified GHC.Driver.Config.Finder as GHC -import qualified GHC.Driver.Config.Tidy as GHC -import GHC.Driver.Env as GHCi -import GHC.Driver.Env.KnotVars -import GHC.Driver.Errors.Types -import GHC.Types.Unique -import GHC.Types.Unique.Map -import GHC.Unit.Env -import qualified GHC.Unit.Finder as GHC -import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph -import GHC.Utils.Error (mkPlainErrorMsgEnvelope) -import GHC.Utils.Panic -import GHC.Utils.TmpFs +#if MIN_VERSION_ghc(9,11,0) +import System.OsPath #endif #if !MIN_VERSION_ghc(9,7,0) import GHC.Types.Avail (greNamePrintableName) #endif +#if !MIN_VERSION_ghc(9,9,0) +import GHC.Hs (SrcSpanAnn') +#endif + mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation -#if MIN_VERSION_ghc(9,3,0) -mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f +#if MIN_VERSION_ghc(9,11,0) +mkHomeModLocation df mn f = + let osf = unsafeEncodeUtf f + in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osf #else -mkHomeModLocation = GHC.mkHomeModLocation +mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f #endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan -#else -pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan -#endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) -#else -pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y -#endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc -#else -pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc -#endif pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y {-# COMPLETE RealSrcLoc, UnhelpfulLoc #-} @@ -664,6 +661,8 @@ #if MIN_VERSION_ghc(9,9,0) instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where getLoc (L l _) = getLoc l +instance HasSrcSpan (SrcLoc.GenLocated (GHC.EpaLocation) a) where + getLoc = GHC.getHasLoc #else instance HasSrcSpan (SrcSpanAnn' ann) where getLoc = GHC.locA @@ -703,7 +702,7 @@ loadDLL :: HscEnv -> String -> IO (Maybe String) loadDLL env str = do res <- GHCi.loadDLL (GHCi.hscInterp env) str -#if MIN_VERSION_ghc(9,11,0) +#if MIN_VERSION_ghc(9,11,0) || (MIN_VERSION_ghc(9, 8, 3) && !MIN_VERSION_ghc(9, 9, 0)) pure $ case res of Left err_msg -> Just err_msg @@ -718,12 +717,6 @@ (GHCi.hscInterp hsc_env) hsc_env linkables -#if !MIN_VERSION_ghc(9,3,0) -setOutputFile :: FilePath -> DynFlags -> DynFlags -setOutputFile f d = d { - outputFile_ = Just f - } -#endif isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLocA a) (GHC.getLocA b) @@ -744,7 +737,7 @@ #endif ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} -collectHsBindsBinders :: CollectPass p => Bag (XRec p (HsBindLR p idR)) -> [IdP p] +collectHsBindsBinders :: CollectPass p => LHsBindsLR p idR -> [IdP p] collectHsBindsBinders x = GHC.collectHsBindsBinders CollNoDictBinders x @@ -752,54 +745,28 @@ makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails makeSimpleDetails hsc_env = GHC.makeSimpleDetails -#if MIN_VERSION_ghc(9,3,0) (hsc_logger hsc_env) -#else - hsc_env -#endif mkIfaceTc :: HscEnv -> GHC.SafeHaskellMode -> ModDetails -> ModSummary -> Maybe CoreProgram -> TcGblEnv -> IO ModIface mkIfaceTc hscEnv shm md _ms _mcp = #if MIN_VERSION_ghc(9,5,0) GHC.mkIfaceTc hscEnv shm md _ms _mcp -- mcp::Maybe CoreProgram is only used in GHC >= 9.6 -#elif MIN_VERSION_ghc(9,3,0) - GHC.mkIfaceTc hscEnv shm md _ms -- ms::ModSummary is only used in GHC >= 9.4 #else - GHC.mkIfaceTc hscEnv shm md + GHC.mkIfaceTc hscEnv shm md _ms -- ms::ModSummary is only used in GHC >= 9.4 #endif mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc -#if MIN_VERSION_ghc(9,3,0) (hsc_logger session) -#else - session -#endif -#if !MIN_VERSION_ghc(9,3,0) -type TidyOpts = HscEnv -#endif initTidyOpts :: HscEnv -> IO TidyOpts initTidyOpts = -#if MIN_VERSION_ghc(9,3,0) GHC.initTidyOpts -#else - pure -#endif -#if MIN_VERSION_ghc(9,3,0) driverNoStop :: StopPhase driverNoStop = NoStop -#else -driverNoStop :: Phase -driverNoStop = StopLn -#endif -#if !MIN_VERSION_ghc(9,3,0) -hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv -hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } -#endif #if !MIN_VERSION_ghc(9,4,0) pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg @@ -846,11 +813,7 @@ #endif mkSimpleTarget :: DynFlags -> FilePath -> Target -#if MIN_VERSION_ghc(9,3,0) mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing -#else -mkSimpleTarget _ fp = Target (TargetFile fp Nothing) True Nothing -#endif #if MIN_VERSION_ghc(9,7,0) lookupGlobalRdrEnv gre_env occ = lookupGRE gre_env (LookupOccName occ AllRelevantGREs) diff --git a/src/Development/IDE/GHC/Compat/Driver.hs b/src/Development/IDE/GHC/Compat/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Driver.hs @@ -0,0 +1,155 @@ +-- ============================================================================ +-- DO NOT EDIT +-- This module copies parts of the driver code in GHC.Driver.Main to provide +-- `hscTypecheckRenameWithDiagnostics`. +-- Issue to add this function: https://gitlab.haskell.org/ghc/ghc/-/issues/24996 +-- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891 +-- ============================================================================ + +{-# LANGUAGE CPP #-} + +module Development.IDE.GHC.Compat.Driver + ( hscTypecheckRenameWithDiagnostics + ) where + +#if MIN_VERSION_ghc(9,11,0) + +import GHC.Driver.Main (hscTypecheckRenameWithDiagnostics) + +#else + +import Control.Monad +import GHC.Core +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Hs +import GHC.Hs.Dump +import GHC.Iface.Ext.Ast (mkHieFile) +import GHC.Iface.Ext.Binary (hie_file_result, readHieFile, + writeHieFile) +import GHC.Iface.Ext.Debug (diffFile, validateScopes) +import GHC.Iface.Ext.Types (getAsts, hie_asts, hie_module) +import GHC.Tc.Module +import GHC.Tc.Utils.Monad +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Unit +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain + +hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule + -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage) +hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = + runHsc' hsc_env $ hsc_typecheck True mod_summary (Just rdr_module) + +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkHomeModule home_unit mod_name + inner_mod = homeModuleNameInstantiation home_unit mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + massert (isHomeModule home_unit outer_mod) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then +#if MIN_VERSION_ghc(9,5,0) + do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary +#else + do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary +#endif + ioMsgMaybe $ hoistTcRnMessage $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + logger <- getLogger + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- Hsc $ \e w -> return (e, w) + liftIO $ do + -- Validate Scopes + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of + [] -> putMsg logger $ text "Got valid scopes" + xs -> do + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs + -- Roundtrip testing + file' <- readHieFile (hsc_NC hs_env) out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg logger $ text "Got no roundtrip errors" + xs -> do + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs + return rn_info + +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ +#if MIN_VERSION_ghc(9,5,0) +hscSimpleIface :: HscEnv + -> Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> IO (ModIface, ModDetails) +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary +#else +hscSimpleIface :: HscEnv + -> TcGblEnv + -> ModSummary + -> IO (ModIface, ModDetails) +hscSimpleIface hsc_env tc_result summary + = runHsc hsc_env $ hscSimpleIface' tc_result summary +#endif + +#endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -4,11 +4,7 @@ -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env ( Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph -#if MIN_VERSION_ghc(9,3,0) , hsc_type_env_vars -#else - , hsc_type_env_var -#endif ), Env.hsc_HPT, InteractiveContext(..), @@ -19,9 +15,6 @@ Env.hsc_logger, Env.hsc_tmpfs, Env.hsc_unit_env, -#if !MIN_VERSION_ghc(9,3,0) - Env.hsc_unit_dbs, -#endif Env.hsc_hooks, hscSetHooks, TmpFs, @@ -64,6 +57,7 @@ import GHC (setInteractiveDynFlags) import GHC.Driver.Backend as Backend +import GHC.Driver.Env (HscEnv, hscSetActiveUnitId) import qualified GHC.Driver.Env as Env import GHC.Driver.Hooks (Hooks) import GHC.Driver.Session @@ -76,41 +70,12 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import qualified Data.Set as S -import GHC.Driver.Env (HscEnv, hsc_EPS) -#endif - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (HscEnv, hscSetActiveUnitId) -#endif - - -#if !MIN_VERSION_ghc(9,3,0) -hscSetActiveUnitId :: UnitId -> HscEnv -> HscEnv -hscSetActiveUnitId _ env = env - -reexportedModules :: HscEnv -> S.Set a -reexportedModules _ = S.empty -#endif - -#if MIN_VERSION_ghc(9,3,0) hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = Env.hsc_unit_env -#endif -#if !MIN_VERSION_ghc(9,3,0) -workingDirectory :: a -> Maybe b -workingDirectory _ = Nothing - setWorkingDirectory :: FilePath -> DynFlags -> DynFlags -setWorkingDirectory = const id -#else -setWorkingDirectory :: FilePath -> DynFlags -> DynFlags setWorkingDirectory p d = d { workingDirectory = Just p } -#endif setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid } diff --git a/src/Development/IDE/GHC/Compat/Error.hs b/src/Development/IDE/GHC/Compat/Error.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Error.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +module Development.IDE.GHC.Compat.Error ( + -- * Top-level error types and lens for easy access + MsgEnvelope(..), + msgEnvelopeErrorL, + GhcMessage(..), + -- * Error messages for the typechecking and renamer phase + TcRnMessage (..), + TcRnMessageDetailed (..), + stripTcRnMessageContext, + -- * Parsing error message + PsMessage(..), + -- * Desugaring diagnostic + DsMessage (..), + -- * Driver error message + DriverMessage (..), + -- * General Diagnostics + Diagnostic(..), + -- * Prisms for error selection + _TcRnMessage, + _GhcPsMessage, + _GhcDsMessage, + _GhcDriverMessage, + ) where + +import Control.Lens +import GHC.Driver.Errors.Types +import GHC.HsToCore.Errors.Types +import GHC.Tc.Errors.Types +import GHC.Types.Error + +_TcRnMessage :: Prism' GhcMessage TcRnMessage +_TcRnMessage = prism' GhcTcRnMessage (\case + GhcTcRnMessage tcRnMsg -> Just tcRnMsg + _ -> Nothing) + +_GhcPsMessage :: Prism' GhcMessage PsMessage +_GhcPsMessage = prism' GhcPsMessage (\case + GhcPsMessage psMsg -> Just psMsg + _ -> Nothing) + +_GhcDsMessage :: Prism' GhcMessage DsMessage +_GhcDsMessage = prism' GhcDsMessage (\case + GhcDsMessage dsMsg -> Just dsMsg + _ -> Nothing) + +_GhcDriverMessage :: Prism' GhcMessage DriverMessage +_GhcDriverMessage = prism' GhcDriverMessage (\case + GhcDriverMessage driverMsg -> Just driverMsg + _ -> Nothing) + +-- | Some 'TcRnMessage's are nested in other constructors for additional context. +-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'. +-- However, in some occasions you don't need the additional context and you just want +-- the error message. @'stripTcRnMessageContext'@ recursively unwraps these constructors, +-- until there are no more constructors with additional context. +-- +stripTcRnMessageContext :: TcRnMessage -> TcRnMessage +stripTcRnMessageContext = \case +#if MIN_VERSION_ghc(9, 6, 1) + TcRnWithHsDocContext _ tcMsg -> stripTcRnMessageContext tcMsg +#endif + TcRnMessageWithInfo _ (TcRnMessageDetailed _ tcMsg) -> stripTcRnMessageContext tcMsg + msg -> msg + +msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e +msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } ) diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -9,25 +9,22 @@ import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Outputable import GHC +import GHC.Driver.Session (targetProfile) import qualified GHC.Iface.Load as Iface import GHC.Unit.Finder.Types (FindResult) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Session (targetProfile) -#endif - #if MIN_VERSION_ghc(9,7,0) import GHC.Iface.Errors.Ppr (missingInterfaceErrorDiagnostic) import GHC.Iface.Errors.Types (IfaceMessage) #endif writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,11,0) +writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) (Iface.flagsToIfCompression $ hsc_dflags env) fp iface +#elif MIN_VERSION_ghc(9,3,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface -#else -writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface #endif cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -14,20 +14,14 @@ import Development.IDE.GHC.Compat.Outputable +import GHC.Types.Error import GHC.Utils.Logger as Logger import GHC.Utils.Outputable --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Error -#endif - putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env = env { hsc_logger = logger } -#if MIN_VERSION_ghc(9,3,0) type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. @@ -41,11 +35,3 @@ #endif logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify -#else -type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () - --- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. -logActionCompat :: LogActionCompat -> LogAction -logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify - -#endif diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -24,7 +24,6 @@ initDiagOpts, pprMessages, #endif -#if MIN_VERSION_ghc(9,3,0) DiagnosticReason(..), renderDiagnosticMessageWithHints, pprMsgEnvelopeBagWithLoc, @@ -34,10 +33,6 @@ errMsgDiagnostic, unDecorated, diagnosticMessage, -#else - pprWarning, - pprError, -#endif -- * Error infrastructure DecoratedSDoc, MsgEnvelope, @@ -53,33 +48,24 @@ textDoc, ) where +import Data.Maybe +import GHC.Driver.Config.Diagnostic import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session +import GHC.Parser.Errors.Types import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Unit.State +import GHC.Utils.Error import GHC.Utils.Outputable as Out import GHC.Utils.Panic -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Parser.Errors -import qualified GHC.Parser.Errors.Ppr as Ppr -import GHC.Utils.Error hiding (mkWarnMsg) -#endif - -#if MIN_VERSION_ghc(9,3,0) -import Data.Maybe -import GHC.Driver.Config.Diagnostic -import GHC.Parser.Errors.Types -import GHC.Utils.Error -#endif - #if MIN_VERSION_ghc(9,5,0) import GHC.Driver.Errors.Types (DriverMessage, GhcMessage) #endif @@ -114,41 +100,29 @@ doc' = pprWithUnitState emptyUnitState doc -#if !MIN_VERSION_ghc(9,3,0) -pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc -pprWarning = - Ppr.pprWarning -pprError :: PsError -> MsgEnvelope DecoratedSDoc -pprError = - Ppr.pprError -#endif - formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = showSDoc dflags (pprNoLocMsgEnvelope e) -#if MIN_VERSION_ghc(9,3,0) pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc -#else -pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc -#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e , errMsgContext = unqual }) = sdocWithContext $ \_ctx -> withErrStyle unqual $ #if MIN_VERSION_ghc(9,7,0) formatBulleted e -#elif MIN_VERSION_ghc(9,3,0) - formatBulleted _ctx $ e #else - formatBulleted _ctx $ Error.renderDiagnostic e + formatBulleted _ctx e #endif +#if MIN_VERSION_ghc(9,5,0) +type ErrMsg = MsgEnvelope GhcMessage +type WarnMsg = MsgEnvelope GhcMessage +#else type ErrMsg = MsgEnvelope DecoratedSDoc -#if MIN_VERSION_ghc(9,3,0) type WarnMsg = MsgEnvelope DecoratedSDoc #endif @@ -165,7 +139,6 @@ mkPrintUnqualified (hsc_unit_env env) #endif -#if MIN_VERSION_ghc(9,3,0) renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc (diagnosticMessage @@ -173,16 +146,9 @@ (defaultDiagnosticOpts @a) #endif a) (mkDecorated $ map ppr $ diagnosticHints a) -#endif -#if MIN_VERSION_ghc(9,3,0) mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc mkWarnMsg df reason _logFlags l st doc = fmap renderDiagnosticMessageWithHints $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc) -#else -mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc -mkWarnMsg _ _ = - const Error.mkWarnMsg -#endif textDoc :: String -> SDoc textDoc = text diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -5,22 +5,20 @@ module Development.IDE.GHC.Compat.Parser ( initParserOpts, initParserState, - ApiAnns, PsSpan(..), pattern HsParsedModule, type GHC.HsParsedModule, Development.IDE.GHC.Compat.Parser.hpm_module, Development.IDE.GHC.Compat.Parser.hpm_src_files, - Development.IDE.GHC.Compat.Parser.hpm_annotations, pattern ParsedModule, Development.IDE.GHC.Compat.Parser.pm_parsed_source, type GHC.ParsedModule, Development.IDE.GHC.Compat.Parser.pm_mod_summary, Development.IDE.GHC.Compat.Parser.pm_extra_src_files, - Development.IDE.GHC.Compat.Parser.pm_annotations, - mkApiAnns, -- * API Annotations +#if !MIN_VERSION_ghc(9,11,0) Anno.AnnKeywordId(..), +#endif pattern EpaLineComment, pattern EpaBlockComment ) where @@ -38,17 +36,8 @@ pm_mod_summary, pm_parsed_source) import qualified GHC -import GHC.Hs (hpm_module, hpm_src_files) - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if !MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Config as Config -#endif - -#if MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Config.Parser as Config -#endif +import GHC.Hs (hpm_module, hpm_src_files) @@ -60,34 +49,28 @@ initParserState = Lexer.initParserState --- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the --- annotations are found in the ast. -type ApiAnns = () - #if MIN_VERSION_ghc(9,5,0) -pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> ApiAnns -> GHC.HsParsedModule +pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> GHC.HsParsedModule #else -pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule +pattern HsParsedModule :: Located HsModule -> [FilePath] -> GHC.HsParsedModule #endif pattern HsParsedModule { hpm_module , hpm_src_files - , hpm_annotations - } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations)) + } <- GHC.HsParsedModule{..} where - HsParsedModule hpm_module hpm_src_files _hpm_annotations = + HsParsedModule hpm_module hpm_src_files = GHC.HsParsedModule hpm_module hpm_src_files -pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> GHC.ParsedModule +pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> GHC.ParsedModule pattern ParsedModule { pm_mod_summary , pm_parsed_source , pm_extra_src_files - , pm_annotations - } <- ( (,()) -> (GHC.ParsedModule{..}, pm_annotations)) + } <- GHC.ParsedModule{..} where - ParsedModule ms parsed extra_src_files _anns = + ParsedModule ms parsed extra_src_files = GHC.ParsedModule { pm_mod_summary = ms , pm_parsed_source = parsed @@ -95,6 +78,4 @@ } {-# COMPLETE ParsedModule :: GHC.ParsedModule #-} -mkApiAnns :: PState -> ApiAnns -mkApiAnns = const () diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -7,8 +7,6 @@ defaultPlugin, PluginWithArgs(..), applyPluginsParsedResultAction, - initializePlugins, - initPlugins, -- * Static plugins StaticPlugin(..), @@ -20,79 +18,32 @@ ) where import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) -import Development.IDE.GHC.Compat.Parser as Parser +import Development.IDE.GHC.Compat.Parser as Parser -import qualified GHC.Driver.Env as Env -import GHC.Driver.Plugins (Plugin (..), - PluginWithArgs (..), - StaticPlugin (..), - defaultPlugin, - withPlugins) -import qualified GHC.Runtime.Loader as Loader +import qualified GHC.Driver.Env as Env +import GHC.Driver.Plugins (ParsedResult (..), + Plugin (..), + PluginWithArgs (..), + PsMessages (..), + StaticPlugin (..), + defaultPlugin, + staticPlugins, withPlugins) +import qualified GHC.Parser.Lexer as Lexer --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import Data.Bifunctor (bimap) -import Development.IDE.GHC.Compat.Outputable as Out -import Development.IDE.GHC.Compat.Util (Bag) -#endif - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Plugins (ParsedResult (..), - PsMessages (..), - staticPlugins) -import qualified GHC.Parser.Lexer as Lexer -#endif - -#if !MIN_VERSION_ghc(9,3,0) -type PsMessages = (Bag WarnMsg, Bag ErrMsg) -#endif - getPsMessages :: PState -> PsMessages getPsMessages pst = -#if MIN_VERSION_ghc(9,3,0) uncurry PsMessages $ Lexer.getPsMessages pst -#else - bimap (fmap pprWarning) (fmap pprError) $ getMessages pst -#endif -applyPluginsParsedResultAction :: HscEnv -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) -applyPluginsParsedResultAction env ms hpm_annotations parsed msgs = do +applyPluginsParsedResultAction :: HscEnv -> ModSummary -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) +applyPluginsParsedResultAction env ms parsed msgs = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms -#if MIN_VERSION_ghc(9,3,0) - fmap (\result -> (hpm_module (parsedResultModule result), (parsedResultMessages result))) $ runHsc env $ withPlugins -#else - fmap (\parsed_module -> (hpm_module parsed_module, msgs)) $ runHsc env $ withPlugins -#endif -#if MIN_VERSION_ghc(9,3,0) + fmap (\result -> (hpm_module (parsedResultModule result), parsedResultMessages result)) $ runHsc env $ withPlugins (Env.hsc_plugins env) -#else - env -#endif applyPluginAction -#if MIN_VERSION_ghc(9,3,0) - (ParsedResult (HsParsedModule parsed [] hpm_annotations) msgs) -#else - (HsParsedModule parsed [] hpm_annotations) -#endif + (ParsedResult (HsParsedModule parsed []) msgs) -initializePlugins :: HscEnv -> IO HscEnv -initializePlugins env = do - Loader.initializePlugins env --- | Plugins aren't stored in ModSummary anymore since GHC 9.2, but this --- function still returns it for compatibility with 8.10 -initPlugins :: HscEnv -> ModSummary -> IO (ModSummary, HscEnv) -initPlugins session modSummary = do - session1 <- initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) - return (modSummary{ms_hspp_opts = hsc_dflags session1}, session1) - hsc_static_plugins :: HscEnv -> [StaticPlugin] -#if MIN_VERSION_ghc(9,3,0) hsc_static_plugins = staticPlugins . Env.hsc_plugins -#else -hsc_static_plugins = Env.hsc_static_plugins -#endif 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 @@ -5,7 +5,6 @@ -- * UnitState UnitState, initUnits, - oldInitUnits, unitState, getUnitName, explicitUnits, @@ -53,10 +52,17 @@ import Development.IDE.GHC.Compat.Outputable import Prelude hiding (mod) +import Control.Monad +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified GHC import qualified GHC.Data.ShortText as ST +import qualified GHC.Driver.Session as DynFlags +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) import GHC.Types.Unique.Set import GHC.Unit.External import qualified GHC.Unit.Finder as GHC +import GHC.Unit.Home.ModInfo import qualified GHC.Unit.Info as UnitInfo import GHC.Unit.State (LookupResult, UnitInfo, UnitInfoMap, @@ -69,40 +75,19 @@ import qualified GHC.Unit.State as State import GHC.Unit.Types --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Data.FastString -import GHC.Unit.Env -import GHC.Unit.Finder hiding - (findImportedModule) -import qualified GHC.Unit.Types as Unit -#endif - -#if MIN_VERSION_ghc(9,3,0) -import Control.Monad -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified GHC -import qualified GHC.Driver.Session as DynFlags -import GHC.Types.PkgQual (PkgQual (NoPkgQual)) -import GHC.Unit.Home.ModInfo -#endif - - type PreloadUnitClosure = UniqSet UnitId unitState :: HscEnv -> UnitState unitState = ue_units . hsc_unit_env -#if MIN_VERSION_ghc(9,3,0) createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph createUnitEnvFromFlags unitDflags = let newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags in - unitEnv_new (Map.fromList (NE.toList (unitEnvList))) + unitEnv_new (Map.fromList (NE.toList unitEnvList)) initUnits :: [DynFlags] -> HscEnv -> IO HscEnv initUnits unitDflags env = do @@ -135,25 +120,11 @@ , ue_eps = ue_eps (hsc_unit_env env) } pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env -#else -initUnits :: [DynFlags] -> HscEnv -> IO HscEnv -initUnits _df env = pure env -- Can't do anything here, oldInitUnits should already be called -#endif --- | oldInitUnits only needs to modify DynFlags for GHC <9.2 --- For GHC >= 9.2, we need to set the hsc_unit_env also, that is --- done later by initUnits -oldInitUnits :: DynFlags -> IO DynFlags -oldInitUnits = pure - explicitUnits :: UnitState -> [Unit] explicitUnits ue = -#if MIN_VERSION_ghc(9,3,0) map fst $ State.explicitUnits ue -#else - State.explicitUnits ue -#endif listVisibleModuleNames :: HscEnv -> [ModuleName] listVisibleModuleNames env = @@ -166,11 +137,7 @@ lookupModuleWithSuggestions :: HscEnv -> ModuleName -#if MIN_VERSION_ghc(9,3,0) -> GHC.PkgQual -#else - -> Maybe FastString -#endif -> LookupResult lookupModuleWithSuggestions env modname mpkg = State.lookupModuleWithSuggestions (unitState env) modname mpkg @@ -204,10 +171,6 @@ installedModule :: unit -> ModuleName -> GenModule unit installedModule = Module -#if !MIN_VERSION_ghc(9,3,0) -moduleUnitId :: Module -> UnitId -moduleUnitId = Unit.toUnitId . Unit.moduleUnit -#endif filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags = @@ -225,11 +188,7 @@ 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/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -68,6 +68,7 @@ import Control.Exception.Safe (MonadCatch, catch, try) import GHC.Data.Bag +import GHC.Data.Bool import GHC.Data.BooleanFormula import GHC.Data.EnumSet import GHC.Data.FastString @@ -79,13 +80,3 @@ import GHC.Utils.Fingerprint import GHC.Utils.Outputable (pprHsString) import GHC.Utils.Panic hiding (try) - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Misc -#endif - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Data.Bool -#endif diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -26,6 +26,9 @@ import GHC.Fingerprint import GHC.Iface.Binary import GHC.Iface.Env +#if MIN_VERSION_ghc(9,11,0) +import qualified GHC.Iface.Load as Iface +#endif import GHC.Iface.Recomp.Binary (fingerprintBinMem) import GHC.IfaceToCore import GHC.Types.Id.Make @@ -87,14 +90,20 @@ return (file, fp) -- | Write a core file -writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint -writeBinCoreFile core_path fat_iface = do +writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint +writeBinCoreFile _dflags core_path fat_iface = do bh <- openBinMem initBinMemSize let quietTrace = QuietBinIFace - putWithUserData quietTrace bh fat_iface + putWithUserData + quietTrace +#if MIN_VERSION_ghc(9,11,0) + (Iface.flagsToIfCompression _dflags) +#endif + bh + fat_iface -- And send the result to the file writeBinMem bh core_path @@ -141,7 +150,11 @@ | (op, val_index) <- classAllSelIds cls `zip` [0..] ] get_defn :: Id -> CoreBind -get_defn identifier = NonRec identifier (unfoldingTemplate (realIdUnfolding identifier)) +get_defn identifier = NonRec identifier templ + where + templ = case maybeUnfoldingTemplate (realIdUnfolding identifier) of + Nothing -> error "get_dfn: no unfolding template" + Just x -> x toIfaceTopBndr1 :: Module -> Id -> IfaceId toIfaceTopBndr1 mod identifier @@ -197,7 +210,7 @@ name' <- newIfaceName (mkVarOcc $ getOccString name) pure $ ifid{ ifName = name' } | otherwise = pure ifid - unmangle_decl_name _ifid = error $ "tcIfaceId: got non IfaceId: " + unmangle_decl_name _ifid = error "tcIfaceId: got non IfaceId: " -- invariant: 'IfaceId' is always a 'IfaceId' constructor getIfaceId (AnId identifier) = identifier getIfaceId _ = error "tcIfaceId: got non Id" 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 @@ -1,11 +1,15 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error ( -- * Producing Diagnostic values - diagFromErrMsgs + diagFromGhcErrorMessages + , diagFromErrMsgs , diagFromErrMsg + , diagFromSDocErrMsgs + , diagFromSDocErrMsg , diagFromString , diagFromStrings , diagFromGhcException @@ -33,10 +37,13 @@ , toDSeverity ) where +import Control.Lens import Data.Maybe import Data.String (fromString) import qualified Data.Text as T -import Development.IDE.GHC.Compat (DecoratedSDoc, MsgEnvelope, +import Data.Tuple.Extra (uncurry3) +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, + errMsgDiagnostic, errMsgSeverity, errMsgSpan, formatErrorWithQual, srcErrorMessages) @@ -51,30 +58,51 @@ CodePointRange (CodePointRange)) -diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic -diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) - Diagnostic - { _range = fromMaybe noRange $ srcSpanToRange loc - , _severity = Just sev - , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers - , _message = msg - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - , _codeDescription = Nothing - , _data_ = Nothing - } +diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic +diagFromText diagSource sev loc msg origMsg = + D.ideErrorWithSource + (Just diagSource) (Just sev) + (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc) + msg origMsg + & fdLspDiagnosticL %~ \diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc } -- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] -diagFromErrMsg diagSource dflags e = - [ diagFromText diagSource sev (errMsgSpan e) - $ T.pack $ formatErrorWithQual dflags e - | Just sev <- [toDSeverity $ errMsgSeverity e]] +diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic] +diagFromErrMsg diagSource dflags origErr = + let err = fmap (\e -> (Compat.renderDiagnosticMessageWithHints e, Just origErr)) origErr + in + diagFromSDocWithOptionalOrigMsg diagSource dflags err -diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] +-- | Compatibility function for creating '[FileDiagnostic]' from +-- a 'Compat.Bag' of GHC error messages. +-- The function signature changes based on the GHC version. +-- While this is not desirable, it avoids more CPP statements in code +-- that implements actual logic. +#if MIN_VERSION_ghc(9,5,0) +diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] +diagFromGhcErrorMessages sourceParser dflags errs = + diagFromErrMsgs sourceParser dflags errs +#else +diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic] +diagFromGhcErrorMessages sourceParser dflags errs = + diagFromSDocErrMsgs sourceParser dflags errs +#endif + +diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList +diagFromSDocErrMsg :: T.Text -> DynFlags -> MsgEnvelope Compat.DecoratedSDoc -> [FileDiagnostic] +diagFromSDocErrMsg diagSource dflags err = + diagFromSDocWithOptionalOrigMsg diagSource dflags (fmap (,Nothing) err) + +diagFromSDocErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic] +diagFromSDocErrMsgs diagSource dflags = concatMap (diagFromSDocErrMsg diagSource dflags) . Compat.bagToList + +diagFromSDocWithOptionalOrigMsg :: T.Text -> DynFlags -> MsgEnvelope (Compat.DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> [FileDiagnostic] +diagFromSDocWithOptionalOrigMsg diagSource dflags err = + [ diagFromText diagSource sev (errMsgSpan err) (T.pack (formatErrorWithQual dflags (fmap fst err))) (snd (errMsgDiagnostic err)) + | Just sev <- [toDSeverity $ errMsgSeverity err]] + -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range srcSpanToRange (UnhelpfulSpan _) = Nothing @@ -157,27 +185,19 @@ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity -#if !MIN_VERSION_ghc(9,3,0) -toDSeverity SevOutput = Nothing -toDSeverity SevInteractive = Nothing -toDSeverity SevDump = Nothing -toDSeverity SevInfo = Just DiagnosticSeverity_Information -toDSeverity SevFatal = Just DiagnosticSeverity_Error -#else -toDSeverity SevIgnore = Nothing -#endif -toDSeverity SevWarning = Just DiagnosticSeverity_Warning -toDSeverity SevError = Just DiagnosticSeverity_Error +toDSeverity SevIgnore = Nothing +toDSeverity SevWarning = Just DiagnosticSeverity_Warning +toDSeverity SevError = Just DiagnosticSeverity_Error -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given -- (optional) locations and message strings. -diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic] -diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev)) +diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))] -> [FileDiagnostic] +diagFromStrings diagSource sev = concatMap (uncurry3 (diagFromString diagSource sev)) -- | Produce a GHC-style error from a source span and a message. -diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic] -diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] +diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic] +diagFromString diagSource sev sp x origMsg = [diagFromText diagSource sev sp (T.pack x) origMsg] -- | Produces an "unhelpful" source span with the given string. @@ -207,15 +227,11 @@ Right <$> ghcM where ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics = return . Left . diagFromErrMsgs fromWhere dflags -#if MIN_VERSION_ghc(9,3,0) - . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages -#endif - . srcErrorMessages - + sourceErrorToDiagnostics diag = pure $ Left $ + diagFromErrMsgs fromWhere dflags (Compat.getMessages (srcErrorMessages diag)) diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] -diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) +diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) Nothing 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 @@ -7,7 +7,9 @@ -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding + (DuplicateRecordFields, + FieldSelectors) import Development.IDE.GHC.Util import Control.DeepSeq @@ -17,26 +19,18 @@ import Data.String (IsString (fromString)) import Data.Text (unpack) +import Data.Bifunctor (Bifunctor (..)) import GHC.ByteCode.Types import GHC.Data.Bag import GHC.Data.FastString import qualified GHC.Data.StringBuffer as SB -import GHC.Types.SrcLoc - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Types.Unique (getKey) -import GHC.Unit.Module.Graph (ModuleGraph) -#endif - -import Data.Bifunctor (Bifunctor (..)) import GHC.Parser.Annotation - -#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.FieldLabel (DuplicateRecordFields (DuplicateRecordFields, NoDuplicateRecordFields), + FieldSelectors (FieldSelectors, NoFieldSelectors)) import GHC.Types.PkgQual +import GHC.Types.SrcLoc -#endif +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo @@ -57,6 +51,17 @@ instance NFData ModDetails where rnf = rwhnf instance NFData SafeHaskellMode where rnf = rwhnf instance Show Linkable where show = unpack . printOutputable +#if MIN_VERSION_ghc(9,11,0) +instance NFData Linkable where rnf (Linkable a b c) = rnf a `seq` rnf b `seq` rnf c +instance NFData LinkableObjectSort where rnf = rwhnf +instance NFData LinkablePart where + rnf (DotO a b) = rnf a `seq` rnf b + rnf (DotA f) = rnf f + rnf (DotDLL f) = rnf f + rnf (BCOs a) = seqCompiledByteCode a + rnf (CoreBindings wcb) = rnf wcb + rnf (LazyBCOs a b) = seqCompiledByteCode a `seq` rnf b +#else instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where rnf (DotO f) = rnf f @@ -66,14 +71,24 @@ #if MIN_VERSION_ghc(9,5,0) rnf (CoreBindings wcb) = rnf wcb rnf (LoadedBCOs us) = rnf us +#endif +#endif +#if MIN_VERSION_ghc(9,5,0) instance NFData WholeCoreBindings where +#if MIN_VERSION_ghc(9,11,0) + rnf (WholeCoreBindings bs m ml f) = rnf bs `seq` rnf m `seq` rnf ml `seq` rnf f +#else rnf (WholeCoreBindings bs m ml) = rnf bs `seq` rnf m `seq` rnf ml +#endif instance NFData ModLocation where +#if MIN_VERSION_ghc(9,11,0) + rnf (OsPathModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 +#else rnf (ModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 - #endif +#endif instance Show PackageFlag where show = unpack . printOutputable instance Show InteractiveImport where show = unpack . printOutputable @@ -88,9 +103,6 @@ instance Show Module where show = moduleNameString . moduleName -#if !MIN_VERSION_ghc(9,3,0) -instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable -#endif #if !MIN_VERSION_ghc(9,5,0) instance (NFData l, NFData e) => NFData (GenLocated l e) where @@ -131,12 +143,6 @@ instance NFData HieFile where rnf = rwhnf -#if !MIN_VERSION_ghc(9,3,0) -deriving instance Eq SourceModified -deriving instance Show SourceModified -instance NFData SourceModified where - rnf = rwhnf -#endif instance Hashable ModuleName where hashWithSalt salt = hashWithSalt salt . show @@ -222,7 +228,6 @@ instance NFData HomeModInfo where rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link -#if MIN_VERSION_ghc(9,3,0) instance NFData PkgQual where rnf NoPkgQual = () rnf (ThisPkg uid) = rnf uid @@ -233,7 +238,6 @@ instance NFData NodeKey where rnf = rwhnf -#endif #if MIN_VERSION_ghc(9,5,0) instance NFData HomeModLinkable where @@ -246,8 +250,27 @@ instance NFData (Pat (GhcPass Renamed)) where rnf = rwhnf +instance NFData (HsExpr (GhcPass Typechecked)) where + rnf = rwhnf + +instance NFData (Pat (GhcPass Typechecked)) where + rnf = rwhnf + instance NFData Extension where rnf = rwhnf instance NFData (UniqFM Name [Name]) where rnf (ufmToIntMap -> m) = rnf m + +#if !MIN_VERSION_ghc(9,5,0) +instance NFData DuplicateRecordFields where + rnf DuplicateRecordFields = () + rnf NoDuplicateRecordFields = () + +instance NFData FieldSelectors where + rnf FieldSelectors = () + rnf NoFieldSelectors = () + +instance NFData FieldLabel where + rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d +#endif diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -255,7 +255,6 @@ -- Tracing exactprint terms -- | Print a GHC value in `defaultUserStyle` without unique symbols. --- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally. -- -- This is the most common print utility. -- It will do something additionally compared to what the 'Outputable' instance does. 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 @@ -6,15 +6,37 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict -import Data.List +import Control.Lens (over) import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics -import Language.LSP.Protocol.Types (type (|?) (..)) +{- + Note [withWarnings and its dangers] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + withWarnings collects warnings by registering a custom logger which extracts + the SDocs of those warnings. If you receive warnings this way, you will not + get them in a structured form. In the medium term we'd like to remove all + uses of withWarnings to get structured messages everywhere we can. + For the time being, withWarnings is no longer used for anything in the main + typecheckModule codepath, but it is still used for bytecode/object code + generation, as well as a few other places. + + I suspect some of these functions (e.g. codegen) will need deeper changes to + be able to get diagnostics as a list, though I don't have great evidence for + that atm. I haven't taken a look to see if those functions that are wrapped + with this could produce diagnostics another way. + + It would be good for someone to take a look. What we've done so far gives us + diagnostics for renaming and typechecking, and doesn't require us to copy + too much code from GHC or make any deeper changes, and lets us get started + with the bulk of the useful plugin work, but it would be good to have all + diagnostics with structure be collected that way. +-} + -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some -- parsed module 'pm@') and produce a "decorated" action that will -- harvest any warnings encountered executing the action. The 'phase' @@ -24,42 +46,16 @@ -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action -#if MIN_VERSION_ghc(9,3,0) +-- +-- Also, See Note [withWarnings and its dangers] for some commentary on this function. withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a) -#else -withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) -#endif withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg + let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) - where - third3 :: (c -> d) -> (a, b, c) -> (a, b, d) - third3 f (a, b, c) = (a, b, f c) - -#if MIN_VERSION_ghc(9,3,0) -attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic -attachReason Nothing d = d -attachReason (Just wr) d = d{_code = InR <$> showReason wr} - where - showReason = \case - WarningWithFlag flag -> showFlag flag - _ -> Nothing -#else -attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr d = d{_code = InR <$> showReason wr} - where - showReason = \case - NoReason -> Nothing - Reason flag -> showFlag flag - ErrReason flag -> showFlag =<< flag -#endif - -showFlag :: WarningFlag -> Maybe T.Text -showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags 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 @@ -20,6 +20,7 @@ , insertImport , pathToId , idToPath + , idToModLocation , reachableModules , processDependencyInformation , transitiveDeps @@ -47,21 +48,14 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Tuple.Extra hiding (first, second) +import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () -import GHC.Generics (Generic) -import Prelude hiding (mod) - import Development.IDE.Import.FindImports (ArtifactsLocation (..)) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location - -import Development.IDE.GHC.Compat - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +import GHC.Generics (Generic) +import Prelude hiding (mod) -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Graph (ModuleGraph) -#endif -- | The imports for a given module. newtype ModuleImports = ModuleImports 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 @@ -14,29 +14,23 @@ ) where import Control.DeepSeq -import Development.IDE.GHC.Compat as Compat -import Development.IDE.GHC.Error as ErrUtils -import Development.IDE.GHC.Orphans () -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location - --- standard imports import Control.Monad.Extra import Control.Monad.IO.Class import Data.List (find, isSuffixOf) import Data.Maybe import qualified Data.Set as S +import Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Error as ErrUtils +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import GHC.Types.PkgQual +import GHC.Unit.State import System.FilePath --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import Development.IDE.GHC.Compat.Util -#endif - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Types.PkgQual -import GHC.Unit.State +#if MIN_VERSION_ghc(9,11,0) +import GHC.Driver.DynFlags #endif data Import @@ -105,12 +99,11 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -#if MIN_VERSION_ghc(9,3,0) mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, ([FilePath], S.Set ModuleName)) -mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags)) +#if MIN_VERSION_ghc(9,11,0) +mkImportDirs _env (i, flags) = Just (i, (importPaths flags, S.fromList $ map reexportTo $ reexportedModules flags)) #else -mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath], S.Set ModuleName)) -mkImportDirs env (i, flags) = (, (i, importPaths flags, S.empty)) <$> getUnitName env i +mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags)) #endif -- | locate a module in either the file system or the package database. Where we go from *daml to @@ -122,42 +115,22 @@ -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -#if MIN_VERSION_ghc(9,3,0) -> PkgQual -- ^ Package name -#else - -> Maybe FastString -- ^ Package name -#endif -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -#if MIN_VERSION_ghc(9,3,0) -- 'ThisPkg' just means some home module, not the current unit ThisPkg uid | Just (dirs, reexports) <- lookup uid import_paths -> lookupLocal uid dirs reexports | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound [] -#else - -- "this" means that we should only look in the current package - Just "this" -> do - lookupLocal (homeUnitId_ dflags) (importPaths dflags) S.empty -#endif -- if a package name is given we only go look for a package -#if MIN_VERSION_ghc(9,3,0) OtherPkg uid | Just (dirs, reexports) <- lookup uid import_paths -> lookupLocal uid dirs reexports -#else - Just pkgName - | Just (uid, dirs, reexports) <- lookup (PackageName pkgName) import_paths - -> lookupLocal uid dirs reexports -#endif | otherwise -> lookupInPackageDB -#if MIN_VERSION_ghc(9,3,0) NoPkgQual -> do -#else - Nothing -> do -#endif -- Reexports for current unit have to be empty because they only apply to other units depending on the -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying @@ -181,7 +154,11 @@ -- 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. +#if MIN_VERSION_ghc(9,11,0) + map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, S.fromList $ map reexportTo $ reexportedModules this_df)) hpt_deps +#else map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, reexportedModules this_df)) hpt_deps +#endif ue = hsc_unit_env env units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue hpt_deps :: [UnitId] @@ -196,11 +173,7 @@ -- 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. _import_paths' = -- import_paths' is only used in GHC < 9.4 -#if MIN_VERSION_ghc(9,3,0) import_paths -#else - map snd import_paths -#endif toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) @@ -226,7 +199,7 @@ mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where dfs = hsc_dflags env - mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) + mkError' doc = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) doc Nothing modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer. @@ -263,10 +236,5 @@ , fr_suggestions = [] } -#if MIN_VERSION_ghc(9,3,0) noPkgQual :: PkgQual noPkgQual = NoPkgQual -#else -noPkgQual :: Maybe a -noPkgQual = Nothing -#endif 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 @@ -7,8 +7,10 @@ ( Log(..) -- * For haskell-language-server , hover + , foundHover , gotoDefinition , gotoTypeDefinition + , gotoImplementation , documentHighlight , references , wsSymbols @@ -46,9 +48,11 @@ gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition) hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) +gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation) documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null) -gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst) +gotoImplementation = request "Implementation" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL 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 @@ -19,22 +19,18 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToRealSrcSpan, realSrcSpanToRange) -import Development.IDE.Types.Location import Development.IDE.GHC.Util (printOutputable) +import Development.IDE.Types.Location import Ide.Types -import Language.LSP.Protocol.Types (DocumentSymbol (..), +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InL, InR), uriToFilePath) -import Language.LSP.Protocol.Message + type (|?) (InL, InR), + uriToFilePath) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import qualified Data.Text as T -#endif - moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } @@ -118,21 +114,13 @@ , L (locA -> RealSrcSpan l' _) n <- cs , let l'' = case con of L (locA -> RealSrcSpan l''' _) _ -> l''' - _ -> l' + _ -> l' ] } where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol -#if MIN_VERSION_ghc(9,3,0) cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) -#else - cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) -#endif -#if MIN_VERSION_ghc(9,3,0) { _name = printOutputable (unLoc (foLabel n)) -#else - { _name = printOutputable (unLoc (rdrNameFieldOcc n)) -#endif , _kind = SymbolKind_Field } cvtFld _ = Nothing @@ -148,23 +136,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = -#if MIN_VERSION_ghc(9,3,0) - printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) -#else - printOutputable (unLoc feqn_tycon) <> " " <> T.unwords - (map printOutputable feqn_pats) -#endif + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = -#if MIN_VERSION_ghc(9,3,0) - printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) -#else - printOutputable (unLoc feqn_tycon) <> " " <> T.unwords - (map printOutputable feqn_pats) -#endif + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = @@ -267,18 +245,16 @@ get_flds_h98 :: HsConDeclH98Details GhcPs -> [LFieldOcc GhcPs] get_flds_h98 (RecCon flds) = get_flds (reLoc flds) - get_flds_h98 _ = [] + get_flds_h98 _ = [] get_flds_gadt :: HsConDeclGADTDetails GhcPs -> [LFieldOcc GhcPs] #if MIN_VERSION_ghc(9,9,0) get_flds_gadt (RecConGADT _ flds) = get_flds (reLoc flds) -#elif MIN_VERSION_ghc(9,3,0) - get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #else - get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) + get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #endif - get_flds_gadt _ = [] + get_flds_gadt _ = [] get_flds :: Located [LConDeclField GhcPs] -> [LFieldOcc GhcPs] 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 @@ -41,7 +41,7 @@ trace x = otTracedHandler "Request" (show _method) $ \sp -> do traceWithSpan sp _params x - writeChan chan $ ReactorRequest (_id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) + writeChan chan $ ReactorRequest _id (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler :: forall m c. PluginMethod Notification m => 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 @@ -16,7 +16,6 @@ putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, - catchAny, displayException) import Control.Monad.Extra (concatMapM, unless, when) @@ -32,7 +31,7 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import Development.IDE (Action, - Priority (Debug, Error), + Priority (Debug), Rules, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) @@ -72,9 +71,9 @@ import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, + getInitialGhcLibDirDefault, loadSessionWithOptions, - retryOnSqliteBusy, - setInitialDynFlags) + retryOnSqliteBusy) import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') @@ -136,7 +135,6 @@ | LogLspStart [PluginId] | LogLspStartDuration !Seconds | LogShouldRunSubset !Bool - | LogSetInitialDynFlagsException !SomeException | LogConfigurationChange T.Text | LogService Service.Log | LogShake Shake.Log @@ -160,8 +158,6 @@ "Started LSP server in" <+> pretty (showDuration duration) LogShouldRunSubset shouldRunSubset -> "shouldRunSubset:" <+> pretty shouldRunSubset - LogSetInitialDynFlagsException e -> - "setInitialDynFlags:" <+> pretty (displayException e) LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg LogService msg -> pretty msg LogShake msg -> pretty msg @@ -329,13 +325,6 @@ getIdeState env rootPath withHieDb threadQueue = do t <- ioT logWith recorder Info $ LogLspStartDuration t - -- We want to set the global DynFlags right now, so that we can use - -- `unsafeGlobalDynFlags` even before the project is configured - _mlibdir <- - setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions - -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -435,7 +424,7 @@ let root = argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def + mlibdir <- getInitialGhcLibDirDefault (cmapWithPrio LogSession recorder) root rng <- newStdGen case mlibdir of Nothing -> exitWith $ ExitFailure 1 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 @@ -19,6 +19,7 @@ import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Compile +import Development.IDE.Core.FileStore (getUriContents) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes @@ -133,11 +134,7 @@ $ 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 -#else - name <- liftIO $ upNameCache nc (lookupNameCache mod occ) -#endif mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file let (dm,km) = case mdkm of Just (DKMap docMap tyThingMap, _) -> (docMap,tyThingMap) @@ -169,8 +166,9 @@ CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position ,_context=completionContext} = ExceptT $ do - contents <- pluginGetVirtualFile $ toNormalizedUri uri - fmap Right $ case (contents, uriToFilePath' uri) of + contentsMaybe <- + liftIO $ runAction "Completion" ide $ getUriContents $ toNormalizedUri uri + fmap Right $ case (contentsMaybe, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do @@ -204,7 +202,7 @@ pure (opts, fmap (,pm,binds) compls, moduleExports, astres) case compls of Just (cci', parsedMod, bindMap) -> do - let pfix = getCompletionPrefix position cnts + let pfix = getCompletionPrefixFromRope position cnts case (pfix, completionContext) of (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) -> return (InL []) 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 @@ -74,11 +74,6 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Plugins (defaultSDocContext, - renderWithContext) -#endif - #if MIN_VERSION_ghc(9,5,0) import Language.Haskell.Syntax.Basic #endif @@ -514,13 +509,8 @@ -- -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@ -- Hence, we must concat nested arguments into one to get all the fields. -#if MIN_VERSION_ghc(9,3,0) extract ConDeclField{..} = map (foLabel . unLoc) cd_fld_names -#else - extract ConDeclField{..} - = map (rdrNameFieldOcc . unLoc) cd_fld_names -#endif -- XConDeclField extract _ = [] findRecordCompl _ _ _ = [] 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 @@ -16,7 +16,6 @@ import Data.Aeson.Types import Data.Hashable (Hashable) import Data.Text (Text) -import Data.Typeable (Typeable) import Development.IDE.GHC.Compat import Development.IDE.Graph (RuleResult) import Development.IDE.Spans.Common () @@ -31,12 +30,12 @@ type instance RuleResult NonLocalCompletions = CachedCompletions data LocalCompletions = LocalCompletions - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable LocalCompletions instance NFData LocalCompletions data NonLocalCompletions = NonLocalCompletions - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable NonLocalCompletions instance NFData NonLocalCompletions 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 @@ -10,7 +10,10 @@ ) where import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad +import qualified Control.Monad.Extra as Extra +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Except (runExceptT) import qualified Data.Aeson as A import Data.Bifunctor (first) @@ -22,7 +25,7 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (isNothing, mapMaybe) import Data.Some import Data.String import Data.Text (Text) @@ -39,6 +42,7 @@ import Ide.Plugin.HandleRequestTypes import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS +import qualified Language.LSP.Protocol.Lens as JL import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP @@ -58,6 +62,7 @@ | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException + | LogResolveDefaultHandler (Some SMethod) instance Pretty Log where pretty = \case @@ -71,6 +76,8 @@ ExceptionInPlugin plId (Some method) exception -> "Exception in plugin " <> viaShow plId <> " while processing " <> pretty method <> ": " <> viaShow exception + LogResolveDefaultHandler (Some method) -> + "No plugin can handle" <+> pretty method <+> "request. Return object unchanged." instance Show Log where show = renderString . layoutCompact . pretty noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c) @@ -250,8 +257,16 @@ let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs' let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest m params desc config)) <$> dfs -- Clients generally don't display ResponseErrors so instead we log any that we come across + -- However, some clients do display ResponseErrors! See for example the issues: + -- https://github.com/haskell/haskell-language-server/issues/4467 + -- https://github.com/haskell/haskell-language-server/issues/4451 case nonEmpty fs of - Nothing -> liftIO $ noPluginHandles recorder m disabledPluginsReason + Nothing -> do + liftIO (fallbackResolveHandler recorder m params) >>= \case + Nothing -> + liftIO $ noPluginHandles recorder m disabledPluginsReason + Just result -> + pure $ Right result Just neFs -> do let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params @@ -272,6 +287,72 @@ Just xs -> do pure $ Right $ combineResponses m config caps params xs +-- | Fallback Handler for resolve requests. +-- For all kinds of `*/resolve` requests, if they don't have a 'data_' value, +-- produce the original item, since no other plugin has any resolve data. +-- +-- This is an internal handler, so it cannot be turned off and should be opaque +-- to the end-user. +-- This function does not take the ServerCapabilities into account, and assumes +-- clients will only send these requests, if and only if the Language Server +-- advertised support for it. +-- +-- See Note [Fallback Handler for LSP resolve requests] for justification and reasoning. +fallbackResolveHandler :: MonadIO m => Recorder (WithPriority Log) -> SMethod s -> MessageParams s -> m (Maybe (MessageResult s)) +fallbackResolveHandler recorder m params = do + let result = case m of + SMethod_InlayHintResolve + | noResolveData params -> Just params + SMethod_CompletionItemResolve + | noResolveData params -> Just params + SMethod_CodeActionResolve + | noResolveData params -> Just params + SMethod_WorkspaceSymbolResolve + | noResolveData params -> Just params + SMethod_CodeLensResolve + | noResolveData params -> Just params + SMethod_DocumentLinkResolve + | noResolveData params -> Just params + _ -> Nothing + logResolveHandling result + pure result + where + noResolveData :: JL.HasData_ p (Maybe a) => p -> Bool + noResolveData p = isNothing $ p ^. JL.data_ + + -- We only log if we are handling the request. + -- If we don't handle this request, this should be logged + -- on call-site. + logResolveHandling p = Extra.whenJust p $ \_ -> do + logWith recorder Debug $ LogResolveDefaultHandler (Some m) + +{- Note [Fallback Handler for LSP resolve requests] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We have a special fallback for `*/resolve` requests. + +We had multiple reports, where `resolve` requests (such as +`completion/resolve` and `codeAction/resolve`) are rejected +by HLS since the `_data_` field of the respective LSP feature has not been +populated by HLS. +This makes sense, as we only support `resolve` for certain kinds of +`CodeAction`/`Completions`, when they contain particularly expensive +properties, such as documentation or non-local type signatures. + +So what to do? We can see two options: + +1. Be dumb and permissive: if no plugin wants to resolve a request, then + just respond positively with the original item! Potentially this masks + real issues, but may not be too bad. If a plugin thinks it can + handle the request but it then fails to resolve it, we should still return a failure. +2. Try and be smart: we try to figure out requests that we're "supposed" to + resolve (e.g. those with a data field), and fail if no plugin wants to handle those. + This is possible since we set data. + So as long as we maintain the invariant that only things which need resolving get + data, then it could be okay. + +In 'fallbackResolveHandler', we implement the option (2). +-} -- --------------------------------------------------------------------- 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 @@ -51,6 +51,8 @@ Hover.gotoDefinition recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} -> + Hover.gotoImplementation recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> Hover.documentHighlight recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder) 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -26,7 +27,8 @@ import qualified Data.Map as Map import Data.Maybe (catMaybes, maybeToList) import qualified Data.Text as T -import Development.IDE (GhcSession (..), +import Development.IDE (FileDiagnostic (..), + GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, Uri, define, srcSpanToRange, @@ -126,9 +128,10 @@ -- We don't actually pass any data to resolve, however we need this -- dummy type to make sure HLS resolves our lens [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) - | (dFile, _, diag@Diagnostic{_range}) <- diags - , dFile == nfp - , isGlobalDiagnostic diag] + | diag <- diags + , let lspDiag@Diagnostic {_range} = fdLspDiagnostic diag + , fdFilePath diag == nfp + , isGlobalDiagnostic lspDiag] -- The second option is to generate lenses from the GlobalBindingTypeSig -- rule. This is the only type that needs to have the range adjusted -- with PositionMapping. @@ -319,7 +322,11 @@ let name = idName identifier hasSig name $ do env <- tcInitTidyEnv +#if MIN_VERSION_ghc(9,11,0) + let ty = tidyOpenType env (idType identifier) +#else let (_, ty) = tidyOpenType env (idType identifier) +#endif pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) patToSig p = do let name = patSynName p 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 @@ -10,6 +10,7 @@ atPoint , gotoDefinition , gotoTypeDefinition + , gotoImplementation , documentHighlight , pointCommand , referencesAtPoint @@ -23,6 +24,10 @@ , LookupModule ) where + +import GHC.Data.FastString (lengthFS) +import qualified GHC.Utils.Outputable as O + import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location @@ -31,6 +36,7 @@ import Prelude hiding (mod) -- compiler and infrastructure +import Development.IDE.Core.Compile (setNonHomeFCHook) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat @@ -52,9 +58,13 @@ import qualified Data.Array as A import Data.Either -import Data.List (isSuffixOf) import Data.List.Extra (dropEnd1, nubOrd) + +import Data.Either.Extra (eitherToMaybe) +import Data.List (isSuffixOf, sortOn) +import Data.Tree +import qualified Data.Tree as T import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb) import HieDb hiding (pointCommand, @@ -171,14 +181,19 @@ highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) - pure $ makeHighlight ref - makeHighlight (sp,dets) = - DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) + maybeToList (makeHighlight n ref) + makeHighlight n (sp,dets) + | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing + | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) highlightType s = if any (isJust . getScopeFromContext) s then DocumentHighlightKind_Write else DocumentHighlightKind_Read + isBadSpan :: Name -> RealSrcSpan -> Bool + isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n)) + +-- | Locate the type definition of the name at a given position. gotoTypeDefinition :: MonadIO m => WithHieDb @@ -186,7 +201,7 @@ -> IdeOptions -> HieAstResult -> Position - -> MaybeT m [Location] + -> MaybeT m [(Location, Identifier)] gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans @@ -197,12 +212,25 @@ -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath - -> HieASTs a + -> HieAstResult -> Position - -> MaybeT m [Location] + -> MaybeT m [(Location, Identifier)] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans +-- | Locate the implementation definition of the name at a given position. +-- Goto Implementation for an overloaded function. +gotoImplementation + :: MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> HieAstResult + -> Position + -> MaybeT m [Location] +gotoImplementation withHieDb getHieFile ideOpts srcSpans pos + = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts pos srcSpans + -- | Synopsis for the name at a given position. atPoint :: IdeOptions @@ -211,13 +239,13 @@ -> HscEnv -> Position -> IO (Maybe (Maybe Range, [T.Text])) -atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos = +atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos = listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text]) hoverInfo ast = do - prettyNames <- mapM prettyName filteredNames + prettyNames <- mapM prettyName names pure (Just range, prettyNames ++ pTypes) where pTypes :: [T.Text] @@ -234,24 +262,34 @@ info :: NodeInfo hietype info = nodeInfoH kind ast + -- We want evidence variables to be displayed last. + -- Evidence trees contain information of secondary relevance. names :: [(Identifier, IdentifierDetails hietype)] - names = M.assocs $ nodeIdentifiers info - - -- Check for evidence bindings - isInternal :: (Identifier, IdentifierDetails a) -> Bool - isInternal (Right _, dets) = - any isEvidenceContext $ identInfo dets - isInternal (Left _, _) = False - - filteredNames :: [(Identifier, IdentifierDetails hietype)] - filteredNames = filter (not . isInternal) names + names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info 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 - ] + prettyName (Right n, dets) + -- We want to print evidence variable using a readable tree structure. + -- Evidence variables contain information why a particular instance or + -- type equality was chosen, paired with location information. + | any isEvidenceUse (identInfo dets) = + let + -- The evidence tree may not be present for some reason, e.g., the 'Name' is not + -- present in the tree. + -- Thus, we need to handle it here, but in practice, this should never be 'Nothing'. + evidenceTree = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) + in + pure $ evidenceTree <> "\n" + -- Identifier details that are not evidence variables are used to display type information and + -- documentation of that name. + | otherwise = + let + typeSig = wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) + definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n)) + docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n) + in + pure $ T.unlines $ + [typeSig] ++ definitionLoc ++ docs where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" @@ -269,7 +307,7 @@ -- the package(with version) this `ModuleName` belongs to. packageNameForImportStatement :: ModuleName -> IO T.Text packageNameForImportStatement mod = do - mpkg <- findImportedModule env mod :: IO (Maybe Module) + mpkg <- findImportedModule (setNonHomeFCHook env) mod :: IO (Maybe Module) let moduleName = printOutputable mod case mpkg >>= packageNameWithVersion of Nothing -> pure moduleName @@ -285,7 +323,7 @@ version = T.pack $ showVersion (unitPackageVersion conf) pure $ pkgName <> "-" <> version - -- Type info for the current node, it may contains several symbols + -- Type info for the current node, it may contain several symbols -- for one range, like wildcard types :: [hietype] types = nodeType info @@ -294,10 +332,13 @@ 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) + prettyType = printOutputable . expandType + expandType :: a -> SDoc + expandType t = case kind of + HieFresh -> ppr t + HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file) + definedAt :: Name -> Maybe T.Text definedAt name = -- do not show "at " and similar messages @@ -306,6 +347,67 @@ UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" + -- We want to render the root constraint even if it is a let, + -- but we don't want to render any subsequent lets + renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc + -- However, if the root constraint is simply a (Show (,), Show [], Show Int, Show Bool)@ + -- + -- It is also quite helpful to look at the @.hie@ file directly to see how the + -- evidence information is presented on disk. @hiedb dump @ + renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x]) + = renderEvidenceTree x + renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs) + = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ text "constructed using:" : map renderEvidenceTree' xs + renderEvidenceTree (T.Node (EvidenceInfo{..}) _) + = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar) + + -- renderEvidenceTree' skips let bound evidence variables and prints the children directly + renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs) + = vcat (map renderEvidenceTree' xs) + renderEvidenceTree' (T.Node (EvidenceInfo{..}) _) + = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ + printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar) + + printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc + printDets _ Nothing = text "using an external instance" + printDets ospn (Just (src,_,mspn)) = pprSrc + $$ text "at" <+> text (T.unpack $ srcSpanToMdLink location) + where + location = realSrcSpanToLocation spn + -- Use the bind span if we have one, else use the occurrence span + spn = fromMaybe ospn mspn + pprSrc = case src of + -- Users don't know what HsWrappers are + EvWrapperBind -> "bound by type signature or pattern" + _ -> ppr src + +-- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's. typeLocationsAtPoint :: forall m . MonadIO m @@ -314,14 +416,14 @@ -> IdeOptions -> Position -> HieAstResult - -> m [Location] + -> m [(Location, Identifier)] typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = case hieKind of HieFromDisk hf -> let arr = hie_types hf ts = concat $ pointCommand ast pos getts unfold = map (arr A.!) - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo' x getTypes' ts' = flip concatMap (unfold ts') $ \case HTyVarTy n -> [n] @@ -332,12 +434,12 @@ HQualTy a b -> getTypes' [a,b] HCastTy a -> getTypes' [a] _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts) + in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes' ts) HieFresh -> let ts = concat $ pointCommand ast pos getts - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo x - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] @@ -350,24 +452,46 @@ namesInType _ = [] getTypes :: [Type] -> [Name] -getTypes ts = concatMap namesInType ts +getTypes = concatMap namesInType +-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint - :: forall m a + :: forall m . MonadIO m => WithHieDb -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position - -> HieASTs a - -> m [Location] -locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = + -> HieAstResult + -> m [(Location, Identifier)] +locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos - modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns + modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports + in fmap (nubOrd . concat) $ mapMaybeM + (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) + (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) + ns + +-- | Find 'Location's of a implementation definition at a specific point. +instanceLocationsAtPoint + :: forall m + . MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> Position + -> HieAstResult + -> m [Location] +instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) = + let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) + evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns + evNs = concatMap (map (evidenceVar) . T.flatten) evTrees + in fmap (nubOrd . concat) $ mapMaybeM + (nameToLocation withHieDb lookupModule) + evNs -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -13,22 +13,26 @@ , spanDocToMarkdownForTest , DocMap , TyThingMap +, srcSpanToMdLink ) where import Control.DeepSeq +import Data.Bifunctor (second) import Data.List.Extra import Data.Maybe import qualified Data.Text as T -import GHC.Generics - +import Development.IDE.GHC.Util +import qualified Documentation.Haddock.Parser as H +import qualified Documentation.Haddock.Types as H import GHC +import GHC.Generics +import System.FilePath -import Data.Bifunctor (second) +import Control.Lens import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util -import qualified Documentation.Haddock.Parser as H -import qualified Documentation.Haddock.Types as H +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Types type DocMap = NameEnv SpanDoc type TyThingMap = NameEnv TyThing @@ -54,13 +58,8 @@ safeTyThingId _ = Nothing -- Possible documentation for an element in the code -#if MIN_VERSION_ghc(9,3,0) data SpanDoc = SpanDocString [HsDocString] SpanDocUris -#else -data SpanDoc - = SpanDocString HsDocString SpanDocUris -#endif | SpanDocText [T.Text] SpanDocUris deriving stock (Eq, Show, Generic) deriving anyclass NFData @@ -97,11 +96,7 @@ spanDocToMarkdown = \case (SpanDocString docs uris) -> let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ -#if MIN_VERSION_ghc(9,3,0) renderHsDocStrings docs -#else - unpackHDS docs -#endif in go [doc] uris (SpanDocText txt uris) -> go txt uris where @@ -118,8 +113,14 @@ [ linkify "Documentation" <$> mdoc , linkify "Source" <$> msrc ] - where linkify title uri = "[" <> title <> "](" <> uri <> ")" +-- | Generate a markdown link. +-- +-- >>> linkify "Title" "uri" +-- "[Title](Uri)" +linkify :: T.Text -> T.Text -> T.Text +linkify title uri = "[" <> title <> "](" <> uri <> ")" + spanDocToMarkdownForTest :: String -> String spanDocToMarkdownForTest = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing @@ -224,3 +225,35 @@ = case lines s of [] -> "" (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest + +-- | Generate a source link for the 'Location' according to VSCode's supported form: +-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160 +-- +srcSpanToMdLink :: Location -> T.Text +srcSpanToMdLink location = + let + uri = location ^. JL.uri + range = location ^. JL.range + -- LSP 'Range' starts at '0', but link locations start at '1'. + intText n = T.pack $ show (n + 1) + srcRangeText = + T.concat + [ "L" + , intText (range ^. JL.start . JL.line) + , "," + , intText (range ^. JL.start . JL.character) + , "-L" + , intText (range ^. JL.end . JL.line) + , "," + , intText (range ^. JL.end . JL.character) + ] + + -- If the 'Location' is a 'FilePath', display it in shortened form. + -- This avoids some redundancy and better readability for the user. + title = case uriToFilePath uri of + Just fp -> T.pack (takeFileName fp) <> ":" <> intText (range ^. JL.start . JL.line) + Nothing -> getUri uri + + srcLink = getUri uri <> "#" <> srcRangeText + in + linkify title srcLink 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 @@ -41,16 +41,8 @@ -> IO DocAndTyThingMap mkDocMap env rm this_mod = do -#if MIN_VERSION_ghc(9,3,0) (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod -#else - (_ , DeclDocMap this_docs, _) <- extractDocs this_mod -#endif -#if MIN_VERSION_ghc(9,3,0) d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names -#else - d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names -#endif k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where @@ -84,11 +76,7 @@ Left _ -> return [] Right res -> zipWithM unwrap res names where -#if MIN_VERSION_ghc(9,3,0) unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n -#else - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n -#endif unwrap _ n = mkSpanDocText n mkSpanDocText name = 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,6 +15,8 @@ import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as Text +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util @@ -27,10 +29,10 @@ import Development.IDE.Core.PluginUtils import qualified Language.LSP.Protocol.Lens as L -getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo -getNextPragmaInfo dynFlags mbSourceText = - if | Just sourceText <- mbSourceText - , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText) +getNextPragmaInfo :: DynFlags -> Maybe Rope -> NextPragmaInfo +getNextPragmaInfo dynFlags mbSource = + if | Just source <- mbSource + , let sourceStringBuffer = stringToStringBuffer (Text.unpack (Rope.toText source)) , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer -> case parserState of ParserStateNotDone{ nextPragma } -> nextPragma @@ -56,7 +58,7 @@ 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 + fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp pure $ getNextPragmaInfo sessionDynFlags fileContents -- Pre-declaration comments parser ----------------------------------------------------- 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 @@ -1,32 +1,69 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} module Development.IDE.Types.Diagnostics ( LSP.Diagnostic(..), ShowDiagnostic(..), - FileDiagnostic, + FileDiagnostic(..), + fdFilePathL, + fdLspDiagnosticL, + fdShouldShowDiagnosticL, + fdStructuredMessageL, + StructuredMessage(..), + _NoStructuredMessage, + _SomeStructuredMessage, IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, ideErrorText, ideErrorWithSource, + ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, - IdeResultNoDiagnosticsEarlyCutoff) where +#if MIN_VERSION_ghc(9,5,0) + showGhcCode, +#endif + IdeResultNoDiagnosticsEarlyCutoff, + attachReason, + attachedReason) where +import Control.Applicative ((<|>)) import Control.DeepSeq +import Control.Lens +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Lens as JSON import Data.ByteString (ByteString) +import Data.Foldable import Data.Maybe as Maybe import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, + WarningFlag, flagSpecFlag, + flagSpecName, wWarningFlags) import Development.IDE.Types.Location +import GHC.Generics +#if MIN_VERSION_ghc(9,5,0) +import GHC.Types.Error (DiagnosticCode (..), + DiagnosticReason (..), + diagnosticCode, + diagnosticReason, + errMsgDiagnostic) +#else +import GHC.Types.Error (DiagnosticReason (..), + diagnosticReason, + errMsgDiagnostic) +#endif import Language.LSP.Diagnostics -import Language.LSP.Protocol.Types as LSP (Diagnostic (..), - DiagnosticSeverity (..)) +import Language.LSP.Protocol.Lens (data_) +import Language.LSP.Protocol.Types as LSP import Prettyprinter import Prettyprinter.Render.Terminal (Color (..), color) import qualified Prettyprinter.Render.Terminal as Terminal import Prettyprinter.Render.Text +import Text.Printf (printf) -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, @@ -44,26 +81,102 @@ -- | an IdeResult with a fingerprint type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) +-- | Produce a 'FileDiagnostic' for the given 'NormalizedFilePath' +-- with an error message. ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) +ideErrorText nfp msg = + ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) nfp msg Nothing +-- | Create a 'FileDiagnostic' from an existing 'LSP.Diagnostic' for a +-- specific 'NormalizedFilePath'. +-- The optional 'MsgEnvelope GhcMessage' is the original error message +-- that was used for creating the 'LSP.Diagnostic'. +-- It is included here, to allow downstream consumers, such as HLS plugins, +-- to provide LSP features based on the structured error messages. +-- Additionally, if available, we insert the ghc error code into the +-- 'LSP.Diagnostic'. These error codes are used in https://errors.haskell.org/ +-- to provide documentation and explanations for error messages. +ideErrorFromLspDiag + :: LSP.Diagnostic + -> NormalizedFilePath + -> Maybe (MsgEnvelope GhcMessage) + -> FileDiagnostic +ideErrorFromLspDiag lspDiag fdFilePath mbOrigMsg = + let fdShouldShowDiagnostic = ShowDiag + fdStructuredMessage = + case mbOrigMsg of + Nothing -> NoStructuredMessage + Just msg -> SomeStructuredMessage msg + fdLspDiagnostic = + lspDiag + & attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg) + & setGhcCode mbOrigMsg + in + FileDiagnostic {..} + +-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code which is linked +-- to https://errors.haskell.org/. +setGhcCode :: Maybe (MsgEnvelope GhcMessage) -> LSP.Diagnostic -> LSP.Diagnostic +#if MIN_VERSION_ghc(9,5,0) +setGhcCode mbOrigMsg diag = + let mbGhcCode = do + origMsg <- mbOrigMsg + code <- diagnosticCode (errMsgDiagnostic origMsg) + pure (InR (showGhcCode code)) + in + diag { _code = mbGhcCode <|> _code diag } +#else +setGhcCode _ diag = diag +#endif + +#if MIN_VERSION_ghc(9,9,0) +-- DiagnosticCode only got a show instance in 9.10.1 +showGhcCode :: DiagnosticCode -> T.Text +showGhcCode = T.pack . show +#elif MIN_VERSION_ghc(9,5,0) +showGhcCode :: DiagnosticCode -> T.Text +showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c +#endif + +attachedReason :: Traversal' Diagnostic (Maybe JSON.Value) +attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason" + +attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic +attachReason Nothing = id +attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr) + where + showReason = \case + WarningWithFlag flag -> Just $ catMaybes [showFlag flag] +#if MIN_VERSION_ghc(9,7,0) + WarningWithFlags flags -> Just $ catMaybes (fmap showFlag $ toList flags) +#endif + _ -> Nothing + +showFlag :: WarningFlag -> Maybe T.Text +showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags + ideErrorWithSource :: Maybe T.Text -> Maybe DiagnosticSeverity - -> a + -> NormalizedFilePath -> T.Text - -> (a, ShowDiagnostic, Diagnostic) -ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { - _range = noRange, - _severity = sev, - _code = Nothing, - _source = source, - _message = msg, - _relatedInformation = Nothing, - _tags = Nothing, - _codeDescription = Nothing, - _data_ = Nothing - }) + -> Maybe (MsgEnvelope GhcMessage) + -> FileDiagnostic +ideErrorWithSource source sev fdFilePath msg origMsg = + let lspDiagnostic = + LSP.Diagnostic { + _range = noRange, + _severity = sev, + _code = Nothing, + _source = source, + _message = msg, + _relatedInformation = Nothing, + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing + } + in + ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg -- | Defines whether a particular diagnostic should be reported -- back to the user. @@ -80,14 +193,79 @@ instance NFData ShowDiagnostic where rnf = rwhnf +-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or +-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on +-- FileDiagnostic. FileDiagnostic only uses this as metadata so we can safely +-- ignore it in fields. +-- +-- Instead of pattern matching on these constructors directly, consider 'Prism' from +-- the 'lens' package. This allows to conveniently pattern match deeply into the 'MsgEnvelope GhcMessage' +-- constructor. +-- The module 'Development.IDE.GHC.Compat.Error' implements additional 'Lens's and 'Prism's, +-- allowing you to avoid importing GHC modules directly. +-- +-- For example, to pattern match on a 'TcRnMessage' you can use the lens: +-- +-- @ +-- message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage +-- @ +-- +-- This produces a value of type `Maybe TcRnMessage`. +-- +-- Further, consider utility functions such as 'stripTcRnMessageContext', which strip +-- context from error messages which may be more convenient in certain situations. +data StructuredMessage + = NoStructuredMessage + | SomeStructuredMessage (MsgEnvelope GhcMessage) + deriving (Generic) + +instance Show StructuredMessage where + show NoStructuredMessage = "NoStructuredMessage" + show SomeStructuredMessage {} = "SomeStructuredMessage" + +instance Eq StructuredMessage where + (==) NoStructuredMessage NoStructuredMessage = True + (==) SomeStructuredMessage {} SomeStructuredMessage {} = True + (==) _ _ = False + +instance Ord StructuredMessage where + compare NoStructuredMessage NoStructuredMessage = EQ + compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ + compare NoStructuredMessage SomeStructuredMessage {} = GT + compare SomeStructuredMessage {} NoStructuredMessage = LT + +instance NFData StructuredMessage where + rnf NoStructuredMessage = () + rnf SomeStructuredMessage {} = () + -- | Human readable diagnostics for a specific file. -- -- This type packages a pretty printed, human readable error message -- along with the related source location so that we can display the error -- on either the console or in the IDE at the right source location. -- -type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic) +-- It also optionally keeps a structured diagnostic message GhcMessage in +-- StructuredMessage. +-- +data FileDiagnostic = FileDiagnostic + { fdFilePath :: NormalizedFilePath + , fdShouldShowDiagnostic :: ShowDiagnostic + , fdLspDiagnostic :: Diagnostic + -- | The original diagnostic that was used to produce 'fdLspDiagnostic'. + -- We keep it here, so downstream consumers, e.g. HLS plugins, can use the + -- the structured error messages and don't have to resort to parsing + -- error messages via regexes or similar. + -- + -- The optional GhcMessage inside of this StructuredMessage is ignored for + -- Eq, Ord, Show, and NFData instances. This is fine because this field + -- should only ever be metadata and should never be used to distinguish + -- between FileDiagnostics. + , fdStructuredMessage :: StructuredMessage + } + deriving (Eq, Ord, Show, Generic) +instance NFData FileDiagnostic + prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1) @@ -106,13 +284,17 @@ prettyDiagnostics = vcat . map prettyDiagnostic prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle -prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) = +prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagnostic = LSP.Diagnostic{..} } = vcat - [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp) - , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes" + [ slabel_ "File: " $ pretty (fromNormalizedFilePath fdFilePath) + , slabel_ "Hidden: " $ if fdShouldShowDiagnostic == ShowDiag then "no" else "yes" , slabel_ "Range: " $ prettyRange _range , slabel_ "Source: " $ pretty _source , slabel_ "Severity:" $ pretty $ show sev + , slabel_ "Code: " $ case _code of + Just (InR text) -> pretty text + Just (InL i) -> pretty i + Nothing -> "" , slabel_ "Message: " $ case sev of LSP.DiagnosticSeverity_Error -> annotate $ color Red @@ -150,3 +332,9 @@ defaultTermWidth :: Int defaultTermWidth = 80 + +makePrisms ''StructuredMessage + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''FileDiagnostic 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 @@ -1,25 +1,21 @@ +{-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq ( HscEnvEq, hscEnv, newHscEnvEq, - hscEnvWithImportPaths, - newHscEnvEqPreserveImportPaths, - newHscEnvEqWithImportPaths, updateHscEnvEq, - envImportPaths, envPackageExports, envVisibleModuleNames, - deps ) where import Control.Concurrent.Async (Async, async, waitCatch) import Control.Concurrent.Strict (modifyVar, newVar) -import Control.DeepSeq (force) +import Control.DeepSeq (force, rwhnf) import Control.Exception (evaluate, mask, throwIO) import Control.Monad.Extra (eitherM, join, mapMaybeM) import Data.Either (fromRight) -import Data.Set (Set) -import qualified Data.Set as Set +import Data.IORef +import qualified Data.Map as M import Data.Unique (Unique) import qualified Data.Unique as Unique import Development.IDE.GHC.Compat hiding (newUnique) @@ -28,23 +24,18 @@ import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import GHC.Driver.Env (hsc_all_home_unit_ids) import Ide.PluginUtils (toAbsolute) import OpenTelemetry.Eventlog (withSpan) -import System.FilePath +import System.Directory (makeAbsolute) + -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq' or -- 'updateHscEnvEq'. data HscEnvEq = HscEnvEq { envUnique :: !Unique , hscEnv :: !HscEnv - , deps :: [(UnitId, DynFlags)] - -- ^ In memory components for this HscEnv - -- This is only used at the moment for the import dirs in - -- the DynFlags - , envImportPaths :: Maybe (Set FilePath) - -- ^ If Just, import dirs originally configured in this env - -- If Nothing, the env import dirs are unaltered , envPackageExports :: IO ExportsMap , envVisibleModuleNames :: IO (Maybe [ModuleName]) -- ^ 'listVisibleModuleNames' is a pure function, @@ -59,18 +50,32 @@ update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq root cradlePath hscEnv0 deps = do - let relativeToCradle = (takeDirectory cradlePath ) - hscEnv = removeImportPaths hscEnv0 - - -- Make Absolute since targets are also absolute - let importPathsCanon = toAbsolute root . relativeToCradle <$> importPaths (hsc_dflags hscEnv0) +newHscEnvEq :: HscEnv -> IO HscEnvEq +newHscEnvEq hscEnv' = do - newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps + mod_cache <- newIORef emptyInstalledModuleEnv + file_cache <- newIORef M.empty + -- This finder cache is for things which are outside of things which are tracked + -- by HLS. For example, non-home modules, dependent object files etc +#if MIN_VERSION_ghc(9,11,0) + let hscEnv = hscEnv' + { hsc_FC = FinderCache + { flushFinderCaches = \_ -> error "GHC should never call flushFinderCaches outside the driver" + , addToFinderCache = \(GWIB im _) val -> do + if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv' + then error "tried to add home module to FC" + else atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c im val, ()) + , lookupFinderCache = \(GWIB im _) -> do + if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv' + then error ("tried to lookup home module from FC" ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv'))) + else lookupInstalledModuleEnv <$> readIORef mod_cache <*> pure im + , lookupFileCache = \fp -> error ("not used by HLS" ++ fp) + } + } -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do +#else + let hscEnv = hscEnv' +#endif let dflags = hsc_dflags hscEnv @@ -112,23 +117,6 @@ return HscEnvEq{..} --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEqPreserveImportPaths - :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing - --- | Unwrap the 'HscEnv' with the original import paths. --- Used only for locating imports -hscEnvWithImportPaths :: HscEnvEq -> HscEnv -hscEnvWithImportPaths HscEnvEq{..} - | Just imps <- envImportPaths - = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv - | otherwise - = hscEnv - -removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc - instance Show HscEnvEq where show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) @@ -136,9 +124,9 @@ a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _ _) = + rnf (HscEnvEq a b _ _) = -- deliberately skip the package exports map and visible module names - rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d + rnf (Unique.hashUnique a) `seq` rwhnf b instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique 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 @@ -89,9 +89,9 @@ deriving (Eq,Ord,Show,Enum) data IdePreprocessedSource = IdePreprocessedSource - { preprocWarnings :: [(GHC.SrcSpan, String)] + { preprocWarnings :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these warnings structured as well? -- ^ Warnings emitted by the preprocessor. - , preprocErrors :: [(GHC.SrcSpan, String)] + , preprocErrors :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these errors structured as well? -- ^ Errors emitted by the preprocessor. , preprocSource :: GHC.ParsedSource -- ^ New parse tree emitted by the preprocessor. diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -33,10 +33,9 @@ import HieDb.Types (HieDb) import qualified StmContainers.Map as STM import Type.Reflection (SomeTypeRep (SomeTypeRep), - pattern App, pattern Con, - typeOf, typeRep, - typeRepTyCon) -import Unsafe.Coerce (unsafeCoerce) + eqTypeRep, pattern App, + type (:~~:) (HRefl), + typeOf, typeRep) -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality @@ -86,11 +85,12 @@ -- | fromKeyType (Q (k,f)) = (typeOf k, f) fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath) -fromKeyType (Key k) = case typeOf k of - App (Con tc) a | tc == typeRepTyCon (typeRep @Q) - -> case unsafeCoerce k of - Q (_ :: (), f) -> Just (SomeTypeRep a, f) - _ -> Nothing +fromKeyType (Key k) + | App tc a <- typeOf k + , Just HRefl <- tc `eqTypeRep` (typeRep @Q) + , Q (_, f) <- k + = Just (SomeTypeRep a, f) + | otherwise = Nothing toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key toNoFileKey k = newKey $ Q (k, emptyFilePath) @@ -101,12 +101,10 @@ instance Show k => Show (Q k) where show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file --- | Invariant: the 'v' must be in normal form (fully evaluated). +-- | Invariant: the @v@ must be in normal form (fully evaluated). -- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database newtype A v = A (Value v) deriving Show - -instance NFData (A v) where rnf (A v) = v `seq` () -- In the Shake database we only store one type of key/result pairs, -- namely Q (question) / A (answer). 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 @@ -89,8 +89,7 @@ -> T.Text -- ^ Pattern to look for. -> [T.Text] -- ^ List of texts to check. -> [Scored T.Text] -- ^ The ones that match. -simpleFilter chunk maxRes pattern xs = - filter chunk maxRes pattern xs id +simpleFilter chunk maxRes pat xs = filter chunk maxRes pat xs id -- | The function to filter a list of values by fuzzy search on the text extracted from them, @@ -104,15 +103,15 @@ -- ^ 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) +filter' chunkSize maxRes pat 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 + pat' = case T.uncons pat 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) + _ -> pat + vss = map (mapMaybe (\t -> flip Scored t <$> match' pat' (extract t))) (chunkList chunkSize ts) `using` parList (evalList rseq) - perfectScore = fromMaybe (error $ T.unpack pattern) $ match' pattern' pattern' + perfectScore = fromMaybe (error $ T.unpack pat) $ match' pat' pat' -- | 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. @@ -122,8 +121,8 @@ -> [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 +filter chunkSize maxRes pat ts extract = + filter' chunkSize maxRes pat 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. @@ -136,8 +135,8 @@ -> (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' +simpleFilter' chunk maxRes pat xs match' = + filter' chunk maxRes pat xs id match' -------------------------------------------------------------------------------- chunkList :: Int -> [a] -> [[a]] diff --git a/test/data/TH/THA.hs b/test/data/TH/THA.hs deleted file mode 100644 --- a/test/data/TH/THA.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THA where -import Language.Haskell.TH - -th_a :: DecsQ -th_a = [d| a = () |] diff --git a/test/data/TH/THB.hs b/test/data/TH/THB.hs deleted file mode 100644 --- a/test/data/TH/THB.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA - -$th_a diff --git a/test/data/TH/THC.hs b/test/data/TH/THC.hs deleted file mode 100644 --- a/test/data/TH/THC.hs +++ /dev/null @@ -1,5 +0,0 @@ -module THC where -import THB - -c ::() -c = a diff --git a/test/data/TH/hie.yaml b/test/data/TH/hie.yaml deleted file mode 100644 --- a/test/data/TH/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/THCoreFile/THA.hs b/test/data/THCoreFile/THA.hs deleted file mode 100644 --- a/test/data/THCoreFile/THA.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THA where -import Language.Haskell.TH -import Control.Monad (when) - -th_a :: DecsQ -th_a = do - when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" - when (show (classMethod 'z') /= "True") $ error "TH validation error" - when (show (classMethod 'a') /= "False") $ error "TH validation error" - [d| a = () |] - -data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show -data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show -data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show - -class SingleMethodClass a where - classMethod :: a -> Bool - -instance SingleMethodClass Char where - classMethod = (== 'z') diff --git a/test/data/THCoreFile/THB.hs b/test/data/THCoreFile/THB.hs deleted file mode 100644 --- a/test/data/THCoreFile/THB.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA -import Control.Monad (when) - -$(do - -- Need to verify in both defining module and usage module" - when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" - when (show (classMethod 'z') /= "True") $ error "TH validation error" - when (show (classMethod 'a') /= "False") $ error "TH validation error" - th_a) diff --git a/test/data/THCoreFile/THC.hs b/test/data/THCoreFile/THC.hs deleted file mode 100644 --- a/test/data/THCoreFile/THC.hs +++ /dev/null @@ -1,5 +0,0 @@ -module THC where -import THB - -c ::() -c = a diff --git a/test/data/THCoreFile/hie.yaml b/test/data/THCoreFile/hie.yaml deleted file mode 100644 --- a/test/data/THCoreFile/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/THLoading/A.hs b/test/data/THLoading/A.hs deleted file mode 100644 --- a/test/data/THLoading/A.hs +++ /dev/null @@ -1,5 +0,0 @@ -module A where -import B (bar) - -foo :: () -foo = bar diff --git a/test/data/THLoading/B.hs b/test/data/THLoading/B.hs deleted file mode 100644 --- a/test/data/THLoading/B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B where - -bar :: () -bar = () diff --git a/test/data/THLoading/THA.hs b/test/data/THLoading/THA.hs deleted file mode 100644 --- a/test/data/THLoading/THA.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THA where -import Language.Haskell.TH -import A (foo) - -th_a :: DecsQ -th_a = [d| a = foo |] diff --git a/test/data/THLoading/THB.hs b/test/data/THLoading/THB.hs deleted file mode 100644 --- a/test/data/THLoading/THB.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA - -$th_a diff --git a/test/data/THLoading/hie.yaml b/test/data/THLoading/hie.yaml deleted file mode 100644 --- a/test/data/THLoading/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "A", "B"]}} diff --git a/test/data/THNewName/A.hs b/test/data/THNewName/A.hs deleted file mode 100644 --- a/test/data/THNewName/A.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A (template) where - -import Language.Haskell.TH - -template :: DecsQ -template = (\consA -> [DataD [] (mkName "A") [] Nothing [NormalC consA []] []]) <$> newName "A" diff --git a/test/data/THNewName/B.hs b/test/data/THNewName/B.hs deleted file mode 100644 --- a/test/data/THNewName/B.hs +++ /dev/null @@ -1,5 +0,0 @@ -module B(A(A)) where - -import A - -template diff --git a/test/data/THNewName/C.hs b/test/data/THNewName/C.hs deleted file mode 100644 --- a/test/data/THNewName/C.hs +++ /dev/null @@ -1,4 +0,0 @@ -module C where -import B - -a = A diff --git a/test/data/THNewName/hie.yaml b/test/data/THNewName/hie.yaml deleted file mode 100644 --- a/test/data/THNewName/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-XTemplateHaskell","-Wmissing-signatures","A", "B", "C"]}} diff --git a/test/data/THUnboxed/THA.hs b/test/data/THUnboxed/THA.hs deleted file mode 100644 --- a/test/data/THUnboxed/THA.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-} -module THA where -import Language.Haskell.TH - -data Foo = Foo !Int !Char !String - deriving Show - -newtype Bar = Bar Int - deriving Show - - -f :: Int -> (# Int, Int, Foo, Bar#) -f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #) - -th_a :: DecsQ -th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |] diff --git a/test/data/THUnboxed/THB.hs b/test/data/THUnboxed/THB.hs deleted file mode 100644 --- a/test/data/THUnboxed/THB.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA - -$th_a diff --git a/test/data/THUnboxed/THC.hs b/test/data/THUnboxed/THC.hs deleted file mode 100644 --- a/test/data/THUnboxed/THC.hs +++ /dev/null @@ -1,5 +0,0 @@ -module THC where -import THB - -c ::() -c = a diff --git a/test/data/THUnboxed/hie.yaml b/test/data/THUnboxed/hie.yaml deleted file mode 100644 --- a/test/data/THUnboxed/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/boot/A.hs b/test/data/boot/A.hs deleted file mode 100644 --- a/test/data/boot/A.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module A where - -import B( TB(..) ) - -newtype TA = MkTA Int - deriving Eq - -f :: TB -> TA -f (MkTB x) = MkTA x diff --git a/test/data/boot/A.hs-boot b/test/data/boot/A.hs-boot deleted file mode 100644 --- a/test/data/boot/A.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module A where -newtype TA = MkTA Int -instance Eq TA diff --git a/test/data/boot/B.hs b/test/data/boot/B.hs deleted file mode 100644 --- a/test/data/boot/B.hs +++ /dev/null @@ -1,7 +0,0 @@ -module B(TA(..), TB(..)) where -import {-# SOURCE #-} A( TA(..) ) - -data TB = MkTB !Int - -g :: TA -> TB -g (MkTA x) = MkTB x diff --git a/test/data/boot/C.hs b/test/data/boot/C.hs deleted file mode 100644 --- a/test/data/boot/C.hs +++ /dev/null @@ -1,8 +0,0 @@ -module C where - -import B -import A hiding (MkTA(..)) - -x = MkTA -y = MkTB -z = f diff --git a/test/data/boot/hie.yaml b/test/data/boot/hie.yaml deleted file mode 100644 --- a/test/data/boot/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["A.hs", "A.hs-boot", "B.hs", "C.hs"]}} diff --git a/test/data/boot2/A.hs b/test/data/boot2/A.hs deleted file mode 100644 --- a/test/data/boot2/A.hs +++ /dev/null @@ -1,12 +0,0 @@ -module A where - --- E source imports B --- In interface file see source module dependencies: B {-# SOURCE #-} -import E --- C imports B --- In interface file see source module dependencies: B -import C - --- Instance for B only available from B.hi not B.hi-boot, so tests we load --- that. -main = print B diff --git a/test/data/boot2/B.hs b/test/data/boot2/B.hs deleted file mode 100644 --- a/test/data/boot2/B.hs +++ /dev/null @@ -1,8 +0,0 @@ -module B where - -import D - -data B = B - -instance Show B where - show B = "B" diff --git a/test/data/boot2/B.hs-boot b/test/data/boot2/B.hs-boot deleted file mode 100644 --- a/test/data/boot2/B.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module B where - -data B = B diff --git a/test/data/boot2/C.hs b/test/data/boot2/C.hs deleted file mode 100644 --- a/test/data/boot2/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C where - -import B diff --git a/test/data/boot2/D.hs b/test/data/boot2/D.hs deleted file mode 100644 --- a/test/data/boot2/D.hs +++ /dev/null @@ -1,3 +0,0 @@ -module D where - -import {-# SOURCE #-} B diff --git a/test/data/boot2/E.hs b/test/data/boot2/E.hs deleted file mode 100644 --- a/test/data/boot2/E.hs +++ /dev/null @@ -1,3 +0,0 @@ -module E(B(B)) where - -import {-# SOURCE #-} B diff --git a/test/data/boot2/hie.yaml b/test/data/boot2/hie.yaml deleted file mode 100644 --- a/test/data/boot2/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}} diff --git a/test/data/cabal-exe/a/a.cabal b/test/data/cabal-exe/a/a.cabal deleted file mode 100644 --- a/test/data/cabal-exe/a/a.cabal +++ /dev/null @@ -1,14 +0,0 @@ -cabal-version: 2.2 - -name: a -version: 0.1.0.0 -author: Fendor -maintainer: power.walross@gmail.com -build-type: Simple - -executable a - main-is: Main.hs - hs-source-dirs: src - ghc-options: -Wall - build-depends: base - default-language: Haskell2010 diff --git a/test/data/cabal-exe/a/src/Main.hs b/test/data/cabal-exe/a/src/Main.hs deleted file mode 100644 --- a/test/data/cabal-exe/a/src/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Main where - -main = putStrLn "Hello, Haskell!" diff --git a/test/data/cabal-exe/cabal.project b/test/data/cabal-exe/cabal.project deleted file mode 100644 --- a/test/data/cabal-exe/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./a diff --git a/test/data/cabal-exe/hie.yaml b/test/data/cabal-exe/hie.yaml deleted file mode 100644 --- a/test/data/cabal-exe/hie.yaml +++ /dev/null @@ -1,3 +0,0 @@ -cradle: - cabal: - component: "exe:a" diff --git a/test/data/hover/Bar.hs b/test/data/hover/Bar.hs deleted file mode 100644 --- a/test/data/hover/Bar.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Bar (Bar(..)) where - --- | Bar Haddock -data Bar = Bar diff --git a/test/data/hover/Foo.hs b/test/data/hover/Foo.hs deleted file mode 100644 --- a/test/data/hover/Foo.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Foo (Bar, foo) where - -import Bar - --- | foo Haddock -foo = Bar diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs deleted file mode 100644 --- a/test/data/hover/GotoHover.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -{- HLINT ignore -} -module GotoHover ( module GotoHover) where -import Data.Text (Text, pack) -import Foo (Bar, foo) - - -data TypeConstructor = DataConstructor - { fff :: Text - , ggg :: Int } -aaa :: TypeConstructor -aaa = DataConstructor - { fff = "dfgy" - , ggg = 832 - } -bbb :: TypeConstructor -bbb = DataConstructor "mjgp" 2994 -ccc :: (Text, Int) -ccc = (fff bbb, ggg aaa) -ddd :: Num a => a -> a -> a -ddd vv ww = vv +! ww -a +! b = a - b -hhh (Just a) (><) = a >< a -iii a b = a `b` a -jjj s = pack $ s <> s -class MyClass a where - method :: a -> Int -instance MyClass Int where - method = succ -kkk :: MyClass a => Int -> a -> Int -kkk n c = n + method c - -doBind :: Maybe () -doBind = do unwrapped <- Just () - return unwrapped - -listCompBind :: [Char] -listCompBind = [ succ c | c <- "ptfx" ] - -multipleClause :: Bool -> Char -multipleClause True = 't' -multipleClause False = 'f' - --- | Recognizable docs: kpqz -documented :: Monad m => Either Int (m a) -documented = Left 7518 - -listOfInt = [ 8391 :: Int, 6268 ] - -outer :: Bool -outer = undefined inner where - - inner :: Char - inner = undefined - -imported :: Bar -imported = foo - -aa2 :: Bool -aa2 = $(id [| True |]) - -hole :: Int -hole = _ - -hole2 :: a -> Maybe a -hole2 = _ - --- A comment above a type defnition with a deriving clause -data Example = Example - deriving (Eq) diff --git a/test/data/hover/RecordDotSyntax.hs b/test/data/hover/RecordDotSyntax.hs deleted file mode 100644 --- a/test/data/hover/RecordDotSyntax.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} - -module RecordDotSyntax ( module RecordDotSyntax) where - -import qualified Data.Maybe as M - -data MyRecord = MyRecord - { a :: String - , b :: Integer - , c :: MyChild - } deriving (Eq, Show) - -newtype MyChild = MyChild - { z :: String - } deriving (Eq, Show) - -x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } -y = x.a ++ show x.b ++ x.c.z diff --git a/test/data/hover/hie.yaml b/test/data/hover/hie.yaml deleted file mode 100644 --- a/test/data/hover/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/test/data/ignore-fatal/IgnoreFatal.hs b/test/data/ignore-fatal/IgnoreFatal.hs deleted file mode 100644 --- a/test/data/ignore-fatal/IgnoreFatal.hs +++ /dev/null @@ -1,8 +0,0 @@ --- "missing signature" is declared a fatal warning in the cabal file, --- but is ignored in this module. - -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module IgnoreFatal where - -a = 'a' diff --git a/test/data/ignore-fatal/cabal.project b/test/data/ignore-fatal/cabal.project deleted file mode 100644 --- a/test/data/ignore-fatal/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ignore-fatal.cabal diff --git a/test/data/ignore-fatal/hie.yaml b/test/data/ignore-fatal/hie.yaml deleted file mode 100644 --- a/test/data/ignore-fatal/hie.yaml +++ /dev/null @@ -1,4 +0,0 @@ -cradle: - cabal: - - path: "." - component: "lib:ignore-fatal" diff --git a/test/data/ignore-fatal/ignore-fatal.cabal b/test/data/ignore-fatal/ignore-fatal.cabal deleted file mode 100644 --- a/test/data/ignore-fatal/ignore-fatal.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: ignore-fatal -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: IgnoreFatal - hs-source-dirs: . - ghc-options: -Werror=missing-signatures diff --git a/test/data/multi-unit-reexport/a/A.hs b/test/data/multi-unit-reexport/a/A.hs deleted file mode 100644 --- a/test/data/multi-unit-reexport/a/A.hs +++ /dev/null @@ -1,3 +0,0 @@ -module A(foo) where -import Data.Text -foo = () diff --git a/test/data/multi-unit-reexport/b/B.hs b/test/data/multi-unit-reexport/b/B.hs deleted file mode 100644 --- a/test/data/multi-unit-reexport/b/B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module B(module B) where -import A -qux = foo diff --git a/test/data/multi-unit-reexport/c/C.hs b/test/data/multi-unit-reexport/c/C.hs deleted file mode 100644 --- a/test/data/multi-unit-reexport/c/C.hs +++ /dev/null @@ -1,4 +0,0 @@ -module C(module C) where -import A -import B -cux = foo `seq` qux diff --git a/test/data/multi-unit-reexport/cabal.project b/test/data/multi-unit-reexport/cabal.project deleted file mode 100644 --- a/test/data/multi-unit-reexport/cabal.project +++ /dev/null @@ -1,2 +0,0 @@ -packages: a b c -multi-repl: True diff --git a/test/data/multi-unit-reexport/hie.yaml b/test/data/multi-unit-reexport/hie.yaml deleted file mode 100644 --- a/test/data/multi-unit-reexport/hie.yaml +++ /dev/null @@ -1,6 +0,0 @@ -cradle: - direct: - arguments: ["-unit" ,"@a-1.0.0-inplace" - ,"-unit" ,"@b-1.0.0-inplace" - ,"-unit" ,"@c-1.0.0-inplace" - ] diff --git a/test/data/multi-unit/a/A.hs b/test/data/multi-unit/a/A.hs deleted file mode 100644 --- a/test/data/multi-unit/a/A.hs +++ /dev/null @@ -1,3 +0,0 @@ -module A(foo) where -import Data.Text -foo = () diff --git a/test/data/multi-unit/b/B.hs b/test/data/multi-unit/b/B.hs deleted file mode 100644 --- a/test/data/multi-unit/b/B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module B(module B) where -import "a" A -qux = foo diff --git a/test/data/multi-unit/c/C.hs b/test/data/multi-unit/c/C.hs deleted file mode 100644 --- a/test/data/multi-unit/c/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C(module C) where -import A -cux = foo diff --git a/test/data/multi-unit/cabal.project b/test/data/multi-unit/cabal.project deleted file mode 100644 --- a/test/data/multi-unit/cabal.project +++ /dev/null @@ -1,2 +0,0 @@ -packages: a b c -multi-repl: True diff --git a/test/data/multi-unit/hie.yaml b/test/data/multi-unit/hie.yaml deleted file mode 100644 --- a/test/data/multi-unit/hie.yaml +++ /dev/null @@ -1,6 +0,0 @@ -cradle: - direct: - arguments: ["-unit" ,"@a-1.0.0-inplace" - ,"-unit" ,"@b-1.0.0-inplace" - ,"-unit" ,"@c-1.0.0-inplace" - ] diff --git a/test/data/multi/a/A.hs b/test/data/multi/a/A.hs deleted file mode 100644 --- a/test/data/multi/a/A.hs +++ /dev/null @@ -1,3 +0,0 @@ -module A(foo) where -import Control.Concurrent.Async -foo = () diff --git a/test/data/multi/a/a.cabal b/test/data/multi/a/a.cabal deleted file mode 100644 --- a/test/data/multi/a/a.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: a -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, async >= 2.0 - exposed-modules: A - hs-source-dirs: . diff --git a/test/data/multi/b/B.hs b/test/data/multi/b/B.hs deleted file mode 100644 --- a/test/data/multi/b/B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module B(module B) where -import A -qux = foo diff --git a/test/data/multi/b/b.cabal b/test/data/multi/b/b.cabal deleted file mode 100644 --- a/test/data/multi/b/b.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: b -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, a - exposed-modules: B - hs-source-dirs: . diff --git a/test/data/multi/c/C.hs b/test/data/multi/c/C.hs deleted file mode 100644 --- a/test/data/multi/c/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C(module C) where -import A -cux = foo diff --git a/test/data/multi/c/c.cabal b/test/data/multi/c/c.cabal deleted file mode 100644 --- a/test/data/multi/c/c.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: c -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, a - exposed-modules: C - hs-source-dirs: . diff --git a/test/data/multi/cabal.project b/test/data/multi/cabal.project deleted file mode 100644 --- a/test/data/multi/cabal.project +++ /dev/null @@ -1,3 +0,0 @@ -packages: a b c - -allow-newer: base diff --git a/test/data/multi/hie.yaml b/test/data/multi/hie.yaml deleted file mode 100644 --- a/test/data/multi/hie.yaml +++ /dev/null @@ -1,8 +0,0 @@ -cradle: - cabal: - - path: "./a" - component: "lib:a" - - path: "./b" - component: "lib:b" - - path: "./c" - component: "lib:c" diff --git a/test/data/plugin-knownnat/KnownNat.hs b/test/data/plugin-knownnat/KnownNat.hs deleted file mode 100644 --- a/test/data/plugin-knownnat/KnownNat.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-} -module KnownNat where -import Data.Proxy -import GHC.TypeLits - -f :: forall n. KnownNat n => Proxy n -> Integer -f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2)) -foo :: Int -> Int -> Int -foo a _b = a + c diff --git a/test/data/plugin-knownnat/cabal.project b/test/data/plugin-knownnat/cabal.project deleted file mode 100644 --- a/test/data/plugin-knownnat/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -packages: . - --- Needed for ghc >= 9.0.2 and ghc-typelits-natnormalise == 0.7.6 -allow-newer: ghc-typelits-natnormalise:ghc-bignum diff --git a/test/data/plugin-knownnat/plugin.cabal b/test/data/plugin-knownnat/plugin.cabal deleted file mode 100644 --- a/test/data/plugin-knownnat/plugin.cabal +++ /dev/null @@ -1,9 +0,0 @@ -cabal-version: 1.18 -name: plugin -version: 1.0.0 -build-type: Simple - -library - build-depends: base, ghc-typelits-knownnat - exposed-modules: KnownNat - hs-source-dirs: . diff --git a/test/data/recomp/A.hs b/test/data/recomp/A.hs deleted file mode 100644 --- a/test/data/recomp/A.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A(x) where - -import B - -x :: Int -x = y diff --git a/test/data/recomp/B.hs b/test/data/recomp/B.hs deleted file mode 100644 --- a/test/data/recomp/B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B(y) where - -y :: Int -y = undefined diff --git a/test/data/recomp/P.hs b/test/data/recomp/P.hs deleted file mode 100644 --- a/test/data/recomp/P.hs +++ /dev/null @@ -1,5 +0,0 @@ -module P() where -import A -import B - -bar = x :: Int diff --git a/test/data/recomp/hie.yaml b/test/data/recomp/hie.yaml deleted file mode 100644 --- a/test/data/recomp/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-Wmissing-signatures","B", "A", "P"]}} diff --git a/test/data/references/Main.hs b/test/data/references/Main.hs deleted file mode 100644 --- a/test/data/references/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import References - -main :: IO () -main = return () - - - -a = 2 :: Int -b = a + 1 - -acc :: Account -acc = Savings diff --git a/test/data/references/OtherModule.hs b/test/data/references/OtherModule.hs deleted file mode 100644 --- a/test/data/references/OtherModule.hs +++ /dev/null @@ -1,9 +0,0 @@ -module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where - -import OtherOtherModule - -symbolDefinedInOtherModule = 1 - -symbolLocalToOtherModule = 2 - -someFxn x = x + symbolLocalToOtherModule diff --git a/test/data/references/OtherOtherModule.hs b/test/data/references/OtherOtherModule.hs deleted file mode 100644 --- a/test/data/references/OtherOtherModule.hs +++ /dev/null @@ -1,3 +0,0 @@ -module OtherOtherModule where - -symbolDefinedInOtherOtherModule = "asdf" diff --git a/test/data/references/References.hs b/test/data/references/References.hs deleted file mode 100644 --- a/test/data/references/References.hs +++ /dev/null @@ -1,25 +0,0 @@ -module References where - -import OtherModule - -foo = bar - -bar = let x = bar 42 in const "hello" - -baz = do - x <- bar 23 - return $ bar 14 - -data Account = - Checking - | Savings - -bobsAccount = Checking - -bobHasChecking = case bobsAccount of - Checking -> True - Savings -> False - -x = symbolDefinedInOtherModule - -y = symbolDefinedInOtherOtherModule diff --git a/test/data/references/hie.yaml b/test/data/references/hie.yaml deleted file mode 100644 --- a/test/data/references/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}} diff --git a/test/data/rootUri/dirA/Foo.hs b/test/data/rootUri/dirA/Foo.hs deleted file mode 100644 --- a/test/data/rootUri/dirA/Foo.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Foo () where - -foo = () diff --git a/test/data/rootUri/dirA/foo.cabal b/test/data/rootUri/dirA/foo.cabal deleted file mode 100644 --- a/test/data/rootUri/dirA/foo.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: foo -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: Foo - hs-source-dirs: . diff --git a/test/data/rootUri/dirB/Foo.hs b/test/data/rootUri/dirB/Foo.hs deleted file mode 100644 --- a/test/data/rootUri/dirB/Foo.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Foo () where - -foo = () diff --git a/test/data/rootUri/dirB/foo.cabal b/test/data/rootUri/dirB/foo.cabal deleted file mode 100644 --- a/test/data/rootUri/dirB/foo.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: foo -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: Foo - hs-source-dirs: . diff --git a/test/data/symlink/hie.yaml b/test/data/symlink/hie.yaml deleted file mode 100644 --- a/test/data/symlink/hie.yaml +++ /dev/null @@ -1,10 +0,0 @@ - -cradle: - direct: - arguments: - - -i - - -isrc - - -iother_loc/ - - other_loc/Sym.hs - - src/Foo.hs - - -Wall diff --git a/test/data/symlink/some_loc/Sym.hs b/test/data/symlink/some_loc/Sym.hs deleted file mode 100644 --- a/test/data/symlink/some_loc/Sym.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Sym where - -foo :: String -foo = "" diff --git a/test/data/symlink/src/Foo.hs b/test/data/symlink/src/Foo.hs deleted file mode 100644 --- a/test/data/symlink/src/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Foo where - -import Sym - diff --git a/test/data/working-dir/a/A.hs b/test/data/working-dir/a/A.hs deleted file mode 100644 --- a/test/data/working-dir/a/A.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module A(th_a) where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Control.Monad.IO.Class - -th_a :: DecsQ -th_a = do - str <- makeRelativeToProject "wdtest" >>= liftIO . readFile - [d| a = $(lift str) |] diff --git a/test/data/working-dir/a/B.hs b/test/data/working-dir/a/B.hs deleted file mode 100644 --- a/test/data/working-dir/a/B.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module B() where - -import A - -$th_a diff --git a/test/data/working-dir/a/a.cabal b/test/data/working-dir/a/a.cabal deleted file mode 100644 --- a/test/data/working-dir/a/a.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: a -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 -extra-source-files: wdtest - -library - build-depends: base, template-haskell - exposed-modules: A B - ghc-options: -Wmissing-signatures - hs-source-dirs: . diff --git a/test/data/working-dir/cabal.project b/test/data/working-dir/cabal.project deleted file mode 100644 --- a/test/data/working-dir/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: a diff --git a/test/data/working-dir/hie.yaml b/test/data/working-dir/hie.yaml deleted file mode 100644 --- a/test/data/working-dir/hie.yaml +++ /dev/null @@ -1,2 +0,0 @@ -cradle: - cabal: diff --git a/test/preprocessor/Main.hs b/test/preprocessor/Main.hs deleted file mode 100644 --- a/test/preprocessor/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ - -module Main(main) where - -import System.Environment - -main :: IO () -main = do - _:input:output:_ <- getArgs - let f = map (\x -> if x == 'x' then 'y' else x) - writeFile output . f =<< readFile input