Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Commit

Permalink
Always desugar, don't call interactive API functions
Browse files Browse the repository at this point in the history
  • Loading branch information
@wz1000
wz1000 committed Oct 1, 2020
1 parent 1690956 commit 4d57c12
Show file tree
Hide file tree
Showing 7 changed files with 79 additions and 199 deletions.
95 changes: 52 additions & 43 deletions src/Development/IDE/Core/Compile.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -65,10 +65,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, hscGenHardCode)
import HscMain (hscDesugar, hscTypecheckRename, hscInteractive, hscSimplify, hscGenHardCode)
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

Expand Down Expand Up @@ -127,7 +127,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

Expand All @@ -136,17 +136,31 @@ typecheckModule (IdeDefer defer) hsc pm = do

modSummary' <- initPlugins modSummary
(warnings, tcm1) <- withWarnings "typecheck" $ \tweak ->
GHC.typecheckModule $ enableTopLevelWarnings
$ enableUnnecessaryAndDeprecationWarnings
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
tcm2 <- liftIO $ fixDetailsForTH tcm1
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)
(compile_diags, tcm2) <- mkTcModuleResult pm tcm1 (any fst diags)
return (compile_diags ++ map snd diags, tcm2)
where
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

tcRnModule :: (GhcMonad m) => ParsedModule -> m (TcGblEnv, RenamedSource)
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 (tc_gbl_env, rn_info)

