+cons_prec = 5 -- TODO Extract this info from GHC itself
+
+pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
+pprTerm y p t | Just doc <- pprTermM y p t = doc
+pprTerm _ _ _ = panic "pprTerm"
+
+pprTermM, pprNewtypeWrap :: Monad m =>
+ (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
+pprTermM 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 <+> sep tt_docs)
+
+pprTermM y p Term{dc=Right dc, subTerms=tt}
+{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
+ = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
+ <+> hsep (map (pprTerm1 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 <+> sep tt_docs)
+
+pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+
+pprTermM _ _ t = pprTermM1 t
+
+pprTermM1 :: Monad m => Term -> m SDoc
+pprTermM1 Prim{value=words, ty=ty} =
+ return$ text$ repPrim (tyConAppTyCon ty) words
+pprTermM1 Term{} = panic "pprTermM1 - unreachable"
+pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
+pprTermM1 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
+pprTermM1 _ = panic "pprTermM1"
+
+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.
+
+-- Concretely a custom term printer takes an explicit
+-- recursion knot, and produces a list of Term Processors,
+-- which additionally need a precedence value to
+-- either produce a SDoc or fail (and they do this in some monad m).
+
+type Precedence = Int
+type RecursionKnot m = Precedence -> Term -> m SDoc
+type CustomTermPrinter m = RecursionKnot 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
+
+ firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
+ firstJustM [] = return Nothing
+
+-- Default set of custom printers. Note that the recursion knot is explicit
+cPprTermBase :: Monad m => CustomTermPrinter m
+cPprTermBase y =
+ [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
+ . mapM (y (-1))
+ . subTerms)
+ , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
+ (\ p Term{subTerms=[h,t]} -> doList p h t)
+ , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
+ , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
+ , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
+ , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
+ , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
+ ]
+ where ifTerm pred f prec t@Term{}
+ | pred t = Just `liftM` f prec t
+ ifTerm _ _ _ _ = return Nothing
+
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- splitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- splitTyConApp_maybe ty
+ return (tc `elem` (fst.unzip.elems) boxedTupleArr)
+
+ isTyCon a_tc ty = fromMaybe False $ do
+ (tc,_) <- splitTyConApp_maybe ty
+ return (a_tc == tc)
+
+ coerceShow f _p = return . text . show . f . unsafeCoerce# . val