mirror of
https://github.com/achlipala/frap.git
synced 2024-11-10 00:07:51 +00:00
Start of SessionTypes
This commit is contained in:
Adam Chlipala
parent
b3705cc79e
commit
91fc06122d
1 changed files with 225 additions and 0 deletions
225
SessionTypes.v
Normal file
225
SessionTypes.v
Normal file
|
|
@ -0,0 +1,225 @@
|
|||
(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
|
||||
* Chapter 20: Session Types
|
||||
* Author: Adam Chlipala
|
||||
* License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)
|
||||
|
||||
Require Import Frap MessagesAndRefinement.
|
||||
|
||||
Set Implicit Arguments.
|
||||
Set Asymmetric Patterns.
|
||||
|
||||
|
||||
(** * Defining the Type System *)
|
||||
|
||||
Inductive type :=
|
||||
| TSend (ch : channel) (A : Set) (t : type)
|
||||
| TRecv (ch : channel) (A : Set) (t : type)
|
||||
| TPar (t1 t2 : type)
|
||||
| TDup (t : type)
|
||||
| TDone
|
||||
|
||||
| InternalChoice (t1 t2 : type)
|
||||
| ExternalChoice (t1 t2 : type).
|
||||
|
||||
Infix "||" := Par : st_scope.
|
||||
Delimit Scope st_scope with st.
|
||||
Bind Scope st_scope with type.
|
||||
Notation "!!! ch ( A ) ; k" := (TSend ch A k%st) (right associativity, at level 45, ch at level 0) : st_scope.
|
||||
Notation "??? ch ( A ) ; k" := (TRecv ch A k%st) (right associativity, at level 45, ch at level 0) : st_scope.
|
||||
Infix "|?|" := InternalChoice (at level 40) : st_scope.
|
||||
Infix "?|?" := ExternalChoice (at level 40) : st_scope.
|
||||
|
||||
|
||||
Inductive ignoresChannel (ch : channel) : type -> Prop :=
|
||||
| IcSend : forall ch' A t,
|
||||
ch' <> ch
|
||||
-> ignoresChannel ch t
|
||||
-> ignoresChannel ch (TSend ch' A t)
|
||||
| IcRecv : forall ch' A t,
|
||||
ch' <> ch
|
||||
-> ignoresChannel ch t
|
||||
-> ignoresChannel ch (TRecv ch' A t)
|
||||
| IcPar : forall t1 t2,
|
||||
ignoresChannel ch t1
|
||||
-> ignoresChannel ch t2
|
||||
-> ignoresChannel ch (TPar t1 t2)
|
||||
| IcDup : forall t,
|
||||
ignoresChannel ch t
|
||||
-> ignoresChannel ch (TDup t)
|
||||
| IcDone :
|
||||
ignoresChannel ch TDone
|
||||
|
||||
| IcInternalChoice : forall t1 t2,
|
||||
ignoresChannel ch t1
|
||||
-> ignoresChannel ch t2
|
||||
-> ignoresChannel ch (InternalChoice t1 t2)
|
||||
| IcExternalChoice : forall t1 t2,
|
||||
ignoresChannel ch t1
|
||||
-> ignoresChannel ch t2
|
||||
-> ignoresChannel ch (ExternalChoice t1 t2).
|
||||
|
||||
Inductive hideChannel (ch : channel) : type -> type -> Prop :=
|
||||
| HideIgnored : forall t,
|
||||
ignoresChannel ch t
|
||||
-> hideChannel ch t t
|
||||
|
||||
| HideExtSend1 : forall ch' A t1 t2 t',
|
||||
ch' <> ch
|
||||
-> ignoresChannel ch' t2
|
||||
-> hideChannel ch (TPar t1 t2) t'
|
||||
-> hideChannel ch (TPar (TSend ch' A t1) t2) (TSend ch' A t')
|
||||
| HideExtRecv1 : forall ch' A t1 t2 t',
|
||||
ch' <> ch
|
||||
-> ignoresChannel ch' t2
|
||||
-> hideChannel ch (TPar t1 t2) t'
|
||||
-> hideChannel ch (TPar (TRecv ch' A t1) t2) (TRecv ch' A t')
|
||||
| HideExtSend2 : forall ch' A t1 t2 t',
|
||||
ch' <> ch
|
||||
-> ignoresChannel ch' t2
|
||||
-> hideChannel ch (TPar t1 t2) t'
|
||||
-> hideChannel ch (TPar t1 (TSend ch' A t2)) (TSend ch' A t')
|
||||
| HideExtRecv2 : forall ch' A t1 t2 t',
|
||||
ch' <> ch
|
||||
-> ignoresChannel ch' t2
|
||||
-> hideChannel ch (TPar t1 t2) t'
|
||||
-> hideChannel ch (TPar t1 (TRecv ch' A t2)) (TRecv ch' A t')
|
||||
|
||||
| HideRendezvous1 : forall A t1 t2 t',
|
||||
hideChannel ch (TPar t1 t2) t'
|
||||
-> hideChannel ch (TPar (TSend ch A t1) (TRecv ch A t2)) t'
|
||||
| HideRendezvous2 : forall A t1 t2 t',
|
||||
hideChannel ch (TPar t1 t2) t'
|
||||
-> hideChannel ch (TPar (TRecv ch A t1) (TSend ch A t2)) t'.
|
||||
|
||||
Fixpoint shrink (t : type) : type :=
|
||||
match t with
|
||||
| TSend ch A t1 => TSend ch A (shrink t1)
|
||||
| TRecv ch A t1 => TRecv ch A (shrink t1)
|
||||
| TPar t1 t2 =>
|
||||
let t1' := shrink t1 in
|
||||
let t2' := shrink t2 in
|
||||
match t1', t2' with
|
||||
| TDone, _ => t2'
|
||||
| _, TDone => t1'
|
||||
| _, _ => TPar t1' t2'
|
||||
end
|
||||
| TDup t1 =>
|
||||
let t1' := shrink t1 in
|
||||
match t1' with
|
||||
| TDone => TDone
|
||||
| _ => TDup t1'
|
||||
end
|
||||
| TDone => TDone
|
||||
|
||||
| InternalChoice t1 t2 => InternalChoice (shrink t1) (shrink t2)
|
||||
| ExternalChoice t1 t2 => ExternalChoice (shrink t1) (shrink t2)
|
||||
end.
|
||||
|
||||
Inductive hasty : proc -> type -> Prop :=
|
||||
| HtNewChannel : forall notThese k t tc tcs,
|
||||
(forall ch, ~In ch notThese -> hasty (k ch) (t ch))
|
||||
-> (forall ch, ~In ch notThese -> hideChannel ch (t ch) tc)
|
||||
-> shrink tc = tcs
|
||||
-> hasty (NewChannel notThese k) tcs
|
||||
| HtBlockChannel : forall ch pr t tc tcs,
|
||||
hasty pr t
|
||||
-> hideChannel ch t tc
|
||||
-> shrink tc = tcs
|
||||
-> hasty (BlockChannel ch pr) tcs
|
||||
| HtSend : forall ch (A : Set) (v : A) k t,
|
||||
hasty k t
|
||||
-> hasty (Send ch v k) (TSend ch A t)
|
||||
| HtRecv : forall ch (A : Set) (k : A -> _) t,
|
||||
(forall v, hasty (k v) t)
|
||||
-> hasty (Recv ch k) (TRecv ch A t)
|
||||
| HtPar : forall pr1 pr2 t1 t2,
|
||||
hasty pr1 t1
|
||||
-> hasty pr2 t2
|
||||
-> hasty (Par pr1 pr2) (TPar t1 t2)
|
||||
| HtDup : forall pr t,
|
||||
hasty pr t
|
||||
-> hasty (Dup pr) (TDup t)
|
||||
| HtDone :
|
||||
hasty Done TDone
|
||||
|
||||
| HtInternalChoice1 : forall pr t1 t2,
|
||||
hasty pr t1
|
||||
-> hasty pr (InternalChoice t1 t2)
|
||||
| HtInternalChoice2 : forall pr t1 t2,
|
||||
hasty pr t2
|
||||
-> hasty pr (InternalChoice t1 t2)
|
||||
| HtExternalChoice : forall pr t1 t2,
|
||||
hasty pr t1
|
||||
-> hasty pr t2
|
||||
-> hasty pr (ExternalChoice t1 t2).
|
||||
|
||||
|
||||
(** * Examples of Typed Processes *)
|
||||
|
||||
(* Recall our first example from last chapter. *)
|
||||
Definition addN (k : nat) (input output : channel) : proc :=
|
||||
??input(n : nat);
|
||||
!!output(n + k);
|
||||
Done.
|
||||
|
||||
Theorem addN_typed : forall k input output,
|
||||
hasty (addN k input output) (???input(nat); !!!output(nat); TDone).
|
||||
Proof.
|
||||
simplify.
|
||||
repeat (constructor; simplify).
|
||||
Qed.
|
||||
|
||||
Definition add2 (input output : channel) : proc :=
|
||||
Dup (New[input;output](intermediate);
|
||||
addN 1 input intermediate
|
||||
|| addN 1 intermediate output).
|
||||
|
||||
Ltac hide1 := apply HideRendezvous1 || apply HideRendezvous2
|
||||
|| (eapply HideIgnored; repeat constructor; equality)
|
||||
|| (eapply HideExtSend1; [ equality | repeat constructor; equality | ])
|
||||
|| (eapply HideExtRecv1; [ equality | repeat constructor; equality | ])
|
||||
|| (eapply HideExtSend2; [ equality | repeat constructor; equality | ])
|
||||
|| (eapply HideExtRecv2; [ equality | repeat constructor; equality | ]).
|
||||
|
||||
Ltac hide := repeat hide1.
|
||||
|
||||
Ltac hasty1 :=
|
||||
match goal with
|
||||
| [ |- hasty _ _ ] => econstructor; simplify
|
||||
end.
|
||||
|
||||
Ltac hasty := simplify; repeat hasty1; simplify; hide; try equality.
|
||||
|
||||
Theorem add2_typed : forall input output,
|
||||
input <> output
|
||||
-> hasty (add2 input output) (TDup (???input(nat); !!!output(nat); TDone)).
|
||||
Proof.
|
||||
hasty.
|
||||
Qed.
|
||||
|
||||
|
||||
(** * Complementing Types *)
|
||||
|
||||
Fixpoint complement (t : type) : type :=
|
||||
match t with
|
||||
| TSend ch A t1 => TRecv ch A (complement t1)
|
||||
| TRecv ch A t1 => TSend ch A (complement t1)
|
||||
| TPar t1 t2 => TPar (complement t1) (complement t2)
|
||||
| TDup t1 => TDup (complement t1)
|
||||
| TDone => TDone
|
||||
|
||||
| InternalChoice t1 t2 => ExternalChoice (complement t1) (complement t2)
|
||||
| ExternalChoice t1 t2 => InternalChoice (complement t1) (complement t2)
|
||||
end.
|
||||
|
||||
Definition add2_client (input output : channel) : proc :=
|
||||
Dup (!!input(42);
|
||||
??output(_ : nat);
|
||||
Done).
|
||||
|
||||
Theorem add2_client_typed : forall input output,
|
||||
input <> output
|
||||
-> hasty (add2_client input output) (complement (TDup (???input(nat); !!!output(nat); TDone))).
|
||||
Proof.
|
||||
hasty.
|
||||
Qed.
|
||||
Loading…
Reference in a new issue