diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index b00ced3..be95604 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -398,6 +398,37 @@ testInputCase = TestList (defineMyProtocol >> defineC) --TODO test alt guards + + -- Input that only involves tags: + {- + The idea is to transform: + ALT + c ? CASE + a0 + --Process p0 + into: + ALT + INT tag: + c ? tag + CASE tag + a0 + --Process p0 + -} + ,TestCase $ testPass "testInputCase 100" + (tag3 A.Alt DontCare False $ + tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag2 A.Declaration DontCare A.Int) $ + tag2 A.OnlyA DontCare $ tag4 A.Alternative DontCare 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)) $ + tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0 + ) + (transformInputCase $ + A.Alt emptyMeta False $ A.OnlyA emptyMeta $ A.Alternative emptyMeta c + (A.InputCase emptyMeta $ A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0) + (A.Skip emptyMeta) + ) + (defineMyProtocol >> defineC) + ] where -- Various distinct simple processes: diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 5e3b181..e9bf388 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -144,9 +144,13 @@ transformInputCase = doGeneric `extM` doProcess return $ A.Seq m $ A.Spec m' spec $ A.Several m' [A.OnlyP m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)]) ,A.OnlyP m' $ A.Case m' (A.ExprVariable m $ A.Variable m n) s'] + doProcess (A.Alt m pri s) + = do s' <- doStructured undefined s + return (A.Alt m pri s') doProcess p = doGeneric p doStructured :: A.Variable -> A.Structured -> PassM A.Structured + -- These entries all just burrow deeper into the structured: doStructured v (A.ProcThen m p s) = do s' <- doStructured v s p' <- doProcess p @@ -157,6 +161,11 @@ transformInputCase = doGeneric `extM` doProcess doStructured v (A.Several m ss) = do ss' <- mapM (doStructured v) ss return (A.Several m ss') + doStructured v (A.Rep m rep s) + = do s' <- doStructured v s + return (A.Rep m rep s') + + -- Transform variant options: doStructured chanVar (A.OnlyV m (A.Variant m' n iis p)) = do (Right items) <- protocolItems chanVar let (Just idx) = elemIndex n (fst $ unzip items) @@ -167,3 +176,20 @@ transformInputCase = doGeneric `extM` doProcess else A.Seq m' $ A.Several m' [A.OnlyP m' $ A.Input m' chanVar (A.InputSimple m' iis) ,A.OnlyP (findMeta p') p'] + + -- Transform alt guards: + -- The processes that are the body of input-case guards are always skip, so we can discard them: + doStructured _ (A.OnlyA m (A.Alternative m' v (A.InputCase m'' s) _)) + = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original + s' <- doStructured v s + return $ A.Spec m' spec $ A.OnlyA m $ + A.Alternative m' v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $ + A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s' + doStructured _ (A.OnlyA m (A.AlternativeCond m' e v (A.InputCase m'' s) _)) + = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original + s' <- doStructured v s + return $ A.Spec m' spec $ A.OnlyA m $ + A.AlternativeCond m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $ + A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s' + -- Leave other guards untouched: + doStructured _ a@(A.OnlyA {}) = return a