{-# 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

import Join

-- a concurrent stack implemented using the Join interface built on top of multisetrewrite



-- short-hands


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

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


-- method pattern and calls

-- pattern
push x = method "Push" x
pop x =  method "Pop" x
stack x = method "Stack" x

callPush join x = call join "Push" x

callPop join  = do
 x <- newSync 
 call join "Pop" x
 v <- waitSync x
 return v

callStack join x = call join "Stack" x

-- concurrent stack rules
                        
stackRules join activeMethod = do
  y <- newVar :: IO (VAR (Sync Int))
  x <- newVar :: IO (VAR Int)
  s <- newVar :: IO (VAR [Int])
  let prog = 
       compileRulePattern
       [ 
         [push x, stack s] .->. 
                do v_s <- readVar s
                   v_x <- readVar x
                   callStack join (v_x:v_s)
                   return ()
       , [pop y, stack s] `when` (isNotEmptyStack s) .->.
                do (t:rest) <- readVar s
                   y .=. t
                   callStack join rest
                   return ()
       , [push x, pop y] .->. y .=. x
       ]

  res <- executeRules (store join) activeMethod prog
  case res of
    Just action -> action
    Nothing -> 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

  jStore <- newJoinStore 
  let join = Join {store = jStore, rules = stackRules}
  callStack join ([1] :: [Int])

  mapM (\x -> forkIO $ callPush join x) ([1..no])

  mapM (\_ -> forkIO ( do v :: Int <- callPop join 
                          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