haskell/ghcide
1
1
Fork 0
mirror of https://github.com/haskell/ghcide.git synced 2024-09-11 13:57:06 +03:00
Code Issues Projects Releases Wiki Activity

Use object code for Template Haskell, emit desugarer warnings (#836)

Browse Source 
* Use object code for TH

* Set target location for TargetFiles

* Fix tests

* hlint

* fix build on 8.10

* fix ghc-lib

* address review comments

* hlint

* better error handling if module headers don't parse

* Always desugar, don't call interactive API functions

* deprioritize desugar when not TH, fix iface handling

* write hie file on save

* more tweaks

* fix tests

* disable desugarer warnings

* use ModGuts for exports map

* don't desugar

* use bytecode

* make HiFileStable early-cutoff

* restore object code

* re-enable desugar

* review comments

* Don't use ModIface for DocMap

* fix docs for the current module

* mark test as broken on windows
This commit is contained in:
wz1000 2020-10-04 21:34:43 +05:30 committed by GitHub
parent d6fc31e16b
commit 03bdcaebfd
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
17 changed files with 467 additions and 421 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
session-loader/Development/IDE/Session.hs
View File

@ -118,9 +118,12 @@ loadSession dir = do
-- files in the project so that `knownFiles` can learn about them and
-- we can generate a complete module graph
let extendKnownTargets newTargets = do
knownTargets <- forM newTargets $ \TargetDetails{..} -> do
found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
return (targetTarget, found)
knownTargets <- forM newTargets $ \TargetDetails{..} ->
case targetTarget of
TargetFile f -> pure (targetTarget, [f])
TargetModule _ -> do
found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
return (targetTarget, found)
modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do
let known' = HM.unionWith (<>) known $ HM.fromList knownTargets
when (known /= known') $
@ -501,6 +504,7 @@ setCacheDir logger prefix hscComponents comps dflags = do
pure $ dflags
& setHiDir cacheDir
& setHieDir cacheDir
& setODir cacheDir
renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
@ -641,7 +645,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions df = df {
ghcLink = LinkInMemory
, hscTarget = HscNothing
, hscTarget = HscAsm
, ghcMode = CompManager
}
@ -657,6 +661,11 @@ setHiDir f d =
-- override user settings to avoid conflicts leading to recompilation
d { hiDir = Just f}
setODir :: FilePath -> DynFlags -> DynFlags
setODir f d =
-- override user settings to avoid conflicts leading to recompilation
d { objectDir = Just f}
getCacheDir :: String -> [String] -> IO FilePath
getCacheDir prefix opts = getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
where

270
src/Development/IDE/Core/Compile.hs
View File

@ -16,7 +16,9 @@ module Development.IDE.Core.Compile
, typecheckModule
, computePackageDeps
, addRelativeImport
, mkTcModuleResult
, mkHiFileResultCompile
, mkHiFileResultNoCompile
, generateObjectCode
, generateByteCode
, generateHieAsts
, writeHieFile
@ -46,11 +48,16 @@ import Development.IDE.Types.Location
import Language.Haskell.LSP.Types (DiagnosticTag(..))
import LoadIface (loadModuleInterface)
import DriverPhases
import HscTypes
import DriverPipeline hiding (unP)
import qualified Parser
import Lexer
#if MIN_GHC_API_VERSION(8,10,0)
import Control.DeepSeq (force, rnf)
#else
import Control.DeepSeq (rnf)
import ErrUtils
#endif
@ -61,10 +68,10 @@ import qualified Development.IDE.GHC.Compat as Compat
import GhcMonad
import GhcPlugins as GHC hiding (fst3, (<>))
import qualified HeaderInfo as Hdr
import HscMain (hscInteractive, hscSimplify)
import HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive)
import MkIface
import StringBuffer as SB
import TcRnMonad (tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds)
import TcRnMonad (finalSafeMode, TcGblEnv, tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds)
import TcIface (typecheckIface)
import TidyPgm
@ -82,7 +89,6 @@ import qualified Data.Map.Strict as Map
import System.FilePath
import System.Directory
import System.IO.Extra
import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Exception (ExceptionMonad)
import TcEnv (tcLookup)
@ -123,7 +129,7 @@ typecheckModule :: IdeDefer
-> ParsedModule
-> IO (IdeResult (HscEnv, TcModuleResult))
typecheckModule (IdeDefer defer) hsc pm = do
fmap (either (, Nothing) (second Just . sequence) . sequence) $
fmap (\(hsc, res) -> case res of Left d -> (d,Nothing); Right (d,res) -> (d,fmap (hsc,) res)) $
runGhcEnv hsc $
catchSrcErrors "typecheck" $ do
@ -131,18 +137,87 @@ typecheckModule (IdeDefer defer) hsc pm = do
dflags = ms_hspp_opts modSummary
modSummary' <- initPlugins modSummary
(warnings, tcm1) <- withWarnings "typecheck" $ \tweak ->
GHC.typecheckModule $ enableTopLevelWarnings
$ enableUnnecessaryAndDeprecationWarnings
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
tcm2 <- liftIO $ fixDetailsForTH tcm1
(warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
tcRnModule $ enableTopLevelWarnings
$ enableUnnecessaryAndDeprecationWarnings
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
let errorPipeline = unDefer . hideDiag dflags . tagDiag
diags = map errorPipeline warnings
tcm3 <- mkTcModuleResult tcm2 (any fst diags)
return (map snd diags, tcm3)
deferedError = any fst diags
return (map snd diags, Just $ tcm{tmrDeferedError = deferedError})
where
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
tcRnModule :: GhcMonad m => ParsedModule -> m TcModuleResult
tcRnModule pmod = do
let ms = pm_mod_summary pmod
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
(tc_gbl_env, mrn_info)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod,
hpm_annotations = pm_annotations pmod }
let rn_info = case mrn_info of
Just x -> x
Nothing -> error "no renamed info tcRnModule"
pure (TcModuleResult pmod rn_info tc_gbl_env False)
mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
mkHiFileResultNoCompile session tcm = do
let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms }
ms = pm_mod_summary $ tmrParsed tcm
tcGblEnv = tmrTypechecked tcm
details <- makeSimpleDetails hsc_env_tmp tcGblEnv
sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv
#if MIN_GHC_API_VERSION(8,10,0)
iface <- mkIfaceTc session sf details tcGblEnv
#else
(iface, _) <- mkIfaceTc session Nothing sf details tcGblEnv
#endif
let mod_info = HomeModInfo iface details Nothing
pure $! HiFileResult ms mod_info
mkHiFileResultCompile
:: HscEnv
-> TcModuleResult
-> ModGuts
-> IO (IdeResult HiFileResult)
mkHiFileResultCompile session' tcm simplified_guts = catchErrs $ do
let session = session' { hsc_dflags = ms_hspp_opts ms }
ms = pm_mod_summary $ tmrParsed tcm
-- give variables unique OccNames
(guts, details) <- tidyProgram session simplified_guts
(diags, obj_res) <- generateObjectCode session ms guts
case obj_res of
Nothing -> do
#if MIN_GHC_API_VERSION(8,10,0)
let !partial_iface = force (mkPartialIface session details simplified_guts)
final_iface <- mkFullIface session partial_iface
#else
(final_iface,_) <- mkIface session Nothing details simplified_guts
#endif
let mod_info = HomeModInfo final_iface details Nothing
pure (diags, Just $ HiFileResult ms mod_info)
Just linkable -> do
#if MIN_GHC_API_VERSION(8,10,0)
let !partial_iface = force (mkPartialIface session details simplified_guts)
final_iface <- mkFullIface session partial_iface
#else
(final_iface,_) <- mkIface session Nothing details simplified_guts
#endif
let mod_info = HomeModInfo final_iface details (Just linkable)
pure (diags, Just $! HiFileResult ms mod_info)
where
dflags = hsc_dflags session'
source = "compile"
catchErrs x = x `catches`
[ Handler $ return . (,Nothing) . diagFromGhcException source dflags
, Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")
. (("Error during " ++ T.unpack source) ++) . show @SomeException
]
initPlugins :: GhcMonad m => ModSummary -> m ModSummary
initPlugins modSummary = do
session <- getSession
@ -160,50 +235,66 @@ newtype RunSimplifier = RunSimplifier Bool
compileModule
:: RunSimplifier
-> HscEnv
-> [(ModSummary, HomeModInfo)]
-> TcModuleResult
-> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
compileModule (RunSimplifier simplify) packageState deps tmr =
-> ModSummary
-> TcGblEnv
-> IO (IdeResult ModGuts)
compileModule (RunSimplifier simplify) packageState ms tcg =
fmap (either (, Nothing) (second Just)) $
evalGhcEnv packageState $
catchSrcErrors "compile" $ do
setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
let tm = tmrModule tmr
session <- getSession
(warnings,desugar) <- withWarnings "compile" $ \tweak -> do
let pm = tm_parsed_module tm
let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
let tm' = tm{tm_parsed_module = pm'}
GHC.dm_core_module <$> GHC.desugarModule tm'
let tc_result = fst (tm_internals_ (tmrModule tmr))
let ms' = tweak ms
liftIO $ hscDesugar session{ hsc_dflags = ms_hspp_opts ms'} ms' tcg
desugared_guts <-
if simplify
then do
plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
plugins <- liftIO $ readIORef (tcg_th_coreplugins tcg)
liftIO $ hscSimplify session plugins desugar
else pure desugar
-- give variables unique OccNames
(guts, details) <- liftIO $ tidyProgram session desugared_guts
return (map snd warnings, (mg_safe_haskell desugar, guts, details))
return (map snd warnings, desugared_guts)
generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
generateByteCode hscEnv deps tmr guts =
generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateObjectCode hscEnv summary guts = do
fmap (either (, Nothing) (second Just)) $
evalGhcEnv hscEnv $
catchSrcErrors "bytecode" $ do
setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
session <- getSession
(warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
evalGhcEnv hscEnv $
catchSrcErrors "object" $ do
session <- getSession
let dot_o = ml_obj_file (ms_location summary)
let session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }}
fp = replaceExtension dot_o "s"
liftIO $ createDirectoryIfMissing True (takeDirectory fp)
(warnings, dot_o_fp) <-
withWarnings "object" $ \_tweak -> liftIO $ do
(outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
#if MIN_GHC_API_VERSION(8,10,0)
liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
(ms_location summary)
#else
liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
(_tweak summary)
#endif
let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
let unlinked = BCOs bytecode sptEntries
let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
pure (map snd warnings, linkable)
fp
compileFile session' StopLn (outputFilename, Just (As False))
let unlinked = DotO dot_o_fp
let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
pure (map snd warnings, linkable)
generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
generateByteCode hscEnv summary guts = do
fmap (either (, Nothing) (second Just)) $
evalGhcEnv hscEnv $
catchSrcErrors "bytecode" $ do
session <- getSession
(warnings, (_, bytecode, sptEntries)) <-
withWarnings "bytecode" $ \_tweak -> liftIO $
hscInteractive session guts
#if MIN_GHC_API_VERSION(8,10,0)
(ms_location summary)
#else
(_tweak summary)
#endif
let unlinked = BCOs bytecode sptEntries
let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
pure (map snd warnings, linkable)
demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings =
@ -299,24 +390,6 @@ addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport fp modu dflags = dflags
{importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
mkTcModuleResult
:: GhcMonad m
=> TypecheckedModule
-> Bool
-> m TcModuleResult
mkTcModuleResult tcm upgradedError = do
session <- getSession
let sf = modInfoSafe (tm_checked_module_info tcm)
#if MIN_GHC_API_VERSION(8,10,0)
iface <- liftIO $ mkIfaceTc session sf details tcGblEnv
#else
(iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
#endif
let mod_info = HomeModInfo iface details Nothing
return $ TcModuleResult tcm mod_info upgradedError Nothing
where
(tcGblEnv, details) = tm_internals_ tcm
atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
atomicFileWrite targetPath write = do
let dir = takeDirectory targetPath
@ -324,16 +397,12 @@ atomicFileWrite targetPath write = do
(tempFilePath, cleanUp) <- newTempFileWithin dir
(write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
generateHieAsts :: HscEnv -> TypecheckedModule -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts hscEnv tcm =
handleGenerationErrors' dflags "extended interface generation" $ do
case tm_renamed_source tcm of
Just rnsrc -> runHsc hscEnv $
Just <$> GHC.enrichHie (tcg_binds $ fst $ tm_internals_ tcm) rnsrc
_ ->
return Nothing
handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $
Just <$> GHC.enrichHie (tcg_binds $ tmrTypechecked tcm) (tmrRenamed tcm)
where
dflags = hsc_dflags hscEnv
dflags = hsc_dflags hscEnv
writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
writeHieFile hscEnv mod_summary exports ast source =
@ -346,14 +415,14 @@ writeHieFile hscEnv mod_summary exports ast source =
mod_location = ms_location mod_summary
targetPath = Compat.ml_hie_file mod_location
writeHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile hscEnv tc =
handleGenerationErrors dflags "interface generation" $ do
atomicFileWrite targetPath $ \fp ->
writeIfaceFile dflags fp modIface
where
modIface = hm_iface $ tmrModInfo tc
targetPath = ml_hi_file $ ms_location $ tmrModSummary tc
modIface = hm_iface $ hirHomeMod tc
targetPath = ml_hi_file $ ms_location $ hirModSummary tc
dflags = hsc_dflags hscEnv
handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
@ -372,19 +441,6 @@ handleGenerationErrors' dflags source action =
. (("Error during " ++ T.unpack source) ++) . show @SomeException
]
-- | Setup the environment that GHC needs according to our
-- best understanding (!)
--
-- This involves setting up the finder cache and populating the
-- HPT.
setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
setupEnv tms = do
setupFinderCache (map fst tms)
-- load dependent modules, which must be in topological order.
modifySession $ \e ->
foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
-- | Initialise the finder cache, dependencies should be topologically
-- sorted.
setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
@ -428,20 +484,14 @@ loadModuleHome mod_info e =
mod_name = moduleName $ mi_module $ hm_iface mod_info
-- | Load module interface.
loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv
loadDepModuleIO iface linkable hsc = do
details <- liftIO $ fixIO $ \details -> do
let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }
initIfaceLoad hsc' (typecheckIface iface)
let mod_info = HomeModInfo iface details linkable
loadDepModuleIO :: HomeModInfo -> HscEnv -> IO HscEnv
loadDepModuleIO mod_info hsc = do
return $ loadModuleHome mod_info hsc
where
mod = moduleName $ mi_module iface
loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m ()
loadDepModule iface linkable = do
loadDepModule :: GhcMonad m => HomeModInfo -> m ()
loadDepModule mod_info = do
e <- getSession
e' <- liftIO $ loadDepModuleIO iface linkable e
e' <- liftIO $ loadDepModuleIO mod_info e
setSession e'
-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
@ -667,12 +717,13 @@ loadInterface
:: MonadIO m => HscEnv
-> ModSummary
-> SourceModified
-> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface
-> Bool
-> (Bool -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface
-> m ([FileDiagnostic], Maybe HiFileResult)
loadInterface session ms sourceMod regen = do
loadInterface session ms sourceMod objNeeded regen = do
res <- liftIO $ checkOldIface session ms sourceMod Nothing
case res of
(UpToDate, Just x)
(UpToDate, Just iface)
-- If the module used TH splices when it was last
-- compiled, then the recompilation check is not
-- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481)
@ -687,9 +738,28 @@ loadInterface session ms sourceMod regen = do
-- nothing at all has changed. Stability is just
-- the same check that make is doing for us in
-- one-shot mode.
| not (mi_used_th x) || SourceUnmodifiedAndStable == sourceMod
-> return ([], Just $ HiFileResult ms x)
(_reason, _) -> regen
| not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod
-> do
linkable <-
if objNeeded
then liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms)
else pure Nothing
let objUpToDate = not objNeeded || case linkable of
Nothing -> False
Just (LM obj_time _ _) -> obj_time > ms_hs_date ms
if objUpToDate
then do
hmi <- liftIO $ mkDetailsFromIface session iface linkable
return ([], Just $ HiFileResult ms hmi)
else regen objNeeded
(_reason, _) -> regen objNeeded
mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
mkDetailsFromIface session iface linkable = do
details <- liftIO $ fixIO $ \details -> do
let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) }
initIfaceLoad hsc' (typecheckIface iface)
return (HomeModInfo iface details linkable)
-- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
-- The interactive paths create problems in ghc-lib builds