initPlugins :: GhcMonad m => ModSummary -> m ModSummary
initPlugins modSummary = do
session <- getSession
Expand All @@ -164,25 +178,21 @@ newtype RunSimplifier = RunSimplifier Bool
compileModule
:: RunSimplifier
-> HscEnv
-> TcModuleResult
-> ModSummary
-> TcGblEnv
-> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
compileModule (RunSimplifier simplify) packageState tmr =
compileModule (RunSimplifier simplify) packageState ms tcg =
fmap (either (, Nothing) (second Just)) $
evalGhcEnv packageState $
catchSrcErrors "compile" $ do
setupEnv [(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
Expand All @@ -196,26 +206,26 @@ generateByteCode hscEnv deps tmr guts =
catchSrcErrors "bytecode" $ do
setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
session <- getSession
let summary = tmrModSummary tmr
(warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
#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)
liftIO $ hscInteractive session guts (GHC.ms_location $ tweak summary)
#else
liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
liftIO $ hscInteractive session guts (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)


generateObjectCode :: HscEnv -> TcModuleResult -> IO (IdeResult Linkable)
generateObjectCode hscEnv tmr = do
(compile_diags, Just (_, guts, _)) <- compileModule (RunSimplifier True) hscEnv tmr
let guts = tmrGuts tmr
fmap (either (, Nothing) (second Just)) $
evalGhcEnv hscEnv $
catchSrcErrors "object" $ do
session <- getSession
let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
let summary = tmrModSummary tmr
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"
Expand All @@ -232,7 +242,7 @@ generateObjectCode hscEnv tmr = do
compileFile session' StopLn (fp, Just (As False))
let unlinked = DotO dot_o_fp
let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
pure (compile_diags ++ map snd warnings, linkable)
pure (map snd warnings, linkable)

demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
demoteTypeErrorsToWarnings =
Expand Down Expand Up @@ -330,21 +340,24 @@ addRelativeImport fp modu dflags = dflags

mkTcModuleResult
:: GhcMonad m
=> TypecheckedModule
=> ParsedModule
-> (TcGblEnv, RenamedSource)
-> Bool
-> m TcModuleResult
mkTcModuleResult tcm upgradedError = do
-> m (IdeResult TcModuleResult)
mkTcModuleResult pm (tcGblEnv, rn_src) upgradedError = do
session <- getSession
let sf = modInfoSafe (tm_checked_module_info tcm)
(compile_diags, res) <- liftIO $ compileModule (RunSimplifier True) session (pm_mod_summary pm) tcGblEnv
case res of
Nothing -> pure (compile_diags, Nothing)
Just (_, guts, details) -> do
sf <- liftIO $ finalSafeMode (ms_hspp_opts $ pm_mod_summary pm) tcGblEnv
#if MIN_GHC_API_VERSION(8,10,0)
iface <- liftIO $ mkIfaceTc session sf details tcGblEnv
iface <- liftIO $ mkIfaceTc session sf details tcGblEnv
#else
(iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
(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
let mod_info = HomeModInfo iface details Nothing
return (compile_diags, Just $ TcModuleResult pm rn_src tcGblEnv mod_info upgradedError Nothing guts)

atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
atomicFileWrite targetPath write = do
Expand All @@ -353,16 +366,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 =
Expand Down
33 changes: 8 additions & 25 deletions src/Development/IDE/Core/RuleTypes.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,13 +26,14 @@ import Development.Shake
import GHC.Generics (Generic)

import Module (InstalledUnitId)
import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
import HscTypes (hm_iface, CgGuts, 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
Expand Down Expand Up @@ -65,23 +66,23 @@ type instance RuleResult GetKnownTargets = KnownTargets
-- | 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
{ tmrParsed :: ParsedModule
, tmrRenamed :: RenamedSource
, tmrTypechecked :: TcGblEnv
, tmrModInfo :: HomeModInfo
-- ^ Never includes the linkable
, tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
, tmrHieAsts :: !(Maybe (HieASTs Type)) -- ^ The HieASTs if we computed them
, tmrGuts :: CgGuts
}
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
Expand Down Expand Up @@ -136,12 +137,6 @@ instance Show DocAndKindMap where

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

Expand Down Expand Up @@ -252,18 +247,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
Expand Down
38 changes: 7 additions & 31 deletions src/Development/IDE/Core/Rules.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,6 @@ module Development.IDE.Core.Rules(
highlightAtPoint,
getDependencies,
getParsedModule,
generateCore,
) where

import Fingerprint
Expand Down Expand Up @@ -529,7 +528,7 @@ getHieAstsRule =
-- Compute asts if we haven't already computed them
Nothing -> do
hsc <- hscEnv <$> use_ GhcSession f
(diagsHieGen, masts) <- liftIO $ generateHieAsts hsc (tmrModule tmr)
(diagsHieGen, masts) <- liftIO $ generateHieAsts hsc tmr
pure (diagsHieGen, masts)
let refmap = generateReferencesMap . getAsts <$> masts
im <- use GetLocatedImports f
Expand Down Expand Up @@ -606,10 +605,9 @@ typeCheckRuleDefinition hsc pm isFoi source = 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)
let ms = tmrModSummary tcm
exports = tcg_exports $ tmrTypechecked tcm
(diagsHieGen, masts) <- generateHieAsts hsc tcm
diagsHieWrite <- case masts of
Nothing -> pure mempty
Just asts -> writeHieFile hsc ms exports asts $ fromMaybe "" source
Expand All @@ -636,26 +634,6 @@ typeCheckRuleDefinition hsc pm isFoi source = do
return r


generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
generateCore runSimplifier file = do
tm <- use_ TypeCheck file
setPriority priorityGenerateCore
packageState <- hscEnv <$> use_ GhcSessionDeps file
liftIO $ compileModule runSimplifier packageState 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

-- 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.
-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
Expand Down Expand Up @@ -860,7 +838,7 @@ compileToObjCodeIfNeeded _hsc _obj Nothing = pure ([],Nothing)
compileToObjCodeIfNeeded _hsc False (Just tmr) = pure ([], Just $! HiFileResult (tmrModSummary tmr) (tmrModInfo tmr))
compileToObjCodeIfNeeded hsc True (Just tmr) = do
(diags, linkable) <- generateObjectCode hsc tmr
let hmi = (tmrModInfo tmr) { hm_linkable = linkable }
let hmi = (tmrModInfo tmr) { hm_linkable = linkable}
pure (diags, Just $! HiFileResult (tmrModSummary tmr) hmi)

getClientSettingsRule :: Rules ()
Expand All @@ -877,8 +855,8 @@ needsObjectCodeRule = defineEarlyCutoff $ \NeedsObjectCode file -> do
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)
=<< fmap (maybe [] $ immediateReverseDependencies file) (useNoFile GetModuleGraph)
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) =
Expand All @@ -894,8 +872,6 @@ mainRule = do
getDependenciesRule
typeCheckRule
getDocMapRule
generateCoreRule
generateByteCodeRule
loadGhcSession
getModIfaceFromDiskRule
getModIfaceRule
Expand Down
Loading

0 comments on commit 4d57c12

Please sign in to comment.