+cons_prec = 5 -- TODO Extract this info from GHC itself
+
+pprTerm :: TermPrinter -> TermPrinter
+pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
+pprTerm _ _ _ = panic "pprTerm"
+
+pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
+
+pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc
+pprTermM1 t = pprDeeper `liftM` ppr_termM1 t
+
+ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
+ tt_docs <- mapM (y app_prec) tt
+ return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
+{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
+ = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
+ <+> hsep (map (ppr_term1 True) tt)
+-} -- TODO Printing infix constructors properly
+ | null tt = return$ ppr dc
+ | otherwise = do
+ tt_docs <- mapM (y app_prec) tt
+ return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+
+ppr_termM _ _ t = ppr_termM1 t
+
+
+ppr_termM1 Prim{value=words, ty=ty} =
+ return$ text$ repPrim (tyConAppTyCon ty) words
+ppr_termM1 Term{} = panic "ppr_termM1 - unreachable"
+ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
+ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
+ | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
+ | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 _ = panic "ppr_termM1"
+
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+ | Just (tc,_) <- splitNewTyConApp_maybe ty
+ , ASSERT(isNewTyCon tc) True
+ , Just new_dc <- maybeTyConSingleCon tc = do
+ real_term <- y 10 t
+ return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
+
+-------------------------------------------------------
+-- Custom Term Pretty Printers
+-------------------------------------------------------
+
+-- We can want to customize the representation of a
+-- term depending on its type.
+-- However, note that custom printers have to work with
+-- type representations, instead of directly with types.
+-- We cannot use type classes here, unless we employ some
+-- typerep trickery (e.g. Weirich's RepLib tricks),
+-- which I didn't. Therefore, this code replicates a lot
+-- of what type classes provide for free.
+
+type CustomTermPrinter m = TermPrinterM m
+ -> [Precedence -> Term -> (m (Maybe SDoc))]
+
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- and returns the output of the first succesful printer, or the default printer
+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
+cPprTerm printers_ = go 0 where
+ printers = printers_ go
+ go prec t | isTerm t || isNewtypeWrap t = do
+ let default_ = Just `liftM` pprTermM go prec t
+ mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
+ Just doc <- firstJustM mb_customDocs
+ return$ cparen (prec>app_prec+1) doc
+ go _ t = pprTermM1 t