2
src/Development/IDE/Core/FileStore.hs
View File

@ -236,7 +236,7 @@ typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents
typecheckParentsAction :: NormalizedFilePath -> Action ()
typecheckParentsAction nfp = do
revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph
revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph
logger <- logger <$> getShakeExtras
let log = L.logInfo logger . T.pack
liftIO $ do

12
src/Development/IDE/Core/OfInterest.hs
View File

@ -25,14 +25,14 @@ import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import Data.Tuple.Extra
import Development.Shake
import Control.Monad (void)
import Development.IDE.Types.Exports
import Development.IDE.Types.Location
import Development.IDE.Types.Logger
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake
import Data.Maybe (mapMaybe)
import GhcPlugins (HomeModInfo(hm_iface))
import Data.Maybe (catMaybes)
newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
instance IsIdeGlobal OfInterestVar
@ -90,15 +90,15 @@ modifyFilesOfInterest state f = do
-- Could be improved
kick :: DelayedAction ()
kick = mkDelayedAction "kick" Debug $ do
files <- getFilesOfInterest
files <- HashMap.keys <$> getFilesOfInterest
ShakeExtras{progressUpdate} <- getShakeExtras
liftIO $ progressUpdate KickStarted
-- Update the exports map for the project
results <- uses TypeCheck $ HashMap.keys files
(results, ()) <- par (uses GenerateCore files) (void $ uses GetHieAst files)
ShakeExtras{exportsMap} <- getShakeExtras
let modIfaces = mapMaybe (fmap (hm_iface . tmrModInfo)) results
!exportsMap' = createExportsMap modIfaces
let mguts = catMaybes results
!exportsMap' = createExportsMapMg mguts
liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap' <>)
liftIO $ progressUpdate KickCompleted

