module MultiSetRewrite.StorePrettyPrinter where
import Data.IORef
import Control.Concurrent
import Control.Concurrent.STM
import MultiSetRewrite.ConcurrentBag as B
import MultiSetRewrite.ConcurrentList as L
import MultiSetRewrite.Base
import MultiSetRewrite.StoreRepresentation
retrieveList :: ListHandle a -> IO [a]
retrieveList (ListHandle {headList = ptrPtr}) =
do { startptr <-
do { ptr <- readIORef ptrPtr
; Head {next = startptr} <- readIORef ptr
; return startptr }
; retrieveListHelp startptr }
where
retrieveListHelp :: IORef (List a) -> IO [a]
retrieveListHelp curNodePtr =
do { curNode <- readIORef curNodePtr
; case curNode of
Null -> return []
Node {val = curval, next = curnext} ->
do { as <- retrieveListHelp curnext
; return $ curval:as }
DelNode {next = curnext} -> retrieveListHelp curnext
}
retrieveBag :: Bag a -> IO [a]
retrieveBag (Bag _ ls) =
do { ass <- mapM retrieveList ls
; return $ foldl (++) [] ass }
class PrettyPrint a where
prettyIt :: a -> IO String
prettyItList :: PrettyPrint a => [a] -> String -> IO String
prettyItList [] _ = return ""
prettyItList [a] _ = prettyIt a
prettyItList (a:as) d = do
{ s <- prettyIt a
; s' <- prettyItList as d
; return $ s ++ d ++ s' }
instance PrettyPrint a => PrettyPrint (VAR a) where
prettyIt (VAR iref _) = do
{ v <- readIORef iref
; prettyIt v }
prettyIt DontCare = return "_"
instance PrettyPrint a => PrettyPrint (L a) where
prettyIt (Val a) = prettyIt a
prettyIt (Var var) = prettyIt var
instance PrettyPrint a => PrettyPrint [a] where
prettyIt [a] = prettyIt a
prettyIt (a:as) = do
{ s <- prettyIt a
; s' <- prettyIt as
; return $ s ++ "," ++ s' }
instance PrettyPrint Int where
prettyIt i = return $ show i
instance PrettyPrint Char where
prettyIt c = return $ show c
instance PrettyPrint Bool where
prettyIt b = return $ show b
instance PrettyPrint a => PrettyPrint (MVar a) where
prettyIt mv = do
{ mb <- tryTakeMVar mv
; case mb of
Just v -> do { s <- prettyIt v
; tryPutMVar mv v
; return s }
Nothing -> return "?" }
instance PrettyPrint a => PrettyPrint (TVar a) where
prettyIt tv = do
{ v <- atomically $ readTVar tv
; prettyIt v }
instance PrettyPrint a => PrettyPrint (InternalMsg a) where
prettyIt (InternalMsg a _) = prettyIt a
instance PrettyPrint a => PrettyPrint (B.Bag a) where
prettyIt bag = do
{ as <- retrieveBag bag
; prettyItList as "," }
instance PrettyPrint a => PrettyPrint (Store a) where
prettyIt (Store as _) = prettyItList as "\n"