refactor: use do-notation rather than `thenBc`-style

[ghc-hetmet.git] / compiler / ghci / Debugger.hs

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 6248e0c..be27bf7 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -66,8 +66,8 @@ pprintClosureCommand bindThings force str = do
            uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
            return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
   mb_ids  <- io$ mapM (cleanUp cms newvarsNames) (words str)
-  new_ids <- mapM (io . go cms) (catMaybes mb_ids)
-  io$ updateIds cms new_ids
+  mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
+  io$ updateIds cms (catMaybes mb_new_ids)
  where 
    -- Find the Id, clean up 'Unknowns'
    cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
@@ -78,22 +78,23 @@ pprintClosureCommand bindThings force str = do
 
    -- Do the obtainTerm--bindSuspensions-refineIdType dance
    -- Warning! This function got a good deal of side-effects
-   go :: Session -> Id -> IO Id
+   go :: Session -> Id -> IO (Maybe Id)
    go cms id = do
-     Just term <- obtainTerm cms force id
-     term'     <- if not bindThings then return term 
-                   else bindSuspensions cms term                         
-     showterm  <- pprTerm cms term'
-     unqual    <- GHC.getPrintUnqual cms
-     let showSDocForUserOneLine unqual doc = 
-             showDocWith LeftMode (doc (mkErrStyle unqual))
-     (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
+     mb_term <- obtainTerm cms force id
+     maybe (return Nothing) `flip` mb_term $ \term -> do
+       term'     <- if not bindThings then return term 
+                     else bindSuspensions cms term                         
+       showterm  <- pprTerm cms term'
+       unqual    <- GHC.getPrintUnqual cms
+       let showSDocForUserOneLine unqual doc = 
+               showDocWith LeftMode (doc (mkErrStyle unqual))
+       (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
      -- Before leaving, we compare the type obtained to see if it's more specific
      -- Note how we need the Unknown-clear type returned by obtainTerm
-     let Just reconstructedType = termType term  
-     new_type  <- instantiateTyVarsToUnknown cms 
-                  (mostSpecificType (idType id) reconstructedType)
-     return (setIdType id new_type)
+       let Just reconstructedType = termType term  
+       new_type  <- instantiateTyVarsToUnknown cms 
+                    (mostSpecificType (idType id) reconstructedType)
+       return . Just $ setIdType id new_type
 
    updateIds :: Session -> [Id] -> IO ()
    updateIds (Session ref) new_ids = do
@@ -265,7 +266,7 @@ instantiateTyVarsToUnknown cms ty
 
 -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
 stripUnknowns :: [Name] -> Id -> Id
-stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType 
+stripUnknowns names id = setIdType id . fst . go names . idType 
                            $ id
  where 
    go tyvarsNames@(v:vv) ty 
@@ -330,24 +331,33 @@ bkptOptions cmd = do
       io$ putStrLn msg
 
     bkptOptions' s ("add":cmds) bt 
+      | [line]         <- cmds
+      , [(lineNum,[])] <- reads line
+      = do (toplevel,_) <- io$ GHC.getContext s
+           case toplevel of
+             (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m
+             [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode"
+
       | [mod_name,line]<- cmds
       , [(lineNum,[])] <- reads line
-      =  handleAdd mod_name $ (\mod->addBkptByLine mod lineNum)
+      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
+         handleAdd (\mod->addBkptByLine mod lineNum)
 
       | [mod_name,line,col] <- cmds
-      = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col))
+      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
+         handleAdd (\mod->addBkptByCoord mod (read line, read col))
 
       | otherwise = throwDyn $ CmdLineError $ 
                        "syntax: :breakpoint add Module line [col]"
        where 
-         handleAdd mod_name f = do
-           mod         <- io$ GHC.findModule s (GHC.mkModuleName mod_name) Nothing
+         handleAdd f mod = 
            either 
              (handleBkptEx s mod)
              (\(newTable, site) -> do
-               setBkptTable newTable 
-               io (putStrLn ("Breakpoint set at " ++ 
-                              show (getSiteCoords newTable mod site))))
+               setBkptTable newTable
+               let (x,y) = getSiteCoords newTable mod site
+               io (putStrLn ("Breakpoint set at " ++ showSDoc (ppr mod) 
+                    ++ ':' : show x  ++ ':' : show y)))
              (f mod bt) 
 
     bkptOptions' s ("del":cmds) bt 
@@ -373,31 +383,28 @@ bkptOptions cmd = do
       = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
         
       | otherwise = throwDyn $ CmdLineError $ 
-             "syntax: :breakpoint del (breakpoint # | Module line [col])"
+             "syntax: :breakpoint del (breakpoint # | [Module] line [col])"
 
        where delMsg = "Breakpoint deleted"
              handleDel mod f = either (handleBkptEx s mod)
                                       (\newtable-> setBkptTable newtable >> io (putStrLn delMsg))
                                       (f bt)
                                       
-
     bkptOptions' _ _ _ = throwDyn $ CmdLineError $ 
                          "syntax: :breakpoint (list|continue|stop|add|del)"
 
 -- Error messages
 --    handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
-    handleBkptEx s m NotHandled  = io$
-                                   findModSummary m                  >>= \mod_summary ->
-                                   isModuleInterpreted s mod_summary >>= \it -> 
-       if it
+    handleBkptEx s m NotHandled  = io$ do
+       isInterpreted <- findModSummary m >>= isModuleInterpreted s
+       if isInterpreted
         then error$ "Module " ++ showSDoc (ppr m) ++  " was not loaded under debugging mode.\n" 
                  ++ "Enable debugging mode with -fdebugging (and reload your module)"
         else error$ "Module " ++ showSDoc (ppr m) ++  " was loaded in compiled (.o) mode.\n" 
                  ++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
-                     where findModSummary m = getModuleGraph s >>= \mod_graph ->  
-                               case [ modsum | modsum <- mod_graph
-                                             , ms_mod modsum == m ] of
-                                 [modsum] -> return modsum
+         where findModSummary m = do 
+                 mod_graph <- getModuleGraph s 
+                 return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m]
     handleBkptEx _ _ e = error (show e)
 
 -------------------------