suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Finished converting all the cases in testInputCase to use the new occam EDSL

Browse Source
This commit is contained in:
Neil Brown 2008-11-16 16:57:52 +00:00
parent 9ac861ac93
commit 771297632d
2 changed files with 106 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
common/OccamEDSL.hs
View File

@ -18,13 +18,13 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | The necessary components for using an occam EDSL (for building test-cases). -- | The necessary components for using an occam EDSL (for building test-cases).
module OccamEDSL (ExpInp, ExpInpT, oSEQ, oPAR, oPROC, oSKIP, oINT, module OccamEDSL (ExpInp, ExpInpT, oSEQ, oPAR, oPROC, oSKIP, oINT,
oCASE, oCASEinput, oCASE, oCASEinput, oALT, guard,
Occ, oA, oB, oC, oX, oY, oZ, (*?), (*!), (*:=), decl, decl', oempty, testOccamPass, Occ, oA, oB, oC, oX, oY, oZ, p0, p1, p2, (*?), (*!), (*:=), decl, decl', oempty, testOccamPass,
testOccamPassTransform, ExpInpC(shouldComeFrom), testOccamPassTransform, ExpInpC(shouldComeFrom),
caseOption, inputCaseOption, caseOption, inputCaseOption,
becomes) where becomes) where
import Control.Monad.State import Control.Monad.State hiding (guard)
import Data.Generics import Data.Generics
import qualified Data.Map as Map import qualified Data.Map as Map
import Test.HUnit hiding (State) import Test.HUnit hiding (State)
@ -165,6 +165,12 @@ instance Castable (A.Structured A.Variant) A.Variant where
makeStruct = id makeStruct = id
makePlain = A.Only emptyMeta 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, oPAR :: Castable c A.Process => [O (A.Structured A.Process)] -> O c
oSEQ = liftM (makePlain . A.Seq emptyMeta . singlify . A.Several emptyMeta) . sequence oSEQ = liftM (makePlain . A.Seq emptyMeta . singlify . A.Several emptyMeta) . sequence
oPAR = liftM (makePlain . A.Par emptyMeta A.PlainPar . 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 os' <- sequence os
return $ makePlain $ A.Case emptyMeta e' $ singlify $ A.Several emptyMeta 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 :: (CanBeExpression e, Castable c A.Option) => ([e], O A.Process) -> O c
caseOption (es, p) = mapM (liftExpInp . expr) es >>= \es' -> return $ makePlain $ A.Option emptyMeta es' p 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 :: (Castable c A.Variant) => (A.Name, [ExpInp A.Variable], O A.Process) -> O c
inputCaseOption (n, is, p) = return $ makePlain $ A.Variant emptyMeta n is p 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 :: [O (A.Structured A.Variant)] -> O (A.Structured A.Variant)
oCASEinput = liftM (singlify . A.Several emptyMeta) . sequence 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 :: Data a => A.Structured a -> A.Structured a
singlify (A.Several _ [s]) = s singlify (A.Several _ [s]) = s
singlify ss = ss singlify ss = ss
@ -216,11 +237,11 @@ oX = return $ variable "X"
oY = return $ variable "Y" oY = return $ variable "Y"
oZ = return $ variable "Z" 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 (*?) bch bdest = do
ch <- liftExpInp bch ch <- liftExpInp bch
dest <- liftExpInp bdest >>* inputItem 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) (*!), (*:=) :: CanBeExpression e => ExpInp A.Variable -> ExpInp e -> O (A.Structured A.Process)
(*!) bch bsrc = do (*!) bch bsrc = do
@ -276,9 +297,15 @@ class CanBeInput a where
instance CanBeInput A.Variable where instance CanBeInput A.Variable where
inputItem v = A.InputSimple emptyMeta [A.InVariable emptyMeta v] 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 instance CanBeInput (A.Structured A.Variant) where
inputItem = A.InputCase emptyMeta inputItem = A.InputCase emptyMeta
instance CanBeInput A.InputMode where
inputItem = id
oempty :: Data a => O (A.Structured a) oempty :: Data a => O (A.Structured a)
oempty = return $ A.Several emptyMeta [] oempty = return $ A.Several emptyMeta []

142
transformations/PassTest.hs
View File