89
src/Development/IDE/Core/RuleTypes.hs
View File

@ -2,7 +2,8 @@
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
-- | A Shake implementation of the compiler service, built
-- using the "Shaker" abstraction layer for in-memory use.
@ -26,13 +27,14 @@ import Development.Shake
import GHC.Generics (Generic)
import Module (InstalledUnitId)
import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
import HscTypes (ModGuts, hm_iface, HomeModInfo)
import Development.IDE.Spans.Common
import Development.IDE.Spans.LocalBindings
import Development.IDE.Import.FindImports (ArtifactsLocation)
import Data.ByteString (ByteString)
import Language.Haskell.LSP.Types (NormalizedFilePath)
import TcRnMonad (TcGblEnv)
-- NOTATION
-- Foo+ means Foo for the dependencies
@ -52,6 +54,9 @@ type instance RuleResult GetDependencies = TransitiveDependencies
type instance RuleResult GetModuleGraph = DependencyInformation
-- | Does this module need object code?
type instance RuleResult NeedsObjectCode = Bool
data GetKnownTargets = GetKnownTargets
deriving (Show, Generic, Eq, Ord)
instance Hashable GetKnownTargets
@ -59,42 +64,58 @@ instance NFData GetKnownTargets
instance Binary GetKnownTargets
type instance RuleResult GetKnownTargets = KnownTargets
-- | Convert to Core, requires TypeCheck*
type instance RuleResult GenerateCore = ModGuts
data GenerateCore = GenerateCore
deriving (Eq, Show, Typeable, Generic)
instance Hashable GenerateCore
instance NFData GenerateCore
instance Binary GenerateCore
data GetImportMap = GetImportMap
deriving (Eq, Show, Typeable, Generic)
instance Hashable GetImportMap
instance NFData GetImportMap
instance Binary GetImportMap
type instance RuleResult GetImportMap = ImportMap
newtype ImportMap = ImportMap
{ importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located?
} deriving stock Show
deriving newtype NFData
-- | Contains the typechecked module and the OrigNameCache entry for
-- that module.
data TcModuleResult = TcModuleResult
{ tmrModule :: TypecheckedModule
-- ^ warning, the ModIface in the tm_checked_module_info of the
-- TypecheckedModule will always be Nothing, use the ModIface in the
-- HomeModInfo instead
, tmrModInfo :: HomeModInfo
{ tmrParsed :: ParsedModule
, tmrRenamed :: RenamedSource
, tmrTypechecked :: TcGblEnv
, tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
, tmrHieAsts :: !(Maybe (HieASTs Type)) -- ^ The HieASTs if we computed them
}
instance Show TcModuleResult where
show = show . pm_mod_summary . tm_parsed_module . tmrModule
show = show . pm_mod_summary . tmrParsed
instance NFData TcModuleResult where
rnf = rwhnf
tmrModSummary :: TcModuleResult -> ModSummary
tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule
tmrModSummary = pm_mod_summary . tmrParsed
data HiFileResult = HiFileResult
{ hirModSummary :: !ModSummary
-- Bang patterns here are important to stop the result retaining
-- a reference to a typechecked module
, hirModIface :: !ModIface
, hirHomeMod :: !HomeModInfo
-- ^ Includes the Linkable iff we need object files
}
tmr_hiFileResult :: TcModuleResult -> HiFileResult
tmr_hiFileResult tmr = HiFileResult modSummary modIface
where
modIface = hm_iface . tmrModInfo $ tmr
modSummary = tmrModSummary tmr
hiFileFingerPrint :: HiFileResult -> ByteString
hiFileFingerPrint = fingerprintToBS . getModuleHash . hirModIface
hirModIface :: HiFileResult -> ModIface
hirModIface = hm_iface . hirHomeMod
instance NFData HiFileResult where
rnf = rwhnf
@ -106,12 +127,14 @@ data HieAstResult
= HAR
{ hieModule :: Module
, hieAst :: !(HieASTs Type)
, refMap :: !RefMap
, importMap :: !(M.Map ModuleName NormalizedFilePath) -- ^ Where are the modules imported by this file located?
, refMap :: RefMap
-- ^ Lazy because its value only depends on the hieAst, which is bundled in this type
-- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same
-- as that of `hieAst`
}
instance NFData HieAstResult where
rnf (HAR m hf rm im) = rnf m `seq` rwhnf hf `seq` rnf rm `seq` rnf im
rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf
instance Show HieAstResult where
show = show . hieModule
@ -127,19 +150,13 @@ type instance RuleResult GetBindings = Bindings
data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap}
instance NFData DocAndKindMap where
rnf (DKMap a b) = rnf a `seq` rnf b
rnf (DKMap a b) = rwhnf a `seq` rwhnf b
instance Show DocAndKindMap where
show = const "docmap"
type instance RuleResult GetDocMap = DocAndKindMap
-- | Convert to Core, requires TypeCheck*
type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
-- | Generate byte code for template haskell.
type instance RuleResult GenerateByteCode = Linkable
-- | A GHC session that we reuse.
type instance RuleResult GhcSession = HscEnvEq
@ -196,6 +213,12 @@ instance Hashable GetLocatedImports
instance NFData GetLocatedImports
instance Binary GetLocatedImports
data NeedsObjectCode = NeedsObjectCode
deriving (Eq, Show, Typeable, Generic)
instance Hashable NeedsObjectCode
instance NFData NeedsObjectCode
instance Binary NeedsObjectCode
data GetDependencyInformation = GetDependencyInformation
deriving (Eq, Show, Typeable, Generic)
instance Hashable GetDependencyInformation
@ -244,18 +267,6 @@ instance Hashable GetBindings
instance NFData GetBindings
instance Binary GetBindings
data GenerateCore = GenerateCore
deriving (Eq, Show, Typeable, Generic)
instance Hashable GenerateCore
instance NFData GenerateCore
instance Binary GenerateCore
data GenerateByteCode = GenerateByteCode
deriving (Eq, Show, Typeable, Generic)
instance Hashable GenerateByteCode
instance NFData GenerateByteCode
instance Binary GenerateByteCode
data GhcSession = GhcSession
deriving (Eq, Show, Typeable, Generic)
instance Hashable GhcSession

