diff options
author | David Terei <davidterei@gmail.com> | 2011-12-13 16:37:30 -0800 |
---|---|---|
committer | David Terei <davidterei@gmail.com> | 2011-12-19 19:13:09 -0800 |
commit | a3bd0b7067a08d31f9b7d714fe1c0fe562d97ef3 (patch) | |
tree | 2e0f2bc922f079288479b0447f098345d8dd6f0e /compiler/main/InteractiveEval.hs | |
parent | e7e771d14ac671904a69abecf9e133d4647026c1 (diff) | |
download | haskell-a3bd0b7067a08d31f9b7d714fe1c0fe562d97ef3.tar.gz |
Tabs -> Spaces
Diffstat (limited to 'compiler/main/InteractiveEval.hs')
-rw-r--r-- | compiler/main/InteractiveEval.hs | 177 |
1 files changed, 85 insertions, 92 deletions
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index b4cf6b8197..3439231aa6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -6,17 +6,10 @@ -- -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, @@ -25,18 +18,18 @@ module InteractiveEval ( getModBreaks, getHistoryModule, back, forward, - setContext, getContext, + setContext, getContext, availsToGlobalRdrEnv, - getNamesInScope, - getRdrNamesInScope, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - showModule, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + showModule, isModuleInterpreted, - compileExpr, dynCompileExpr, + compileExpr, dynCompileExpr, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -51,7 +44,7 @@ import HsSyn import HscTypes import InstEnv import Type hiding( typeKind ) -import TcType hiding( typeKind ) +import TcType hiding( typeKind ) import Var import Id import Name hiding ( varName ) @@ -98,7 +91,7 @@ import System.IO.Unsafe -- running a statement interactively data RunResult - = RunOk [Name] -- ^ names bound by this evaluation + = RunOk [Name] -- ^ names bound by this evaluation | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) @@ -112,13 +105,13 @@ data Resume = Resume { resumeStmt :: String, -- the original statement resumeThreadId :: ThreadId, -- thread running the computation - resumeBreakMVar :: MVar (), + resumeBreakMVar :: MVar (), resumeStatMVar :: MVar Status, resumeBindings :: ([TyThing], GlobalRdrEnv), resumeFinalIds :: [Id], -- [Id] to bind on completion resumeApStack :: HValue, -- The object from which we can get -- value of the free variables. - resumeBreakInfo :: Maybe BreakInfo, + resumeBreakInfo :: Maybe BreakInfo, -- the breakpoint we stopped at -- (Nothing <=> exception) resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain @@ -191,8 +184,8 @@ runStmt = runStmtWithLocation "<interactive>" 1 -- | Run a statement in the current interactive context. Passing debug information -- Statement may bind multple values. -runStmtWithLocation :: GhcMonad m => String -> Int -> - String -> SingleStep -> m RunResult +runStmtWithLocation :: GhcMonad m => String -> Int -> + String -> SingleStep -> m RunResult runStmtWithLocation source linenumber expr step = do hsc_env <- getSession @@ -216,7 +209,7 @@ runStmtWithLocation source linenumber expr step = withBreakAction (isStep step) dflags' breakMVar statusMVar $ do let thing_to_run = unsafeCoerce# hval :: IO [HValue] liftIO $ sandboxIO dflags' statusMVar thing_to_run - + let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -242,7 +235,7 @@ runDeclsWithLocation source linenumber expr = hsc_env' = hsc_env{ hsc_dflags = dflags' } (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber - + setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession hsc_env' <- liftIO $ rttiEnvironment hsc_env @@ -257,7 +250,7 @@ withVirtualCWD m = do let set_cwd = do dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of + case ic_cwd ic of Just dir -> liftIO $ setCurrentDirectory dir Nothing -> return () return dir @@ -283,7 +276,7 @@ handleRunStatus :: GhcMonad m => -> m RunResult handleRunStatus expr bindings final_ids breakMVar statusMVar status history = - case status of + case status of -- did we hit a breakpoint or did we complete? (Break is_exception apStack info tid) -> do hsc_env <- getSession @@ -293,9 +286,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status mb_info let resume = Resume { resumeStmt = expr, resumeThreadId = tid - , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_info + , resumeApStack = apStack, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume @@ -303,9 +296,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status modifySession (\_ -> hsc_env2) return (RunBreak tid names mb_info) (Complete either_hvals) -> - case either_hvals of - Left e -> return (RunException e) - Right hvals -> do + case either_hvals of + Left e -> return (RunException e) + Right hvals -> do hsc_env <- getSession let final_ic = extendInteractiveContext (hsc_IC hsc_env) (map AnId final_ids) @@ -369,8 +362,8 @@ resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 -- this points to the IO action that is executed when a breakpoint is hit -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) -- When running a computation, we redirect ^C exceptions to the running -- thread. ToDo: we might want a way to continue even if the target @@ -407,7 +400,7 @@ sandboxIO dflags statusMVar thing = rethrow :: DynFlags -> IO a -> IO a rethrow dflags io = Exception.catch io $ \se -> do -- If -fbreak-on-error, we break unconditionally, - -- but with care of not breaking twice + -- but with care of not breaking twice if dopt Opt_BreakOnError dflags && not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 @@ -481,28 +474,28 @@ resume canLogSpan step ic_rn_gbl_env = resume_rdr_env, ic_resume = rs } modifySession (\_ -> hsc_env{ hsc_IC = ic' }) - - -- remove any bindings created since the breakpoint from the + + -- remove any bindings created since the breakpoint from the -- linker's environment let new_names = map getName (filter (`notElem` resume_tmp_te) (ic_tythings ic)) liftIO $ Linker.deleteFromLinkEnv new_names - + when (isStep step) $ liftIO setStepFlag - case r of + case r of Resume { resumeStmt = expr, resumeThreadId = tid , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span , resumeHistory = hist } -> do withVirtualCWD $ do - withBreakAction (isStep step) (hsc_dflags hsc_env) + withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- liftIO $ withInterruptsSentTo tid $ do putMVar breakMVar () -- this awakens the stopped thread... takeMVar statusMVar - -- and wait for the result + -- and wait for the result let prevHistoryLst = fromListBL 50 hist hist' = case info of Nothing -> prevHistoryLst @@ -511,7 +504,7 @@ resume canLogSpan step | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist case step of - RunAndLogSteps -> + RunAndLogSteps -> traceRunStatus expr bindings final_ids breakMVar statusMVar status hist' _other -> @@ -543,23 +536,23 @@ moveHist fn = do update_ic apStack mb_info = do (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info - let ic = hsc_IC hsc_env1 + let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } - + modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) - + return (names, new_ix, span) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to -- make this the case. ToDo: this is v. fragile, do something better. if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, + then case r of + Resume { resumeApStack = apStack, resumeBreakInfo = mb_info } -> update_ic apStack mb_info - else case history !! (new_ix - 1) of + else case history !! (new_ix - 1) of History apStack info _ -> update_ic apStack (Just info) @@ -598,9 +591,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack (Just info) = do - let + let mod_name = moduleName (breakInfo_module info) - hmi = expectJust "bindLocalsAtBreakpoint" $ + hmi = expectJust "bindLocalsAtBreakpoint" $ lookupUFM (hsc_HPT hsc_env) mod_name breaks = getModBreaks hmi index = breakInfo_number info @@ -628,7 +621,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ - text "Warning: _result has been evaluated, some bindings have been lost" + text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' let (us1, us2) = splitUniqSupply us @@ -683,10 +676,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us , let name = setNameUnique (tyVarName tv) uniq ] -rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let tmp_ids = [id | AnId id <- ic_tythings ic] - incompletelyTypedIds = + incompletelyTypedIds = [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] @@ -744,7 +737,7 @@ abandon = do resume = ic_resume ic case resume of [] -> return False - r:rs -> do + r:rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } liftIO $ abandon_ r return True @@ -756,13 +749,13 @@ abandonAll = do resume = ic_resume ic case resume of [] -> return False - rs -> do + rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } liftIO $ mapM_ abandon_ rs return True --- when abandoning a computation we have to --- (a) kill the thread with an async exception, so that the +-- when abandoning a computation we have to +-- (a) kill the thread with an async exception, so that the -- computation itself is stopped, and -- (b) fill in the MVar. This step is necessary because any -- thunks that were under evaluation will now be updated @@ -773,7 +766,7 @@ abandonAll = do abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) - putMVar (resumeBreakMVar r) () + putMVar (resumeBreakMVar r) () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons @@ -821,7 +814,7 @@ findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls - -- This call also loads any orphan modules + -- This call also loads any orphan modules ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } where @@ -838,21 +831,21 @@ availsToGlobalRdrEnv mod_name avails -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of - Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ + Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> - case mi_globals (hm_iface details) of - Nothing -> - ghcError (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return env + case mi_globals (hm_iface details) of + Nothing -> + ghcError (ProgramError ("mkTopLevEnv: not interpreted " + ++ showSDoc (ppr modl))) + Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -872,10 +865,10 @@ moduleIsInterpreted modl = withSession $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) --- Filter the instances by the ones whose tycons (or clases resp) +-- Filter the instances by the ones whose tycons (or clases resp) -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. --- (see Trac #1581) +-- (see Trac #1581) getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getInfo name = withSession $ \hsc_env -> @@ -886,15 +879,15 @@ getInfo name let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) where - plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env - = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec - where -- A name is ok if it's in the rdr_env, - -- whether qualified or not - ok n | n == name = True -- The one we looked for in the first place! - | isBuiltInSyntax n = True - | isExternalName n = any ((== n) . gre_name) - (lookupGRE_Name rdr_env n) - | otherwise = True + plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env + = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True -- The one we looked for in the first place! + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] @@ -903,7 +896,7 @@ getNamesInScope = withSession $ \hsc_env -> do getRdrNamesInScope :: GhcMonad m => m [RdrName] getRdrNamesInScope = withSession $ \hsc_env -> do - let + let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv @@ -920,9 +913,9 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } 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 + | 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. @@ -954,12 +947,12 @@ typeKind normalise str = withSession $ \hsc_env -> do compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) - -- Run it! + -- Run it! hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) case (ids,hvals) of ([_],[hv]) -> return hv - _ -> panic "compileExpr" + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- -- Compile an expression into a dynamic @@ -979,7 +972,7 @@ dynCompileExpr expr = do } setContext (IIDecl importDecl : iis) let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession $ \hsc_env -> + Just (ids, hvals) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt setContext iis vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) @@ -999,10 +992,10 @@ showModule mod_summary = isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return (not obj_linkable) - where - obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) + Nothing -> panic "missing linkable" + Just mod_info -> return (not obj_linkable) + where + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) ---------------------------------------------------------------------------- -- RTTI primitives @@ -1019,7 +1012,7 @@ obtainTermFromId hsc_env bound force id = do -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - hv <- Linker.getHValue hsc_env (varName id) + hv <- Linker.getHValue hsc_env (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar |