{-# LANGUAGE CPP, TemplateHaskell, RecordWildCards, ScopedTypeVariables #-}
-- Copyright : (c) JP Moresmau 2011,
-- Well-Typed 2012
-- (JP Moresmau's buildwrapper package used as template for GHC API use)
--
-- | Implementation details of the calls to GHC that compute information
-- based on source files, provides progress information while doing so
-- and optionally compiles, links and executes code.
--
-- Only @IdeSession.GHC.Run@ and @IdeSession.GHC.HsWalk@ should import
-- any modules from the ghc package and the modules should not be reexported
-- anywhere else, with the exception of @IdeSession.GHC.Server@.
module Run
( -- * Re-exported GHC API
Ghc
, runFromGhc
, liftIO
, GhcException
, ghandle
, ghandleJust
, getModuleGraph
, moduleNameString
, ms_mod_name, ms_hs_date
-- * Processing source files (including compilation)
, compileInGhc
, collectSrcError
, DynamicOpts
, submitStaticOpts
, optsToDynFlags
, DynFlags(hooks)
, defaultDynFlags
, getSessionDynFlags
, setSessionDynFlags
, parseDynamicFlags
, hsExtensions
, importList
, autocompletion
-- * Executing snippets
, runInGhc
, RunCmd(..)
, RunResult(..)
, RunBufferMode(..)
, breakFromSpan
, printVars
) where
#define DEBUG 0
import Prelude hiding (id, mod, span)
import qualified Control.Exception as Ex
import Control.Monad (filterM, liftM, void, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Applicative ((<$>))
import Data.List ((\\))
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import Data.Array (Array)
import qualified Data.Array as Array
import qualified Data.Text as Text
import System.FilePath.Find (find, always, extension)
import System.Process
import System.IO.Unsafe (unsafePerformIO)
#if defined(GHC_761)
-- http://hackage.haskell.org/trac/ghc/ticket/7548
-- is not fixed in this version. Compilation should fail,
-- because the problem is not minor and not easy to spot otherwise.
#error "GHC 7.6.1 is broken (#7548) and not supported"
#endif
import Bag (bagToList)
import DynFlags (defaultDynFlags)
import Exception (ghandle)
import ErrUtils (ErrMsg)
import FastString (unpackFS, mkFastString)
import GHC hiding (
ModuleName
, RunResult(..)
, BreakInfo(..)
, getBreak
)
import GhcMonad (liftIO)
import OccName (occEnvElts)
import Outputable (PprStyle, mkUserStyle)
import RdrName (GlobalRdrEnv, GlobalRdrElt, gre_name)
import RnNames (rnImports)
import SrcLoc (mkRealSrcSpan, mkRealSrcLoc)
import TcRnMonad (initTc)
import TcRnTypes (RnM)
import RtClosureInspect (Term)
import qualified HscTypes
import qualified GHC as GHC
import qualified Config as GHC
import qualified Outputable as GHC
import qualified ByteCodeInstr as GHC
import qualified Id as GHC
#if __GLASGOW_HASKELL__ >= 706
import ErrUtils ( MsgDoc )
#else
import ErrUtils ( Message )
#endif
import IdeSession.GHC.API
import IdeSession.Types.Public (RunBufferMode(..), Targets(..))
import IdeSession.Types.Private
import qualified IdeSession.Types.Public as Public
import IdeSession.Util
import IdeSession.Strict.Container
import IdeSession.Strict.IORef
import qualified IdeSession.Strict.List as StrictList
import qualified IdeSession.Strict.Map as StrictMap
import HsWalk (idInfoForName)
import Haddock
import Debug
import Conv
import FilePathCaching
import Break
import GhcShim
type DynamicOpts = [Located String]
-- | Set static flags at server startup and return dynamic flags.
submitStaticOpts :: [String] -> IO DynamicOpts
submitStaticOpts opts = do
(dynFlags, _) <- parseStaticFlags (map noLoc opts)
return dynFlags
-- | Create dynamic flags from their command-line names.
optsToDynFlags :: [String] -> DynamicOpts
optsToDynFlags = map noLoc
getGhcLibdir :: IO FilePath
getGhcLibdir = do
let ghcbinary = "ghc-" ++ GHC.cProjectVersion
out <- readProcess ghcbinary ["--print-libdir"] ""
case lines out of
[libdir] -> return libdir
_ -> fail "cannot parse output of ghc --print-libdir"
runFromGhc :: Ghc a -> IO a
runFromGhc a = do
libdir <- getGhcLibdir
runGhc (Just libdir) a
-- | Version of handleJust for use in the GHC monad
ghandleJust :: Ex.Exception e => (e -> Maybe b) -> (b -> Ghc a) -> Ghc a -> Ghc a
ghandleJust p handler a = ghandle handler' a
where
handler' e = case p e of
Nothing -> liftIO $ Ex.throwIO e
Just b -> handler b
-- | Compile a set of targets
--
-- Returns the errors, loaded modules, and mapping from filenames to modules
compileInGhc :: FilePath -- ^ target directory, only used for 'TargetsExclude'
-> Bool -- ^ should we generate code
-> Targets -- ^ targets
-> StrictIORef (Strict [] SourceError) -- ^ the IORef where GHC stores errors
-> Ghc ( Strict [] SourceError
, [ModuleName]
, Strict (Map FilePath) ModuleId
)
compileInGhc configSourcesDir generateCode mTargets errsRef = do
-- Reset errors storage.
liftIO $ writeIORef errsRef StrictList.nil
-- Compute new GHC flags.
flags1 <- getSessionDynFlags
-- Let GHC API print "compiling M ... done." for each module.
let verbosityNew :: Int
verbosityNew = 1
(hscTargetNew, ghcLinkNew)
| generateCode = (HscInterpreted, LinkInMemory)
| otherwise = (HscNothing, NoLink)
flagsNeedChange = hscTargetNew /= hscTarget flags1
|| ghcLinkNew /= ghcLink flags1
|| verbosityNew /= verbosity flags1
flags = flags1 {
hscTarget = hscTargetNew,
ghcLink = ghcLinkNew,
verbosity = verbosityNew
}
handleErrors flags $ do
defaultCleanupHandler flags $ do
-- Set up the GHC flags.
when flagsNeedChange $ void $ setSessionDynFlags flags
setTargets =<< computeTargets
void $ load LoadAllTargets
-- Collect info
errs <- liftIO $ readIORef errsRef
loaded <- getLoaded
fileMap <- getFileMap
return ( StrictList.reverse errs
, loaded
, StrictMap.fromList $ fileMap
)
where
getLoaded :: Ghc [ModuleName]
getLoaded = do
graph <- getModuleGraph
names <- filterM isLoaded $ map ms_mod_name graph
return $ map (Text.pack . moduleNameString) names
getFileMap :: Ghc [(FilePath, ModuleId)]
getFileMap = do
dflags <- getSessionDynFlags
let aux :: ModSummary -> Maybe (FilePath, ModuleId)
aux summary = do
hs <- ml_hs_file $ ms_location summary
return (hs, importModuleId dflags (ms_mod summary))
graph <- getModuleGraph
return $ catMaybes $ map aux graph
computeTargets :: Ghc [Target]
computeTargets = do
targetIds <- case mTargets of
TargetsInclude include -> return (map targetIdFromFile include)
TargetsExclude exclude -> liftIO $ do
allPaths <- find always ((`elem` hsExtensions) `liftM` extension)
configSourcesDir
let paths = allPaths \\ exclude
return (map targetIdFromFile paths)
return (map targetWithId targetIds)
targetWithId :: TargetId -> Target
targetWithId targetId = Target {
targetId = targetId
, targetAllowObjCode = True
, targetContents = Nothing
}
targetIdFromFile :: FilePath -> TargetId
targetIdFromFile path = TargetFile path Nothing
sourceErrorHandler :: DynFlags -> HscTypes.SourceError -> Ghc ()
sourceErrorHandler _flags e = liftIO $ do
debug dVerbosity $ "handleSourceError: " ++ show e
errs <- readIORef errsRef
e' <- fromHscSourceError e
writeIORef errsRef (force e' StrictList.++ errs)
-- A workaround for http://hackage.haskell.org/trac/ghc/ticket/7430.
-- Some errors are reported as exceptions instead.
ghcExceptionHandler :: DynFlags -> GhcException -> Ghc ()
ghcExceptionHandler _flags e = liftIO $ do
let eText = Text.pack $ show e -- no SrcSpan as a field in GhcException
fromEx = Text.pack $ "<from GhcException>"
exError = SourceError KindError (TextSpan fromEx) eText
-- though it may be embedded in string
debug dVerbosity $ "handleOtherErrors: " ++ Text.unpack eText
errs <- readIORef errsRef
writeIORef errsRef (exError `StrictList.cons` errs)
handleErrors :: DynFlags -> Ghc () -> Ghc ()
handleErrors flags = ghandle (ghcExceptionHandler flags)
. handleSourceError (sourceErrorHandler flags)
importList :: ModSummary -> Ghc (Strict [] Import)
importList summary = do
dflags <- getSessionDynFlags
-- TODO: This is lossy. We might want a more accurate data type.
let unLIE :: LIE RdrName -> Text
unLIE (L _ name) = Text.pack $ pretty dflags GHC.defaultUserStyle name
#if __GLASGOW_HASKELL__ >= 710
let unLocNames :: Located [LIE name] -> [LIE name]
unLocNames (L _ names) = names
#else
let unLocNames :: [LIE name] -> [LIE name]
unLocNames names = names
#endif
#if __GLASGOW_HASKELL__ >= 710
let mkImportEntities :: Maybe (Bool, Located [LIE RdrName]) -> ImportEntities
#else
let mkImportEntities :: Maybe (Bool, [LIE RdrName]) -> ImportEntities
#endif
mkImportEntities Nothing = ImportAll
mkImportEntities (Just (True, names)) = ImportHiding (force $ map unLIE (unLocNames names))
mkImportEntities (Just (False, names)) = ImportOnly (force $ map unLIE (unLocNames names))
let goImp :: Located (ImportDecl RdrName) -> Import
goImp (L _ decl) = Import {
importModule = importModuleId' dflags (ideclPkgQual decl) (unLoc (ideclName decl))
, importPackage = force $ ((Text.pack . unpackFS) <$> ideclPkgQual decl)
, importQualified = ideclQualified decl
, importImplicit = ideclImplicit decl
, importAs = force $ ((Text.pack . moduleNameString) <$> ideclAs decl)
, importEntities = mkImportEntities (ideclHiding decl)
}
return . force $ map goImp (ms_srcimps summary)
++ map goImp (ms_textual_imps summary)
autocompletion :: ModSummary -> Ghc (Strict [] IdInfo)
autocompletion summary = do
dflags <- getSessionDynFlags
session <- getSession
let pkgDeps = pkgDepsFromModSummary dflags summary
linkEnv <- liftIO $ linkEnvForDeps dflags pkgDeps
let eltsToAutocompleteMap :: GlobalRdrElt -> Ghc IdInfo
eltsToAutocompleteMap elt = do
let name = gre_name elt
currentModule = Nothing -- Must be imported (TH stage restriction)
(idProp, Just idScope) <- idInfoForName dflags
name
UseSite
(Just elt)
currentModule
(homeModuleFor dflags linkEnv)
return IdInfo{..}
autoEnvs :: ModSummary -> IO [GlobalRdrElt]
autoEnvs ms@ModSummary{ ms_mod
, ms_hsc_src
, ms_srcimps
, ms_textual_imps
} = do
let go :: RnM (a, GlobalRdrEnv, b, c) -> IO [GlobalRdrElt]
go op = do
#if GHC_AFTER_710_1
-- Not sure if this is the same thing that GHC would
-- pass in, but this is just to initialize the state,
-- and will be overridden before any uses.
let srcSpan = mkRealSrcSpan loc loc
loc = mkRealSrcLoc (mkFastString (HscTypes.msHsFilePath ms)) 1 1
((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod srcSpan op
#else
((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod op
#endif
case res of
Nothing -> do
-- TODO: deal with import errors
#if DEBUG
appendFile "/tmp/ghc.importerrors" $ show
. map GHC.showSDoc
$ ErrUtils.pprErrMsgBag _errs
#endif
return []
Just (_, elts, _, _) ->
return . concat $ occEnvElts elts
env1 <- go $ rnImports ms_srcimps
env2 <- go $ rnImports ms_textual_imps
return $ env1 ++ env2
envs <- liftIO $ autoEnvs summary
idIs <- mapM eltsToAutocompleteMap envs
return $ force idIs
-- | Run a snippet.
runInGhc :: RunCmd -> Ghc RunResult
runInGhc cmd = do
flags <- getSessionDynFlags
defaultCleanupHandler flags . handleErrors $ do
runRes <- runCmd cmd
case runRes of
GHC.RunOk _ ->
return RunOk
GHC.RunException ex ->
return $ RunProgException (showExWithClass ex)
GHC.RunBreak _tid names mBreakInfo -> do
Just info <- importBreakInfo mBreakInfo names
return $ RunBreak info
where
handleError :: Show a => a -> Ghc RunResult
handleError = return . RunGhcException . show
-- "such-and-such not in scope" is reported as a source error
-- not sure when GhcExceptions are thrown (if at all)
handleErrors :: Ghc RunResult -> Ghc RunResult
handleErrors = handleSourceError handleError
. ghandle (handleError :: GhcException -> Ghc RunResult)
-- | Auxiliary to 'runInGhc'
runCmd :: RunCmd -> Ghc GHC.RunResult
runCmd (RunStmt {..}) = do
setContext $ [ IIDecl $ simpleImportDecl $ mkModuleName runCmdModule
, IIDecl $ simpleImportDecl $ mkModuleName "IdeBackendRTS"
]
runStmt expr RunToCompletion
where
expr :: String
expr = fqn "run "
++ "(" ++ fqBMode runCmdStdout ++ ")"
++ "(" ++ fqBMode runCmdStderr ++ ")"
++ "(" ++ runCmdModule ++ "." ++ runCmdFunction ++ ")"
fqn :: String -> String
fqn = (++) "IdeBackendRTS."
fqBMode :: RunBufferMode -> String
fqBMode RunNoBuffering =
fqn "RunNoBuffering"
fqBMode (RunLineBuffering t) =
fqn "RunLineBuffering (" ++ fqMInt t ++ ")"
fqBMode (RunBlockBuffering sz t) =
fqn "RunBlockBuffering (" ++ fqMInt sz ++ ") (" ++ fqMInt t ++ ")"
fqMInt :: Maybe Int -> String
fqMInt Nothing = fqn "Nothing"
fqMInt (Just n) = fqn "Just " ++ show n
runCmd Resume =
resume (const True) RunToCompletion
{------------------------------------------------------------------------------
Dealing with breakpoints
------------------------------------------------------------------------------}
-- | We store a print context whenever we hit a breakpoint so that we have
-- sufficient context for subsequent requests for pretty-printing types
printContext :: StrictIORef PprStyle
{-# NOINLINE printContext #-}
printContext = unsafePerformIO $
newIORef (mkUserStyle alwaysQualify GHC.AllTheWay)
getPrintContext :: Ghc PprStyle
getPrintContext = liftIO $ readIORef printContext
setPrintContext :: PprStyle -> Ghc ()
setPrintContext ctxt = liftIO $ writeIORef printContext ctxt
breakFromSpan :: ModuleName -- ^ Module containing the breakpoint
-> Public.SourceSpan -- ^ Location of the breakpoint
-> Bool -- ^ New value for the breakpoint
-> Ghc (Maybe Bool) -- ^ Old valeu of the breakpoint (if valid)
breakFromSpan modName span newValue = runMaybeT $ do
modInfo <- MaybeT $ getModuleInfo mod
let ModBreaks{..} = modInfoModBreaks modInfo
breakIndex <- MaybeT $ return $ findBreakIndex modBreaks_locs
oldValue <- MaybeT $ getBreak modBreaks_flags breakIndex
lift $ setBreak modBreaks_flags breakIndex newValue
return oldValue
where
findBreakIndex :: Array BreakIndex SrcSpan -> Maybe BreakIndex
findBreakIndex breaks = listToMaybe
. catMaybes
. map matchesSpan
. Array.assocs
$ breaks
matchesSpan :: (BreakIndex, SrcSpan) -> Maybe BreakIndex
matchesSpan (_, UnhelpfulSpan _) = Nothing
matchesSpan (i, RealSrcSpan span') =
if srcSpanStartLine span' == Public.spanFromLine span
&& srcSpanStartCol span' == Public.spanFromColumn span
&& srcSpanEndLine span' == Public.spanToLine span
&& srcSpanEndCol span' == Public.spanToColumn span
then Just i
else Nothing
mod :: Module
mod = mkModule mainPackageKey (mkModuleName . Text.unpack $ modName)
importBreakInfo :: Maybe GHC.BreakInfo
-> [Name]
-> Ghc (Maybe BreakInfo)
importBreakInfo (Just GHC.BreakInfo{..}) names = runMaybeT $ do
modInfo <- MaybeT $ getModuleInfo breakInfo_module
printUnqualified <- MaybeT $ mkPrintUnqualifiedForModule modInfo
let ModBreaks{..} = modInfoModBreaks modInfo
srcSpan = modBreaks_locs Array.! breakInfo_number
pprStyle = mkUserStyle printUnqualified GHC.AllTheWay
lift $ do
setPrintContext pprStyle
localVars <- mkTerms >>= mapM (exportVar pprStyle)
ProperSpan srcSpan' <- liftIO $ extractEitherSpan srcSpan
prettyResTy <- prettyM pprStyle breakInfo_resty
return BreakInfo {
breakInfoModule = mod
, breakInfoSpan = srcSpan'
, breakInfoResultType = Text.pack prettyResTy
, breakInfoVariableEnv = localVars
}
where
mkTerms :: Ghc [(Id, Term)]
mkTerms = resolveNames names >>= evaluateIds False False
-- we ignore the package (because it's always the home package)
mod = Text.pack . moduleNameString . GHC.moduleName $ breakInfo_module
importBreakInfo Nothing _names = error "importBreakInfo: missing case"
printVars :: String -> Bool -> Bool -> Ghc Public.VariableEnv
printVars vars bind forceEval =
getPrintContext >>= \unqual ->
parseNames vars >>=
resolveNames >>=
evaluateIds bind forceEval >>=
mapM (exportVar unqual)
exportVar :: PprStyle -> (Id, Term) -> Ghc (Public.Name, Public.Type, Public.Value)
exportVar pprStyle (var, term) = do
nameStr <- prettyM pprStyle (GHC.idName var)
typeStr <- prettyTypeM pprStyle showForalls (GHC.idType var)
termStr <- prettyM pprStyle term
return (Text.pack nameStr, Text.pack typeStr, Text.pack termStr)
where
showForalls = False
-----------------------
-- Source error conversion and collection
--
collectSrcError :: StrictIORef (Strict [] SourceError)
-> (String -> IO ())
-> (String -> IO ())
-> DynFlags
-> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
collectSrcError errsRef handlerOutput handlerRemaining flags
severity srcspan style msg = do
-- Prepare debug prints.
debug dVerbosity
$ "Severity: " ++ show severity
++ " SrcSpan: " ++ show srcspan
-- ++ " PprStyle: " ++ show style
++ " MsgDoc: "
++ showSDocForUser flags (queryQual style) msg
++ "\n"
-- Actually collect errors.
collectSrcError'
errsRef handlerOutput handlerRemaining flags severity srcspan style msg
collectSrcError' :: StrictIORef (Strict [] SourceError)
-> (String -> IO ())
-> (String -> IO ())
-> DynFlags
-> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
collectSrcError' errsRef _ _ flags severity srcspan style msg
| Just errKind <- case severity of
SevWarning -> Just KindWarning
SevError -> Just KindError
SevFatal -> Just KindError
_ -> Nothing
= do let msgstr = showSDocForUser flags (queryQual style) msg
sp <- extractEitherSpan srcspan
modifyIORef errsRef (StrictList.cons $ SourceError errKind sp (Text.pack msgstr))
collectSrcError' _errsRef handlerOutput _ flags SevOutput _srcspan style msg
= let msgstr = showSDocForUser flags (queryQual style) msg
in handlerOutput msgstr
collectSrcError' _errsRef _ handlerRemaining flags _severity _srcspan style msg
= let msgstr = showSDocForUser flags (queryQual style) msg
in handlerRemaining msgstr
-- TODO: perhaps make a honest SrcError from the first span from the first
-- error message and put the rest into the message string? That probably
-- entains string-search-and-replace inside the message string not to
-- duplicate the first span, because the types involved are abstract.
-- And even then, all the file paths but the first would be out of
-- our control (and so, e.g., not relative to the project root).
-- But at least the IDE could point somewhere in the code.
-- | Convert GHC's SourceError type into ours.
fromHscSourceError :: forall m. MonadFilePathCaching m => HscTypes.SourceError -> m [SourceError]
fromHscSourceError = mapM aux . bagToList . HscTypes.srcErrorMessages
where
aux :: ErrMsg -> m SourceError
aux e = do
let err = Text.pack (show e)
noloc = Text.pack "<no location info>"
case sourceErrorSpan e of
Just real -> do
xSpan <- extractEitherSpan real
return $ SourceError KindError xSpan err
Nothing ->
return $ SourceError KindError (TextSpan noloc) err
-----------------------
-- GHC version compat
--
#if __GLASGOW_HASKELL__ < 706
type MsgDoc = Message
#endif
showSDocForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> String
#if __GLASGOW_HASKELL__ >= 706
showSDocForUser flags uqual msg = GHC.showSDocForUser flags uqual msg
#else
showSDocForUser _flags uqual msg = GHC.showSDocForUser uqual msg
#endif
showSDocDebug :: DynFlags -> MsgDoc -> String
#if __GLASGOW_HASKELL__ >= 706
showSDocDebug flags msg = GHC.showSDocDebug flags msg
#else
showSDocDebug _flags msg = GHC.showSDocDebug msg
#endif
queryQual :: PprStyle -> PrintUnqualified
#if __GLASGOW_HASKELL__ >= 710
queryQual = GHC.queryQual
#else
queryQual style = (GHC.qualName style, GHC.qualModule style)
#endif
-----------------------
-- Debug
--
_debugPpContext :: DynFlags -> String -> Ghc ()
_debugPpContext flags msg = do
context <- getContext
liftIO $ debug dVerbosity
$ msg ++ ": " ++ showSDocDebug flags (GHC.ppr context)