286
src/Development/IDE/Core/Rules.hs
View File

@ -27,7 +27,6 @@ module Development.IDE.Core.Rules(
highlightAtPoint,
getDependencies,
getParsedModule,
generateCore,
) where
import Fingerprint
@ -95,6 +94,8 @@ import Data.Time (UTCTime(..))
import Data.Hashable
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HM
import TcRnMonad (tcg_dependent_files)
import Data.IORef
-- | This is useful for rules to convert rules that can only produce errors or
-- a result into the more general IdeResult type that supports producing
@ -149,7 +150,8 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
getDefinition file pos = runMaybeT $ do
ide <- ask
opts <- liftIO $ getIdeOptionsIO ide
(HAR _ hf _ imports, mapping) <- useE GetHieAst file
(HAR _ hf _ , mapping) <- useE GetHieAst file
(ImportMap imports, _) <- useE GetImportMap file
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
AtPoint.gotoDefinition (getHieFile ide file) opts imports hf pos'
@ -163,7 +165,7 @@ getTypeDefinition file pos = runMaybeT $ do
highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
highlightAtPoint file pos = runMaybeT $ do
(HAR _ hf rf _,mapping) <- useE GetHieAst file
(HAR _ hf rf,mapping) <- useE GetHieAst file
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
AtPoint.documentHighlight hf rf pos'
@ -203,8 +205,8 @@ getHomeHieFile f = do
wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do
hsc <- hscEnv <$> use_ GhcSession f
pm <- use_ GetParsedModule f
source <- getSourceFileSource f
typeCheckRuleDefinition hsc pm NotFOI (Just source)
(_, mtm)<- typeCheckRuleDefinition hsc pm
mapM_ (getHieAstRuleDefinition f hsc) mtm -- Write the HiFile to disk
_ <- MaybeT $ liftIO $ timeout 1 wait
ncu <- mkUpdater
liftIO $ loadHieFile ncu hie_f
@ -263,6 +265,7 @@ priorityFilesOfInterest = Priority (-2)
-- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490
getParsedModuleRule :: Rules ()
getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
_ <- use_ GetModSummaryWithoutTimestamps file -- Fail if we can't even parse the ModSummary
sess <- use_ GhcSession file
let hsc = hscEnv sess
-- These packages are used when removing PackageImports from a
@ -392,7 +395,8 @@ rawDependencyInformation fs = do
-- If we have, just return its Id but don't update any of the state.
-- Otherwise, we need to process its imports.
checkAlreadyProcessed f $ do
al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummaryWithoutTimestamps f
msum <- lift $ use GetModSummaryWithoutTimestamps f
let al = modSummaryToArtifactsLocation f msum
-- Get a fresh FilePathId for the new file
fId <- getFreshFid al
-- Adding an edge to the bootmap so we can make sure to
@ -457,15 +461,14 @@ rawDependencyInformation fs = do
updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
if not artifactIsSource
then
let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)
let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath)
in case msource_mod_id of
Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm
Nothing -> bm
else bm
dropBootSuffix :: ModLocation -> FilePath
dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src
dropBootSuffix _ = error "dropBootSuffix"
dropBootSuffix :: FilePath -> FilePath
dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src
getDependencyInformationRule :: Rules ()
getDependencyInformationRule =
@ -523,18 +526,29 @@ getHieAstsRule :: Rules ()
getHieAstsRule =
define $ \GetHieAst f -> do
tmr <- use_ TypeCheck f
(diags,masts) <- case tmrHieAsts tmr of
-- If we already have them from typechecking, return them
Just asts -> pure ([], Just asts)
-- Compute asts if we haven't already computed them
Nothing -> do
hsc <- hscEnv <$> use_ GhcSession f
(diagsHieGen, masts) <- liftIO $ generateHieAsts hsc (tmrModule tmr)
pure (diagsHieGen, masts)
let refmap = generateReferencesMap . getAsts <$> masts
im <- use GetLocatedImports f
let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports
pure (diags, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> fmap mkImports im)
hsc <- hscEnv <$> use_ GhcSession f
getHieAstRuleDefinition f hsc tmr
getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)
getHieAstRuleDefinition f hsc tmr = do
(diags, masts) <- liftIO $ generateHieAsts hsc tmr
isFoi <- use_ IsFileOfInterest f
diagsWrite <- case isFoi of
IsFOI Modified -> pure []
_ | Just asts <- masts -> do
source <- getSourceFileSource f
liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source
_ -> pure []
let refmap = generateReferencesMap . getAsts <$> masts
pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap)
getImportMapRule :: Rules()
getImportMapRule = define $ \GetImportMap f -> do
im <- use GetLocatedImports f
let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports
pure ([], ImportMap . mkImports <$> im)
getBindingsRule :: Rules ()
getBindingsRule =
@ -545,24 +559,21 @@ getBindingsRule =
getDocMapRule :: Rules ()
getDocMapRule =
define $ \GetDocMap file -> do
hmi <- hirModIface <$> use_ GetModIface file
hsc <- hscEnv <$> use_ GhcSessionDeps file
(refMap -> rf) <- use_ GetHieAst file
deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
let tdeps = transitiveModuleDeps deps
(tmrTypechecked -> tc,_) <- useWithStale_ TypeCheck file
(hscEnv -> hsc,_) <-useWithStale_ GhcSessionDeps file
(refMap -> rf, _) <- useWithStale_ GetHieAst file
-- When possible, rely on the haddocks embedded in our interface files
-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
#if !defined(GHC_LIB)
let parsedDeps = []
#else
deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
let tdeps = transitiveModuleDeps deps
parsedDeps <- uses_ GetParsedModule tdeps
#endif
ifaces <- uses_ GetModIface tdeps
dkMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf hmi (map hirModIface ifaces)
dkMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf tc
return ([],Just dkMap)
-- Typechecks a module.
@ -570,11 +581,7 @@ typeCheckRule :: Rules ()
typeCheckRule = define $ \TypeCheck file -> do
pm <- use_ GetParsedModule file
hsc <- hscEnv <$> use_ GhcSessionDeps file
-- do not generate interface files as this rule is called
-- for files of interest on every keystroke
source <- getSourceFileSource file
isFoi <- use_ IsFileOfInterest file
typeCheckRuleDefinition hsc pm isFoi (Just source)
typeCheckRuleDefinition hsc pm
knownFilesRule :: Rules ()
knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do
@ -595,70 +602,20 @@ getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do
typeCheckRuleDefinition
:: HscEnv
-> ParsedModule
-> IsFileOfInterestResult -- ^ Should generate .hi and .hie files ?
-> Maybe BS.ByteString
-> Action (IdeResult TcModuleResult)
typeCheckRuleDefinition hsc pm isFoi source = do
typeCheckRuleDefinition hsc pm = do
setPriority priorityTypeCheck
IdeOptions { optDefer = defer } <- getIdeOptions
addUsageDependencies $ liftIO $ do
res <- typecheckModule defer hsc pm
case res of
(diags, Just (hsc,tcm)) -> do
case isFoi of
IsFOI Modified -> return (diags, Just tcm)
_ -> do -- If the file is saved on disk, or is not a FOI, we write out ifaces
let tm = tmrModule tcm
ms = tmrModSummary tcm
exports = tcg_exports $ fst $ tm_internals_ tm
(diagsHieGen, masts) <- generateHieAsts hsc (tmrModule tcm)
diagsHieWrite <- case masts of
Nothing -> pure mempty
Just asts -> writeHieFile hsc ms exports asts $ fromMaybe "" source
-- Don't save interface files for modules that compiled due to defering
-- type errors, as we won't get proper diagnostics if we load these from
-- disk
diagsHi <- if not $ tmrDeferedError tcm
then writeHiFile hsc tcm
else pure mempty
return (diags <> diagsHi <> diagsHieGen <> diagsHieWrite, Just tcm{tmrHieAsts = masts})
(diags, res) ->
return (diags, snd <$> res)
where
addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
addUsageDependencies a = do
r@(_, mtc) <- a
forM_ mtc $ \tc -> do
let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))
udep (UsageFile fp _h) = Just fp
udep _ = Nothing
-- Add a dependency on these files which are added by things like
-- qAddDependentFile
void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
return r
generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
generateCore runSimplifier file = do
deps <- use_ GetDependencies file
(tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
setPriority priorityGenerateCore
packageState <- hscEnv <$> use_ GhcSession file
liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
generateCoreRule :: Rules ()
generateCoreRule =
define $ \GenerateCore -> generateCore (RunSimplifier True)
generateByteCodeRule :: Rules ()
generateByteCodeRule =
define $ \GenerateByteCode file -> do
deps <- use_ GetDependencies file
(tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
session <- hscEnv <$> use_ GhcSession file
(_, guts, _) <- use_ GenerateCore file
liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
addUsageDependencies $ fmap (second (fmap snd)) $ liftIO $
typecheckModule defer hsc pm
where
addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
addUsageDependencies a = do
r@(_, mtc) <- a
forM_ mtc $ \tc -> do
used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc
void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
return r
-- A local rule type to get caching. We want to use newCache, but it has
-- thread killed exception issues, so we lift it to a full rule.
@ -709,37 +666,21 @@ loadGhcSession = do
ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
ghcSessionDepsDefinition file = do
hsc <- hscEnv <$> use_ GhcSession file
(ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file
(deps,_) <- useWithStale_ GetDependencies file
let tdeps = transitiveModuleDeps deps
ifaces <- uses_ GetModIface tdeps
-- Figure out whether we need TemplateHaskell or QuasiQuotes support
let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
file_uses_th_qq = uses_th_qq $ ms_hspp_opts ms
any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
bytecodes <- if any_uses_th_qq
then -- If we use TH or QQ, we must obtain the bytecode
fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
else
pure $ repeat Nothing
-- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
-- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
-- Long-term we might just want to change the order returned by GetDependencies
let inLoadOrder = reverse (zipWith unpack ifaces bytecodes)
let inLoadOrder = reverse (map hirHomeMod ifaces)
(session',_) <- liftIO $ runGhcEnv hsc $ do
setupFinderCache (map hirModSummary ifaces)
mapM_ (uncurry loadDepModule) inLoadOrder
mapM_ loadDepModule inLoadOrder
res <- liftIO $ newHscEnvEq "" session' []
return ([], Just res)
where
unpack HiFileResult{..} bc = (hirModIface, bc)
uses_th_qq dflags =
xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
getModIfaceFromDiskRule :: Rules ()
getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
@ -749,7 +690,8 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
Nothing -> return (Nothing, (diags_session, Nothing))
Just session -> do
sourceModified <- use_ IsHiFileStable f
r <- loadInterface (hscEnv session) ms sourceModified (regenerateHiFile session f)
needsObj <- use_ NeedsObjectCode f
r <- loadInterface (hscEnv session) ms sourceModified needsObj (regenerateHiFile session f)
case r of
(diags, Just x) -> do
let fp = Just (hiFileFingerPrint x)
@ -757,7 +699,7 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
(diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))
isHiFileStableRule :: Rules ()
isHiFileStableRule = define $ \IsHiFileStable f -> do
isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do
ms <- use_ GetModSummaryWithoutTimestamps f
let hiFile = toNormalizedFilePath'
$ ml_hi_file $ ms_location ms
@ -775,7 +717,7 @@ isHiFileStableRule = define $ \IsHiFileStable f -> do
pure $ if all (== SourceUnmodifiedAndStable) deps
then SourceUnmodifiedAndStable
else SourceUnmodified
return ([], Just sourceModified)
return (Just (BS.pack $ show sourceModified), ([], Just sourceModified))
getModSummaryRule :: Rules ()
getModSummaryRule = do
@ -820,30 +762,51 @@ getModSummaryRule = do
hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime)
generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
generateCore runSimplifier file = do
packageState <- hscEnv <$> use_ GhcSessionDeps file
tm <- use_ TypeCheck file
setPriority priorityGenerateCore
liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm)
generateCoreRule :: Rules ()
generateCoreRule =
define $ \GenerateCore -> generateCore (RunSimplifier True)
getModIfaceRule :: Rules ()
getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do
#if !defined(GHC_LIB)
fileOfInterest <- use_ IsFileOfInterest f
case fileOfInterest of
IsFOI _ -> do
IsFOI status -> do
-- Never load from disk for files of interest
tmr <- use TypeCheck f
let !hiFile = extractHiFileResult tmr
tmr <- use_ TypeCheck f
needsObj <- use_ NeedsObjectCode f
hsc <- hscEnv <$> use_ GhcSessionDeps f
let compile = fmap ([],) $ use GenerateCore f
(diags, !hiFile) <- compileToObjCodeIfNeeded hsc needsObj compile tmr
let fp = hiFileFingerPrint <$> hiFile
return (fp, ([], hiFile))
hiDiags <- case hiFile of
Just hiFile
| OnDisk <- status
, not (tmrDeferedError tmr) -> liftIO $ writeHiFile hsc hiFile
_ -> pure []
return (fp, (diags++hiDiags, hiFile))
NotFOI -> do
hiFile <- use GetModIfaceFromDisk f
let fp = hiFileFingerPrint <$> hiFile
return (fp, ([], hiFile))
#else
tm <- use TypeCheck f
let !hiFile = extractHiFileResult tm
tm <- use_ TypeCheck f
hsc <- hscEnv <$> use_ GhcSessionDeps f
(diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc False (error "can't compile with ghc-lib") tm
let fp = hiFileFingerPrint <$> hiFile
return (fp, ([], tmr_hiFileResult <$> tm))
return (fp, (diags, hiFile))
#endif
regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Action ([FileDiagnostic], Maybe HiFileResult)
regenerateHiFile sess f = do
regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Bool -> Action ([FileDiagnostic], Maybe HiFileResult)
regenerateHiFile sess f objNeeded = do
let hsc = hscEnv sess
-- After parsing the module remove all package imports referring to
-- these packages as we have already dealt with what they map to.
@ -862,19 +825,48 @@ regenerateHiFile sess f = do
case mb_pm of
Nothing -> return (diags, Nothing)
Just pm -> do
source <- getSourceFileSource f
-- Invoke typechecking directly to update it without incurring a dependency
-- on the parsed module and the typecheck rules
(diags', tmr) <- typeCheckRuleDefinition hsc pm NotFOI (Just source)
-- Bang pattern is important to avoid leaking 'tmr'
let !res = extractHiFileResult tmr
return (diags <> diags', res)
(diags', mtmr) <- typeCheckRuleDefinition hsc pm
case mtmr of
Nothing -> pure (diags', Nothing)
Just tmr -> do
extractHiFileResult :: Maybe TcModuleResult -> Maybe HiFileResult
extractHiFileResult Nothing = Nothing
extractHiFileResult (Just tmr) =
-- Bang patterns are important to force the inner fields
Just $! tmr_hiFileResult tmr
-- compile writes .o file
let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
-- Bang pattern is important to avoid leaking 'tmr'
(diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc objNeeded compile tmr
-- Write hi file
hiDiags <- case res of
Just hiFile
| not $ tmrDeferedError tmr ->
liftIO $ writeHiFile hsc hiFile
_ -> pure []
-- Write hie file
(gDiags, masts) <- liftIO $ generateHieAsts hsc tmr
wDiags <- forM masts $ \asts ->
liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts $ maybe "" T.encodeUtf8 contents
return (diags <> diags' <> diags'' <> hiDiags <> gDiags <> concat wDiags, res)
type CompileMod m = m (IdeResult ModGuts)
-- | HscEnv should have deps included already
compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Bool -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)
compileToObjCodeIfNeeded hsc False _ tmr = liftIO $ do
res <- mkHiFileResultNoCompile hsc tmr
pure ([], Just $! res)
compileToObjCodeIfNeeded hsc True getGuts tmr = do
(diags, mguts) <- getGuts
case mguts of
Nothing -> pure (diags, Nothing)
Just guts -> do
(diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts
pure (diags++diags', res)
getClientSettingsRule :: Rules ()
getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do
@ -882,6 +874,21 @@ getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do
settings <- clientSettings <$> getIdeConfiguration
return (BS.pack . show . hash $ settings, settings)
needsObjectCodeRule :: Rules ()
needsObjectCodeRule = defineEarlyCutoff $ \NeedsObjectCode file -> do
(ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file
-- A file needs object code if it uses TH or any file that depends on it uses TH
res <-
if uses_th_qq ms
then pure True
-- Treat as False if some reverse dependency header fails to parse
else anyM (fmap (fromMaybe False) . use NeedsObjectCode) . maybe [] (immediateReverseDependencies file)
=<< useNoFile GetModuleGraph
pure (Just $ BS.pack $ show $ hash res, ([], Just res))
where
uses_th_qq (ms_hspp_opts -> dflags) =
xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
-- | A rule that wires per-file rules together
mainRule :: Rules ()
mainRule = do
@ -892,8 +899,6 @@ mainRule = do
getDependenciesRule
typeCheckRule
getDocMapRule
generateCoreRule
generateByteCodeRule
loadGhcSession
getModIfaceFromDiskRule
getModIfaceRule
@ -904,6 +909,9 @@ mainRule = do
getClientSettingsRule
getHieAstsRule
getBindingsRule
needsObjectCodeRule
generateCoreRule
getImportMapRule
-- | Given the path to a module src file, this rule returns True if the
-- corresponding `.hi` file is stable, that is, if it is newer

91
src/Development/IDE/GHC/Compat.hs
View File

@ -42,7 +42,6 @@ module Development.IDE.GHC.Compat(
getLoc,
upNameCache,
disableWarningsAsErrors,
fixDetailsForTH,
AvailInfo,
tcg_exports,
@ -100,14 +99,6 @@ import Data.List (foldl', isSuffixOf)
#endif
import ErrUtils (ErrorMessages)
import FastString (FastString)
import ConLike (ConLike (PatSynCon))
#if MIN_GHC_API_VERSION(8,8,0)
import InstEnv (updateClsInstDFun)
import PatSyn (PatSyn, updatePatSynIds)
#else
import InstEnv (tidyClsInstDFun)
import PatSyn (PatSyn, tidyPatSynIds)
#endif
import Development.IDE.GHC.HieAst (mkHieFile,enrichHie)
import Development.IDE.GHC.HieBin
@ -124,12 +115,10 @@ import Development.IDE.GHC.HieTypes
import System.FilePath ((-<.>))
#endif
#if MIN_GHC_API_VERSION(8,8,0)
import GhcPlugins (Unfolding(BootUnfolding), setIdUnfolding, tidyTopType, setIdType, globaliseId, ppr, pprPanic, isWiredInName, elemNameSet, idName, filterOut)
# else
#if !MIN_GHC_API_VERSION(8,8,0)
import qualified EnumSet
import GhcPlugins (srcErrorMessages, Unfolding(BootUnfolding), setIdUnfolding, tidyTopType, setIdType, globaliseId, isWiredInName, elemNameSet, idName, filterOut)
import GhcPlugins (srcErrorMessages)
import Control.Exception (catch)
import System.IO
@ -148,7 +137,6 @@ noExtField :: NoExt
noExtField = noExt
#endif
supportsHieFiles :: Bool
supportsHieFiles = True
@ -313,78 +301,3 @@ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do
fmap hpm_module $
runHsc env $ withPlugins dflags applyPluginAction
(HsParsedModule parsed [] hpm_annotations)
-- | This function recalculates the fields md_types and md_insts in the ModDetails.
-- It duplicates logic from GHC mkBootModDetailsTc to keep more ids,
-- because ghc drops ids in tcg_keep, which matters because TH identifiers
-- might be in there. See the original function for more comments.
fixDetailsForTH :: TypecheckedModule -> IO TypecheckedModule
fixDetailsForTH tcm = do
keep_ids <- readIORef keep_ids_ptr
let
keep_it id | isWiredInName id_name = False
-- See Note [Drop wired-in things]
| isExportedId id = True
| id_name `elemNameSet` exp_names = True
| id_name `elemNameSet` keep_ids = True -- This is the line added in comparison to the original function.
| otherwise = False
where
id_name = idName id
final_ids = [ globaliseAndTidyBootId id
| id <- typeEnvIds type_env
, keep_it id ]
final_tcs = filterOut (isWiredInName . getName) tcs
type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts
insts' = mkFinalClsInsts type_env1 insts
pat_syns' = mkFinalPatSyns type_env1 pat_syns
type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1
fixedDetails = details {
md_types = type_env'
, md_insts = insts'
}
pure $ tcm { tm_internals_ = (tc_gbl_env, fixedDetails) }
where
(tc_gbl_env, details) = tm_internals_ tcm
TcGblEnv{ tcg_exports = exports,
tcg_type_env = type_env,
tcg_tcs = tcs,
tcg_patsyns = pat_syns,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_keep = keep_ids_ptr
} = tc_gbl_env
exp_names = availsToNameSet exports
-- Functions from here are only pasted from ghc TidyPgm.hs
mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]
#if MIN_GHC_API_VERSION(8,8,0)
mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))
mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))
lookupFinalId :: TypeEnv -> Id -> Id
lookupFinalId type_env id
= case lookupTypeEnv type_env (idName id) of
Just (AnId id') -> id'
_ -> pprPanic "lookup_final_id" (ppr id)
#else
mkFinalClsInsts _env = map (tidyClsInstDFun globaliseAndTidyBootId)
mkFinalPatSyns _env = map (tidyPatSynIds globaliseAndTidyBootId)
#endif
extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns tidy_patsyns type_env
= extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
globaliseAndTidyBootId :: Id -> Id
-- For a LocalId with an External Name,
-- makes it into a GlobalId
-- * unchanged Name (might be Internal or External)
-- * unchanged details
-- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)
-- * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)
globaliseAndTidyBootId id
= globaliseId id `setIdType` tidyTopType (idType id)
`setIdUnfolding` BootUnfolding

5
src/Development/IDE/GHC/Orphans.hs
View File

@ -102,3 +102,8 @@ instance Show a => Show (Bag a) where
instance NFData HsDocString where
rnf = rwhnf
instance Show ModGuts where
show _ = "modguts"
instance NFData ModGuts where
rnf = rwhnf

15
src/Development/IDE/Import/DependencyInformation.hs
View File

@ -21,7 +21,8 @@ module Development.IDE.Import.DependencyInformation
, reachableModules
, processDependencyInformation
, transitiveDeps
, reverseDependencies
, transitiveReverseDependencies
, immediateReverseDependencies
, BootIdMap
, insertBootId
@ -316,8 +317,8 @@ partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
partitionSCC [] = ([], [])
-- | Transitive reverse dependencies of a file
reverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath]
reverseDependencies file DependencyInformation{..} =
transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath]
transitiveReverseDependencies file DependencyInformation{..} =
let FilePathId cur_id = pathToId depPathIdMap file
in map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))
where
@ -328,6 +329,12 @@ reverseDependencies file DependencyInformation{..} =
new = IntSet.difference i outwards
in IntSet.foldr go res new
-- | Immediate reverse dependencies of a file
immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath]
immediateReverseDependencies file DependencyInformation{..} =
let FilePathId cur_id = pathToId depPathIdMap file
in map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))
transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
transitiveDeps DependencyInformation{..} file = do
let !fileId = pathToId depPathIdMap file
@ -378,7 +385,7 @@ instance NFData TransitiveDependencies
data NamedModuleDep = NamedModuleDep {
nmdFilePath :: !NormalizedFilePath,
nmdModuleName :: !ModuleName,
nmdModLocation :: !ModLocation
nmdModLocation :: !(Maybe ModLocation)
}
deriving Generic

