From: Pepe Iborra <mnislaih@gmail.com>
Date: Sat, 14 Apr 2007 17:30:46 +0000 (+0000)
Subject: :print command - Do not compute all the custom printers, only the first one matching
X-Git-Tag: 2007-05-06~156
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=89d00c460ec79f7986dc9d7dbc842b47e724bcb1

:print command - Do not compute all the custom printers, only the first one matching
---

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 4389213..415055a 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -62,7 +62,7 @@ pprintClosureCommand bindThings force str = do
   mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
   io$ updateIds cms (catMaybes mb_new_ids)
  where 
-   -- Find the Id, clean up 'Unknowns'
+   -- Find the Id, clean up 'Unknowns' in the idType
    cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
    cleanUp cms newNames str = do
      tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b12d296..6bbcc30 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -315,20 +315,21 @@ printTerm1 p Term{dc=dc, subTerms=tt}
 
 printTerm1 _ t = printTerm t
 
-customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
-customPrintTerm custom = let 
+customPrintTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
+customPrintTerm custom = go 0 where
 --  go :: Monad m => Int -> Term -> m SDoc
   go prec t@Term{subTerms=tt, dc=dc} = do
-    mb_customDocs <- sequence$ sequence (custom go) t  -- Inner sequence is List monad
-    case msum mb_customDocs of        -- msum is in Maybe monad
+    let mb_customDocs = map ($t) (custom go) :: [m (Maybe SDoc)]    
+    first_success <- firstJustM mb_customDocs
+    case first_success of
       Just doc -> return$ parensCond (prec>app_prec+1) doc
 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =
       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
                      return$ parensCond (prec>app_prec+1) 
                                         (ppr dc <+> sep pprSubterms)
   go _ t = return$ printTerm t
-  in go 0 
-   where fixity = undefined 
+  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
+  firstJustM [] = return Nothing
 
 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
 customPrintTermBase showP =