From 63f8bf0136bc85c18b0080a3e30431a1faa1f980 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 20 Apr 2007 17:02:06 +0000 Subject: [PATCH] Haskell list syntax for the :print command I did quite a bit of clean up in the Term pretty printer code too. Support for infix constructors is still on the TODO list --- compiler/ghci/Debugger.hs | 12 +++-- compiler/ghci/RtClosureInspect.hs | 107 ++++++++++++++++++------------------- 2 files changed, 58 insertions(+), 61 deletions(-) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 415055a..4f721d1 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -77,7 +77,7 @@ pprintClosureCommand bindThings force str = do maybe (return Nothing) `flip` mb_term $ \term -> do term' <- if not bindThings then return term else bindSuspensions cms term - showterm <- pprTerm cms term' + showterm <- printTerm cms term' unqual <- GHC.getPrintUnqual cms let showSDocForUserOneLine unqual doc = showDocWith LeftMode (doc (mkErrStyle unqual)) @@ -160,10 +160,10 @@ bindSuspensions cms@(Session ref) t = do -- A custom Term printer to enable the use of Show instances -pprTerm cms@(Session ref) = customPrintTerm customPrint +printTerm cms@(Session ref) = cPprTerm cPpr where - customPrint = \p-> customPrintShowable : customPrintTermBase p - customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do + cPpr = \p-> cPprShowable : cPprTermBase p + cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do let hasType = isEmptyVarSet (tyVarsOfType ty) -- redundant isEvaled = isFullyEvaluatedTerm t if not isEvaled -- || not hasType @@ -179,8 +179,10 @@ pprTerm cms@(Session ref) = customPrintTerm customPrint GHC.setSessionDynFlags cms dflags{log_action=noop_log} mb_txt <- withExtendedLinkEnv [(bname, val)] (GHC.compileExpr cms expr) + let myprec = 9 -- TODO Infix constructors case mb_txt of - Just txt -> return . Just . text . unsafeCoerce# $ txt + Just txt -> return . Just . text . unsafeCoerce# + $ txt Nothing -> return Nothing `finally` do writeIORef ref hsc_env diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index e24b942..b98d61a 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -17,9 +17,9 @@ module RtClosureInspect( isIndirection, -- :: ClosureType -> Bool Term(..), - printTerm, - customPrintTerm, - customPrintTermBase, + pprTerm, + cPprTerm, + cPprTermBase, termType, foldTerm, TermFold(..), @@ -87,9 +87,9 @@ import IO > (('a',_,_),_,('b',_,_)) = Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_)) - [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk] - , Thunk - , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]] + [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension] + , Suspension + , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]] -} data Term = Term { ty :: Type @@ -122,7 +122,7 @@ isFullyEvaluatedTerm Suspension {} = False isFullyEvaluatedTerm Prim {} = True instance Outputable (Term) where - ppr = head . customPrintTerm customPrintTermBase + ppr = head . cPprTerm cPprTermBase ------------------------------------------------------------------------- -- Runtime Closure Datatype and functions for retrieving closure related stuff @@ -142,7 +142,6 @@ data Closure = Closure { tipe :: ClosureType , infoPtr :: Ptr () , infoTable :: StgInfoTable , ptrs :: Array Int HValue - -- What would be the type here? HValue is ok? Should I build a Ptr? , nonPtrs :: ByteArray# } @@ -289,79 +288,75 @@ idTermFoldM = TermFold { -- Pretty printing of terms ---------------------------------- -parensCond True = parens -parensCond False = id app_prec::Int app_prec = 10 -printTerm :: Term -> SDoc -printTerm Prim{value=value} = text value -printTerm t@Term{} = printTerm1 0 t -printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_' -printTerm Suspension{mb_ty=Just ty, bound_to=Just n} - | Just _ <- splitFunTy_maybe ty = text "" - | otherwise = parens$ ppr n <> text "::" <> ppr ty - -printTerm1 p Term{dc=dc, subTerms=tt} +pprTerm :: Int -> Term -> SDoc +pprTerm p Term{dc=dc, subTerms=tt} {- | dataConIsInfix dc, (t1:t2:tt') <- tt - = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2) - <+> hsep (map (printTerm1 True) tt) + = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2) + <+> hsep (map (pprTerm1 True) tt) -} | null tt = ppr dc - | otherwise = parensCond (p > app_prec) - (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt)) + | otherwise = cparen (p >= app_prec) + (ppr dc <+> sep (map (pprTerm app_prec) tt)) where fixity = undefined -printTerm1 _ t = printTerm t +pprTerm _ t = pprTerm1 t + +pprTerm1 Prim{value=value} = text value +pprTerm1 t@Term{} = pprTerm 0 t +pprTerm1 Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_' +pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n} + | Just _ <- splitFunTy_maybe ty = ptext SLIT("") + | otherwise = parens$ ppr n <> text "::" <> ppr ty + -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 +cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc +cPprTerm custom = go 0 where go prec t@Term{subTerms=tt, dc=dc} = do - let mb_customDocs = map ($t) (custom go) :: [m (Maybe SDoc)] + let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)] first_success <- firstJustM mb_customDocs case first_success of - Just doc -> return$ parensCond (prec>app_prec+1) doc + Just doc -> return$ cparen (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 + return$ cparen (prec >= app_prec) + (ppr dc <+> sep pprSubterms) + go _ t = return$ pprTerm1 t 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 = +cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)] +cPprTermBase pprP = [ - test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms) - , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t) - , test (isDC intDataCon) (coerceShow$ \(a::Int)->a) - , test (isDC charDataCon) (coerceShow$ \(a::Char)->a) --- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a) - , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a) - , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a) - , test isIntegerDC (coerceShow$ \(a::Integer)->a) + ifTerm isTupleDC (\_ -> liftM (parens . hcat . punctuate comma) + . mapM (pprP (-1)) . subTerms) + , ifTerm (isDC consDataCon) (\ p Term{subTerms=[h,t]} -> doList p h t) + , ifTerm (isDC intDataCon) (coerceShow$ \(a::Int)->a) + , ifTerm (isDC charDataCon) (coerceShow$ \(a::Char)->a) +-- , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a) + , ifTerm (isDC floatDataCon) (coerceShow$ \(a::Float)->a) + , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a) + , ifTerm isIntegerDC (coerceShow$ \(a::Integer)->a) ] - where test pred f t = if pred t then liftM Just (f t) else return Nothing + where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing isIntegerDC Term{dc=dc} = dataConName dc `elem` [ smallIntegerDataConName , largeIntegerDataConName] - isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr)) - isDC a_dc Term{dc=dc} = a_dc == dc - coerceShow f = return . text . show . f . unsafeCoerce# . val + isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr)) + isDC a_dc Term{dc=dc} = a_dc == dc + coerceShow f _ = return . text . show . f . unsafeCoerce# . val --TODO pprinting of list terms is not lazy - doList h t = do + doList p h t = do let elems = h : getListTerms t - isConsLast = isSuspension (last elems) && - (mb_ty$ last elems) /= (termType h) - init <- mapM (showP 0) (init elems) - last0 <- showP 0 (last elems) - let last = case length elems of - 1 -> last0 - _ | isConsLast -> text " | " <> last0 - _ -> comma <> last0 - return$ brackets (hcat (punctuate comma init ++ [last])) + isConsLast = termType(last elems) /= termType h + print_elems <- mapM (pprP 5) elems + return$ if isConsLast + then cparen (p >= 5) . hsep . punctuate (space<>colon) + $ print_elems + else brackets (hcat$ punctuate comma print_elems) where Just a /= Just b = not (a `coreEqType` b) _ /= _ = True -- 1.7.10.4