13
src/Development/IDE/Import/FindImports.hs
View File

@ -32,6 +32,7 @@ import Control.Monad.IO.Class
import System.FilePath
import DriverPhases
import Data.Maybe
import Data.List (isSuffixOf)
data Import
= FileImport !ArtifactsLocation
@ -40,7 +41,7 @@ data Import
data ArtifactsLocation = ArtifactsLocation
{ artifactFilePath :: !NormalizedFilePath
, artifactModLocation :: !ModLocation
, artifactModLocation :: !(Maybe ModLocation)
, artifactIsSource :: !Bool -- ^ True if a module is a source input
}
deriving (Show)
@ -55,12 +56,14 @@ instance NFData Import where
rnf (FileImport x) = rnf x
rnf (PackageImport x) = rnf x
modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation
modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms))
modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source
where
isSource HsSrcFile = True
isSource _ = False
source = case ms of
Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp
Just ms -> isSource (ms_hsc_src ms)
-- | locate a module in the file system. Where we go from *daml to Haskell
locateModuleFile :: MonadIO m
@ -123,7 +126,7 @@ locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
import_paths = mapMaybe (mkImportDirs dflags) comp_info
toModLocation file = liftIO $ do
loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)
return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)
lookupLocal dirs = do
mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName

