{-# LANGUAGE PatternSignatures, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, MultiParamTypeClasses  #-}

module Join where

import IO
import Monad hiding (when)
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.STM

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


-- join-style concurrency built on top of multisetrewrite


------------------------------------------------------
-- Boiler plate code to encode a asynchronous and synchronous methods
-- constraints of the following form
--   C     ::=  Name Args
--   Name ::= String
--   Args ::= () | B | (B,B) | (B,B,B)   -- constant, unary, binary, tenary predicates
--   B    ::= x -- variables
--         |  i -- integers
--         |  s -- strings
--         |  b -- booleans
--         |  tv int -- tvar int
--         | [i]

-- it's easy to support further 'primitive' types by extending
-- the boiler plate code below.

-- message types (well here methods)

data Method = C String [Argument]

data Argument = ArgInt (L Int)
              | ArgString (L String)
              | ArgBool (L Bool) 
              | ArgTVarInt (L (TVar Int))
              | ArgListInt (L [Int])
              | ArgSyncInt (L (MVar Int))
              | ArgSyncString (L (MVar String))
              | ArgSyncBool (L (MVar Bool))         deriving (Eq, Show)
              -- we could use typed syntax
           

-- boilerplate

valHashOpMsg = HashOp {numberOfTables = 1,
                       hashMsg = \ _ -> 1
                      }

instance Eq Method where
   (==) (C s1 a1) (C s2 a2) = (s1 == s2) && (a1 == a2)

instance Show Method
instance Show (MVar Int)
instance Show (MVar Bool)
instance Show (MVar String)
instance Show (TVar Int)

instance Show a => Show (L a)

instance EMatch Method where
  match tags (C s1 a1) (C s2 a2) = 
         if s1 == s2 then 
           foldM (\ (b,cur_tags) -> \ (a1,a2) -> do
                       (b2, new_tags) <- match cur_tags a1 a2
                       return (b && b2, new_tags))
                 (True, tags)
                 (zip a1 a2)   
                    -- NOTE: user's responsibility to guarantee that
                    -- number of arguments are consistent
         else return (False, tags)


matchList tags a1 a2 = 
           foldM (\ (b,cur_tags) -> \ (a1,a2) -> do
                       (b2, new_tags) <- match cur_tags a1 a2
                       return (b && b2, new_tags))
                 (True, tags)
                 (zip a1 a2)   

instance EMatch Argument where
  match tags (ArgInt x) (ArgInt y) = match tags x y
  match tags (ArgBool x) (ArgBool y) = match tags x y
  match tags (ArgString x) (ArgString y) = match tags x y
  match tags (ArgTVarInt x) (ArgTVarInt y) = match tags x y
  match tags (ArgListInt x) (ArgListInt y) = match tags x y
  match tags (ArgSyncInt x) (ArgSyncInt y) = match tags x y
  match tags (ArgSyncBool x) (ArgSyncBool y) = match tags x y
  match tags (ArgSyncString x) (ArgSyncString y) = match tags x y
  match tags _ _ = return (False, tags)

instance EMatch [Int] where
  match tags x y = matchList tags x y

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

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

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

instance Eq a => EMatch (MVar a) where
  match tags x y = return (x==y, tags)

instance Eq a => EMatch (TVar a) where
  match tags x y = return (x==y, tags)

-- interface

class Cons a where
  cons :: String -> a -> Method

instance CollectArgs a => Cons a where
  cons s x = C s (collectArgs x)

class CollectArgs a where
  collectArgs :: a -> [Argument]


instance CollectArgs () where
   collectArgs _ = []

instance CollectArgs (VAR Int) where
   collectArgs x = [ArgInt (Var x)]
instance CollectArgs Int where
   collectArgs x = [ArgInt (Val x)]

instance CollectArgs (VAR Bool) where
   collectArgs x = [ArgBool (Var x)]
instance CollectArgs Bool where
   collectArgs x = [ArgBool (Val x)]

instance CollectArgs (VAR String) where
   collectArgs x = [ArgString (Var x)]
instance CollectArgs String where
   collectArgs x = [ArgString (Val x)]

instance CollectArgs (VAR (TVar Int)) where
   collectArgs x = [ArgTVarInt (Var x)]
instance CollectArgs (TVar Int) where
   collectArgs x = [ArgTVarInt (Val x)]

instance CollectArgs (VAR (MVar Int)) where
   collectArgs x = [ArgSyncInt (Var x)]
instance CollectArgs (MVar Int) where
   collectArgs x = [ArgSyncInt (Val x)]

instance CollectArgs (VAR (MVar Bool)) where
   collectArgs x = [ArgSyncBool (Var x)]
instance CollectArgs (MVar Bool) where
   collectArgs x = [ArgSyncBool (Val x)]

instance CollectArgs (VAR (MVar String)) where
   collectArgs x = [ArgSyncString (Var x)]
instance CollectArgs (MVar String) where
   collectArgs x = [ArgSyncString (Val x)]

instance CollectArgs (VAR [Int]) where
   collectArgs xs = [ArgListInt (Var xs)]
instance CollectArgs [Int] where
   collectArgs xs = [ArgListInt (Val xs)]

instance (CollectArgs a,
          CollectArgs b) => CollectArgs (a,b) where
   collectArgs (x,y) = (collectArgs x) ++ (collectArgs y)

instance (CollectArgs a,
          CollectArgs b,
          CollectArgs c) => CollectArgs (a,b,c) where
   collectArgs (x,y,z) = (collectArgs x) ++ (collectArgs y) ++ (collectArgs z)


-- user interface

type ActiveMethod = Location Method

data Join = Join { store :: Store Method,
                   rules :: Join -> ActiveMethod -> IO ()
                 }

newJoinStore :: IO (Store Method)
newJoinStore = newStore valHashOpMsg

type Sync a = MVar a

newSync= newEmptyMVar

waitSync = readMVar

method s args = cons s args

call :: (CollectArgs a) => Join -> String -> a -> IO ()
call join method args = do
  let m = cons method args
  activeMethod <- addMsg (store join) m
  forkIO $ (rules join) join activeMethod 
  return ()

class Assign a b where
   (.=.) :: a -> b -> IO ()


instance Assign (VAR (MVar a)) (VAR a) where
   (.=.) x y = do
     v_x <- readVar x
     v_y <- readVar y
     putMVar v_x v_y

instance Assign (VAR (MVar a)) a where
   (.=.) x v_y = do
     v_x <- readVar x
     putMVar v_x v_y