X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=be7aa0a85b87b45f43ac34bb74ee3f3b99eb13c2;hp=3530d78c41b0d0fa44642a22655cbae3e854e825;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=0ed635befe3cefab52d60ed06fc36668a9795e52

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 3530d78..be7aa0a 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -6,6 +6,13 @@
 --
 -- -----------------------------------------------------------------------------
 
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module InteractiveEval (
 #ifdef GHCI
         RunResult(..), Status(..), Resume(..), History(..),
@@ -13,10 +20,8 @@ module InteractiveEval (
         resume,
         abandon, abandonAll,
         getResumeContext,
-        getHistoryTick,
         getHistorySpan,
         getHistoryModule,
-        findEnclosingDeclSpanByTick,
         back, forward,
 	setContext, getContext,	
         nameSetToGlobalRdrEnv,
@@ -31,7 +36,7 @@ module InteractiveEval (
         isModuleInterpreted,
 	compileExpr, dynCompileExpr,
 	lookupName,
-        obtainTerm, obtainTerm1, reconstructType,
+        Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
         skolemiseSubst, skolemiseTy
 #endif
         ) where
@@ -80,6 +85,7 @@ import GHC.Exts
 import Data.Array
 import Control.Exception as Exception
 import Control.Concurrent
+import Data.List (sortBy)
 import Data.IORef
 import Foreign.StablePtr
 
@@ -133,7 +139,7 @@ data History
    = History {
         historyApStack   :: HValue,
         historyBreakInfo :: BreakInfo,
-        historyEnclosingDecl :: Name
+        historyEnclosingDecl :: Id
          -- ^^ A cache of the enclosing top level declaration, for convenience
    }
 
@@ -144,9 +150,6 @@ mkHistory hsc_env hval bi = let
                                      (getHistorySpan hsc_env h)
     in h
 
-getHistoryTick :: History -> BreakIndex
-getHistoryTick = breakInfo_number . historyBreakInfo 
-
 getHistoryModule :: History -> Module
 getHistoryModule = breakInfo_module . historyBreakInfo
 
@@ -159,33 +162,18 @@ getHistorySpan hsc_env hist =
        _ -> panic "getHistorySpan"
 
 -- | Finds the enclosing top level function name 
-findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Name
+findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
 findEnclosingDecl hsc_env mod span =
    case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
          Nothing -> panic "findEnclosingDecl"
          Just hmi -> let
-                globals   = typeEnvIds (md_types (hm_details hmi))
-                Just decl = find (\n -> nameSrcSpan n < span) 
-                                 (reverse $ map idName globals)
-                              --   ^^ assumes md_types is sorted
-              in decl
-
--- | Finds the span of the (smallest) function containing this BreakIndex
-findEnclosingDeclSpanByTick :: HscEnv -> Module -> BreakIndex -> SrcSpan
-findEnclosingDeclSpanByTick hsc_env mod tick = 
-   case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
-         Nothing -> panic "findEnclosingDecl"
-         Just hmi -> let
-             modbreaks = md_modBreaks (hm_details hmi)
-          in ASSERT (inRange (bounds (modBreaks_decls modbreaks)) tick)
-             modBreaks_decls modbreaks ! tick
-
--- | Find the Module corresponding to a FilePath
-findModuleFromFile :: HscEnv -> FilePath -> Maybe Module
-findModuleFromFile hsc_env fp =
-   listToMaybe $ [ms_mod ms | ms <- hsc_mod_graph hsc_env
-                            , ml_hs_file(ms_location ms) == Just (read fp)]
-
+             globals   = typeEnvIds (md_types (hm_details hmi))
+             Just decl = 
+                 find (\id -> let n = idName id in 
+                               nameSrcSpan n < span && isExternalName n)
+                      (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
+                                       globals)
+           in decl
 
 -- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.
@@ -531,8 +519,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    -- So that we don't fall over in a heap when this happens, just don't
    -- bind any free variables instead, and we emit a warning.
    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
-   let (filtered_hvs, filtered_ids) = 
-                       unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ]
+   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"
@@ -579,7 +566,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 
 rttiEnvironment :: HscEnv -> IO HscEnv 
 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
-   let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic
+   let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
        incompletelyTypedIds = 
            [id | id <- tmp_ids
                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
@@ -922,12 +909,17 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 
 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
 obtainTerm1 hsc_env force mb_ty x = 
-              cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+              cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
+
+obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermB hsc_env bound force id =  do
+              hv <- Linker.getHValue hsc_env (varName id) 
+              cvObtainTerm hsc_env bound force (Just$ idType id) hv
 
 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 obtainTerm hsc_env force id =  do
               hv <- Linker.getHValue hsc_env (varName id) 
-              cvObtainTerm hsc_env force (Just$ idType id) hv
+              cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)