4
src/Development/IDE/Plugin/Completions.hs
View File

@ -92,8 +92,8 @@ produceCompletions = do
}
tm <- liftIO $ typecheckModule (IdeDefer True) env pm
case tm of
(_, Just (_,TcModuleResult{..})) -> do
cdata <- liftIO $ cacheDataProducer env tmrModule parsedDeps
(_, Just (_,tcm)) -> do
cdata <- liftIO $ cacheDataProducer env tcm parsedDeps
-- Do not return diags from parsing as they would duplicate
-- the diagnostics from typechecking
return ([], Just cdata)

15
src/Development/IDE/Plugin/Completions/Logic.hs
View File

@ -15,7 +15,6 @@ import Data.Generics
import Data.List.Extra as List hiding (stripPrefix)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Maybe as UnsafeMaybe (fromJust)
import qualified Data.Text as T
import qualified Text.Fuzzy as Fuzzy
@ -233,13 +232,13 @@ mkPragmaCompl label insertText =
Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
Nothing Nothing Nothing Nothing Nothing
cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
cacheDataProducer :: HscEnv -> TcModuleResult -> [ParsedModule] -> IO CachedCompletions
cacheDataProducer packageState tm deps = do
let parsedMod = tm_parsed_module tm
let parsedMod = tmrParsed tm
dflags = hsc_dflags packageState
curMod = ms_mod $ pm_mod_summary parsedMod
curModName = moduleName curMod
(_,limports,_,_) = UnsafeMaybe.fromJust $ tm_renamed_source tm -- safe because we always save the typechecked source
(_,limports,_,_) = tmrRenamed tm -- safe because we always save the typechecked source
iDeclToModName :: ImportDecl name -> ModuleName
iDeclToModName = unLoc . ideclName
@ -255,8 +254,8 @@ cacheDataProducer packageState tm deps = do
-- The given namespaces for the imported modules (ie. full name, or alias if used)
allModNamesAsNS = map (showModName . asNamespace) importDeclerations
typeEnv = tcg_type_env $ fst $ tm_internals_ tm
rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm
typeEnv = tcg_type_env $ tmrTypechecked tm
rdrEnv = tcg_rdr_env $ tmrTypechecked tm
rdrElts = globalRdrEnvElts rdrEnv
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
@ -290,12 +289,12 @@ cacheDataProducer packageState tm deps = do
varToCompl var = do
let typ = Just $ varType var
name = Var.varName var
docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) name
docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tmrParsed tm : deps) name
return $ mkNameCompItem name curModName typ Nothing docs
toCompItem :: Module -> ModuleName -> Name -> IO CompItem
toCompItem m mn n = do
docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) n
docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tmrParsed tm : deps) n
ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
name' <- lookupName m n
return $ name' >>= safeTyThingType

