{-------------------------------------------------------------------------------

        Module:                 PrettyGraph

        Description:            Pretty printing of the graph representation
                                of Haskell values

        Primary Authors:        Bernie Pope

-------------------------------------------------------------------------------}

module PrettyGraph ( prettyGraph ) where

import ReifyHs
   ( Graph (..)
   , GraphKind (..)
   , graphKind
   , graphIsList
   , graphIsTuple )

import Data.Char (showLitChar)

prettyGraph :: Graph -> String
prettyGraph g = prettyGraphS False g ""

prettyGraphS :: Bool -> Graph -> ShowS
prettyGraphS parens graph@(AppNode _unique desc tag numKids kids)
   | graphIsList  graph = prettyList graph
   | graphIsTuple graph = prettyTuple graph
   | otherwise = prettyGraphApp parens desc tag numKids kids
   where
   prettyGraphApp :: Bool -> String -> Int -> Int -> [Graph] -> ShowS
   prettyGraphApp parens desc tag numKids kids
      = case graphKind graph of
           GNode -> if numKids <= 0
                       then showString desc
                       else showParen parens ( showString desc . space . prettyKids True kids)
           GCycle -> showString "<CYCLE>"
           GThunk -> showString "?"
           GApUpd     -> showString "!"
           GException -> prettyKids False kids
           GFun -> showString "<Function>"
   prettyKids :: Bool -> [Graph] -> ShowS
   prettyKids parens [] = id
   prettyKids parens [k] = prettyGraphS parens k
   prettyKids parens (k1:k2:ks) = prettyGraphS parens k1 . space . prettyKids parens (k2:ks)
prettyGraphS parens (CharNode c)    = shows c
prettyGraphS parens (IntNode i)     = shows i
prettyGraphS parens (IntegerNode i) = shows i
prettyGraphS parens (FloatNode f)   = shows f
prettyGraphS parens (DoubleNode d)  = shows d
prettyGraphS parens NullNode        = showString "<Null>"

space :: ShowS
space = showChar ' '

-- graphs that represent lists
prettyList :: Graph -> ShowS
prettyList graph
   | isGraphString graph = prettyString True graph
   | otherwise = prettyListNormal graph

prettyListNormal :: Graph -> ShowS
prettyListNormal (AppNode _unique "[]" _tag _numKids _kids) = showString "[]"
prettyListNormal (AppNode _unique ":" _tag _numKids [x,xs])
   = showChar '[' . prettyGraphS False x . prettyl xs
   where prettyl (AppNode _unique "[]" _tag _numKids _kids) = showChar ']'
         prettyl (AppNode _unique ":" _tag _numKids [x,xs])
            = showString "," . prettyGraphS False x . prettyl xs
         prettyl other = showString " .. " . prettyGraphS False other

-- graphs that represent strings
prettyString :: Bool -> Graph -> ShowS
prettyString quotes (AppNode _unique "[]" _tag _numKids _kids)
   | quotes = showString "\"\""
   | otherwise = id
prettyString quotes (AppNode _unique ":" _tag _numKids [x,xs])
   | quotes = showChar '\"' . prettyLitChar x . prettyl quotes xs
   | otherwise = prettyLitChar x . prettyl quotes xs
   where prettyl quotes (AppNode _unique "[]" _tag _numKids _kids)
            | quotes = showChar '\"'
            | otherwise = id
         prettyl quotes (AppNode _unique ":" _tag _numKids [x,xs])
            = prettyLitChar x . prettyl quotes xs
         prettyl quotes other = showString " .. " . prettyGraphS False other

-- print a literal character (without the quotes)
prettyLitChar :: Graph -> ShowS
prettyLitChar (CharNode c) = showLitChar c
prettyLitChar other = prettyGraphS True other  -- could be a thunk or something weird

-- graphs that represent tuples
prettyTuple :: Graph -> ShowS
prettyTuple (AppNode _unique _desc _tag _numKids kids@(x:xs))
   = showChar '(' . prettyGraphS False x . prettyl xs
   where prettyl [] = showChar ')'
         prettyl (x:xs) = showString "," . prettyGraphS False x . prettyl xs

-- a graph is a string if it is a list and its first item is a character
-- this is a conservative test, but should be enough for usual use
isGraphString :: Graph -> Bool
isGraphString (AppNode _unique ":" _tag _numKids [first,_])
   = graphKind first == GChar
isGraphString other = False