{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
module Development.IDE.Core.Compile
( TcModuleResult(..)
, compileModule
, parseModule
, typecheckModule
, computePackageDeps
, addRelativeImport
) where
import Development.IDE.Core.RuleTypes
import Development.IDE.GHC.CPP
import Development.IDE.GHC.Error
import Development.IDE.GHC.Warnings
import Development.IDE.Types.Diagnostics
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
import GHC hiding (parseModule, typecheckModule)
import qualified Parser
import Lexer
import ErrUtils
import qualified GHC
import Panic
import GhcMonad
import GhcPlugins as GHC hiding (fst3, (<>))
import qualified HeaderInfo as Hdr
import MkIface
import StringBuffer as SB
import TidyPgm
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad.Extra
import Control.Monad.Except
import Control.Monad.Trans.Except
import Data.Function
import Data.Ord
import qualified Data.Text as T
import Data.IORef
import Data.List.Extra
import Data.Maybe
import Data.Tuple.Extra
import qualified Data.Map.Strict as Map
import System.FilePath
import System.IO.Extra
import Data.Char
import SysTools (Option (..), runUnlit)
parseModule
:: IdeOptions
-> HscEnv
-> FilePath
-> Maybe SB.StringBuffer
-> IO ([FileDiagnostic], Maybe ParsedModule)
parseModule IdeOptions{..} env file =
fmap (either (, Nothing) (second Just)) .
runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
computePackageDeps
:: HscEnv
-> InstalledUnitId
-> IO (Either [FileDiagnostic] [InstalledUnitId])
computePackageDeps env pkg = do
let dflags = hsc_dflags env
case lookupInstalledPackage dflags pkg of
Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
T.pack $ "unknown package: " ++ show pkg]
Just pkgInfo -> return $ Right $ depends pkgInfo
typecheckModule
:: HscEnv
-> [TcModuleResult]
-> ParsedModule
-> IO ([FileDiagnostic], Maybe TcModuleResult)
typecheckModule packageState deps pm =
fmap (either (, Nothing) (second Just)) $
runGhcEnv packageState $
catchSrcErrors "typecheck" $ do
setupEnv deps
(warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
tcm2 <- mkTcModuleResult tcm
return (warnings, tcm2)
compileModule
:: HscEnv
-> [TcModuleResult]
-> TcModuleResult
-> IO ([FileDiagnostic], Maybe CoreModule)
compileModule packageState deps tmr =
fmap (either (, Nothing) (second Just)) $
runGhcEnv packageState $
catchSrcErrors "compile" $ do
setupEnv (deps ++ [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'
(tidy, details) <- liftIO $ tidyProgram session desugar
let core = CoreModule
(cg_module tidy)
(md_types details)
(cg_binds tidy)
(mg_safe_haskell desugar)
return (warnings, core)
addRelativeImport :: ParsedModule -> DynFlags -> DynFlags
addRelativeImport modu dflags = dflags
{importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}
mkTcModuleResult
:: GhcMonad m
=> TypecheckedModule
-> m TcModuleResult
mkTcModuleResult tcm = do
session <- getSession
(iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
let mod_info = HomeModInfo iface details Nothing
return $ TcModuleResult tcm mod_info
where
(tcGblEnv, details) = tm_internals_ tcm
setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
setupEnv tmsIn = do
let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
tms = sortBy (compare `on` Down . isSourceFile) tmsIn
session <- getSession
let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
let graph = mkModuleGraph mss
setSession session { hsc_mod_graph = graph }
let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
liftIO $ modifyIORef (hsc_FC session) $ \fc ->
foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
$ zip ims ifrs
mapM_ loadModuleHome tms
loadModuleHome
:: (GhcMonad m)
=> TcModuleResult
-> m ()
loadModuleHome tmr = modifySession $ \e ->
e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
where
ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
mod_info = tmrModInfo tmr
mod = ms_mod_name ms
getImportsParsed :: DynFlags ->
GHC.ParsedSource ->
Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
getImportsParsed dflags (L loc parsed) = do
let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
let implicit_prelude = xopt GHC.ImplicitPrelude dflags
implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
| i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
, GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
])
getModSummaryFromBuffer
:: GhcMonad m
=> FilePath
-> SB.StringBuffer
-> DynFlags
-> GHC.ParsedSource
-> ExceptT [FileDiagnostic] m ModSummary
getModSummaryFromBuffer fp contents dflags parsed = do
(modName, imports) <- liftEither $ getImportsParsed dflags parsed
let modLoc = ModLocation
{ ml_hs_file = Just fp
, ml_hi_file = derivedFile "hi"
, ml_obj_file = derivedFile "o"
#ifndef GHC_STABLE
, ml_hie_file = derivedFile "hie"
#endif
-- This does not consider the dflags configuration
-- (-osuf and -hisuf, object and hi dir.s).
-- However, we anyway don't want to generate them.
}
InstalledUnitId unitId = thisInstalledUnitId dflags
return $ ModSummary
{ ms_mod = mkModule (fsToUnitId unitId) modName
, ms_location = modLoc
, ms_hs_date = error "Rules should not depend on ms_hs_date"
-- When we are working with a virtual file we do not have a file date.
-- To avoid silent issues where something is not processed because the date
-- has not changed, we make sure that things blow up if they depend on the
-- date.
, ms_textual_imps = [imp | (False, imp) <- imports]
, ms_hspp_file = fp
, ms_hspp_opts = dflags
, ms_hspp_buf = Just contents
-- defaults:
, ms_hsc_src = sourceType
, ms_obj_date = Nothing
, ms_iface_date = Nothing
#ifndef GHC_STABLE
, ms_hie_date = Nothing
#endif
, ms_srcimps = [imp | (True, imp) <- imports]
, ms_parsed_mod = Nothing
}
where
(sourceType, derivedFile) =
let (stem, ext) = splitExtension fp in
if "-boot" `isSuffixOf` ext
then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
else (HsSrcFile , \newExt -> stem <.> newExt)
-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
runLhs dflags filename contents = withTempDir $ \dir -> do
let fout = dir </> takeFileName filename <.> "unlit"
filesrc <- case contents of
Nothing -> return filename
Just cnts -> do
let fsrc = dir </> takeFileName filename <.> "literate"
withBinaryFile fsrc WriteMode $ \h ->
hPutStringBuffer h cnts
return fsrc
unlit filesrc fout
SB.hGetStringBuffer fout
where
unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
args filein fileout = [
SysTools.Option "-h"
, SysTools.Option (escape filename) -- name this file
, SysTools.FileOption "" filein -- input file
, SysTools.FileOption "" fileout ] -- output file
-- taken from ghc's DriverPipeline.hs
escape ('\\':cs) = '\\':'\\': escape cs
escape ('\"':cs) = '\\':'\"': escape cs
escape ('\'':cs) = '\\':'\'': escape cs
escape (c:cs) = c : escape cs
escape [] = []
-- | Run CPP on a file
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
runCpp dflags filename contents = withTempDir $ \dir -> do
let out = dir </> takeFileName filename <.> "out"
case contents of
Nothing -> do
-- Happy case, file is not modified, so run CPP on it in-place
-- which also makes things like relative #include files work
-- and means location information is correct
doCpp dflags True filename out
liftIO $ SB.hGetStringBuffer out
Just contents -> do
-- Sad path, we have to create a version of the path in a temp dir
-- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
-- Relative includes aren't going to work, so we fix that by adding to the include path.
dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
-- Location information is wrong, so we fix that by patching it afterwards.
let inp = dir </> "___GHCIDE_MAGIC___"
withBinaryFile inp WriteMode $ \h ->
hPutStringBuffer h contents
doCpp dflags True inp out
-- Fix up the filename in lines like:
-- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
let tweak x
| Just x <- stripPrefix "# " x
, "___GHCIDE_MAGIC___" `isInfixOf` x
, let num = takeWhile (not . isSpace) x
-- important to use /, and never \ for paths, even on Windows, since then C escapes them
-- and GHC gets all confused
= "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
| otherwise = x
stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
-- | Given a buffer, flags, file path and module summary, produce a
-- parsed module (or errors) and any parse warnings.
parseFileContents
:: GhcMonad m
=> (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
-> FilePath -- ^ the filename (for source locations)
-> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
parseFileContents preprocessor filename mbContents = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
let isOnDisk = isNothing mbContents
-- unlit content if literate Haskell ending
(isOnDisk, contents) <- if ".lhs" `isSuffixOf` filename
then do
dflags <- getDynFlags
newcontent <- liftIO $ runLhs dflags filename mbContents
return (False, newcontent)
else return (isOnDisk, contents)
dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
(contents, dflags) <-
if not $ xopt LangExt.Cpp dflags then
return (contents, dflags)
else do
contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
return (contents, dflags)
case unP Parser.parseModule (mkPState dflags contents loc) of
PFailed _ locErr msgErr ->
throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
POk pst rdr_module ->
let hpm_annotations =
(Map.fromListWith (++) $ annotations pst,
Map.fromList ((noSrcSpan,comment_q pst)
:annotations_comments pst))
(warns, errs) = getMessages pst dflags
in
do
-- Just because we got a `POk`, it doesn't mean there
-- weren't errors! To clarify, the GHC parser
-- distinguishes between fatal and non-fatal
-- errors. Non-fatal errors are the sort that don't
-- prevent parsing from continuing (that is, a parse
-- tree can still be produced despite the error so that
-- further errors/warnings can be collected). Fatal
-- errors are those from which a parse tree just can't
-- be produced.
unless (null errs) $
throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
-- Ok, we got here. It's safe to continue.
let (errs, parsed) = preprocessor rdr_module
unless (null errs) $ throwE $ diagFromStrings "parser" errs
ms <- getModSummaryFromBuffer filename contents dflags parsed
let pm =
ParsedModule {
pm_mod_summary = ms
, pm_parsed_source = parsed
, pm_extra_src_files=[] -- src imports not allowed
, pm_annotations = hpm_annotations
}
warnings = diagFromErrMsgs "parser" dflags warns
pure (warnings, pm)
-- | This reads the pragma information directly from the provided buffer.
parsePragmasIntoDynFlags
:: GhcMonad m
=> FilePath
-> SB.StringBuffer
-> m (Either [FileDiagnostic] DynFlags)
parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
dflags0 <- getSessionDynFlags
let opts = Hdr.getOptions dflags0 contents fp
(dflags, _, _) <- parseDynamicFilePragma dflags0 opts
return dflags
-- | Run something in a Ghc monad and catch the errors (SourceErrors and
-- compiler-internal exceptions like Panic or InstallationError).
catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
catchSrcErrors fromWhere ghcM = do
dflags <- getDynFlags
handleGhcException (ghcExceptionToDiagnostics dflags) $
handleSourceError (sourceErrorToDiagnostics dflags) $
Right <$> ghcM
where
ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages