Generic pretty printing

gpretty.hs

{-# language TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}

module GPretty where

import Data.Data
import Data.Typeable
import Data.Generics.Aliases

data Tree a = Node a [Tree a]
			deriving (Show, Data, Typeable)

testTree = Node "root" [(Node "one" []), (Node "two" [(Node "three" [])])]

-- | A class for pretty printing. This isn't generic or used by the generic func
--   below, but we developed it before we understood what we really wanted to do.
class Pretty a where
	pretty :: a -> String

instance Pretty String where
	pretty s = s

instance (Pretty a) => Pretty (Tree a) where
	pretty tree = pprint 0 tree
		where
			pprint n (Node name ns) =
				replicate (n*2) ' ' ++ pretty name ++ "\n" ++ concatMap (pprint (n+1)) ns

-- | Generic pretty printer
gpretty :: Data a => a -> String
gpretty x = gprettys 0 x ""

gprettys :: Data a => Int -> a -> ShowS
gprettys n = ( \t ->
								showString (replicate (n * 2) ' ')
              . (showString . showConstr . toConstr $ t)
              . showChar '\n'
              . (foldr (.) id . gmapQ (gprettys (n + 1)) $ t)
         ) `extQ` ((\s -> (showString $ replicate (n * 2) ' ') . shows s . showChar '\n') :: String -> ShowS)