{-# LANGUAGE PatternSignatures, FlexibleInstances  #-}

import IO
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.STM

import MultiSetRewrite.Base
import MultiSetRewrite.RuleSyntax
import MultiSetRewrite.RuleCompiler
import MultiSetRewrite.StoreRepresentation


-- a concurrent stack implemented via join-patterns which are
-- built on top of multisetrewrite


------------------------------------------------------
-- Boiler plate code to encode a concurrent stack 

-- message types

data Msg = Push (L Int)
         | Pop (L (MVar Int))
         | Stack (L [Int])

-- boilerplate

valHashOpMsg = HashOp {numberOfTables = 3,
                       hashMsg = let h (Push _)  = 1
                                     h (Pop _)   = 2
                                     h (Stack _) = 3
                                 in h
                      }

instance Eq Msg where
   (==) (Push x) (Push y) = x == y
   (==) (Pop x) (Pop y) = x == y
   (==) (Stack x) (Stack y) = x == y
   (==) _ _ = False

instance Show Msg
instance Show (MVar Int)

instance EMatch Msg where
  match tags (Push x) (Push y) = match tags x y
  match tags (Pop x) (Pop y) = match tags x y
  match tags (Stack x) (Stack y) = match tags x y
  match tags _ _ = return (False, tags)

instance EMatch Int where
  match tags x y = return (x==y, tags)

instance EMatch [Int] where
  match tags x y = return (x==y, tags)

instance EMatch (MVar Int) where
  match tags x y = return (x==y, tags)

-- interface

class Push a where
  pushM :: a -> Msg

instance Push (VAR Int) where
  pushM x = Push (Var x)
instance Push Int where
  pushM x = Push (Val x)

class Pop a where
   popM :: a -> Msg

instance Pop (VAR (MVar Int)) where
   popM x = Pop (Var x)
instance Pop (MVar Int) where
   popM x = Pop (Val x)

class Stack a where
   stackM :: a -> Msg

instance Stack (VAR [Int]) where
   stackM x = Stack (Var x)
instance Stack [Int] where
   stackM x = Stack (Val x)

-- short-hands

assign x y = do
   v_x <- readVar x
   v_y <- readVar y
   putMVar v_x v_y

assign2 x v_y = do
   v_x <- readVar x
   putMVar v_x v_y

isEmptyStack s = do
   v_s <- readVar s
   return (null v_s)

isNotEmptyStack s = do
   v_s <- readVar s
   return (not (null v_s))


-- concurrent stack rules

ruleStack x y s storeObj= do
   compileRulePattern
       [ [pushM x, popM y] .->. y `assign` x
       , [pushM x, stackM s] .->. 
                do v_s <- readVar s
                   v_x <- readVar x
                   stack storeObj (v_x:v_s)
                   --addMsg storeObj (stackM (v_x:v_s))
                   -- is not enough, cause we must also 
                   -- invoke again the rule executer
                   return ()
       , [popM y, stackM s] `when` (isNotEmptyStack s) .->.
                do (t:rest) <- readVar s
                   y `assign2` t
                   stack storeObj rest
                   return ()
       ]
                        
runStack storeObj activeMsg = do
  y <- newVar :: IO (VAR (MVar Int))
  x <- newVar :: IO (VAR Int)
  s <- newVar :: IO (VAR [Int])
  let prog = ruleStack x y s storeObj
  res <- executeRules storeObj activeMsg prog
  case res of
    Just action -> action
    Nothing -> return ()    


----------------------------------------------
-- Concurrent stack interface

pop :: Store Msg -> IO Int
pop storeObj = do
  x <- newEmptyMVar
  activeMsg <- addMsg storeObj (popM x)
  forkIO (runStack storeObj activeMsg)
  v <- readMVar x
  return v


push :: Store Msg -> Int -> IO ()
push storeObj x = do
  activeMsg <- addMsg storeObj (pushM x)
  forkIO (runStack storeObj activeMsg)
  return ()

stack :: Store Msg -> [Int] -> IO ()
stack storeObj x = do
  activeMsg <- addMsg storeObj (stackM x)
  forkIO (runStack storeObj activeMsg)
  return ()



-- sample code

printOutput o = do
   b <- isEmptyChan o
   if b then return ()
    else do w <- readChan o
            putStrLn w
            printOutput o  

main :: IO ()
main = test1

test1 = do
  output <- newChan

  -- we count the number of successful pops
  cnt <- atomically $ newTVar 0
  let no :: Int = 20

  j <- newStore valHashOpMsg
  stack j ([1] :: [Int])

  mapM (\x -> forkIO $ push j x) ([1..no])

  mapM (\_ -> forkIO ( do v :: Int <- pop j 
                          writeChan output $ show v 
                          atomically $ do i <- readTVar cnt
                                          writeTVar cnt (i+1)))
       [1..no]


  atomically $ do i <- readTVar cnt
                  if i >= no then return ()
                   else retry

  printOutput output