Session,
defaultErrorHandler,
defaultCleanupHandler,
- init,
+ init, initFromArgs,
newSession,
-- * Flags and settings
#ifdef GHCI
setContext, getContext,
getNamesInScope,
+ getRdrNamesInScope,
moduleIsInterpreted,
getInfo,
exprType,
Name,
nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
NamedThing(..),
+ RdrName(Qual,Unqual),
-- ** Identifiers
Id, idType,
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- getSynTyConDefn,
+ synTyConDefn, synTyConRhs,
-- ** Type variables
TyVar,
import Packages ( initPackages )
import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName,
+import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
globalRdrEnvElts )
import HsSyn
import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
import TysPrim ( alphaTyVars )
import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
isPrimTyCon, isFunTyCon, tyConArity,
- tyConTyVars, tyConDataCons, getSynTyConDefn )
+ tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
import Class ( Class, classSCTheta, classTvsFds, classMethods )
import FunDeps ( pprFundeps )
import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
dataConFieldLabels, dataConStrictMarks,
dataConIsInfix, isVanillaDataCon )
import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
- nameSrcLoc )
+ nameSrcLoc, nameOccName )
import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SysTools ( cleanTempFilesExcept )
import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
-
-import Directory ( getModificationTime, doesFileExist )
-import Maybe ( isJust, isNothing, fromJust )
import Maybes ( expectJust, mapCatMaybes )
-import List ( partition, nub )
-import qualified List
-import Monad ( unless, when )
-import System ( exitWith, ExitCode(..) )
-import Time ( ClockTime )
-import EXCEPTION as Exception hiding (handle)
-import DATA_IOREF
-import IO
+
+import Control.Concurrent
+import System.Directory ( getModificationTime, doesFileExist )
+import Data.Maybe ( isJust, isNothing )
+import Data.List ( partition, nub )
+import qualified Data.List as List
+import Control.Monad ( unless, when )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Time ( ClockTime )
+import Control.Exception as Exception hiding (handle)
+import Data.IORef
+import System.IO
+import System.IO.Error ( isDoesNotExistError )
+import System.IO.Unsafe ( unsafePerformIO )
import Prelude hiding (init)
+#if __GLASGOW_HASKELL__ < 600
+import System.IO as System.IO.Error ( try )
+#else
+import System.IO.Error ( try )
+#endif
+
-- -----------------------------------------------------------------------------
-- Exception handlers
-- | Initialises GHC. This must be done /once/ only. Takes the
--- command-line arguments. All command-line arguments which aren't
--- understood by GHC will be returned.
+-- TopDir path without the '-B' prefix.
-init :: [String] -> IO [String]
-init args = do
+init :: Maybe String -> IO ()
+init mbMinusB = do
-- catch ^C
+ main_thread <- myThreadId
+ putMVar interruptTargetThread [main_thread]
installSignalHandlers
- -- Grab the -B option if there is one
- let (minusB_args, argv1) = partition (prefixMatch "-B") args
- dflags0 <- initSysTools minusB_args defaultDynFlags
+ dflags0 <- initSysTools mbMinusB defaultDynFlags
writeIORef v_initDynFlags dflags0
- -- Parse the static flags
- argv2 <- parseStaticFlags argv1
- return argv2
+-- | Initialises GHC. This must be done /once/ only. Takes the
+-- command-line arguments. All command-line arguments which aren't
+-- understood by GHC will be returned.
+
+initFromArgs :: [String] -> IO [String]
+initFromArgs args
+ = do init mbMinusB
+ return argv1
+ where -- Grab the -B option if there is one
+ (minusB_args, argv1) = partition (prefixMatch "-B") args
+ mbMinusB | null minusB_args
+ = Nothing
+ | otherwise
+ = Just (drop 2 (last minusB_args))
GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
-- stores the DynFlags between the call to init and subsequent
-- fields within CheckedModule.
type ParsedSource = Located (HsModule RdrName)
-type RenamedSource = HsGroup Name
+type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
type TypecheckedSource = LHsBinds Id
-- NOTE:
--- - things that aren't in the output of the renamer:
--- - the export list
--- - the imports
-- - things that aren't in the output of the typechecker right now:
-- - the export list
-- - the imports
-- ml_hspp_file field, say
let dflags0 = hsc_dflags hsc_env
hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
- filename = fromJust (ml_hs_file (ms_location ms))
+ filename = expectJust "checkModule" (ml_hs_file (ms_location ms))
opts = getOptionsFromStringBuffer hspp_buf filename
(dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
if (not (null leftovers))
findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile summaries file
= case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
- fromJust (ml_hs_file (ms_location ms)) == file ] of
+ expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
[] -> Nothing
(x:xs) -> Just x
case maybe_buf of
Just (_,t) -> check_timestamp old_summary location src_fn t
Nothing -> do
- m <- IO.try (getModificationTime src_fn)
+ m <- System.IO.Error.try (getModificationTime src_fn)
case m of
Right t -> check_timestamp old_summary location src_fn t
Left e | isDoesNotExistError e -> find_it
getNamesInScope s = withSession s $ \hsc_env -> do
return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
+getRdrNamesInScope :: Session -> IO [RdrName]
+getRdrNamesInScope s = withSession s $ \hsc_env -> do
+ let env = ic_rn_gbl_env (hsc_IC hsc_env)
+ return (concat (map greToRdrNames (globalRdrEnvElts env)))
+
+-- ToDo: move to RdrName
+greToRdrNames :: GlobalRdrElt -> [RdrName]
+greToRdrNames GRE{ gre_name = name, gre_prov = prov }
+ = case prov of
+ LocalDef -> [unqual]
+ Imported specs -> concat (map do_spec (map is_decl specs))
+ where
+ occ = nameOccName name
+ unqual = Unqual occ
+ do_spec decl_spec
+ | is_qual decl_spec = [qual]
+ | otherwise = [unqual,qual]
+ where qual = Qual (is_as decl_spec) occ
+
-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
parseName :: Session -> String -> IO [Name]
writeIORef ref new_hsc_env
return (RunOk names)
-
--- We run the statement in a "sandbox" to protect the rest of the
--- system from anything the expression might do. For now, this
--- consists of just wrapping it in an exception handler, but see below
--- for another version.
-
+-- When running a computation, we redirect ^C exceptions to the running
+-- thread. ToDo: we might want a way to continue even if the target
+-- thread doesn't die when it receives the exception... "this thread
+-- is not responding".
sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = Exception.try thing
+sandboxIO thing = do
+ m <- newEmptyMVar
+ ts <- takeMVar interruptTargetThread
+ child <- forkIO (do res <- Exception.try thing; putMVar m res)
+ putMVar interruptTargetThread (child:ts)
+ takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
{-
-- This version of sandboxIO runs the expression in a completely new
Nothing -> panic "missing linkable"
Just mod_info -> return (showModMsg obj_linkable mod_summary)
where
- obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info))
+ obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
#endif /* GHCI */