diff --git a/common/OccamEDSL.hs b/common/OccamEDSL.hs index 67577bc..85ab34f 100644 --- a/common/OccamEDSL.hs +++ b/common/OccamEDSL.hs @@ -18,13 +18,13 @@ with this program. If not, see . -- | The necessary components for using an occam EDSL (for building test-cases). module OccamEDSL (ExpInp, ExpInpT, oSEQ, oPAR, oPROC, oSKIP, oINT, - oCASE, oCASEinput, - Occ, oA, oB, oC, oX, oY, oZ, (*?), (*!), (*:=), decl, decl', oempty, testOccamPass, + oCASE, oCASEinput, oALT, guard, + Occ, oA, oB, oC, oX, oY, oZ, p0, p1, p2, (*?), (*!), (*:=), decl, decl', oempty, testOccamPass, testOccamPassTransform, ExpInpC(shouldComeFrom), - caseOption, inputCaseOption, + caseOption, inputCaseOption, becomes) where -import Control.Monad.State +import Control.Monad.State hiding (guard) import Data.Generics import qualified Data.Map as Map import Test.HUnit hiding (State) @@ -165,6 +165,12 @@ instance Castable (A.Structured A.Variant) A.Variant where makeStruct = id makePlain = A.Only emptyMeta +p0, p1, p2 :: Castable c A.Process => O c +p0 = return $ makePlain $ A.Skip emptyMeta +p1 = return $ makePlain $ A.Seq emptyMeta (A.Several emptyMeta []) +p2 = return $ makePlain $ A.Par emptyMeta A.PlainPar (A.Several emptyMeta []) + + oSEQ, oPAR :: Castable c A.Process => [O (A.Structured A.Process)] -> O c oSEQ = liftM (makePlain . A.Seq emptyMeta . singlify . A.Several emptyMeta) . sequence oPAR = liftM (makePlain . A.Par emptyMeta A.PlainPar . singlify . A.Several emptyMeta) . sequence @@ -175,16 +181,31 @@ oCASE e os = do os' <- sequence os return $ makePlain $ A.Case emptyMeta e' $ singlify $ A.Several emptyMeta os' -caseOption :: (CanBeExpression e, Castable c A.Option) => ([e], A.Process) -> O c -caseOption (es, p) = mapM (liftExpInp . expr) es >>= \es' -> return $ makePlain $ A.Option emptyMeta es' p +caseOption :: (CanBeExpression e, Castable c A.Option) => ([e], O A.Process) -> O c +caseOption (es, p) + = do es' <- mapM (liftExpInp . expr) es + p' <- p + return $ makePlain $ A.Option emptyMeta es' p' -inputCaseOption :: (Castable c A.Variant) => (A.Name, [A.InputItem], A.Process) -> O c -inputCaseOption (n, is, p) = return $ makePlain $ A.Variant emptyMeta n is p +inputCaseOption :: (Castable c A.Variant) => (A.Name, [ExpInp A.Variable], O A.Process) -> O c +inputCaseOption (n, is, p) + = do is' <- sequence $ map liftExpInp is + p' <- p + return $ makePlain $ A.Variant emptyMeta n (map (A.InVariable emptyMeta) is') p' oCASEinput :: [O (A.Structured A.Variant)] -> O (A.Structured A.Variant) oCASEinput = liftM (singlify . A.Several emptyMeta) . sequence +oALT :: Castable c A.Process => [O (A.Structured A.Alternative)] -> O c +oALT = liftM (makePlain . A.Alt emptyMeta False . singlify . A.Several emptyMeta) . sequence + +guard :: (O A.Process, O A.Process) -> O (A.Structured A.Alternative) +guard (inp, body) + = do (A.Input m v im) <- inp + body' <- body + return $ A.Only emptyMeta $ A.Alternative m (A.True emptyMeta) v im body' + singlify :: Data a => A.Structured a -> A.Structured a singlify (A.Several _ [s]) = s singlify ss = ss @@ -216,11 +237,11 @@ oX = return $ variable "X" oY = return $ variable "Y" oZ = return $ variable "Z" -(*?) :: (ExpInpC c a, CanBeInput a) => ExpInp A.Variable -> c a -> O (A.Structured A.Process) +(*?) :: (Castable r A.Process, ExpInpC c a, CanBeInput a) => ExpInp A.Variable -> c a -> O r (*?) bch bdest = do ch <- liftExpInp bch dest <- liftExpInp bdest >>* inputItem - return $ A.Only emptyMeta $ A.Input emptyMeta ch dest + return $ makePlain $ A.Input emptyMeta ch dest (*!), (*:=) :: CanBeExpression e => ExpInp A.Variable -> ExpInp e -> O (A.Structured A.Process) (*!) bch bsrc = do @@ -276,9 +297,15 @@ class CanBeInput a where instance CanBeInput A.Variable where inputItem v = A.InputSimple emptyMeta [A.InVariable emptyMeta v] +instance CanBeInput [A.Variable] where + inputItem = A.InputSimple emptyMeta . map (A.InVariable emptyMeta) + instance CanBeInput (A.Structured A.Variant) where inputItem = A.InputCase emptyMeta +instance CanBeInput A.InputMode where + inputItem = id + oempty :: Data a => O (A.Structured a) oempty = return $ A.Several emptyMeta [] diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index 1b3380b..6e817fb 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -19,7 +19,7 @@ with this program. If not, see . -- | Contains test for various shared passes. module PassTest (tests) where -import Control.Monad.State +import Control.Monad.State hiding (guard) import Data.Generics import qualified Data.Map as Map import Test.HUnit hiding (State) @@ -350,7 +350,7 @@ testInputCase = TestList testOccamPassTransform "testInputCase 0" (nameAndStopCaringPattern "tag" "A") ( defineProtocolAndC $ (oC *? oCASEinput - [inputCaseOption (simpleName "a0", [], p0)] + [inputCaseOption (a0, [], p0)] ) `becomes` oSEQ @@ -389,30 +389,30 @@ testInputCase = TestList c ? x ; y --Process p2 -} - ,TestCase $ testPass "testInputCase 1" - (tag2 A.Seq DontCare $ - mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ mDeclaration A.Int) $ - mSeveralP - [mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] - ,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ mSeveralO - [mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0 - ,mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 2] $ - tag2 A.Seq DontCare $ mSeveralP - [mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],mOnlyP p1] - ,mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 1] $ - tag2 A.Seq DontCare $ mSeveralP - [mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],mOnlyP p2] + ,testOccamPassTransform "testInputCase 1" (nameAndStopCaringPattern "tag" "A") ( + defineProtocolAndC $ + (oC *? oCASEinput + [inputCaseOption (a0, [], p0) + ,inputCaseOption (c1, [oZ], p1) + ,inputCaseOption (b2, [oX, oY], p2) + ] + ) + `becomes` + oSEQ + [decl (return A.Int) oA + [oC *? oA + ,oCASE oA + [caseOption ([0 :: Int], p0) + ,caseOption ([2 :: Int], oSEQ + [oC *? oZ + ,p1]) + ,caseOption ([1 :: Int], oSEQ + [oC *? sequence [oX, oY] + ,p2]) + ] + ] ] - ] - ) - transformInputCase ( - A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta - [A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0 - ,A.Only emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1 - ,A.Only emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2 - ] - ) - (defineMyProtocol >> defineC) + ) transformInputCase -- Input that involves multiple tags and multiple inputs and specs (sheesh!): {- @@ -447,32 +447,34 @@ testInputCase = TestList c ? x ; y --Process p2 -} - ,TestCase $ testPass "testInputCase 2" - (tag2 A.Seq DontCare $ - mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ mDeclaration A.Int) $ - mSeveralP - [mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] - ,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ mSeveralO - [mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0 - ,specIntPatt "z" $ mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 2] $ - tag2 A.Seq DontCare $ mSeveralP - [mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],mOnlyP p1] - ,specIntPatt "x" $ specIntPatt "y" $ mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 1] $ - tag2 A.Seq DontCare $ mSeveralP - [mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],mOnlyP p2] + ,testOccamPassTransform "testInputCase 2" (nameAndStopCaringPattern "tag" "A") ( + defineProtocolAndC $ + (oC *? oCASEinput + [inputCaseOption (a0, [], p0) + ,decl (return A.Int) oZ [inputCaseOption (c1, [oZ], p1)] + ,decl (return A.Int) oX + [decl (return A.Int) oY + [inputCaseOption (b2, [oX, oY], p2)]] + ] + ) + `becomes` + oSEQ + [decl (return A.Int) oA + [oC *? oA + ,oCASE oA + [caseOption ([0 :: Int], p0) + ,decl (return A.Int) oZ [caseOption ([2 :: Int], oSEQ + [oC *? oZ + ,p1])] + ,decl (return A.Int) oX + [decl (return A.Int) oY + [caseOption ([1 :: Int], oSEQ + [oC *? sequence [oX, oY] + ,p2])]] + ] + ] ] - ] - ) - transformInputCase ( - A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta - [A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0 - ,specInt "z" $ A.Only emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1 - ,specInt "x" $ specInt "y" $ A.Only emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2 - ] - ) - (defineMyProtocol >> defineC) - - --TODO test alt guards + ) transformInputCase -- Input that only involves tags: {- @@ -489,50 +491,34 @@ testInputCase = TestList a0 --Process p0 -} - ,TestCase $ testPass "testInputCase 100" - (tag3 A.Alt DontCare False $ - mSpecA (tag3 A.Specification DontCare (Named "tag" DontCare) $ mDeclaration A.Int) $ - mOnlyA $ mAlternative (A.True emptyMeta) c - (tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]) $ - tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ - mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0 - ) - transformInputCase ( - A.Alt emptyMeta False $ A.Only emptyMeta $ A.Alternative emptyMeta (A.True emptyMeta) c - (A.InputCase emptyMeta $ A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0) - (A.Skip emptyMeta) - ) - (defineMyProtocol >> defineC) - + ,testOccamPassTransform "testInputCase 100" (nameAndStopCaringPattern "tag" "A") ( + defineProtocolAndC $ + (oALT + [guard (oC *? oCASEinput + [inputCaseOption (a0, [], p0)], return $ A.Skip emptyMeta) + ] + ) + `becomes` + oALT + [decl (return A.Int) oA + [guard (oC *? oA, + oCASE oA + [caseOption ([0 :: Int], p0)]) + ] + ] + ) transformInputCase ] where - -- Various distinct simple processes: - p0 = A.Skip emptyMeta - p1 = A.Seq emptyMeta (A.Several emptyMeta []) - p2 = A.Stop emptyMeta - c = variable "c" - x = variable "x" - y = variable "y" - z = variable "z" a0 = simpleName "a0" b2 = simpleName "b2" c1 = simpleName "c1" - defineMyProtocol :: CSM m => m () - defineMyProtocol = defineName (simpleName "prot") $ A.NameDef emptyMeta "prot" "prot" - (A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])]) - A.Original A.Unplaced - defineC :: CSM m => m () - defineC = defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot")) - defineProtocolAndC :: Data a => Occ (A.Structured a) -> Occ (A.Structured a) + defineProtocolAndC :: Occ (A.Structured A.Process) -> Occ (A.Structured A.Process) defineProtocolAndC = decl' (simpleName "prot") (A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])]) . (:[]) . decl (return $ A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot")) oC . (:[]) - specInt s = A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int) - specIntPatt s = mSpecA' emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int) - testTransformProtocolInput :: Test testTransformProtocolInput = TestList [