module Join.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
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)
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)
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)
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)
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