7
src/Development/IDE/Spans/AtPoint.hs
View File

@ -30,6 +30,7 @@ import SrcLoc
import TyCoRep
import TyCon
import qualified Var
import NameEnv
import Control.Applicative
import Control.Monad.Extra
@ -114,12 +115,14 @@ atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos ho
prettyNames :: [T.Text]
prettyNames = map prettyName names
prettyName (Right n, dets) = T.unlines $
wrapHaskell (showName n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> M.lookup n km))
wrapHaskell (showName n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind))
: definedAt n
: catMaybes [ T.unlines . spanDocToMarkdown <$> M.lookup n dm
: catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
]
where maybeKind = safeTyThingType =<< lookupNameEnv km n
prettyName (Left m,_) = showName m
prettyTypes = map (("_ :: "<>) . prettyType) types
prettyType t = showName t

6
src/Development/IDE/Spans/Common.hs
View File

@ -20,7 +20,6 @@ module Development.IDE.Spans.Common (
import Data.Maybe
import qualified Data.Text as T
import Data.List.Extra
import Data.Map (Map)
import Control.DeepSeq
import GHC.Generics
@ -30,13 +29,14 @@ import DynFlags
import ConLike
import DataCon
import Var
import NameEnv
import qualified Documentation.Haddock.Parser as H
import qualified Documentation.Haddock.Types as H
import Development.IDE.GHC.Orphans ()
type DocMap = Map Name SpanDoc
type KindMap = Map Name Type
type DocMap = NameEnv SpanDoc
type KindMap = NameEnv TyThing
showGhc :: Outputable a => a -> String
showGhc = showPpr unsafeGlobalDynFlags

31
src/Development/IDE/Spans/Documentation.hs
View File

@ -15,6 +15,7 @@ module Development.IDE.Spans.Documentation (
import Control.Monad
import Control.Monad.Extra (findM)
import Data.Either
import Data.Foldable
import Data.List.Extra
import qualified Data.Map as M
@ -35,37 +36,39 @@ import GhcMonad
import Packages
import Name
import Language.Haskell.LSP.Types (getUri, filePathToUri)
import Data.Either
import TcRnTypes
import ExtractDocs
import NameEnv
mkDocMap
:: GhcMonad m
=> [ParsedModule]
-> RefMap
-> ModIface
-> [ModIface]
-> TcGblEnv
-> m DocAndKindMap
mkDocMap sources rm hmi deps =
do mapM_ (`loadDepModule` Nothing) (reverse deps)
loadDepModule hmi Nothing
d <- foldrM getDocs M.empty names
k <- foldrM getType M.empty names
mkDocMap sources rm this_mod =
do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
k <- foldrM getType (tcg_type_env this_mod) names
pure $ DKMap d k
where
getDocs n map = do
getDocs n map
| maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
| otherwise = do
doc <- getDocumentationTryGhc mod sources n
pure $ M.insert n doc map
pure $ extendNameEnv map n doc
getType n map
| isTcOcc $ occName n = do
kind <- lookupKind mod n
pure $ maybe id (M.insert n) kind map
pure $ maybe map (extendNameEnv map n) kind
| otherwise = pure map
names = rights $ S.toList idents
idents = M.keysSet rm
mod = mi_module hmi
mod = tcg_mod this_mod
lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type)
lookupKind :: GhcMonad m => Module -> Name -> m (Maybe TyThing)
lookupKind mod =
fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod
fmap (either (const Nothing) id) . catchSrcErrors "span" . lookupName mod
getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]

