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
[