mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 09:17:43 +03:00
Clean up hie-core (#1992)
* Split off addRelativeImport from modifying the session * Switch located imports to adding their own relative imports * Delete the unused getGhcDynFlags * Make runGhcEnv no longer need to consult import paths * Call runGhcEnv directly * Move getSrcSpanInfos out to Spans * Remove a redundant import * Make findImports in Either rather than ExceptT * Move getImports over to the right place * Switch to liftEither
This commit is contained in:
parent
a2ba883092
commit
4dc9cd0020
@ -9,24 +9,21 @@
|
||||
-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
|
||||
module Development.IDE.Core.Compile
|
||||
( TcModuleResult(..)
|
||||
, getGhcDynFlags
|
||||
, compileModule
|
||||
, getSrcSpanInfos
|
||||
, parseModule
|
||||
, parseFileContents
|
||||
, typecheckModule
|
||||
, computePackageDeps
|
||||
, addRelativeImport
|
||||
) where
|
||||
|
||||
import Development.IDE.GHC.Warnings
|
||||
import Development.IDE.GHC.CPP
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import qualified Development.IDE.Import.FindImports as FindImports
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Spans.Calculate
|
||||
import Development.IDE.GHC.Orphans()
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.GHC.Compat
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
@ -47,6 +44,7 @@ import qualified GHC.LanguageExtensions as LangExt
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Text as T
|
||||
import Data.IORef
|
||||
@ -54,7 +52,6 @@ import Data.List.Extra
|
||||
import Data.Maybe
|
||||
import Data.Tuple.Extra
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Development.IDE.Spans.Type
|
||||
import System.FilePath
|
||||
import System.Directory
|
||||
import System.IO.Extra
|
||||
@ -74,19 +71,6 @@ instance NFData TcModuleResult where
|
||||
rnf = rwhnf
|
||||
|
||||
|
||||
-- | Get source span info, used for e.g. AtPoint and Goto Definition.
|
||||
getSrcSpanInfos
|
||||
:: ParsedModule
|
||||
-> HscEnv
|
||||
-> [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
-> TcModuleResult
|
||||
-> IO [SpanInfo]
|
||||
getSrcSpanInfos mod env imports tc =
|
||||
runGhcSession (Just mod) env
|
||||
. getSpanInfo imports
|
||||
$ tmrModule tc
|
||||
|
||||
|
||||
-- | Given a string buffer, return a pre-processed @ParsedModule@.
|
||||
parseModule
|
||||
:: IdeOptions
|
||||
@ -97,7 +81,7 @@ parseModule
|
||||
parseModule IdeOptions{..} env file =
|
||||
fmap (either (, Nothing) (second Just)) .
|
||||
-- We need packages since imports fail to resolve otherwise.
|
||||
runGhcSession Nothing env . runExceptT . parseFileContents optPreprocessor file
|
||||
runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
|
||||
|
||||
|
||||
-- | Given a package identifier, what packages does it depend on
|
||||
@ -122,7 +106,7 @@ typecheckModule
|
||||
-> IO ([FileDiagnostic], Maybe TcModuleResult)
|
||||
typecheckModule opt packageState deps pm =
|
||||
fmap (either (, Nothing) (second Just)) $
|
||||
runGhcSession (Just pm) packageState $
|
||||
runGhcEnv packageState $
|
||||
catchSrcErrors $ do
|
||||
setupEnv deps
|
||||
(warnings, tcm) <- withWarnings $ \tweak ->
|
||||
@ -133,14 +117,13 @@ typecheckModule opt packageState deps pm =
|
||||
-- | Compile a single type-checked module to a 'CoreModule' value, or
|
||||
-- provide errors.
|
||||
compileModule
|
||||
:: ParsedModule
|
||||
-> HscEnv
|
||||
:: HscEnv
|
||||
-> [TcModuleResult]
|
||||
-> TcModuleResult
|
||||
-> IO ([FileDiagnostic], Maybe CoreModule)
|
||||
compileModule mod packageState deps tmr =
|
||||
compileModule packageState deps tmr =
|
||||
fmap (either (, Nothing) (second Just)) $
|
||||
runGhcSession (Just mod) packageState $
|
||||
runGhcEnv packageState $
|
||||
catchSrcErrors $ do
|
||||
setupEnv (deps ++ [tmr])
|
||||
|
||||
@ -164,21 +147,9 @@ compileModule mod packageState deps tmr =
|
||||
return (warnings, core)
|
||||
|
||||
|
||||
getGhcDynFlags :: ParsedModule -> HscEnv -> IO DynFlags
|
||||
getGhcDynFlags mod pkg = runGhcSession (Just mod) pkg getSessionDynFlags
|
||||
|
||||
-- | Evaluate a GHC session using a new environment constructed with
|
||||
-- the supplied options.
|
||||
runGhcSession
|
||||
:: Maybe ParsedModule
|
||||
-> HscEnv
|
||||
-> Ghc a
|
||||
-> IO a
|
||||
runGhcSession modu env act = runGhcEnv env $ do
|
||||
modifyDynFlags $ \x -> x
|
||||
{importPaths = nubOrd $ maybeToList (moduleImportPaths =<< modu) ++ importPaths x}
|
||||
act
|
||||
|
||||
addRelativeImport :: ParsedModule -> DynFlags -> DynFlags
|
||||
addRelativeImport modu dflags = dflags
|
||||
{importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}
|
||||
|
||||
moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath
|
||||
moduleImportPaths pm
|
||||
@ -258,6 +229,35 @@ loadModuleHome tmr = modifySession $ \e ->
|
||||
mod_info = tmrModInfo tmr
|
||||
mod = ms_mod_name ms
|
||||
|
||||
|
||||
|
||||
-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
|
||||
-- name and its imports.
|
||||
getImportsParsed :: DynFlags ->
|
||||
GHC.ParsedSource ->
|
||||
Either [FileDiagnostic] (GHC.ModuleName, [(Maybe FastString, Located GHC.ModuleName)])
|
||||
getImportsParsed dflags (L loc parsed) = do
|
||||
let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
|
||||
|
||||
-- refuse source imports
|
||||
let srcImports = filter (ideclSource . GHC.unLoc) $ GHC.hsmodImports parsed
|
||||
when (not $ null srcImports) $ Left $
|
||||
concat
|
||||
[ diagFromString mloc ("Illegal source import of " <> GHC.moduleNameString (GHC.unLoc $ GHC.ideclName i))
|
||||
| L mloc i <- srcImports ]
|
||||
|
||||
-- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
|
||||
-- but we want to avoid parsing the module twice
|
||||
let implicit_prelude = xopt GHC.ImplicitPrelude dflags
|
||||
implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
|
||||
|
||||
-- filter out imports that come from packages
|
||||
return (modName, [(fmap sl_fs $ ideclPkgQual i, ideclName i)
|
||||
| i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
|
||||
, GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
|
||||
])
|
||||
|
||||
|
||||
-- | Produce a module summary from a StringBuffer.
|
||||
getModSummaryFromBuffer
|
||||
:: GhcMonad m
|
||||
@ -267,7 +267,7 @@ getModSummaryFromBuffer
|
||||
-> GHC.ParsedSource
|
||||
-> ExceptT [FileDiagnostic] m ModSummary
|
||||
getModSummaryFromBuffer fp contents dflags parsed = do
|
||||
(modName, imports) <- FindImports.getImportsParsed dflags parsed
|
||||
(modName, imports) <- liftEither $ getImportsParsed dflags parsed
|
||||
|
||||
let modLoc = ModLocation
|
||||
{ ml_hs_file = Just fp
|
||||
|
@ -30,6 +30,7 @@ import Control.Monad.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import qualified Development.IDE.Core.Compile as Compile
|
||||
import qualified Development.IDE.Types.Options as Compile
|
||||
import qualified Development.IDE.Spans.Calculate as Compile
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
import Development.IDE.Import.FindImports
|
||||
import Development.IDE.Core.FileStore
|
||||
@ -50,6 +51,7 @@ import GHC
|
||||
import Development.IDE.GHC.Compat
|
||||
import UniqSupply
|
||||
import NameCache
|
||||
import HscTypes
|
||||
|
||||
import qualified Development.IDE.Spans.AtPoint as AtPoint
|
||||
import Development.IDE.Core.Service
|
||||
@ -143,8 +145,8 @@ getLocatedImportsRule =
|
||||
pm <- use_ GetParsedModule file
|
||||
let ms = pm_mod_summary pm
|
||||
let imports = ms_textual_imps ms
|
||||
packageState <- use_ GhcSession ""
|
||||
dflags <- liftIO $ Compile.getGhcDynFlags pm packageState
|
||||
env <- use_ GhcSession ""
|
||||
let dflags = Compile.addRelativeImport pm $ hsc_dflags env
|
||||
opt <- getIdeOptions
|
||||
xs <- forM imports $ \(mbPkgName, modName) ->
|
||||
(modName, ) <$> locateModule dflags (Compile.optExtensions opt) getFileExists modName mbPkgName
|
||||
@ -229,11 +231,10 @@ getDependenciesRule =
|
||||
getSpanInfoRule :: Rules ()
|
||||
getSpanInfoRule =
|
||||
define $ \GetSpanInfo file -> do
|
||||
pm <- use_ GetParsedModule file
|
||||
tc <- use_ TypeCheck file
|
||||
imports <- use_ GetLocatedImports file
|
||||
packageState <- use_ GhcSession ""
|
||||
x <- liftIO $ Compile.getSrcSpanInfos pm packageState (fileImports imports) tc
|
||||
x <- liftIO $ Compile.getSrcSpanInfos packageState (fileImports imports) tc
|
||||
return ([], Just x)
|
||||
|
||||
-- Typechecks a module.
|
||||
@ -254,10 +255,9 @@ generateCoreRule =
|
||||
define $ \GenerateCore file -> do
|
||||
deps <- use_ GetDependencies file
|
||||
(tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
|
||||
let pm = tm_parsed_module . Compile.tmrModule $ tm
|
||||
setPriority priorityGenerateCore
|
||||
packageState <- use_ GhcSession ""
|
||||
liftIO $ Compile.compileModule pm packageState tms tm
|
||||
liftIO $ Compile.compileModule packageState tms tm
|
||||
|
||||
loadGhcSession :: Rules ()
|
||||
loadGhcSession =
|
||||
|
@ -4,8 +4,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Development.IDE.Import.FindImports
|
||||
( getImportsParsed
|
||||
, locateModule
|
||||
( locateModule
|
||||
, Import(..)
|
||||
) where
|
||||
|
||||
@ -14,13 +13,10 @@ import Development.IDE.GHC.Orphans()
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Location
|
||||
-- GHC imports
|
||||
import BasicTypes (StringLiteral(..))
|
||||
import DynFlags
|
||||
import FastString
|
||||
import GHC
|
||||
import qualified HeaderInfo as Hdr
|
||||
import qualified Module as M
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
import Packages
|
||||
import Outputable (showSDoc, ppr, pprPanic)
|
||||
import Finder
|
||||
@ -29,7 +25,6 @@ import Control.DeepSeq
|
||||
-- standard imports
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Control.Monad.Trans.Except as Ex
|
||||
import System.FilePath
|
||||
|
||||
data Import
|
||||
@ -42,35 +37,6 @@ instance NFData Import where
|
||||
rnf (PackageImport x) = rnf x
|
||||
|
||||
|
||||
-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
|
||||
-- name and its imports.
|
||||
getImportsParsed :: Monad m =>
|
||||
DynFlags ->
|
||||
GHC.ParsedSource ->
|
||||
Ex.ExceptT [FileDiagnostic] m
|
||||
(M.ModuleName, [(Maybe FastString, Located M.ModuleName)])
|
||||
getImportsParsed dflags (L loc parsed) = do
|
||||
let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
|
||||
|
||||
-- refuse source imports
|
||||
let srcImports = filter (ideclSource . GHC.unLoc) $ GHC.hsmodImports parsed
|
||||
when (not $ null srcImports) $ Ex.throwE $
|
||||
concat
|
||||
[ diagFromString mloc ("Illegal source import of " <> GHC.moduleNameString (GHC.unLoc $ GHC.ideclName i))
|
||||
| L mloc i <- srcImports ]
|
||||
|
||||
-- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
|
||||
-- but we want to avoid parsing the module twice
|
||||
let implicit_prelude = xopt GHC.ImplicitPrelude dflags
|
||||
implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
|
||||
|
||||
-- filter out imports that come from packages
|
||||
return (modName, [(fmap sl_fs $ ideclPkgQual i, ideclName i)
|
||||
| i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
|
||||
, GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
|
||||
])
|
||||
|
||||
|
||||
-- | locate a module in the file system. Where we go from *daml to Haskell
|
||||
locateModuleFile :: MonadIO m
|
||||
=> DynFlags
|
||||
|
@ -7,7 +7,7 @@
|
||||
|
||||
-- | Get information on modules, identifiers, etc.
|
||||
|
||||
module Development.IDE.Spans.Calculate(getSpanInfo,listifyAllSpans) where
|
||||
module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where
|
||||
|
||||
import ConLike
|
||||
import Control.Monad
|
||||
@ -27,6 +27,20 @@ import Development.IDE.GHC.Error (zeroSpan)
|
||||
import Prelude hiding (mod)
|
||||
import TcHsSyn
|
||||
import Var
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.GHC.Util
|
||||
|
||||
|
||||
-- | Get source span info, used for e.g. AtPoint and Goto Definition.
|
||||
getSrcSpanInfos
|
||||
:: HscEnv
|
||||
-> [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
-> TcModuleResult
|
||||
-> IO [SpanInfo]
|
||||
getSrcSpanInfos env imports tc =
|
||||
runGhcEnv env
|
||||
. getSpanInfo imports
|
||||
$ tmrModule tc
|
||||
|
||||
-- | Get ALL source spans in the module.
|
||||
getSpanInfo :: GhcMonad m
|
||||
|
Loading…
Reference in New Issue
Block a user