@ -19,7 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | Contains test for various shared passes. -- | Contains test for various shared passes.
module PassTest (tests) where module PassTest (tests) where
import Control.Monad.State import Control.Monad.State hiding (guard)
import Data.Generics import Data.Generics
import qualified Data.Map as Map import qualified Data.Map as Map
import Test.HUnit hiding (State) import Test.HUnit hiding (State)
@ -350,7 +350,7 @@ testInputCase = TestList
testOccamPassTransform "testInputCase 0" (nameAndStopCaringPattern "tag" "A") ( testOccamPassTransform "testInputCase 0" (nameAndStopCaringPattern "tag" "A") (
defineProtocolAndC $ defineProtocolAndC $
(oC *? oCASEinput (oC *? oCASEinput
[inputCaseOption (simpleName "a0", [], p0)] [inputCaseOption (a0, [], p0)]
) )
`becomes` `becomes`
oSEQ oSEQ
@ -389,30 +389,30 @@ testInputCase = TestList
c ? x ; y c ? x ; y
--Process p2 --Process p2
-} -}
,TestCase $ testPass "testInputCase 1" ,testOccamPassTransform "testInputCase 1" (nameAndStopCaringPattern "tag" "A") (
(tag2 A.Seq DontCare $ defineProtocolAndC $
mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ mDeclaration A.Int) $ (oC *? oCASEinput
mSeveralP [inputCaseOption (a0, [], p0)
[mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] ,inputCaseOption (c1, [oZ], p1)
,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ mSeveralO ,inputCaseOption (b2, [oX, oY], p2)
[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]
]
] ]
) )
transformInputCase ( `becomes`
A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta oSEQ
[A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0 [decl (return A.Int) oA
,A.Only emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1 [oC *? oA
,A.Only emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2 ,oCASE oA
[caseOption ([0 :: Int], p0)
,caseOption ([2 :: Int], oSEQ
[oC *? oZ
,p1])
,caseOption ([1 :: Int], oSEQ
[oC *? sequence [oX, oY]
,p2])
] ]
) ]
(defineMyProtocol >> defineC) ]
) transformInputCase
-- Input that involves multiple tags and multiple inputs and specs (sheesh!): -- Input that involves multiple tags and multiple inputs and specs (sheesh!):
{- {-
@ -447,32 +447,34 @@ testInputCase = TestList
c ? x ; y c ? x ; y
--Process p2 --Process p2
-} -}
,TestCase $ testPass "testInputCase 2" ,testOccamPassTransform "testInputCase 2" (nameAndStopCaringPattern "tag" "A") (
(tag2 A.Seq DontCare $ defineProtocolAndC $
mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ mDeclaration A.Int) $ (oC *? oCASEinput
mSeveralP [inputCaseOption (a0, [], p0)
[mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] ,decl (return A.Int) oZ [inputCaseOption (c1, [oZ], p1)]
,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ mSeveralO ,decl (return A.Int) oX
[mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0 [decl (return A.Int) oY
,specIntPatt "z" $ mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 2] $ [inputCaseOption (b2, [oX, oY], p2)]]
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]
]
] ]
) )
transformInputCase ( `becomes`
A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta oSEQ
[A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0 [decl (return A.Int) oA
,specInt "z" $ A.Only emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1 [oC *? oA
,specInt "x" $ specInt "y" $ A.Only emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2 ,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])]]
] ]
) ]
(defineMyProtocol >> defineC) ]
) transformInputCase
--TODO test alt guards
-- Input that only involves tags: -- Input that only involves tags:
{- {-
@ -489,50 +491,34 @@ testInputCase = TestList
a0 a0
--Process p0 --Process p0
-} -}
,TestCase $ testPass "testInputCase 100" ,testOccamPassTransform "testInputCase 100" (nameAndStopCaringPattern "tag" "A") (
(tag3 A.Alt DontCare False $ defineProtocolAndC $
mSpecA (tag3 A.Specification DontCare (Named "tag" DontCare) $ mDeclaration A.Int) $ (oALT
mOnlyA $ mAlternative (A.True emptyMeta) c [guard (oC *? oCASEinput
(tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]) $ [inputCaseOption (a0, [], p0)], return $ A.Skip emptyMeta)
tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ ]
mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0
) )
transformInputCase ( `becomes`
A.Alt emptyMeta False $ A.Only emptyMeta $ A.Alternative emptyMeta (A.True emptyMeta) c oALT
(A.InputCase emptyMeta $ A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0) [decl (return A.Int) oA
(A.Skip emptyMeta) [guard (oC *? oA,
) oCASE oA
(defineMyProtocol >> defineC) [caseOption ([0 :: Int], p0)])
]
]
) transformInputCase
] ]
where 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" a0 = simpleName "a0"
b2 = simpleName "b2" b2 = simpleName "b2"
c1 = simpleName "c1" 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 = defineProtocolAndC =
decl' (simpleName "prot") (A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])]) 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")) . (:[]) . decl (return $ A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot"))
oC . (:[]) 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 :: Test
testTransformProtocolInput = TestList testTransformProtocolInput = TestList
[ [