19
src/Development/IDE/Types/Exports.hs
View File

@ -5,6 +5,8 @@ module Development.IDE.Types.Exports
IdentInfo(..),
ExportsMap(..),
createExportsMap,
createExportsMapMg,
createExportsMapTc
) where
import Avail (AvailInfo(..))
@ -17,11 +19,12 @@ import GHC.Generics (Generic)
import Name
import FieldLabel (flSelector)
import qualified Data.HashMap.Strict as Map
import GhcPlugins (IfaceExport)
import GhcPlugins (IfaceExport, ModGuts(..))
import Data.HashSet (HashSet)
import qualified Data.HashSet as Set
import Data.Bifunctor (Bifunctor(second))
import Data.Hashable (Hashable)
import TcRnTypes(TcGblEnv(..))
newtype ExportsMap = ExportsMap
{getExportsMap :: HashMap IdentifierText (HashSet (IdentInfo,ModuleNameText))}
@ -69,6 +72,20 @@ createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne
where
mn = moduleName $ mi_module mi
createExportsMapMg :: [ModGuts] -> ExportsMap
createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne
where
doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi)
where
mn = moduleName $ mg_module mi
createExportsMapTc :: [TcGblEnv] -> ExportsMap
createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne
where
doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi)
where
mn = moduleName $ tcg_mod mi
unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]
unpackAvail mod =
map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

6
test/exe/Main.hs
View File

@ -284,7 +284,7 @@ diagnosticTests = testGroup "diagnostics"
let contentA = T.unlines [ "module ModuleA where" ]
_ <- createDoc "ModuleA.hs" "haskell" contentA
expectDiagnostics [("ModuleB.hs", [])]
, testSessionWait "add missing module (non workspace)" $ do
, ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do
tmpDir <- liftIO getTemporaryDirectory
let contentB = T.unlines
[ "module ModuleB where"
@ -2488,7 +2488,7 @@ thTests =
_ <- createDoc "A.hs" "haskell" sourceA
_ <- createDoc "B.hs" "haskell" sourceB
expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]
, flip xfail "expect broken (#614)" $ testCase "findsTHnewNameConstructor" $ withoutStackEnv $ runWithExtraFiles "THNewName" $ \dir -> do
, testCase "findsTHnewNameConstructor" $ withoutStackEnv $ runWithExtraFiles "THNewName" $ \dir -> do
-- This test defines a TH value with the meaning "data A = A" in A.hs
-- Loads and export the template in B.hs
@ -3274,8 +3274,6 @@ ifaceErrorTest = testCase "iface-error-test-1" $ withoutStackEnv $ runWithExtraF
ResponseMessage{_result=Right hidir} -> do
hi_exists <- doesFileExist $ hidir </> "B.hi"
assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
hie_exists <- doesFileExist $ hidir </> "B.hie"
assertBool ("Couldn't find B.hie in " ++ hidir) hie_exists
_ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res
pdoc <- createDoc pPath "haskell" pSource