mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
9.4 support + MHU
This commit is contained in:
parent
fdbc555a92
commit
6c99563a9f
2
.github/actions/setup-build/action.yml
vendored
2
.github/actions/setup-build/action.yml
vendored
@ -7,7 +7,7 @@ inputs:
|
||||
cabal:
|
||||
description: "Cabal version"
|
||||
required: false
|
||||
default: "3.6"
|
||||
default: "3.8.1.0"
|
||||
os:
|
||||
description: "Operating system: Linux, Windows or macOS"
|
||||
required: true
|
||||
|
10
.github/workflows/test.yml
vendored
10
.github/workflows/test.yml
vendored
@ -57,7 +57,9 @@ jobs:
|
||||
strategy:
|
||||
fail-fast: true
|
||||
matrix:
|
||||
ghc: [ "9.2.4"
|
||||
ghc: [ "9.4.2"
|
||||
, "9.4.1"
|
||||
, "9.2.4"
|
||||
, "9.2.3"
|
||||
, "9.0.2"
|
||||
, "8.10.7"
|
||||
@ -69,6 +71,9 @@ jobs:
|
||||
]
|
||||
include:
|
||||
# only test supported ghc major versions
|
||||
- os: ubuntu-latest
|
||||
ghc: '9.4.2'
|
||||
test: true
|
||||
- os: ubuntu-latest
|
||||
ghc: '9.2.4'
|
||||
test: true
|
||||
@ -84,6 +89,9 @@ jobs:
|
||||
- os: ubuntu-latest
|
||||
ghc: '8.6.5'
|
||||
test: true
|
||||
- os: windows-latest
|
||||
ghc: '9.4.2'
|
||||
test: true
|
||||
- os: windows-latest
|
||||
ghc: '9.2.4'
|
||||
test: true
|
||||
|
@ -9,7 +9,7 @@ variables:
|
||||
# Commit of ghc/ci-images repository from which to pull Docker images
|
||||
DOCKER_REV: "4ed1a4f27828ba96a34662dc954335e29b470cd2"
|
||||
|
||||
CABAL_INSTALL_VERSION: 3.6.2.0
|
||||
CABAL_INSTALL_VERSION: 3.8.1.0
|
||||
|
||||
.windows_matrix: &windows_matrix
|
||||
matrix:
|
||||
@ -21,6 +21,10 @@ variables:
|
||||
CABAL_PROJECT: cabal.project
|
||||
- GHC_VERSION: 9.2.4
|
||||
CABAL_PROJECT: cabal.project
|
||||
- GHC_VERSION: 9.4.1
|
||||
CABAL_PROJECT: cabal.project
|
||||
- GHC_VERSION: 9.4.2
|
||||
CABAL_PROJECT: cabal.project
|
||||
|
||||
workflow:
|
||||
rules:
|
||||
|
@ -4,3 +4,5 @@
|
||||
9.0.2,cabal.project
|
||||
9.2.3,cabal.project
|
||||
9.2.4,cabal.project
|
||||
9.4.1,cabal.project
|
||||
9.4.2,cabal.project
|
||||
|
@ -2,3 +2,5 @@
|
||||
9.0.2,cabal.project
|
||||
9.2.3,cabal.project
|
||||
9.2.4,cabal.project
|
||||
9.4.1,cabal.project
|
||||
9.4.2,cabal.project
|
||||
|
@ -67,6 +67,16 @@ source-repository-package
|
||||
tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460
|
||||
-- https://github.com/tibbe/ekg-json/pull/12
|
||||
|
||||
source-repository-package
|
||||
type:git
|
||||
location: https://github.com/wz1000/hiedb
|
||||
tag: 67b92df2359558091df9102db5b701327308b930
|
||||
|
||||
source-repository-package
|
||||
type:git
|
||||
location: https://github.com/wz1000/hie-bios
|
||||
tag: aa73d3d2eb89df0003d2468a105e326d71b62cc7
|
||||
|
||||
-- Needed for ghcide-bench until a new release of lsp-test is out
|
||||
source-repository-package
|
||||
type:git
|
||||
@ -76,6 +86,9 @@ source-repository-package
|
||||
-- https://github.com/haskell/lsp/pull/450
|
||||
|
||||
allow-newer:
|
||||
base, ghc-prim, ghc-bignum, ghc, Cabal, binary, bytestring, unix, time, template-haskell,
|
||||
ghc-paths:Cabal,
|
||||
|
||||
-- ghc-9.2
|
||||
----------
|
||||
hiedb:base,
|
||||
|
@ -350,7 +350,6 @@ test-suite ghcide-tests
|
||||
--------------------------------------------------------------
|
||||
ghcide,
|
||||
ghcide-test-utils-internal,
|
||||
ghc-typelits-knownnat,
|
||||
lsp,
|
||||
lsp-types,
|
||||
hls-plugin-api,
|
||||
@ -378,6 +377,8 @@ test-suite ghcide-tests
|
||||
build-depends:
|
||||
record-dot-preprocessor,
|
||||
record-hasfield
|
||||
if impl(ghc < 9.3)
|
||||
build-depends: ghc-typelits-knownnat
|
||||
hs-source-dirs: test/cabal test/exe bench/lib
|
||||
ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors
|
||||
main-is: Main.hs
|
||||
|
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
{-|
|
||||
The logic for setting up a ghcide session by tapping into hie-bios.
|
||||
@ -100,6 +101,9 @@ import HieDb.Types
|
||||
import HieDb.Utils
|
||||
import qualified System.Random as Random
|
||||
import System.Random (RandomGen)
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Exception (evaluate)
|
||||
import Control.DeepSeq
|
||||
|
||||
data Log
|
||||
= LogSettingInitialDynFlags
|
||||
@ -208,11 +212,13 @@ data SessionLoadingOptions = SessionLoadingOptions
|
||||
, 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
|
||||
@ -221,7 +227,9 @@ instance Default SessionLoadingOptions where
|
||||
,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.
|
||||
@ -494,7 +502,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
|
||||
new_deps' <- forM new_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
|
||||
@ -517,10 +529,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
|
||||
-- that I do not fully understand
|
||||
log Info $ LogMakingNewHscEnv inplace
|
||||
hscEnv <- emptyHscEnv ideNc libDir
|
||||
newHscEnv <-
|
||||
!newHscEnv <-
|
||||
-- Add the options for the current component to the HscEnv
|
||||
evalGhcEnv hscEnv $ do
|
||||
_ <- setSessionDynFlags $ setHomeUnitId_ fakeUid df
|
||||
_ <- setSessionDynFlags
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
$ setHomeUnitId_ fakeUid
|
||||
#endif
|
||||
df
|
||||
getSession
|
||||
|
||||
-- Modify the map so the hieYaml now maps to the newly created
|
||||
@ -718,7 +734,11 @@ cradleToOptsAndLibDir recorder cradle file = do
|
||||
logWith recorder Info $ LogNoneCradleFound file
|
||||
return (Left [])
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
emptyHscEnv :: NameCache -> FilePath -> IO HscEnv
|
||||
#else
|
||||
emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
|
||||
#endif
|
||||
emptyHscEnv nc libDir = do
|
||||
env <- runGhc (Just libDir) getSession
|
||||
initDynLinker env
|
||||
@ -757,7 +777,11 @@ toFlagsMap TargetDetails{..} =
|
||||
[ (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 }
|
||||
|
||||
-- | Create a mapping from FilePaths to HscEnvEqs
|
||||
@ -773,6 +797,11 @@ newComponentCache
|
||||
newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do
|
||||
let df = componentDynFlags ci
|
||||
hscEnv' <-
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
-- Set up a multi component session with the other units on GHC 9.4
|
||||
Compat.initUnits (map snd uids) (hscSetFlags df hsc_env)
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
-- 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,
|
||||
@ -782,7 +811,10 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do
|
||||
evalGhcEnv hsc_env $ do
|
||||
_ <- setSessionDynFlags $ df
|
||||
getSession
|
||||
|
||||
#else
|
||||
-- getOptions is enough to initialize units on GHC <9.2
|
||||
pure $ hscSetFlags df hsc_env { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }
|
||||
#endif
|
||||
|
||||
let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
|
||||
henv <- newFunc hscEnv' uids
|
||||
@ -790,6 +822,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do
|
||||
targetDepends = componentDependencyInfo ci
|
||||
res = (targetEnv, targetDepends)
|
||||
logWith recorder Debug $ LogNewComponentCache res
|
||||
evaluate $ liftRnf rwhnf $ componentTargets ci
|
||||
|
||||
let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
|
||||
ctargets <- concatMapM mk (componentTargets ci)
|
||||
@ -998,9 +1031,11 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
|
||||
-- initPackages parses the -package flags and
|
||||
-- sets up the visibility for each component.
|
||||
-- Throws if a -package flag cannot be satisfied.
|
||||
env <- hscSetFlags dflags'' <$> getSession
|
||||
final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env
|
||||
return (hsc_dflags final_env', targets)
|
||||
-- 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)
|
||||
|
||||
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
|
||||
setIgnoreInterfacePragmas df =
|
||||
|
@ -63,6 +63,7 @@ import Data.IORef
|
||||
import Data.List.Extra
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (UTCTime (..))
|
||||
@ -220,7 +221,12 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
-- names in the compiled bytecode, recording the modules that those names
|
||||
-- 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 -> IO ForeignHValue
|
||||
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
|
||||
|
||||
@ -241,13 +247,21 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing,
|
||||
ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
|
||||
ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
|
||||
ml_hie_file = panic "hscCompileCoreExpr':ml_hie_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
|
||||
|
||||
; (binding_id, stg_expr, _, _) <-
|
||||
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
|
||||
@ -269,7 +283,13 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
-- by default, so we can safely ignore them here.
|
||||
|
||||
-- Find the linkables for the modules we need
|
||||
; let needed_mods = mkUniqSet [ moduleName mod
|
||||
; 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
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
| n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
|
||||
#else
|
||||
@ -277,32 +297,55 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
#endif
|
||||
, Just mod <- [nameModule_maybe n] -- Names from other modules
|
||||
, not (isWiredInName n) -- Exclude wired-in names
|
||||
, moduleUnitId mod == uid -- Only care about stuff from the home package
|
||||
, moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set
|
||||
]
|
||||
hpt = hsc_HPT hsc_env
|
||||
uid = homeUnitId_ dflags
|
||||
mods_transitive = getTransitiveMods hpt needed_mods
|
||||
-- Non det OK as we will put it into maps later anyway
|
||||
mods_transitive_list = nonDetEltsUniqSet mods_transitive
|
||||
|
||||
; lbs <- getLinkables [toNormalizedFilePath' file | mod <- mkHomeModule
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
(hscHomeUnit hsc_env)
|
||||
home_unit_ids =
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
map fst (hugElts $ hsc_HUG hsc_env)
|
||||
#else
|
||||
uid
|
||||
[homeUnitId_ dflags]
|
||||
#endif
|
||||
<$> mods_transitive_list
|
||||
, let ms = fromJust $ mgLookupModule (hsc_mod_graph hsc_env) mod
|
||||
, let file = fromJust $ ml_hs_file $ ms_location ms
|
||||
]
|
||||
; let hsc_env' = hsc_env { hsc_HPT = addListToHpt hpt [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] }
|
||||
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
|
||||
map
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
(mkModule (homeUnitId_ dflags))
|
||||
#else
|
||||
(InstalledModule (toInstalledUnitId $ homeUnitId_ dflags))
|
||||
#endif
|
||||
-- Non det OK as we will put it into maps later anyway
|
||||
$ 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
|
||||
| mod <- mods_transitive_list
|
||||
, let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod
|
||||
file = case ifr of
|
||||
InstalledFound loc _ ->
|
||||
fromJust $ ml_hs_file loc
|
||||
_ -> panic "hscCompileCoreExprHook: module not found"
|
||||
]
|
||||
; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env
|
||||
|
||||
-- Essential to do this here after we load the linkables
|
||||
; keep_lbls <- getLinkablesToKeep
|
||||
|
||||
; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#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)
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
{- load it -}
|
||||
; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos
|
||||
; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
|
||||
@ -314,9 +357,26 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
; 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
|
||||
nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod
|
||||
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 hpt needed_mods = go emptyUniqSet needed_mods
|
||||
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'
|
||||
@ -325,8 +385,7 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
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
|
||||
@ -390,11 +449,7 @@ mkHiFileResultNoCompile session tcm = do
|
||||
tcGblEnv = tmrTypechecked tcm
|
||||
details <- makeSimpleDetails hsc_env_tmp tcGblEnv
|
||||
sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv
|
||||
#else
|
||||
(iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv
|
||||
#endif
|
||||
iface <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv
|
||||
pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing
|
||||
|
||||
mkHiFileResultCompile
|
||||
@ -416,12 +471,22 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
|
||||
else do
|
||||
-- write core file
|
||||
-- give variables unique OccNames
|
||||
(guts, details) <- tidyProgram session simplified_guts
|
||||
tidy_opts <- initTidyOpts session
|
||||
(guts, details) <- tidyProgram tidy_opts simplified_guts
|
||||
pure (details, Just guts)
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,1)
|
||||
let !partial_iface = force (mkPartialIface session details simplified_guts)
|
||||
let !partial_iface = force $ mkPartialIface session details
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
ms
|
||||
#endif
|
||||
simplified_guts
|
||||
|
||||
final_iface <- mkFullIface session partial_iface Nothing
|
||||
#if MIN_VERSION_ghc(9,4,2)
|
||||
Nothing
|
||||
#endif
|
||||
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
let !partial_iface = force (mkPartialIface session details simplified_guts)
|
||||
final_iface <- mkFullIface session partial_iface
|
||||
@ -464,8 +529,18 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
|
||||
|
||||
-- Run corePrep first as we want to test the final version of the program that will
|
||||
-- get translated to STG/Bytecode
|
||||
(prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
|
||||
(prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
prepd_binds
|
||||
#else
|
||||
(prepd_binds , _)
|
||||
#endif
|
||||
<- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
prepd_binds'
|
||||
#else
|
||||
(prepd_binds', _)
|
||||
#endif
|
||||
<- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
|
||||
let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
|
||||
binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
|
||||
|
||||
@ -552,9 +627,17 @@ generateObjectCode session summary guts = do
|
||||
withWarnings "object" $ \tweak -> do
|
||||
let env' = tweak (hscSetFlags (ms_hspp_opts summary) session)
|
||||
target = platformDefaultBackend (hsc_dflags env')
|
||||
newFlags = setBackend target $ updOptLevel 0 $ setOutputFile dot_o $ 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,0,1)
|
||||
#if MIN_VERSION_ghc(9,4,2)
|
||||
(outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts
|
||||
#elif MIN_VERSION_ghc(9,0,1)
|
||||
(outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts
|
||||
#else
|
||||
(outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
|
||||
@ -565,7 +648,14 @@ generateObjectCode session summary guts = do
|
||||
summary
|
||||
#endif
|
||||
fp
|
||||
compileFile session' StopLn (outputFilename, Just (As False))
|
||||
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
|
||||
@ -614,10 +704,17 @@ update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedMod
|
||||
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
|
||||
@ -626,10 +723,15 @@ upgradeWarningToError (nfp, sh, fd) =
|
||||
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 (Reason warning, (nfp, _sh, fd))
|
||||
hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))
|
||||
#endif
|
||||
| not (wopt warning originalFlags)
|
||||
= (Reason warning, (nfp, HideDiag, fd))
|
||||
= (w, (nfp, HideDiag, fd))
|
||||
hideDiag _originalFlags t = t
|
||||
|
||||
-- | Warnings which lead to a diagnostic tag
|
||||
@ -650,10 +752,15 @@ unnecessaryDeprecationWarningFlags
|
||||
]
|
||||
|
||||
-- | Add a unnecessary/deprecated tag to the required diagnostics.
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
|
||||
tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))
|
||||
#else
|
||||
tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
|
||||
tagDiag (Reason warning, (nfp, sh, fd))
|
||||
tagDiag (w@(Reason warning), (nfp, sh, fd))
|
||||
#endif
|
||||
| Just tag <- requiresTag warning
|
||||
= (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))
|
||||
= (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))
|
||||
where
|
||||
requiresTag :: WarningFlag -> Maybe DiagnosticTag
|
||||
requiresTag Opt_WarnWarningsDeprecations
|
||||
@ -695,7 +802,12 @@ generateHieAsts hscEnv tcm =
|
||||
insts = tcg_insts ts :: [ClsInst]
|
||||
tcs = tcg_tcs ts :: [TyCon]
|
||||
run ts $
|
||||
Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
pure $ Just $
|
||||
#else
|
||||
Just <$>
|
||||
#endif
|
||||
GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs
|
||||
#else
|
||||
Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm)
|
||||
#endif
|
||||
@ -703,7 +815,7 @@ generateHieAsts hscEnv tcm =
|
||||
dflags = hsc_dflags hscEnv
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
run ts =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)
|
||||
fmap (join . snd) . liftIO . initDs hscEnv ts
|
||||
#else
|
||||
id
|
||||
@ -905,13 +1017,59 @@ loadModulesHome
|
||||
-> HscEnv
|
||||
-> HscEnv
|
||||
loadModulesHome mod_infos e =
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
hscUpdateHUG (\hug -> foldr 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 }
|
||||
, hsc_type_env_var = Nothing
|
||||
}
|
||||
where
|
||||
mod_name = moduleName . mi_module . hm_iface
|
||||
#endif
|
||||
|
||||
-- Merge the HPTs, module graphs and FinderCaches
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
mergeEnvs :: HscEnv -> [ModuleGraphNode] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
|
||||
mergeEnvs env extraNodes extraMods envs = do
|
||||
let extraModSummaries = mapMaybe moduleGraphNodeModSum extraNodes
|
||||
ims = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))) extraModSummaries
|
||||
ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims
|
||||
curFinderCache =
|
||||
foldl'
|
||||
(\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) Compat.emptyInstalledModuleEnv
|
||||
$ zip ims ifrs
|
||||
-- Very important to force this as otherwise the hsc_mod_graph field is not
|
||||
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
|
||||
-- this new one, which in turn leads to the EPS referencing the HPT.
|
||||
module_graph_nodes =
|
||||
extraNodes ++ nubOrdOn mkNodeKey (concatMap (mgModSummaries' . hsc_mod_graph) envs)
|
||||
|
||||
newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
|
||||
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
|
||||
let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
|
||||
(hscUpdateHUG (const newHug) env){
|
||||
hsc_FC = newFinderCache,
|
||||
hsc_mod_graph = mkModuleGraph module_graph_nodes
|
||||
})
|
||||
|
||||
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
|
||||
concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache
|
||||
concatFC cur xs = do
|
||||
fcModules <- mapM (readIORef . fcModuleCache) xs
|
||||
fcFiles <- mapM (readIORef . fcFileCache) xs
|
||||
fcModules' <- newIORef (foldl' (plusInstalledModuleEnv const) cur fcModules)
|
||||
fcFiles' <- newIORef (Map.unions fcFiles)
|
||||
pure $ FinderCache fcModules' fcFiles'
|
||||
|
||||
#else
|
||||
mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
|
||||
mergeEnvs env extraModSummaries extraMods envs = do
|
||||
prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
|
||||
@ -933,11 +1091,13 @@ mergeEnvs env extraModSummaries extraMods envs = do
|
||||
foldl'
|
||||
(\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache
|
||||
$ zip ims ifrs
|
||||
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{
|
||||
hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
|
||||
hsc_FC = newFinderCache,
|
||||
hsc_mod_graph = mkModuleGraph module_graph_nodes
|
||||
})
|
||||
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
|
||||
env{
|
||||
hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
|
||||
hsc_FC = newFinderCache,
|
||||
hsc_mod_graph = mkModuleGraph module_graph_nodes
|
||||
})
|
||||
|
||||
where
|
||||
mergeUDFM = plusUDFM_C combineModules
|
||||
combineModules a b
|
||||
@ -950,6 +1110,7 @@ mergeEnvs env extraModSummaries extraMods envs = do
|
||||
-- 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
|
||||
@ -978,26 +1139,45 @@ getModSummaryFromImports env fp modTime contents = do
|
||||
(src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps
|
||||
|
||||
-- GHC.Prim doesn't exist physically, so don't go looking for it.
|
||||
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
|
||||
. ideclName . unLoc)
|
||||
ord_idecls
|
||||
(ordinary_imps, ghc_prim_imports)
|
||||
= partition ((/= moduleName gHC_PRIM) . unLoc
|
||||
. ideclName . unLoc)
|
||||
ord_idecls
|
||||
|
||||
implicit_prelude = xopt LangExt.ImplicitPrelude dflags
|
||||
implicit_imports = mkPrelImports mod main_loc
|
||||
implicit_prelude imps
|
||||
|
||||
convImport (L _ i) = (fmap sl_fs (ideclPkgQual i)
|
||||
, reLoc $ ideclName i)
|
||||
|
||||
srcImports = map convImport src_idecls
|
||||
textualImports = map convImport (implicit_imports ++ ordinary_imps)
|
||||
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 env)
|
||||
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
|
||||
liftIO $ evaluate $ rnf srcImports
|
||||
liftIO $ evaluate $ rnf textualImports
|
||||
|
||||
#if MIN_VERSION_ghc (9,3,0)
|
||||
!src_hash <- liftIO $ fingerprintFromStringBuffer contents
|
||||
#endif
|
||||
|
||||
modLoc <- liftIO $ if mod == mAIN_NAME
|
||||
-- specially in tests it's common to have lots of nameless modules
|
||||
-- mkHomeModLocation will map them to the same hi/hie locations
|
||||
@ -1012,7 +1192,14 @@ getModSummaryFromImports env fp modTime contents = do
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
, ms_hie_date = Nothing
|
||||
#endif
|
||||
#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
|
||||
@ -1036,7 +1223,14 @@ getModSummaryFromImports env fp modTime contents = do
|
||||
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.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
|
||||
@ -1130,7 +1324,12 @@ parseFileContents env customPreprocessor filename ms = do
|
||||
-- - filter out the .hs/.lhs source filename if we have one
|
||||
--
|
||||
let n_hspp = normalise filename
|
||||
srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`))
|
||||
#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
|
||||
$ filter (not . isPrefixOf "<")
|
||||
@ -1272,7 +1471,13 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
|
||||
-- If mb_old_iface is nothing then checkOldIface will load it for us
|
||||
-- given that the source is unmodified
|
||||
(recomp_iface_reqd, mb_checked_iface)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
<- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case
|
||||
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
|
||||
@ -1309,14 +1514,14 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
|
||||
readBinCoreFile (mkUpdater $ hsc_NC session) core_file
|
||||
if cf_iface_hash == getModuleHash iface
|
||||
then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash)))
|
||||
else do_regenerate (RecompBecause "Core file out of date (doesn't match iface hash)")
|
||||
else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)")
|
||||
| otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)
|
||||
where handleErrs = flip catches
|
||||
[Handler $ \(e :: IOException) -> do_regenerate (RecompBecause $ "Reading core file failed (" ++ show e ++ ")")
|
||||
[Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")
|
||||
,Handler $ \(e :: GhcException) -> case e of
|
||||
Signal _ -> throw e
|
||||
Panic _ -> throw e
|
||||
_ -> do_regenerate (RecompBecause $ "Reading core file failed (" ++ show e ++ ")")
|
||||
_ -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")
|
||||
]
|
||||
(_, _reason) -> do_regenerate _reason
|
||||
|
||||
@ -1351,18 +1556,36 @@ checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
|
||||
let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash]
|
||||
case out_of_date of
|
||||
[] -> pure Nothing
|
||||
_ -> pure $ Just $
|
||||
RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date)
|
||||
_ -> pure $ Just $ recompBecause
|
||||
$ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date)
|
||||
|
||||
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
|
||||
|
||||
mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails
|
||||
mkDetailsFromIface session iface = do
|
||||
fixIO $ \details -> do
|
||||
let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details Nothing) }
|
||||
let hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session
|
||||
initIfaceLoad hsc' (typecheckIface iface)
|
||||
|
||||
coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
|
||||
@ -1371,28 +1594,26 @@ coreFileToCgGuts session iface details core_file = do
|
||||
(HomeModInfo iface details Nothing)
|
||||
this_mod = mi_module iface
|
||||
types_var <- newIORef (md_types details)
|
||||
let kv = Just (this_mod, types_var)
|
||||
hsc_env' = session { hsc_HPT = act (hsc_HPT session)
|
||||
, hsc_type_env_var = kv }
|
||||
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.
|
||||
let implicit_binds = concatMap getImplicitBinds tyCons
|
||||
tyCons = typeEnvTyCons (md_types details)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []
|
||||
#else
|
||||
pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
|
||||
#endif
|
||||
|
||||
coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)
|
||||
coreFileToLinkable linkableType session ms iface details core_file t = do
|
||||
let act hpt = addToHpt hpt (moduleName this_mod)
|
||||
(HomeModInfo iface details Nothing)
|
||||
this_mod = mi_module iface
|
||||
types_var <- newIORef (md_types details)
|
||||
let kv = Just (this_mod, types_var)
|
||||
hsc_env' = session { hsc_HPT = act (hsc_HPT session)
|
||||
, hsc_type_env_var = kv }
|
||||
core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file
|
||||
let implicit_binds = concatMap getImplicitBinds tyCons
|
||||
tyCons = typeEnvTyCons (md_types details)
|
||||
let cgi_guts = CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
|
||||
cgi_guts <- coreFileToCgGuts session iface details core_file
|
||||
(warns, lb) <- case linkableType of
|
||||
BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts
|
||||
ObjectLinkable -> generateObjectCode session ms cgi_guts
|
||||
@ -1405,27 +1626,55 @@ getDocsBatch
|
||||
:: HscEnv
|
||||
-> Module -- ^ a moudle where the names are in scope
|
||||
-> [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 _mod _names = do
|
||||
(msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->
|
||||
case nameModule_maybe name of
|
||||
Nothing -> return (Left $ NameHasNoModule name)
|
||||
Just mod -> do
|
||||
ModIface { mi_doc_hdr = mb_doc_hdr
|
||||
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
|
||||
} <- loadModuleInterface "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 ( Map.lookup name dmap ,
|
||||
else pure (Right (
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
lookupUniqMap dmap name,
|
||||
#else
|
||||
Map.lookup name dmap ,
|
||||
#endif
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
IntMap.fromAscList $ Map.toAscList $
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
lookupWithDefaultUniqMap amap mempty name))
|
||||
#else
|
||||
Map.findWithDefault mempty name amap))
|
||||
#endif
|
||||
case res of
|
||||
Just x -> return $ map (first $ T.unpack . printOutputable) x
|
||||
Just x -> return $ map (first $ T.unpack . printOutputable)
|
||||
$ x
|
||||
Nothing -> throwErrors
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
$ fmap GhcTcRnMessage msgs
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
$ Error.getErrorMessages msgs
|
||||
#else
|
||||
$ snd msgs
|
||||
|
@ -56,8 +56,8 @@ parseConfiguration InitializeParams {..} =
|
||||
clientSettings = hashed _initializationOptions
|
||||
|
||||
parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
|
||||
parseWorkspaceFolder =
|
||||
toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)
|
||||
parseWorkspaceFolder WorkspaceFolder{_uri} =
|
||||
toNormalizedUri (Uri _uri)
|
||||
|
||||
modifyWorkspaceFolders
|
||||
:: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
|
||||
|
@ -1,5 +1,6 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Development.IDE.Core.Preprocessor
|
||||
( preprocessor
|
||||
@ -28,6 +29,10 @@ import Development.IDE.Types.Location
|
||||
import qualified GHC.LanguageExtensions as LangExt
|
||||
import System.FilePath
|
||||
import System.IO.Extra
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Utils.Logger (LogFlags(..))
|
||||
import GHC.Utils.Outputable (renderWithContext)
|
||||
#endif
|
||||
|
||||
-- | Given a file and some contents, apply any necessary preprocessors,
|
||||
-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
|
||||
@ -76,10 +81,15 @@ preprocessor env0 filename mbContents = do
|
||||
where
|
||||
logAction :: IORef [CPPLog] -> LogActionCompat
|
||||
logAction cppLogs dflags _reason severity srcSpan _style msg = do
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg
|
||||
#else
|
||||
let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg
|
||||
#endif
|
||||
modifyIORef cppLogs (log :)
|
||||
|
||||
|
||||
|
||||
data CPPLog = CPPLog Severity SrcSpan Text
|
||||
deriving (Show)
|
||||
|
||||
@ -133,7 +143,11 @@ parsePragmasIntoDynFlags
|
||||
-> Util.StringBuffer
|
||||
-> IO (Either [FileDiagnostic] ([String], DynFlags))
|
||||
parsePragmasIntoDynFlags 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
|
||||
|
@ -158,6 +158,10 @@ import qualified Development.IDE.Types.Shake as Shake
|
||||
import Development.IDE.GHC.CoreFile
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
||||
import Control.Monad.IO.Unlift
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Unit.Module.Graph
|
||||
import GHC.Unit.Env
|
||||
#endif
|
||||
|
||||
data Log
|
||||
= LogShake Shake.Log
|
||||
@ -664,7 +668,7 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck fi
|
||||
-- very expensive.
|
||||
when (foi == NotFOI) $
|
||||
logWith recorder Logger.Warning $ LogTypecheckedFOI file
|
||||
typeCheckRuleDefinition hsc pm
|
||||
typeCheckRuleDefinition hsc pm file
|
||||
|
||||
knownFilesRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do
|
||||
@ -685,8 +689,9 @@ getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \G
|
||||
typeCheckRuleDefinition
|
||||
:: HscEnv
|
||||
-> ParsedModule
|
||||
-> NormalizedFilePath
|
||||
-> Action (IdeResult TcModuleResult)
|
||||
typeCheckRuleDefinition hsc pm = do
|
||||
typeCheckRuleDefinition hsc pm file = do
|
||||
setPriority priorityTypeCheck
|
||||
IdeOptions { optDefer = defer } <- getIdeOptions
|
||||
|
||||
@ -772,9 +777,21 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
|
||||
|
||||
depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
|
||||
ifaces <- uses_ GetModIface deps
|
||||
|
||||
let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces
|
||||
session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions
|
||||
let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
mss_imports <- uses_ GetLocatedImports (file : deps)
|
||||
final_deps <- forM mss_imports $ \imports -> do
|
||||
let fs = mapMaybe (fmap artifactFilePath . snd) imports
|
||||
dep_mss <- map msrModSummary <$> if fullModSummary
|
||||
then uses_ GetModSummary fs
|
||||
else uses_ GetModSummaryWithoutTimestamps fs
|
||||
return (map (NodeKey_Module . msKey) dep_mss)
|
||||
ms <- msrModSummary <$> use_ GetModSummary file
|
||||
let moduleNodes = zipWith ModuleNode final_deps (ms : mss)
|
||||
#else
|
||||
let moduleNodes = mss
|
||||
#endif
|
||||
session' <- liftIO $ mergeEnvs hsc moduleNodes inLoadOrder depSessions
|
||||
|
||||
Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
|
||||
|
||||
@ -880,8 +897,12 @@ getModSummaryRule displayTHWarning recorder = do
|
||||
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))
|
||||
@ -892,7 +913,9 @@ getModSummaryRule displayTHWarning recorder = do
|
||||
case ms 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
|
||||
@ -973,7 +996,7 @@ regenerateHiFile sess f ms compNeeded = do
|
||||
Just pm -> do
|
||||
-- Invoke typechecking directly to update it without incurring a dependency
|
||||
-- on the parsed module and the typecheck rules
|
||||
(diags', mtmr) <- typeCheckRuleDefinition hsc pm
|
||||
(diags', mtmr) <- typeCheckRuleDefinition hsc pm f
|
||||
case mtmr of
|
||||
Nothing -> pure (diags', Nothing)
|
||||
Just tmr -> do
|
||||
|
@ -10,6 +10,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | A Shake implementation of the compiler service.
|
||||
--
|
||||
@ -129,8 +130,11 @@ import Development.IDE.GHC.Compat (NameCache,
|
||||
NameCacheUpdater (..),
|
||||
initNameCache,
|
||||
knownKeyNames,
|
||||
mkSplitUniqSupply,
|
||||
upNameCache)
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
upNameCache,
|
||||
#endif
|
||||
mkSplitUniqSupply
|
||||
)
|
||||
import Development.IDE.GHC.Orphans ()
|
||||
import Development.IDE.Graph hiding (ShakeValue)
|
||||
import qualified Development.IDE.Graph as Shake
|
||||
@ -262,7 +266,11 @@ data ShakeExtras = ShakeExtras
|
||||
-> String
|
||||
-> [DelayedAction ()]
|
||||
-> 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
|
||||
@ -572,8 +580,12 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
|
||||
let log :: Logger.Priority -> Log -> IO ()
|
||||
log = logWith recorder
|
||||
|
||||
#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
|
||||
@ -959,8 +971,14 @@ runIdeAction _herald s i = runReaderT (runIdeActionT i) s
|
||||
askShake :: IdeAction ShakeExtras
|
||||
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) }
|
||||
|
@ -34,6 +34,9 @@ import ToolSettings
|
||||
import DynFlags
|
||||
#endif
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import qualified GHC.Driver.Pipeline.Execute as Pipeline
|
||||
#endif
|
||||
|
||||
addOptP :: String -> DynFlags -> DynFlags
|
||||
#if MIN_VERSION_ghc (8,10,0)
|
||||
|
@ -9,12 +9,19 @@
|
||||
|
||||
-- | Attempt at hiding the GHC version differences we can.
|
||||
module Development.IDE.GHC.Compat(
|
||||
NameCacheUpdater(..),
|
||||
mkHomeModLocation,
|
||||
hPutStringBuffer,
|
||||
addIncludePathsQuote,
|
||||
getModuleHash,
|
||||
setUpTypedHoles,
|
||||
NameCacheUpdater(..),
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
getMessages,
|
||||
diagnosticMessage,
|
||||
nameEnvElts,
|
||||
#else
|
||||
upNameCache,
|
||||
#endif
|
||||
disableWarningsAsErrors,
|
||||
reLoc,
|
||||
reLocA,
|
||||
@ -27,8 +34,10 @@ module Development.IDE.GHC.Compat(
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
extendModSummaryNoDeps,
|
||||
emsModSummary,
|
||||
#endif
|
||||
myCoreToStgExpr,
|
||||
#endif
|
||||
|
||||
@ -87,7 +96,11 @@ module Development.IDE.GHC.Compat(
|
||||
icInteractiveModule,
|
||||
HomePackageTable,
|
||||
lookupHpt,
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
Dependencies(dep_direct_mods),
|
||||
#else
|
||||
Dependencies(dep_mods),
|
||||
#endif
|
||||
bcoFreeNames,
|
||||
ModIfaceAnnotation,
|
||||
pattern Annotation,
|
||||
@ -116,7 +129,7 @@ module Development.IDE.GHC.Compat(
|
||||
) where
|
||||
|
||||
import Data.Bifunctor
|
||||
import Development.IDE.GHC.Compat.Core
|
||||
import Development.IDE.GHC.Compat.Core hiding (moduleUnitId)
|
||||
import Development.IDE.GHC.Compat.Env
|
||||
import Development.IDE.GHC.Compat.Iface
|
||||
import Development.IDE.GHC.Compat.Logger
|
||||
@ -147,7 +160,11 @@ import GHC.Linker.Types (isObjectLinkable)
|
||||
import GHC.Runtime.Context (icInteractiveModule)
|
||||
import GHC.Unit.Home.ModInfo (HomePackageTable,
|
||||
lookupHpt)
|
||||
import GHC.Unit.Module.Deps (Dependencies (dep_mods))
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods))
|
||||
#else
|
||||
import GHC.Unit.Module.Deps (Dependencies(dep_mods))
|
||||
#endif
|
||||
#else
|
||||
import GHC.CoreToByteCode (coreExprToBCOs)
|
||||
import GHC.Driver.Types (Dependencies (dep_mods),
|
||||
@ -255,16 +272,37 @@ import GHC.Types.CostCentre
|
||||
import GHC.Types.IPE
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Types.Error
|
||||
import GHC.Driver.Config.Stg.Pipeline
|
||||
#endif
|
||||
|
||||
type ModIfaceAnnotation = Annotation
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
nameEnvElts :: NameEnv a -> [a]
|
||||
nameEnvElts = nonDetNameEnvElts
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
-> Bool
|
||||
#endif
|
||||
-> Module -> ModLocation -> CoreExpr
|
||||
-> IO ( Id
|
||||
, [StgTopBinding]
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
,[CgStgTopBinding] -- output program
|
||||
#else
|
||||
,[StgTopBinding] -- output program
|
||||
#endif
|
||||
, InfoTableProvMap
|
||||
, CollectedCCs )
|
||||
myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
|
||||
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) -}
|
||||
let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
|
||||
@ -275,24 +313,46 @@ myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
|
||||
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 this_mod ml prepd_binds = do
|
||||
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" #-}
|
||||
coreToStg dflags this_mod ml prepd_binds
|
||||
|
||||
#if MIN_VERSION_ghc(9,4,2)
|
||||
(stg_binds2,_)
|
||||
#else
|
||||
stg_binds2
|
||||
#endif
|
||||
<- {-# SCC "Stg2Stg" #-}
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
stg2stg logger ictxt (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)
|
||||
#endif
|
||||
@ -307,7 +367,9 @@ reLocA = id
|
||||
#endif
|
||||
|
||||
getDependentMods :: ModIface -> [ModuleName]
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
getDependentMods = map gwib_mod . dep_mods . mi_deps
|
||||
#else
|
||||
getDependentMods = map fst . dep_mods . mi_deps
|
||||
@ -333,9 +395,15 @@ hPutStringBuffer hdl (StringBuffer buf len cur)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
type ErrMsg = MsgEnvelope DecoratedSDoc
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
type WarnMsg = MsgEnvelope DecoratedSDoc
|
||||
#endif
|
||||
|
||||
getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg)
|
||||
getMessages' pst dflags =
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
bimap (fmap (fmap diagnosticMessage) . getMessages) (fmap (fmap diagnosticMessage) . getMessages) $ getPsMessages pst
|
||||
#else
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
bimap (fmap pprWarning) (fmap pprError) $
|
||||
#endif
|
||||
@ -343,11 +411,16 @@ getMessages' pst dflags =
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
dflags
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a
|
||||
pattern PFailedWithErrorMessages msgs
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
<- PFailed (const . fmap (fmap diagnosticMessage) . getMessages . getPsErrorMessages -> msgs)
|
||||
#else
|
||||
<- PFailed (const . fmap pprError . getErrorMessages -> msgs)
|
||||
#endif
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a
|
||||
pattern PFailedWithErrorMessages msgs
|
||||
@ -360,7 +433,7 @@ pattern PFailedWithErrorMessages msgs
|
||||
mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err)
|
||||
mkPlainErrMsgIfPFailed _ = Nothing
|
||||
#endif
|
||||
{-# COMPLETE PFailedWithErrorMessages #-}
|
||||
{-# COMPLETE POk, PFailedWithErrorMessages #-}
|
||||
|
||||
supportsHieFiles :: Bool
|
||||
supportsHieFiles = True
|
||||
@ -368,7 +441,9 @@ supportsHieFiles = True
|
||||
hieExportNames :: HieFile -> [(SrcSpan, Name)]
|
||||
hieExportNames = nameListFromAvails . hie_exports
|
||||
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
type NameCacheUpdater = NameCache
|
||||
#else
|
||||
upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
upNameCache = updNameCache
|
||||
@ -376,6 +451,7 @@ upNameCache = updNameCache
|
||||
upNameCache ref upd_fn
|
||||
= atomicModifyIORef' ref upd_fn
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#if !MIN_VERSION_ghc(9,0,1)
|
||||
type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)]
|
||||
@ -535,13 +611,16 @@ data GhcVersion
|
||||
| GHC810
|
||||
| GHC90
|
||||
| GHC92
|
||||
| GHC94
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
ghcVersionStr :: String
|
||||
ghcVersionStr = VERSION_ghc
|
||||
|
||||
ghcVersion :: GhcVersion
|
||||
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
|
||||
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
|
||||
ghcVersion = GHC94
|
||||
#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
|
||||
ghcVersion = GHC92
|
||||
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
|
||||
ghcVersion = GHC90
|
||||
|
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
-- TODO: remove
|
||||
{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-}
|
||||
|
||||
@ -61,7 +62,9 @@ module Development.IDE.GHC.Compat.Core (
|
||||
pattern ExposePackage,
|
||||
parseDynamicFlagsCmdLine,
|
||||
parseDynamicFilePragma,
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
WarnReason(..),
|
||||
#endif
|
||||
wWarningFlags,
|
||||
updOptLevel,
|
||||
-- slightly unsafe
|
||||
@ -84,7 +87,9 @@ module Development.IDE.GHC.Compat.Core (
|
||||
HscSource(..),
|
||||
WhereFrom(..),
|
||||
loadInterface,
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
SourceModified(..),
|
||||
#endif
|
||||
loadModuleInterface,
|
||||
RecompileRequired(..),
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
@ -188,12 +193,17 @@ module Development.IDE.GHC.Compat.Core (
|
||||
hscInteractive,
|
||||
hscSimplify,
|
||||
hscTypecheckRename,
|
||||
makeSimpleDetails,
|
||||
Development.IDE.GHC.Compat.Core.makeSimpleDetails,
|
||||
-- * Typecheck utils
|
||||
Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars,
|
||||
Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe,
|
||||
typecheckIface,
|
||||
mkIfaceTc,
|
||||
Development.IDE.GHC.Compat.Core.mkIfaceTc,
|
||||
Development.IDE.GHC.Compat.Core.mkBootModDetailsTc,
|
||||
Development.IDE.GHC.Compat.Core.initTidyOpts,
|
||||
hscUpdateHPT,
|
||||
driverNoStop,
|
||||
tidyProgram,
|
||||
ImportedModsVal(..),
|
||||
importedByUser,
|
||||
GHC.TypecheckedSource,
|
||||
@ -297,7 +307,6 @@ module Development.IDE.GHC.Compat.Core (
|
||||
Warn(..),
|
||||
-- * ModLocation
|
||||
GHC.ModLocation,
|
||||
pattern ModLocation,
|
||||
Module.ml_hs_file,
|
||||
Module.ml_obj_file,
|
||||
Module.ml_hi_file,
|
||||
@ -349,7 +358,6 @@ module Development.IDE.GHC.Compat.Core (
|
||||
module GHC.HsToCore.Expr,
|
||||
module GHC.HsToCore.Monad,
|
||||
|
||||
module GHC.Iface.Tidy,
|
||||
module GHC.Iface.Syntax,
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
@ -430,7 +438,6 @@ module Development.IDE.GHC.Compat.Core (
|
||||
module TcRnTypes,
|
||||
module TcRnDriver,
|
||||
module TcRnMonad,
|
||||
module TidyPgm,
|
||||
module TyCon,
|
||||
module TysPrim,
|
||||
module TysWiredIn,
|
||||
@ -466,11 +473,46 @@ module Development.IDE.GHC.Compat.Core (
|
||||
module ExtractDocs,
|
||||
module Parser,
|
||||
module Lexer,
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
CompileReason(..),
|
||||
hsc_type_env_vars,
|
||||
hscUpdateHUG, hscUpdateHPT, hsc_HUG,
|
||||
GhcMessage(..),
|
||||
getKey,
|
||||
module GHC.Driver.Env.KnotVars,
|
||||
module GHC.Iface.Recomp,
|
||||
module GHC.Linker.Types,
|
||||
module GHC.Unit.Module.Graph,
|
||||
module GHC.Types.Unique.Map,
|
||||
module GHC.Utils.TmpFs,
|
||||
module GHC.Utils.Panic,
|
||||
module GHC.Unit.Finder.Types,
|
||||
module GHC.Unit.Env,
|
||||
module GHC.Driver.Phases,
|
||||
#endif
|
||||
) where
|
||||
|
||||
import qualified GHC
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Iface.Recomp (CompileReason(..))
|
||||
import GHC.Driver.Env.Types (hsc_type_env_vars)
|
||||
import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG)
|
||||
import GHC.Driver.Env.KnotVars
|
||||
import GHC.Iface.Recomp
|
||||
import GHC.Linker.Types
|
||||
import GHC.Unit.Module.Graph
|
||||
import GHC.Driver.Errors.Types
|
||||
import GHC.Types.Unique.Map
|
||||
import GHC.Types.Unique
|
||||
import GHC.Utils.TmpFs
|
||||
import GHC.Utils.Panic
|
||||
import GHC.Unit.Finder.Types
|
||||
import GHC.Unit.Env
|
||||
import GHC.Driver.Phases
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Builtin.Names hiding (Unique, printName)
|
||||
import GHC.Builtin.Types
|
||||
@ -484,6 +526,10 @@ import qualified GHC.Core.DataCon as DataCon
|
||||
import GHC.Core.FamInstEnv hiding (pprFamInst)
|
||||
import GHC.Core.InstEnv
|
||||
import GHC.Types.Unique.FM
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import qualified GHC.Driver.Config.Tidy as GHC
|
||||
import qualified GHC.Data.Strict as Strict
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Data.Bag
|
||||
import GHC.Core.Multiplicity (scaledThing)
|
||||
@ -505,13 +551,13 @@ import GHC.Core.Utils
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Driver.Env
|
||||
#else
|
||||
import GHC.Driver.Finder
|
||||
import GHC.Driver.Finder hiding (mkHomeModLocation)
|
||||
import GHC.Driver.Types
|
||||
import GHC.Driver.Ways
|
||||
#endif
|
||||
import GHC.Driver.CmdLine (Warn (..))
|
||||
import GHC.Driver.Hooks
|
||||
import GHC.Driver.Main
|
||||
import GHC.Driver.Main as GHC
|
||||
import GHC.Driver.Monad
|
||||
import GHC.Driver.Phases
|
||||
import GHC.Driver.Pipeline
|
||||
@ -537,11 +583,11 @@ import GHC.HsToCore.Docs
|
||||
import GHC.HsToCore.Expr
|
||||
import GHC.HsToCore.Monad
|
||||
import GHC.Iface.Load
|
||||
import GHC.Iface.Make (mkFullIface, mkIfaceTc,
|
||||
mkPartialIface)
|
||||
import GHC.Iface.Make (mkFullIface, mkPartialIface)
|
||||
import GHC.Iface.Make as GHC
|
||||
import GHC.Iface.Recomp
|
||||
import GHC.Iface.Syntax
|
||||
import GHC.Iface.Tidy
|
||||
import GHC.Iface.Tidy as GHC
|
||||
import GHC.IfaceToCore
|
||||
import GHC.Parser
|
||||
import GHC.Parser.Header hiding (getImports)
|
||||
@ -588,7 +634,10 @@ import qualified GHC.Types.Name.Reader as RdrName
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Types.Name.Set
|
||||
import GHC.Types.SourceFile (HscSource (..),
|
||||
SourceModified (..))
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
SourceModified(..)
|
||||
#endif
|
||||
)
|
||||
import GHC.Types.SourceText
|
||||
import GHC.Types.Target (Target (..), TargetId (..))
|
||||
import GHC.Types.TyThing
|
||||
@ -604,7 +653,7 @@ import GHC.Types.Unique.Supply
|
||||
import GHC.Types.Var (Var (varName), setTyVarUnique,
|
||||
setVarUnique)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Unit.Finder
|
||||
import GHC.Unit.Finder hiding (mkHomeModLocation)
|
||||
import GHC.Unit.Home.ModInfo
|
||||
#endif
|
||||
import GHC.Unit.Info (PackageName (..))
|
||||
@ -644,7 +693,7 @@ import ErrUtils hiding (logInfo, mkWarnMsg)
|
||||
import ExtractDocs
|
||||
import FamInst
|
||||
import FamInstEnv
|
||||
import Finder
|
||||
import Finder hiding (mkHomeModLocation)
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
import GHC.Hs hiding (HsLet, LetStmt)
|
||||
#endif
|
||||
@ -652,7 +701,7 @@ import qualified GHCi
|
||||
import GhcMonad
|
||||
import HeaderInfo hiding (getImports)
|
||||
import Hooks
|
||||
import HscMain
|
||||
import HscMain as GHC
|
||||
import HscTypes
|
||||
#if !MIN_VERSION_ghc(8,10,0)
|
||||
-- Syntax imports
|
||||
@ -674,7 +723,7 @@ import InstEnv
|
||||
import Lexer hiding (getSrcLoc)
|
||||
import qualified Linker
|
||||
import LoadIface
|
||||
import MkIface
|
||||
import MkIface as GHC
|
||||
import Module hiding (ModLocation (..), UnitId,
|
||||
addBootSuffixLocnOut,
|
||||
moduleUnitId)
|
||||
@ -716,7 +765,7 @@ import TcRnMonad hiding (Applicative (..), IORef,
|
||||
import TcRnTypes
|
||||
import TcType hiding (mkVisFunTys)
|
||||
import qualified TcType
|
||||
import TidyPgm
|
||||
import TidyPgm as GHC
|
||||
import qualified TyCoRep
|
||||
import TyCon
|
||||
import Type hiding (mkVisFunTys)
|
||||
@ -750,14 +799,48 @@ import System.FilePath
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import Language.Haskell.Syntax hiding (FunDep)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Driver.Env as GHCi
|
||||
#endif
|
||||
|
||||
import Data.Foldable (toList)
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import qualified GHC.Unit.Finder as GHC
|
||||
import qualified GHC.Driver.Config.Finder as GHC
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
import qualified GHC.Unit.Finder as GHC
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
import qualified GHC.Driver.Finder as GHC
|
||||
#else
|
||||
import qualified Finder as GHC
|
||||
#endif
|
||||
|
||||
|
||||
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
|
||||
#else
|
||||
mkHomeModLocation = GHC.mkHomeModLocation
|
||||
#endif
|
||||
|
||||
|
||||
#if !MIN_VERSION_ghc(9,0,0)
|
||||
type BufSpan = ()
|
||||
type BufPos = ()
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#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)
|
||||
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y
|
||||
#else
|
||||
pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where
|
||||
@ -765,7 +848,11 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where
|
||||
#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
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y
|
||||
#else
|
||||
@ -936,14 +1023,6 @@ tcSplitForAllTyVarBinder_maybe =
|
||||
tcSplitForAllTy_maybe
|
||||
#endif
|
||||
|
||||
pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
pattern ModLocation a b c <-
|
||||
GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""
|
||||
#else
|
||||
pattern ModLocation a b c <-
|
||||
GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
|
||||
#endif
|
||||
|
||||
#if !MIN_VERSION_ghc(8,10,0)
|
||||
noExtField :: GHC.NoExt
|
||||
@ -1015,6 +1094,7 @@ unload hsc_env linkables =
|
||||
#endif
|
||||
hsc_env linkables
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
setOutputFile :: FilePath -> DynFlags -> DynFlags
|
||||
setOutputFile f d = d {
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
@ -1023,6 +1103,7 @@ setOutputFile f d = d {
|
||||
outputFile = Just f
|
||||
#endif
|
||||
}
|
||||
#endif
|
||||
|
||||
isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
@ -1072,7 +1153,7 @@ pattern GRE :: Name -> Parent -> Bool -> [ImportSpec] -> RdrName.GlobalRdrElt
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE
|
||||
{gre_name = (greNamePrintableName -> gre_name)
|
||||
,gre_par, gre_lcl, gre_imp}
|
||||
,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)}
|
||||
#else
|
||||
pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..}
|
||||
#endif
|
||||
@ -1091,3 +1172,55 @@ pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds)
|
||||
rationalFromFractionalLit :: FractionalLit -> Rational
|
||||
rationalFromFractionalLit = fl_value
|
||||
#endif
|
||||
|
||||
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 hsc_env sf details ms tcGblEnv =
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
GHC.mkIfaceTc hsc_env sf details
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
ms
|
||||
#endif
|
||||
tcGblEnv
|
||||
#else
|
||||
fst <$> GHC.mkIfaceTc hsc_env Nothing sf details tcGblEnv
|
||||
#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
|
||||
|
||||
driverNoStop =
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
NoStop
|
||||
#else
|
||||
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
|
||||
|
@ -3,7 +3,14 @@
|
||||
-- | Compat module for the main Driver types, such as 'HscEnv',
|
||||
-- 'UnitEnv' and some DynFlags compat functions.
|
||||
module Development.IDE.GHC.Compat.Env (
|
||||
Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph, hsc_HPT, hsc_type_env_var),
|
||||
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(..),
|
||||
setInteractivePrintName,
|
||||
setInteractiveDynFlags,
|
||||
@ -51,7 +58,11 @@ import GHC (setInteractiveDynFlags)
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Driver.Backend as Backend
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Driver.Env (HscEnv)
|
||||
#else
|
||||
import GHC.Driver.Env (HscEnv, hsc_EPS)
|
||||
#endif
|
||||
import qualified GHC.Driver.Env as Env
|
||||
import qualified GHC.Driver.Session as Session
|
||||
import GHC.Platform.Ways hiding (hostFullWays)
|
||||
@ -80,6 +91,11 @@ import HscTypes as Env
|
||||
import Module
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
hsc_EPS :: HscEnv -> UnitEnv
|
||||
hsc_EPS = hsc_unit_env
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
import qualified Data.Set as Set
|
||||
|
@ -7,6 +7,9 @@ module Development.IDE.GHC.Compat.Iface (
|
||||
) where
|
||||
|
||||
import GHC
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Driver.Session (targetProfile)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import qualified GHC.Iface.Load as Iface
|
||||
import GHC.Unit.Finder.Types (FindResult)
|
||||
@ -24,7 +27,9 @@ import Development.IDE.GHC.Compat.Env
|
||||
import Development.IDE.GHC.Compat.Outputable
|
||||
|
||||
writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO ()
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
writeIfaceFile env = Iface.writeIface (hsc_dflags env)
|
||||
|
@ -24,6 +24,9 @@ import GHC.Utils.Logger as Logger
|
||||
import DynFlags
|
||||
import Outputable (queryQual)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Types.Error
|
||||
#endif
|
||||
|
||||
putLogHook :: Logger -> HscEnv -> HscEnv
|
||||
putLogHook logger env =
|
||||
@ -41,6 +44,15 @@ pushLogHook f logger =
|
||||
logger { Env.log_action = f (Env.log_action logger) }
|
||||
#endif
|
||||
|
||||
#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.
|
||||
logActionCompat :: LogActionCompat -> LogAction
|
||||
logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify
|
||||
logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify
|
||||
|
||||
#else
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()
|
||||
|
||||
@ -54,3 +66,4 @@ type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnq
|
||||
logActionCompat :: LogActionCompat -> LogAction
|
||||
logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style)
|
||||
#endif
|
||||
#endif
|
||||
|
@ -17,8 +17,12 @@ module Development.IDE.GHC.Compat.Outputable (
|
||||
-- * Parser errors
|
||||
PsWarning,
|
||||
PsError,
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
DiagnosticReason(..),
|
||||
#else
|
||||
pprWarning,
|
||||
pprError,
|
||||
#endif
|
||||
-- * Error infrastructure
|
||||
DecoratedSDoc,
|
||||
MsgEnvelope,
|
||||
@ -35,7 +39,11 @@ module Development.IDE.GHC.Compat.Outputable (
|
||||
import GHC.Driver.Env
|
||||
import GHC.Driver.Ppr
|
||||
import GHC.Driver.Session
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Parser.Errors
|
||||
#else
|
||||
import GHC.Parser.Errors.Types
|
||||
#endif
|
||||
import qualified GHC.Parser.Errors.Ppr as Ppr
|
||||
import qualified GHC.Types.Error as Error
|
||||
import GHC.Types.Name.Ppr
|
||||
@ -69,6 +77,11 @@ import Outputable as Out hiding
|
||||
import qualified Outputable as Out
|
||||
import SrcLoc
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Utils.Logger
|
||||
import GHC.Driver.Config.Diagnostic
|
||||
import Data.Maybe
|
||||
#endif
|
||||
|
||||
-- | A compatible function to print `Outputable` instances
|
||||
-- without unique symbols.
|
||||
@ -125,6 +138,7 @@ oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc
|
||||
oldFormatErrDoc = Err.formatErrDoc
|
||||
#endif
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc
|
||||
pprWarning =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
@ -140,18 +154,27 @@ pprError =
|
||||
#else
|
||||
id
|
||||
#endif
|
||||
#endif
|
||||
|
||||
formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String
|
||||
formatErrorWithQual dflags e =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
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,3,0)
|
||||
(formatBulleted ctx $ e)
|
||||
#else
|
||||
(formatBulleted ctx $ Error.renderDiagnostic e)
|
||||
#endif
|
||||
|
||||
#else
|
||||
Out.showSDoc dflags
|
||||
@ -178,13 +201,18 @@ mkPrintUnqualifiedDefault env =
|
||||
HscTypes.mkPrintUnqualified (hsc_dflags env)
|
||||
#endif
|
||||
|
||||
mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
|
||||
mkWarnMsg =
|
||||
#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 diagnosticMessage $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc)
|
||||
#else
|
||||
mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
|
||||
mkWarnMsg _ _ =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
const Error.mkWarnMsg
|
||||
#else
|
||||
Err.mkWarnMsg
|
||||
#endif
|
||||
#endif
|
||||
|
||||
defaultUserStyle :: PprStyle
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
|
@ -62,7 +62,11 @@ import GHC (Anchor (anchor),
|
||||
pm_mod_summary,
|
||||
pm_parsed_source)
|
||||
import qualified GHC
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import qualified GHC.Driver.Config.Parser as Config
|
||||
#else
|
||||
import qualified GHC.Driver.Config as Config
|
||||
#endif
|
||||
import GHC.Hs (LEpaComment, hpm_module,
|
||||
hpm_src_files)
|
||||
import GHC.Parser.Lexer hiding (initParserState)
|
||||
|
@ -24,6 +24,11 @@ import qualified GHC.Driver.Env as Env
|
||||
import GHC.Driver.Plugins (Plugin (..),
|
||||
PluginWithArgs (..),
|
||||
StaticPlugin (..),
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
staticPlugins,
|
||||
ParsedResult(..),
|
||||
PsMessages(..),
|
||||
#endif
|
||||
defaultPlugin, withPlugins)
|
||||
import qualified GHC.Runtime.Loader as Loader
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
@ -42,15 +47,25 @@ applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.Api
|
||||
applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do
|
||||
-- Apply parsedResultAction of plugins
|
||||
let applyPluginAction p opts = parsedResultAction p opts ms
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
fmap (hpm_module . parsedResultModule) $
|
||||
#else
|
||||
fmap hpm_module $
|
||||
#endif
|
||||
runHsc env $ withPlugins
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
(Env.hsc_plugins env)
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
env
|
||||
#else
|
||||
dflags
|
||||
#endif
|
||||
applyPluginAction
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
(ParsedResult (HsParsedModule parsed [] hpm_annotations) (PsMessages mempty mempty))
|
||||
#else
|
||||
(HsParsedModule parsed [] hpm_annotations)
|
||||
#endif
|
||||
|
||||
initializePlugins :: HscEnv -> IO HscEnv
|
||||
initializePlugins env = do
|
||||
@ -64,7 +79,9 @@ initializePlugins env = do
|
||||
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
hsc_static_plugins :: HscEnv -> [StaticPlugin]
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
hsc_static_plugins = staticPlugins . Env.hsc_plugins
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
hsc_static_plugins = Env.hsc_static_plugins
|
||||
#else
|
||||
hsc_static_plugins = staticPlugins . hsc_dflags
|
||||
|
@ -5,7 +5,10 @@
|
||||
module Development.IDE.GHC.Compat.Units (
|
||||
-- * UnitState
|
||||
UnitState,
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
initUnits,
|
||||
#endif
|
||||
oldInitUnits,
|
||||
unitState,
|
||||
getUnitName,
|
||||
explicitUnits,
|
||||
@ -39,7 +42,7 @@ module Development.IDE.GHC.Compat.Units (
|
||||
installedModule,
|
||||
-- * Module
|
||||
toUnitId,
|
||||
moduleUnitId,
|
||||
Development.IDE.GHC.Compat.Units.moduleUnitId,
|
||||
moduleUnit,
|
||||
-- * ExternalPackageState
|
||||
ExternalPackageState(..),
|
||||
@ -49,10 +52,18 @@ module Development.IDE.GHC.Compat.Units (
|
||||
showSDocForUser',
|
||||
) where
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Control.Monad
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Unit.Home.ModInfo
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import qualified GHC.Data.ShortText as ST
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Driver.Env (hsc_unit_dbs)
|
||||
#endif
|
||||
import GHC.Driver.Ppr
|
||||
import GHC.Unit.Env
|
||||
import GHC.Unit.External
|
||||
@ -128,37 +139,69 @@ unitState = DynFlags.unitState . hsc_dflags
|
||||
unitState = DynFlags.pkgState . hsc_dflags
|
||||
#endif
|
||||
|
||||
initUnits :: HscEnv -> IO HscEnv
|
||||
initUnits env = do
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
let dflags1 = hsc_dflags env
|
||||
-- Copied from GHC.setSessionDynFlags
|
||||
let cached_unit_dbs = hsc_unit_dbs env
|
||||
(dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs
|
||||
#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)))
|
||||
|
||||
dflags <- DynFlags.updatePlatformConstants dflags1 mconstants
|
||||
initUnits :: [DynFlags] -> HscEnv -> IO HscEnv
|
||||
initUnits unitDflags env = do
|
||||
let dflags0 = hsc_dflags env
|
||||
-- additionally, set checked dflags so we don't lose fixes
|
||||
let initial_home_graph = createUnitEnvFromFlags (dflags0 NE.:| unitDflags)
|
||||
home_units = unitEnv_keys initial_home_graph
|
||||
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
|
||||
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
|
||||
dflags = homeUnitEnv_dflags homeUnitEnv
|
||||
old_hpt = homeUnitEnv_hpt homeUnitEnv
|
||||
|
||||
(dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units
|
||||
|
||||
updated_dflags <- DynFlags.updatePlatformConstants dflags mconstants
|
||||
pure HomeUnitEnv
|
||||
{ homeUnitEnv_units = unit_state
|
||||
, homeUnitEnv_unit_dbs = Just dbs
|
||||
, homeUnitEnv_dflags = updated_dflags
|
||||
, homeUnitEnv_hpt = old_hpt
|
||||
, homeUnitEnv_home_unit = Just home_unit
|
||||
}
|
||||
|
||||
let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) home_unit_graph
|
||||
let unit_env = UnitEnv
|
||||
{ ue_platform = targetPlatform dflags
|
||||
, ue_namever = DynFlags.ghcNameVersion dflags
|
||||
, ue_home_unit = home_unit
|
||||
, ue_units = unit_state
|
||||
{ ue_platform = targetPlatform dflags1
|
||||
, ue_namever = GHC.ghcNameVersion dflags1
|
||||
, ue_home_unit_graph = home_unit_graph
|
||||
, ue_current_unit = homeUnitId_ dflags0
|
||||
, ue_eps = ue_eps (hsc_unit_env env)
|
||||
}
|
||||
pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env
|
||||
{ hsc_unit_dbs = Just dbs
|
||||
}
|
||||
pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env
|
||||
#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
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
oldInitUnits = pure
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
newFlags <- State.initUnits $ hsc_dflags env
|
||||
pure $ hscSetFlags newFlags env
|
||||
oldInitUnits dflags = do
|
||||
newFlags <- State.initUnits dflags
|
||||
pure newFlags
|
||||
#else
|
||||
newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env
|
||||
pure $ hscSetFlags newFlags env
|
||||
oldInitUnits dflags = do
|
||||
newFlags <- fmap fst $ Packages.initPackages dflags
|
||||
pure newFlags
|
||||
#endif
|
||||
|
||||
explicitUnits :: UnitState -> [Unit]
|
||||
explicitUnits ue =
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
map fst $ State.explicitUnits ue
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
State.explicitUnits ue
|
||||
#else
|
||||
Packages.explicitPackages ue
|
||||
@ -180,7 +223,15 @@ getUnitName env i =
|
||||
packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i))
|
||||
#endif
|
||||
|
||||
lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult
|
||||
lookupModuleWithSuggestions
|
||||
:: HscEnv
|
||||
-> ModuleName
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
-> GHC.PkgQual
|
||||
#else
|
||||
-> Maybe FastString
|
||||
#endif
|
||||
-> LookupResult
|
||||
lookupModuleWithSuggestions env modname mpkg =
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
State.lookupModuleWithSuggestions (unitState env) modname mpkg
|
||||
|
@ -24,7 +24,9 @@ module Development.IDE.GHC.Compat.Util (
|
||||
LBooleanFormula,
|
||||
BooleanFormula(..),
|
||||
-- * OverridingBool
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
OverridingBool(..),
|
||||
#endif
|
||||
-- * Maybes
|
||||
MaybeErr(..),
|
||||
orElse,
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
module Development.IDE.GHC.Error
|
||||
@ -121,13 +122,17 @@ p `isInsideSrcSpan` r = case srcSpanToRange r of
|
||||
-- | 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 DsInfo
|
||||
toDSeverity SevFatal = Just DsError
|
||||
#else
|
||||
toDSeverity SevIgnore = Nothing
|
||||
#endif
|
||||
toDSeverity SevWarning = Just DsWarning
|
||||
toDSeverity SevError = Just DsError
|
||||
toDSeverity SevFatal = Just DsError
|
||||
|
||||
|
||||
-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given
|
||||
@ -167,7 +172,11 @@ catchSrcErrors dflags fromWhere ghcM = do
|
||||
Right <$> ghcM
|
||||
where
|
||||
ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
|
||||
sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages
|
||||
sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
. fmap (fmap Compat.diagnosticMessage) . Compat.getMessages
|
||||
#endif
|
||||
. srcErrorMessages
|
||||
|
||||
|
||||
diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
|
||||
|
@ -43,6 +43,9 @@ import GHC.ByteCode.Types
|
||||
#else
|
||||
import ByteCodeTypes
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Types.PkgQual
|
||||
#endif
|
||||
|
||||
-- Orphan instances for types from the GHC API.
|
||||
instance Show CoreModule where show = unpack . printOutputable
|
||||
@ -85,7 +88,9 @@ instance NFData SB.StringBuffer where rnf = rwhnf
|
||||
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
|
||||
|
||||
instance (NFData l, NFData e) => NFData (GenLocated l e) where
|
||||
rnf (L l e) = rnf l `seq` rnf e
|
||||
@ -126,10 +131,12 @@ instance Show HieFile where
|
||||
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
|
||||
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
instance Show ModuleName where
|
||||
@ -207,3 +214,13 @@ instance Show HomeModInfo where show = show . mi_module . hm_iface
|
||||
|
||||
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
|
||||
rnf (OtherPkg uid) = rnf uid
|
||||
|
||||
instance NFData UnitId where
|
||||
rnf = rwhnf
|
||||
#endif
|
||||
|
@ -32,7 +32,7 @@ module Development.IDE.GHC.Util(
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Data.FastString
|
||||
import GHC.Data.StringBuffer
|
||||
import GHC.Driver.Env
|
||||
import GHC.Driver.Env hiding (hscSetFlags)
|
||||
import GHC.Driver.Monad
|
||||
import GHC.Driver.Session hiding (ExposePackage)
|
||||
import GHC.Parser.Lexer
|
||||
|
@ -1,6 +1,7 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
{-# LANGUAGE ExplicitNamespaces #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Development.IDE.GHC.Warnings(withWarnings) where
|
||||
|
||||
@ -23,14 +24,18 @@ import Language.LSP.Types (type (|?) (..))
|
||||
-- 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)
|
||||
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 :: LogActionCompat
|
||||
newAction dynFlags wr _ loc prUnqual msg = do
|
||||
let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg
|
||||
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
|
||||
modifyVar_ warnings $ return . (wr_d:)
|
||||
newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env)
|
||||
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)
|
||||
@ -38,6 +43,15 @@ withWarnings diagSource action = do
|
||||
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
|
||||
@ -45,6 +59,7 @@ attachReason wr d = d{_code = InR <$> showReason wr}
|
||||
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
|
||||
|
@ -27,6 +27,9 @@ import Control.Monad.IO.Class
|
||||
import Data.List (isSuffixOf)
|
||||
import Data.Maybe
|
||||
import System.FilePath
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Types.PkgQual
|
||||
#endif
|
||||
|
||||
data Import
|
||||
= FileImport !ArtifactsLocation
|
||||
@ -37,11 +40,11 @@ data ArtifactsLocation = ArtifactsLocation
|
||||
{ artifactFilePath :: !NormalizedFilePath
|
||||
, artifactModLocation :: !(Maybe ModLocation)
|
||||
, artifactIsSource :: !Bool -- ^ True if a module is a source input
|
||||
}
|
||||
deriving (Show)
|
||||
, artifactModule :: !(Maybe Module)
|
||||
} deriving Show
|
||||
|
||||
instance NFData ArtifactsLocation where
|
||||
rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource
|
||||
rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource `seq` rnf artifactModule
|
||||
|
||||
isBootLocation :: ArtifactsLocation -> Bool
|
||||
isBootLocation = not . artifactIsSource
|
||||
@ -51,28 +54,30 @@ instance NFData Import where
|
||||
rnf PackageImport = ()
|
||||
|
||||
modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
|
||||
modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source
|
||||
modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod
|
||||
where
|
||||
isSource HsSrcFile = True
|
||||
isSource _ = False
|
||||
source = case ms of
|
||||
Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp
|
||||
Just ms -> isSource (ms_hsc_src ms)
|
||||
mod = ms_mod <$> ms
|
||||
|
||||
-- | locate a module in the file system. Where we go from *daml to Haskell
|
||||
locateModuleFile :: MonadIO m
|
||||
=> [[FilePath]]
|
||||
=> [(UnitId, [FilePath])]
|
||||
-> [String]
|
||||
-> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
|
||||
-> Bool
|
||||
-> ModuleName
|
||||
-> m (Maybe NormalizedFilePath)
|
||||
-> m (Maybe (UnitId, NormalizedFilePath))
|
||||
locateModuleFile import_dirss exts targetFor isSource modName = do
|
||||
let candidates import_dirs =
|
||||
[ toNormalizedFilePath' (prefix </> moduleNameSlashes modName <.> maybeBoot ext)
|
||||
| prefix <- import_dirs , ext <- exts]
|
||||
firstJustM (targetFor modName) (concatMap candidates import_dirss)
|
||||
firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs) <- import_dirss])
|
||||
where
|
||||
go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate
|
||||
maybeBoot ext
|
||||
| isSource = ext ++ "-boot"
|
||||
| otherwise = ext
|
||||
@ -81,8 +86,13 @@ locateModuleFile import_dirss exts targetFor isSource modName = do
|
||||
-- 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.
|
||||
mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath])
|
||||
mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath])
|
||||
mkImportDirs env (i, flags) = Just (i, importPaths flags)
|
||||
#else
|
||||
mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath]))
|
||||
mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i
|
||||
#endif
|
||||
|
||||
-- | locate a module in either the file system or the package database. Where we go from *daml to
|
||||
-- Haskell
|
||||
@ -93,43 +103,72 @@ locateModule
|
||||
-> [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
|
||||
-- "this" means that we should only look in the current package
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
ThisPkg _ -> do
|
||||
#else
|
||||
Just "this" -> do
|
||||
lookupLocal [importPaths dflags]
|
||||
#endif
|
||||
lookupLocal (homeUnitId_ dflags) (importPaths dflags)
|
||||
-- if a package name is given we only go look for a package
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
OtherPkg uid
|
||||
| Just dirs <- lookup uid import_paths
|
||||
#else
|
||||
Just pkgName
|
||||
| Just dirs <- lookup (PackageName pkgName) import_paths
|
||||
-> lookupLocal [dirs]
|
||||
| Just (uid, dirs) <- lookup (PackageName pkgName) import_paths
|
||||
#endif
|
||||
-> lookupLocal uid dirs
|
||||
| otherwise -> lookupInPackageDB env
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
NoPkgQual -> do
|
||||
#else
|
||||
Nothing -> do
|
||||
#endif
|
||||
-- first try to find the module as a file. If we can't find it try to find it in the package
|
||||
-- database.
|
||||
-- Here the importPaths for the current modules are added to the front of the import paths from the other components.
|
||||
-- This is particularly important for Paths_* modules which get generated for every component but unless you use it in
|
||||
-- each component will end up being found in the wrong place and cause a multi-cradle match failure.
|
||||
mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName
|
||||
let import_paths' =
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import_paths
|
||||
#else
|
||||
map snd import_paths
|
||||
#endif
|
||||
|
||||
mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName
|
||||
case mbFile of
|
||||
Nothing -> lookupInPackageDB env
|
||||
Just file -> toModLocation file
|
||||
Just (uid, file) -> toModLocation uid file
|
||||
where
|
||||
dflags = hsc_dflags env
|
||||
import_paths = mapMaybe (mkImportDirs env) comp_info
|
||||
toModLocation file = liftIO $ do
|
||||
toModLocation uid file = liftIO $ do
|
||||
loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
|
||||
return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
let mod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes
|
||||
#else
|
||||
let mod = mkModule uid (unLoc modName)
|
||||
#endif
|
||||
return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod)
|
||||
|
||||
lookupLocal dirs = do
|
||||
mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName
|
||||
lookupLocal uid dirs = do
|
||||
mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName
|
||||
case mbFile of
|
||||
Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound []
|
||||
Just file -> toModLocation file
|
||||
Just (uid, file) -> toModLocation uid file
|
||||
|
||||
lookupInPackageDB env =
|
||||
lookupInPackageDB env = do
|
||||
case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of
|
||||
LookupFound _m _pkgConfig -> return $ Right PackageImport
|
||||
reason -> return $ Left $ notFoundErr env modName reason
|
||||
|
@ -11,7 +11,7 @@ where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Functor
|
||||
import Data.Generics
|
||||
import Data.Generics hiding (Prefix)
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.Rules
|
||||
@ -122,8 +122,16 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam
|
||||
}
|
||||
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 = SkField
|
||||
}
|
||||
cvtFld _ = Nothing
|
||||
@ -161,8 +169,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfi
|
||||
documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
|
||||
#endif
|
||||
= Just (defDocumentSymbol l :: DocumentSymbol)
|
||||
{ _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords
|
||||
{ _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
|
||||
, _kind = SkInterface
|
||||
}
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
@ -171,8 +184,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_
|
||||
documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
|
||||
#endif
|
||||
= Just (defDocumentSymbol l :: DocumentSymbol)
|
||||
{ _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords
|
||||
{ _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
|
||||
, _kind = SkInterface
|
||||
}
|
||||
documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =
|
||||
@ -217,7 +235,7 @@ documentSymbolForImportSummary importSymbols =
|
||||
let
|
||||
-- safe because if we have no ranges then we don't take this branch
|
||||
mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)
|
||||
importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols
|
||||
importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols
|
||||
in
|
||||
Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange))
|
||||
{ _name = "imports"
|
||||
@ -293,7 +311,11 @@ hsConDeclsBinders cons
|
||||
|
||||
get_flds_gadt :: HsConDeclGADTDetails GhcPs
|
||||
-> ([LFieldOcc GhcPs])
|
||||
#if 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)
|
||||
#endif
|
||||
get_flds_gadt _ = []
|
||||
|
||||
get_flds :: Located [LConDeclField GhcPs]
|
||||
|
@ -526,7 +526,11 @@ findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result
|
||||
--
|
||||
-- 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)
|
||||
= map (foLabel . unLoc) cd_fld_names
|
||||
#else
|
||||
= map (rdrNameFieldOcc . unLoc) cd_fld_names
|
||||
#endif
|
||||
-- XConDeclField
|
||||
extract _ = []
|
||||
findRecordCompl _ _ _ _ = []
|
||||
|
@ -50,7 +50,11 @@ safeTyThingId _ = Nothing
|
||||
|
||||
-- Possible documentation for an element in the code
|
||||
data SpanDoc
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
= SpanDocString [HsDocString] SpanDocUris
|
||||
#else
|
||||
= SpanDocString HsDocString SpanDocUris
|
||||
#endif
|
||||
| SpanDocText [T.Text] SpanDocUris
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass NFData
|
||||
@ -86,7 +90,12 @@ emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)
|
||||
spanDocToMarkdown :: SpanDoc -> [T.Text]
|
||||
spanDocToMarkdown = \case
|
||||
(SpanDocString docs uris) ->
|
||||
let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs
|
||||
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
|
||||
|
@ -33,6 +33,9 @@ import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
import Language.LSP.Types (filePathToUri, getUri)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Types.Unique.Map
|
||||
#endif
|
||||
|
||||
mkDocMap
|
||||
:: HscEnv
|
||||
@ -41,12 +44,18 @@ mkDocMap
|
||||
-> IO DocAndKindMap
|
||||
mkDocMap env rm this_mod =
|
||||
do
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
(Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod
|
||||
#elif MIN_VERSION_ghc(9,2,0)
|
||||
(_ , DeclDocMap this_docs, _) <- extractDocs this_mod
|
||||
#else
|
||||
let (_ , 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
|
||||
@ -69,7 +78,7 @@ lookupKind env mod =
|
||||
fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
|
||||
|
||||
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
|
||||
getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n]
|
||||
getDocumentationTryGhc env mod n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env mod [n]
|
||||
|
||||
getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]
|
||||
getDocumentationsTryGhc env mod names = do
|
||||
@ -78,7 +87,11 @@ getDocumentationsTryGhc env mod names = do
|
||||
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 =
|
||||
|
@ -259,11 +259,11 @@ initializeResponseTests = withResource acquire release tests where
|
||||
_documentOnTypeFormattingProvider Nothing
|
||||
, chk "NO renaming" _renameProvider (Just $ InL False)
|
||||
, chk "NO doc link" _documentLinkProvider Nothing
|
||||
, chk "NO color" _colorProvider (Just $ InL False)
|
||||
, chk "NO color" (^. L.colorProvider) (Just $ InL False)
|
||||
, chk "NO folding range" _foldingRangeProvider (Just $ InL False)
|
||||
, che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId]
|
||||
, chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))
|
||||
, chk "NO experimental" _experimental Nothing
|
||||
, chk " workspace" (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))
|
||||
, chk "NO experimental" (^. L.experimental) Nothing
|
||||
] where
|
||||
|
||||
tds = Just (InL (TextDocumentSyncOptions
|
||||
@ -564,13 +564,20 @@ diagnosticTests = testGroup "diagnostics"
|
||||
, "useBase = BaseList.map"
|
||||
, "wrong1 = ThisList.map"
|
||||
, "wrong2 = BaseList.x"
|
||||
, "main = pure ()"
|
||||
]
|
||||
_ <- createDoc "Data/List.hs" "haskell" thisDataListContent
|
||||
_ <- createDoc "Main.hs" "haskell" mainContent
|
||||
expectDiagnostics
|
||||
[ ( "Main.hs"
|
||||
, [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
|
||||
,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")
|
||||
, [(DsError, (6, 9),
|
||||
if ghcVersion >= GHC94
|
||||
then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130
|
||||
else "Not in scope: \8216ThisList.map\8217")
|
||||
,(DsError, (7, 9),
|
||||
if ghcVersion >= GHC94
|
||||
then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130
|
||||
else "Not in scope: \8216BaseList.x\8217")
|
||||
]
|
||||
)
|
||||
]
|
||||
@ -588,7 +595,7 @@ diagnosticTests = testGroup "diagnostics"
|
||||
-- where appropriate. The warning should use an unqualified name 'Ord', not
|
||||
-- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
|
||||
-- test this is fairly arbitrary.
|
||||
, [(DsWarning, (2, 0), "Redundant constraint: Ord a")
|
||||
, [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a")
|
||||
]
|
||||
)
|
||||
]
|
||||
@ -621,7 +628,7 @@ diagnosticTests = testGroup "diagnostics"
|
||||
-- Check that if we put a lower-case drive in for A.A
|
||||
-- the diagnostics for A.B will also be lower-case.
|
||||
liftIO $ fileUri @?= uriB
|
||||
let msg = _message (head (toList diags) :: Diagnostic)
|
||||
let msg = head (toList diags) ^. L.message
|
||||
liftIO $ unless ("redundant" `T.isInfixOf` msg) $
|
||||
assertFailure ("Expected redundant import but got " <> T.unpack msg)
|
||||
closeDoc a
|
||||
@ -1096,7 +1103,7 @@ findDefinitionAndHoverTests = let
|
||||
holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]
|
||||
cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]
|
||||
imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
|
||||
reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
|
||||
reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]
|
||||
thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]
|
||||
in
|
||||
mkFindTests
|
||||
@ -1180,7 +1187,7 @@ checkFileCompiles fp diag =
|
||||
pluginSimpleTests :: TestTree
|
||||
pluginSimpleTests =
|
||||
ignoreInWindowsForGHC88And810 $
|
||||
ignoreForGHC92 "blocked on ghc-typelits-natnormalise" $
|
||||
ignoreForGHC92Plus "blocked on ghc-typelits-natnormalise" $
|
||||
testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do
|
||||
_ <- openDoc (dir </> "KnownNat.hs") "haskell"
|
||||
liftIO $ writeFile (dir</>"hie.yaml")
|
||||
@ -1195,7 +1202,7 @@ pluginSimpleTests =
|
||||
pluginParsedResultTests :: TestTree
|
||||
pluginParsedResultTests =
|
||||
ignoreInWindowsForGHC88And810 $
|
||||
ignoreForGHC92 "No need for this plugin anymore!" $
|
||||
ignoreForGHC92Plus "No need for this plugin anymore!" $
|
||||
testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do
|
||||
_ <- openDoc (dir</> "RecordDot.hs") "haskell"
|
||||
expectNoMoreDiagnostics 2
|
||||
@ -1778,10 +1785,10 @@ packageCompletionTests =
|
||||
, _label == "fromList"
|
||||
]
|
||||
liftIO $ take 3 (sort compls') @?=
|
||||
map ("Defined in "<>)
|
||||
map ("Defined in "<>) (
|
||||
[ "'Data.List.NonEmpty"
|
||||
, "'GHC.Exts"
|
||||
]
|
||||
] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else [])
|
||||
|
||||
, testSessionWait "Map" $ do
|
||||
doc <- createDoc "A.hs" "haskell" $ T.unlines
|
||||
@ -1994,10 +2001,10 @@ completionDocTests =
|
||||
test doc (Position 1 7) "id" (Just $ T.length expected) [expected]
|
||||
]
|
||||
where
|
||||
brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92]) "Completion doc doesn't support ghc9"
|
||||
brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2"
|
||||
brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94]) "Completion doc doesn't support ghc9"
|
||||
brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92, GHC94]) "Extern doc doesn't support Windows for ghc9.2"
|
||||
-- https://gitlab.haskell.org/ghc/ghc/-/issues/20903
|
||||
brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9"
|
||||
brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94]) "Extern doc doesn't support MacOS for ghc9"
|
||||
test doc pos label mn expected = do
|
||||
_ <- waitForDiagnostics
|
||||
compls <- getCompletions doc pos
|
||||
@ -2040,7 +2047,7 @@ highlightTests = testGroup "highlight"
|
||||
, DocumentHighlight (R 6 10 6 13) (Just HkRead)
|
||||
, DocumentHighlight (R 7 12 7 15) (Just HkRead)
|
||||
]
|
||||
, knownBrokenForGhcVersions [GHC90, GHC92] "Ghc9 highlights the constructor and not just this field" $
|
||||
, knownBrokenForGhcVersions [GHC90, GHC92, GHC94] "Ghc9 highlights the constructor and not just this field" $
|
||||
testSessionWait "record" $ do
|
||||
doc <- createDoc "A.hs" "haskell" recsource
|
||||
_ <- waitForDiagnostics
|
||||
@ -2048,8 +2055,8 @@ highlightTests = testGroup "highlight"
|
||||
liftIO $ highlights @?= List
|
||||
-- Span is just the .. on 8.10, but Rec{..} before
|
||||
[ if ghcVersion >= GHC810
|
||||
then DocumentHighlight (R 4 8 4 10) (Just HkWrite)
|
||||
else DocumentHighlight (R 4 4 4 11) (Just HkWrite)
|
||||
then DocumentHighlight (R 4 8 4 10) (Just HkWrite)
|
||||
else DocumentHighlight (R 4 4 4 11) (Just HkWrite)
|
||||
, DocumentHighlight (R 4 14 4 20) (Just HkRead)
|
||||
]
|
||||
highlights <- getHighlights doc (Position 3 17)
|
||||
@ -2270,8 +2277,8 @@ ignoreInWindowsForGHC88And810 :: TestTree -> TestTree
|
||||
ignoreInWindowsForGHC88And810 =
|
||||
ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10"
|
||||
|
||||
ignoreForGHC92 :: String -> TestTree -> TestTree
|
||||
ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92])
|
||||
ignoreForGHC92Plus :: String -> TestTree -> TestTree
|
||||
ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94])
|
||||
|
||||
ignoreInWindowsForGHC88 :: TestTree -> TestTree
|
||||
ignoreInWindowsForGHC88 =
|
||||
|
@ -239,12 +239,12 @@ flag dynamic
|
||||
manual: True
|
||||
|
||||
common class
|
||||
if flag(class)
|
||||
if flag(class) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-class-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_class
|
||||
|
||||
common callHierarchy
|
||||
if flag(callHierarchy)
|
||||
if flag(callHierarchy) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-call-hierarchy-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_callHierarchy
|
||||
|
||||
@ -254,22 +254,22 @@ common haddockComments
|
||||
cpp-options: -Dhls_haddockComments
|
||||
|
||||
common eval
|
||||
if flag(eval)
|
||||
if flag(eval) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-eval-plugin ^>= 1.2
|
||||
cpp-options: -Dhls_eval
|
||||
|
||||
common importLens
|
||||
if flag(importLens)
|
||||
if flag(importLens) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-explicit-imports-plugin ^>= 1.1
|
||||
cpp-options: -Dhls_importLens
|
||||
|
||||
common refineImports
|
||||
if flag(refineImports)
|
||||
if flag(refineImports) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-refine-imports-plugin ^>=1.0
|
||||
cpp-options: -Dhls_refineImports
|
||||
|
||||
common rename
|
||||
if flag(rename)
|
||||
if flag(rename) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-rename-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_rename
|
||||
|
||||
@ -284,7 +284,7 @@ common tactic
|
||||
cpp-options: -Dhls_tactic
|
||||
|
||||
common hlint
|
||||
if flag(hlint)
|
||||
if flag(hlint) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-hlint-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_hlint
|
||||
|
||||
@ -294,12 +294,12 @@ common stan
|
||||
cpp-options: -Dhls_stan
|
||||
|
||||
common moduleName
|
||||
if flag(moduleName)
|
||||
if flag(moduleName) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-module-name-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_moduleName
|
||||
|
||||
common pragmas
|
||||
if flag(pragmas)
|
||||
if flag(pragmas) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-pragmas-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_pragmas
|
||||
|
||||
@ -309,54 +309,54 @@ common splice
|
||||
cpp-options: -Dhls_splice
|
||||
|
||||
common alternateNumberFormat
|
||||
if flag(alternateNumberFormat)
|
||||
if flag(alternateNumberFormat) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-alternate-number-format-plugin ^>= 1.1
|
||||
cpp-options: -Dhls_alternateNumberFormat
|
||||
|
||||
common qualifyImportedNames
|
||||
if flag(qualifyImportedNames)
|
||||
if flag(qualifyImportedNames) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-qualify-imported-names-plugin ^>=1.0
|
||||
cpp-options: -Dhls_qualifyImportedNames
|
||||
|
||||
common codeRange
|
||||
if flag(codeRange)
|
||||
if flag(codeRange) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-code-range-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_codeRange
|
||||
|
||||
common changeTypeSignature
|
||||
if flag(changeTypeSignature)
|
||||
if flag(changeTypeSignature) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-change-type-signature-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_changeTypeSignature
|
||||
|
||||
common gadt
|
||||
if flag(gadt)
|
||||
if flag(gadt) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-gadt-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_gadt
|
||||
|
||||
common explicitFixity
|
||||
if flag(explicitFixity)
|
||||
if flag(explicitFixity) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-explicit-fixity-plugin ^>= 1.0
|
||||
cpp-options: -DexplicitFixity
|
||||
|
||||
-- formatters
|
||||
|
||||
common floskell
|
||||
if flag(floskell)
|
||||
if flag(floskell) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-floskell-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_floskell
|
||||
|
||||
common fourmolu
|
||||
if flag(fourmolu)
|
||||
if flag(fourmolu) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-fourmolu-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_fourmolu
|
||||
|
||||
common ormolu
|
||||
if flag(ormolu)
|
||||
if flag(ormolu) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-ormolu-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_ormolu
|
||||
|
||||
common stylishHaskell
|
||||
if flag(stylishHaskell)
|
||||
if flag(stylishHaskell) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-stylish-haskell-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_stylishHaskell
|
||||
|
||||
@ -366,7 +366,7 @@ common brittany
|
||||
cpp-options: -Dhls_brittany
|
||||
|
||||
common refactor
|
||||
if flag(refactor)
|
||||
if flag(refactor) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
|
||||
build-depends: hls-refactor-plugin ^>= 1.0
|
||||
cpp-options: -Dhls_refactor
|
||||
|
||||
|
@ -52,3 +52,5 @@ library
|
||||
hs-source-dirs: src-ghc90 src-reexport-ghc9
|
||||
if (impl(ghc >= 9.2) && impl(ghc < 9.3))
|
||||
hs-source-dirs: src-ghc92 src-reexport-ghc9
|
||||
if (impl(ghc >= 9.4) && impl(ghc < 9.5))
|
||||
hs-source-dirs: src-reexport-ghc92
|
||||
|
3
hie-compat/src-reexport-ghc92/Compat/HieAst.hs
Normal file
3
hie-compat/src-reexport-ghc92/Compat/HieAst.hs
Normal file
@ -0,0 +1,3 @@
|
||||
module Compat.HieAst
|
||||
( module GHC.Iface.Ext.Ast ) where
|
||||
import GHC.Iface.Ext.Ast
|
8
hie-compat/src-reexport-ghc92/Compat/HieBin.hs
Normal file
8
hie-compat/src-reexport-ghc92/Compat/HieBin.hs
Normal file
@ -0,0 +1,8 @@
|
||||
{-
|
||||
Binary serialization for .hie files.
|
||||
-}
|
||||
|
||||
module Compat.HieBin ( module GHC.Iface.Ext.Binary)
|
||||
where
|
||||
|
||||
import GHC.Iface.Ext.Binary
|
10
hie-compat/src-reexport-ghc92/Compat/HieDebug.hs
Normal file
10
hie-compat/src-reexport-ghc92/Compat/HieDebug.hs
Normal file
@ -0,0 +1,10 @@
|
||||
module Compat.HieDebug
|
||||
( module GHC.Iface.Ext.Debug
|
||||
, ppHie ) where
|
||||
import GHC.Iface.Ext.Debug
|
||||
|
||||
import GHC.Iface.Ext.Types (HieAST)
|
||||
import GHC.Utils.Outputable (Outputable(ppr), SDoc)
|
||||
|
||||
ppHie :: Outputable a => HieAST a -> SDoc
|
||||
ppHie = ppr
|
3
hie-compat/src-reexport-ghc92/Compat/HieTypes.hs
Normal file
3
hie-compat/src-reexport-ghc92/Compat/HieTypes.hs
Normal file
@ -0,0 +1,3 @@
|
||||
module Compat.HieTypes
|
||||
( module GHC.Iface.Ext.Types ) where
|
||||
import GHC.Iface.Ext.Types
|
3
hie-compat/src-reexport-ghc92/Compat/HieUtils.hs
Normal file
3
hie-compat/src-reexport-ghc92/Compat/HieUtils.hs
Normal file
@ -0,0 +1,3 @@
|
||||
module Compat.HieUtils
|
||||
( module GHC.Iface.Ext.Utils ) where
|
||||
import GHC.Iface.Ext.Utils
|
@ -18,6 +18,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion
|
||||
other-modules: Ide.Plugin.Literals
|
||||
hs-source-dirs: src
|
||||
@ -47,6 +51,10 @@ library
|
||||
RecordWildCards
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -16,6 +16,10 @@ extra-source-files:
|
||||
test/testdata/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.CallHierarchy
|
||||
other-modules:
|
||||
Ide.Plugin.CallHierarchy.Internal
|
||||
@ -43,6 +47,10 @@ library
|
||||
default-extensions: DataKinds
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -19,6 +19,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.ChangeTypeSignature
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -46,6 +50,10 @@ library
|
||||
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -21,6 +21,10 @@ extra-source-files:
|
||||
test/testdata/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Class
|
||||
other-modules: Ide.Plugin.Class.CodeAction
|
||||
, Ide.Plugin.Class.CodeLens
|
||||
@ -58,6 +62,10 @@ library
|
||||
ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-name-shadowing
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -21,6 +21,10 @@ extra-source-files:
|
||||
test/testdata/selection-range/*.txt
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules:
|
||||
Ide.Plugin.CodeRange
|
||||
Ide.Plugin.CodeRange.Rules
|
||||
@ -48,6 +52,10 @@ library
|
||||
, vector
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -37,6 +37,10 @@ source-repository head
|
||||
location: https://github.com/haskell/haskell-language-server
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules:
|
||||
Ide.Plugin.Eval
|
||||
Ide.Plugin.Eval.Types
|
||||
@ -97,6 +101,10 @@ library
|
||||
TypeOperators
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -16,6 +16,10 @@ extra-source-files:
|
||||
test/testdata/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.ExplicitFixity
|
||||
|
||||
hs-source-dirs: src
|
||||
@ -39,6 +43,10 @@ library
|
||||
default-extensions: DataKinds
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -16,6 +16,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.ExplicitImports
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -37,6 +41,10 @@ library
|
||||
TypeOperators
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -17,6 +17,10 @@ extra-source-files:
|
||||
test/testdata/**/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Floskell
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -31,6 +35,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -23,6 +23,10 @@ source-repository head
|
||||
location: git://github.com/haskell/haskell-language-server.git
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules:
|
||||
Ide.Plugin.Fourmolu
|
||||
, Ide.Plugin.Fourmolu.Shim
|
||||
@ -44,6 +48,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -16,6 +16,10 @@ extra-source-files:
|
||||
test/testdata/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.GADT
|
||||
other-modules: Ide.Plugin.GHC
|
||||
|
||||
@ -46,6 +50,10 @@ library
|
||||
default-extensions: DataKinds
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -26,6 +26,10 @@ flag pedantic
|
||||
manual: True
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Hlint
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -73,6 +77,10 @@ library
|
||||
TypeOperators
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -20,6 +20,10 @@ extra-source-files:
|
||||
test/testdata/**/*.project
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.ModuleName
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -37,6 +41,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -17,6 +17,10 @@ extra-source-files:
|
||||
test/testdata/**/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Ormolu
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -34,6 +38,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -18,6 +18,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Pragmas
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -37,6 +41,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -18,6 +18,10 @@ extra-source-files:
|
||||
test/data/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.QualifyImportedNames
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -41,6 +45,10 @@ library
|
||||
TypeOperators
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -18,6 +18,10 @@ extra-source-files:
|
||||
test/data/**/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Development.IDE.GHC.ExactPrint
|
||||
Development.IDE.GHC.Compat.ExactPrint
|
||||
Development.IDE.Plugin.CodeAction
|
||||
@ -81,6 +85,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -2,6 +2,9 @@
|
||||
-- multiple ghc-exactprint versions, accepting that anything more ambitious is
|
||||
-- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint
|
||||
module Development.IDE.GHC.Compat.ExactPrint
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
( ) where
|
||||
#else
|
||||
( ExactPrint
|
||||
, exactPrint
|
||||
, makeDeltaAst
|
||||
@ -31,3 +34,5 @@ pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA
|
||||
pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast
|
||||
pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
@ -36,7 +36,11 @@ showAstDataHtml a0 = html $
|
||||
li (showAstDataHtml' a0),
|
||||
li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)
|
||||
#else
|
||||
li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0)
|
||||
li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
NoBlankEpAnnotations
|
||||
#endif
|
||||
a0)
|
||||
#endif
|
||||
])
|
||||
where
|
||||
@ -49,7 +53,7 @@ showAstDataHtml a0 = html $
|
||||
li = tag "li"
|
||||
caret x = tag' [("class", text "caret")] "span" "" <+> x
|
||||
nested foo cts
|
||||
#if MIN_VERSION_ghc(9,2,1)
|
||||
#if MIN_VERSION_ghc(9,2,1) && !MIN_VERSION_ghc(9,3,0)
|
||||
| cts == empty = foo
|
||||
#endif
|
||||
| otherwise = foo $$ (caret $ ul cts)
|
||||
|
@ -3,6 +3,9 @@
|
||||
|
||||
-- | This module hosts various abstractions and utility functions to work with ghc-exactprint.
|
||||
module Development.IDE.GHC.ExactPrint
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
( ) where
|
||||
#else
|
||||
( Graft(..),
|
||||
graftDecls,
|
||||
graftDeclsWithM,
|
||||
@ -665,3 +668,5 @@ isCommaAnn :: TrailingAnn -> Bool
|
||||
isCommaAnn AddCommaAnn{} = True
|
||||
isCommaAnn _ = False
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
@ -132,14 +132,16 @@ iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescrip
|
||||
iePluginDescriptor recorder plId =
|
||||
let old =
|
||||
mkGhcideCAsPlugin [
|
||||
wrap suggestExtendImport
|
||||
, wrap suggestImportDisambiguation
|
||||
, wrap suggestNewOrExtendImportForClassMethod
|
||||
, wrap suggestNewImport
|
||||
wrap suggestExportUnusedTopBinding
|
||||
, wrap suggestModuleTypo
|
||||
, wrap suggestFixConstructorImport
|
||||
, wrap suggestNewImport
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
, wrap suggestExtendImport
|
||||
, wrap suggestImportDisambiguation
|
||||
, wrap suggestNewOrExtendImportForClassMethod
|
||||
, wrap suggestHideShadow
|
||||
, wrap suggestExportUnusedTopBinding
|
||||
#endif
|
||||
]
|
||||
plId
|
||||
in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction }
|
||||
@ -149,9 +151,11 @@ typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
|
||||
mkGhcideCAsPlugin [
|
||||
wrap $ suggestSignature True
|
||||
, wrap suggestFillTypeWildcard
|
||||
, wrap removeRedundantConstraints
|
||||
, wrap suggestAddTypeAnnotationToSatisfyContraints
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
, wrap removeRedundantConstraints
|
||||
, wrap suggestConstraint
|
||||
#endif
|
||||
]
|
||||
plId
|
||||
|
||||
@ -159,7 +163,9 @@ bindingsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plugin
|
||||
bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
|
||||
mkGhcideCAsPlugin [
|
||||
wrap suggestReplaceIdentifier
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
, wrap suggestImplicitParameter
|
||||
#endif
|
||||
, wrap suggestNewDefinition
|
||||
, wrap suggestDeleteUnusedBinding
|
||||
]
|
||||
@ -296,7 +302,11 @@ findSigOfBind range bind =
|
||||
msum
|
||||
[findSigOfBinds range (grhssLocalBinds grhs) -- where clause
|
||||
, do
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs)
|
||||
#else
|
||||
grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs)
|
||||
#endif
|
||||
case unLoc grhs of
|
||||
GRHS _ _ bd -> findSigOfExpr (unLoc bd)
|
||||
]
|
||||
@ -305,7 +315,11 @@ findSigOfBind range bind =
|
||||
findSigOfExpr :: HsExpr p -> Maybe (Sig p)
|
||||
findSigOfExpr = go
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
go (HsLet _ _ binds _ _) = findSigOfBinds range binds
|
||||
#else
|
||||
go (HsLet _ binds _) = findSigOfBinds range binds
|
||||
#endif
|
||||
go (HsDo _ _ stmts) = do
|
||||
stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts)
|
||||
case stmtlr of
|
||||
@ -355,6 +369,7 @@ findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l)
|
||||
-- imported from ‘Data.ByteString’ at B.hs:6:1-22
|
||||
-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27
|
||||
-- imported from ‘Data.Text’ at B.hs:7:1-16
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]
|
||||
suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}
|
||||
| Just [identifier, modName, s] <-
|
||||
@ -386,6 +401,7 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}
|
||||
then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents
|
||||
else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl
|
||||
| otherwise = []
|
||||
#endif
|
||||
|
||||
findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs)
|
||||
findImportDeclByModuleName decls modName = flip find decls $ \case
|
||||
@ -978,6 +994,7 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of
|
||||
indentation :: T.Text -> Int
|
||||
indentation = T.length . T.takeWhile isSpace
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)]
|
||||
suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}
|
||||
| Just [binding, mod, srcspan] <-
|
||||
@ -1025,6 +1042,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_
|
||||
, parent = Nothing
|
||||
, isDatacon = False
|
||||
, moduleNameText = mod}
|
||||
#endif
|
||||
|
||||
data HidingMode
|
||||
= HideOthers [ModuleTarget]
|
||||
@ -1050,6 +1068,7 @@ oneAndOthers = go
|
||||
isPreludeImplicit :: DynFlags -> Bool
|
||||
isPreludeImplicit = xopt Lang.ImplicitPrelude
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
-- | Suggests disambiguation for ambiguous symbols.
|
||||
suggestImportDisambiguation ::
|
||||
DynFlags ->
|
||||
@ -1141,6 +1160,7 @@ suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..}
|
||||
<> "."
|
||||
<> symbol
|
||||
suggestImportDisambiguation _ _ _ _ _ = []
|
||||
#endif
|
||||
|
||||
occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool
|
||||
occursUnqualified symbol ImportDecl{..}
|
||||
@ -1163,6 +1183,7 @@ targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =
|
||||
targetModuleName (ExistingImp _) =
|
||||
error "Cannot happen!"
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
disambiguateSymbol ::
|
||||
Annotated ParsedSource ->
|
||||
T.Text ->
|
||||
@ -1195,6 +1216,8 @@ disambiguateSymbol ps fileContents Diagnostic {..} (T.unpack -> symbol) = \case
|
||||
liftParseAST @RdrName df $
|
||||
T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr
|
||||
]
|
||||
#endif
|
||||
|
||||
findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)
|
||||
findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs
|
||||
|
||||
@ -1212,6 +1235,7 @@ suggestFixConstructorImport Diagnostic{_range=_range,..}
|
||||
in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]
|
||||
| otherwise = []
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
-- | Suggests a constraint for a declaration for which a constraint is missing.
|
||||
suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
|
||||
suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..}
|
||||
@ -1293,10 +1317,12 @@ suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _rang
|
||||
[( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId)
|
||||
, appendConstraint (T.unpack implicitT) hsib_body)]
|
||||
| otherwise = []
|
||||
#endif
|
||||
|
||||
findTypeSignatureName :: T.Text -> Maybe T.Text
|
||||
findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
-- | Suggests a constraint for a type signature with any number of existing constraints.
|
||||
suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]
|
||||
|
||||
@ -1443,6 +1469,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos
|
||||
]
|
||||
<> [(quickFixImportKind "new.all", newImportAll moduleNameText)]
|
||||
| otherwise -> []
|
||||
#endif
|
||||
|
||||
suggestNewImport :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]
|
||||
suggestNewImport packageExportsMap ps fileContents Diagnostic{_message}
|
||||
|
@ -26,8 +26,10 @@ import Development.IDE.Core.Shake
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Compat.ExactPrint
|
||||
import Development.IDE.GHC.ExactPrint
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,
|
||||
rewriteToEdit)
|
||||
#endif
|
||||
import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),
|
||||
GlobalBindingTypeSigsResult)
|
||||
import Development.IDE.Spans.LocalBindings (Bindings)
|
||||
@ -70,7 +72,9 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
|
||||
Just (_, txt) -> pure txt
|
||||
_ -> pure Nothing
|
||||
caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
|
||||
#endif
|
||||
caaTmr <- onceIO $ runRule TypeCheck
|
||||
caaHar <- onceIO $ runRule GetHieAst
|
||||
caaBindings <- onceIO $ runRule GetBindings
|
||||
@ -113,6 +117,7 @@ class ToTextEdit a where
|
||||
instance ToTextEdit TextEdit where
|
||||
toTextEdit _ = pure . pure
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
instance ToTextEdit Rewrite where
|
||||
toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $
|
||||
runMaybeT $ do
|
||||
@ -124,6 +129,7 @@ instance ToTextEdit Rewrite where
|
||||
let r = rewriteToEdit df rw
|
||||
#endif
|
||||
pure $ fromRight [] r
|
||||
#endif
|
||||
|
||||
instance ToTextEdit a => ToTextEdit [a] where
|
||||
toTextEdit caa = foldMap (toTextEdit caa)
|
||||
@ -143,7 +149,11 @@ data CodeActionArgs = CodeActionArgs
|
||||
caaParsedModule :: IO (Maybe ParsedModule),
|
||||
caaContents :: IO (Maybe T.Text),
|
||||
caaDf :: IO (Maybe DynFlags),
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
caaAnnSource :: IO (Maybe ParsedSource),
|
||||
#else
|
||||
caaAnnSource :: IO (Maybe (Annotated ParsedSource)),
|
||||
#endif
|
||||
caaTmr :: IO (Maybe TcModuleResult),
|
||||
caaHar :: IO (Maybe HieAstResult),
|
||||
caaBindings :: IO (Maybe Bindings),
|
||||
@ -212,10 +222,17 @@ toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCode
|
||||
|
||||
-- | this instance returns a delta AST, useful for exactprint transforms
|
||||
instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->
|
||||
x >>= \case
|
||||
Just s -> flip runReaderT caa . toCodeAction . f . astA $ s
|
||||
_ -> pure []
|
||||
#else
|
||||
toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} ->
|
||||
x >>= \case
|
||||
Just s -> flip runReaderT caa . toCodeAction . f . pm_parsed_source $ s
|
||||
_ -> pure []
|
||||
#endif
|
||||
|
||||
instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where
|
||||
toCodeAction = toCodeAction3 caaExportsMap
|
||||
@ -244,11 +261,13 @@ instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where
|
||||
instance ToCodeAction r => ToCodeAction (DynFlags -> r) where
|
||||
toCodeAction = toCodeAction2 caaDf
|
||||
|
||||
#if !MIN_VERSION_ghc(9,3,0)
|
||||
instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where
|
||||
toCodeAction = toCodeAction1 caaAnnSource
|
||||
|
||||
instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where
|
||||
toCodeAction = toCodeAction2 caaAnnSource
|
||||
#endif
|
||||
|
||||
instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where
|
||||
toCodeAction = toCodeAction1 caaTmr
|
||||
|
@ -16,6 +16,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.RefineImports
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -38,6 +42,10 @@ library
|
||||
TypeOperators
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -17,6 +17,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Rename
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -41,6 +45,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -13,6 +13,10 @@ build-type: Simple
|
||||
extra-source-files: LICENSE
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.Retrie
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
|
@ -23,6 +23,10 @@ extra-source-files:
|
||||
test/testdata/*.yaml
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules:
|
||||
Ide.Plugin.Splice
|
||||
Ide.Plugin.Splice.Types
|
||||
@ -56,6 +60,10 @@ library
|
||||
TypeOperators
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -76,4 +76,4 @@ test-suite test
|
||||
, text
|
||||
default-extensions:
|
||||
NamedFieldPuns
|
||||
OverloadedStrings
|
||||
OverloadedStrings
|
||||
|
@ -16,6 +16,10 @@ extra-source-files:
|
||||
test/testdata/*.hs
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
exposed-modules: Ide.Plugin.StylishHaskell
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
@ -33,6 +37,10 @@ library
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
|
@ -25,6 +25,10 @@ flag pedantic
|
||||
manual: True
|
||||
|
||||
library
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
hs-source-dirs: src
|
||||
exposed-modules:
|
||||
Ide.Plugin.Tactic
|
||||
@ -127,6 +131,10 @@ library
|
||||
ViewPatterns
|
||||
|
||||
test-suite tests
|
||||
if impl(ghc >= 9.3)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
|
Loading…
Reference in New Issue
Block a user