Stack.xhs

{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE TypeSynonymInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Contains a pseudo implementation of an artificial stack.
-- This is used to print a StackTrace out and manipulate the stack.
--
-----------------------------------------------------------------------------

module WinDll.Debug.Stack
 ( Stack()
 , Stackable(..)
 , FunctionName
 , emptyStack
 , pushStack
 , topStack
 , popStack
 , newStack
 , sizeStack
 , shrinkStack
 , printStack
 ) where

import System.FilePath

import Data.Data
import Data.Typeable

type FunctionName = String

-- | A simple stack implementation
data Stack = Empty                  
           | Then FunctionName Stack
           | Combined Stack Stack
           | Recursed Stack Stack
           deriving (Typeable, Data, Eq, Show, Read, Ord)
           
class Show a => Stackable a where
    toStack :: a -> Stack
    
instance Stackable Stack where
    toStack = id
    
instance Stackable String where
    toStack = newStack
           
-- instance Show Stack where
  -- show = printStack
           
-- | Pretty print a stack back out to a string
printStack :: Stack -> String
printStack Empty            = []
printStack (Then      fn s) = printStack s  </> ";" </> fn </> ";"
printStack (Combined s1 s2) = printStack s2 </> printStack s1
printStack (Recursed s1 s2) = printStack s2 </> printStack s1 </> "..."

-- | Creating an empty stack
emptyStack :: Stack
emptyStack = Empty

-- | Create a new stack from a template
newStack :: FunctionName -> Stack
newStack fn = pushStack Empty fn

-- | Adding an element to the top of the stack
pushStack :: Stackable st => st -> FunctionName -> Stack
pushStack = flip Then . toStack

-- | Remove an element from the top of the stack
popStack :: Stack -> Stack
popStack Empty            = error "An empty stack cannot be popped"
popStack (Then     _   s) = s
popStack (Combined s1 s2) = Combined (popStack s1) s2
popStack (Recursed s1 s2) = Recursed (popStack s1) s2

-- | Look at the item at the top of the stack, but does not remove it
topStack :: Stack -> Maybe FunctionName
topStack Empty            = Nothing
topStack (Then     fn  s) = Just fn
topStack (Combined s1 s2) = topStack s1
topStack (Recursed s1 s2) = topStack s1

-- | The size of the stack e.g the amount of elements inside it
sizeStack :: Stack -> Int
sizeStack Empty      = 0
sizeStack (Then _ s) = 1 + sizeStack s
sizeStack (Combined s1 s2) = sizeStack s1 + sizeStack s2
sizeStack (Recursed s1 s2) = sizeStack s1 + sizeStack s2

-- | Shrinks and Compress the stack, reducing the stack to the bare minimum
--   of steps/calls needed to represent the same stack
shrinkStack :: Stack -> Stack
shrinkStack = id