polylet

examples/BasicDemos/Demo.ml

@@ -2,7 +2,19 @@
 (*---------polymorphism -----------*)
 
 
-let test_poly () = let x = [] in x
+let poly_top = []
+
+let poly_let_1 () = 
+  let x = [] in x
+
+let poly_let_2 () = 
+  let x = ([], []) in x
+
+let poly_let_2_same () =
+  let x : ('a list * 'a list) = ([], []) in x
+ 
+let poly_let_2_partial () =
+  let x : ('a list * int list) = ([], []) in x
 
 
 (*---------simple record------------*)

examples/BasicDemos/Demo_proof.v

@@ -3,22 +3,54 @@ Set Implicit Arguments.
 Require Import CFLib LibInt LibWf (*Facts*) Demo_ml.
 
 
+
 (*************************************************************************)
+(** * Polymorphic let demos *)
 
-(*
-let test_poly () = let x = [] in x
-*)
 
-Lemma test_poly_spec : forall A,
-  Spec test_poly () |B>>
-  B \[] (fun (x:list A) => \[x = @nil A]).
-Proof.
-  intros. xcf. 
-  apply local_erase. intros x Ex.
-  xret.
-  hsimpl.
-  subst x. auto.
-Qed.
+(** Demo top-level polymorphic let. *)
+
+Lemma poly_top_spec : forall A,
+  poly_top = @nil A.
+Proof using. xcf. Qed.
+
+(** Demo local polymorphic let. *)
+
+Lemma poly_let_1_spec : forall A,
+  Spec poly_let_1 () |B>>
+    B \[] (fun (x:list A) => \[x = nil]).
+Proof using. xcf. xval. subst. xrets. auto. Qed.  
+
+(** Demo [xval_st P] *)
+
+Lemma poly_let_1_spec' : forall A,
+  Spec poly_let_1 () |B>>
+    B \[] (fun (x:list A) => \[x = nil]).
+Proof using. xcf. xval_st (fun a => a = @nil). extens~. xrets. subst~. Qed.
+
+(** Demo [xval_st P as x Hx] *)
+
+Lemma poly_let_1_spec'' : forall A,
+  Spec poly_let_1 () |B>>
+    B \[] (fun (x:list A) => \[x = nil]).
+Proof using. xcf. xval_st (fun a => a = @nil) as p Hp. extens~. xrets. subst~. Qed.
+
+(** Demo for partially-polymorphic values. *)
+
+Lemma poly_let_2_spec : forall A1 A2,
+  Spec poly_let_2 () |B>>
+    B \[] (fun '(x,y) : list A1 * list A2 => \[x = nil /\ y = nil]).
+Proof using. intros. xcf. xvals. xrets. auto. Qed.
+
+Lemma poly_let_2_same_spec : forall A,
+  Spec poly_let_2_same () |B>>
+    B \[] (fun '(x,y) : list A * list A => \[x = nil /\ y = nil]).
+Proof using. intros. xcf. xvals. xrets. auto. Qed.
+
+Lemma poly_let_2_partial_spec : forall A,
+  Spec poly_let_2_partial () |B>>
+    B \[] (fun '(x,y) : list A * list int => \[x = nil /\ y = nil]).
+Proof using. intros. xcf. xval as p Hp. subst p. xrets. auto. Qed.
 
 
 

lib/coq/CFPrint.v

@@ -268,12 +268,30 @@ Notation "'App' f x1 x2 x3 x4 ;" :=
 
 Notation "'AppReturns'" := (@app_1 _ _). 
 
-(** Let / Seq / Pay *)
+(** LetVal *)
 
 Notation "'LetVal' x ':=' V 'in' F" :=
   (!V (fun H Q => forall x, x = V -> F H Q))
   (at level 69, x ident) : charac.
 
+Notation "'LetVal' [ A1 ] x ':=' V 'in' F" :=
+  (!V (fun H Q => forall x, x = (fun (A1:Type) => V) -> F H Q))
+  (at level 69, x ident, A1 ident) : charac.
+
+Notation "'LetVal' [ A1 A2 ] x ':=' V 'in' F" :=
+  (!V (fun H Q => forall x, x = (fun (A1 A2:Type) => V) -> F H Q))
+  (at level 69, x ident, A1 ident, A2 ident) : charac.
+
+Notation "'LetVal' [ A1 A2 A3 ] x ':=' V 'in' F" :=
+  (!V (fun H Q => forall x, x = (fun (A1 A2 A3:Type) => V) -> F H Q))
+  (at level 69, x ident, A1 ident, A2 ident, A3 ident) : charac.
+
+Notation "'LetVal' [ A1 A2 A3 A4 ] x ':=' V 'in' F" :=
+  (!V (fun H Q => forall x, x = (fun (A1 A2 A3 A4:Type) => V) -> F H Q))
+  (at level 69, x ident, A1 ident, A2 ident, A3 ident, A4 ident) : charac.
+
+(** Let / Seq / Pay *)
+
 Notation "'Let' x ':=' F1 'in' F2" :=
   (!T (fun H Q => exists Q1, F1 H Q1 /\ forall x, F2 (Q1 x) Q))
   (at level 69, x ident, right associativity,

lib/coq/CFTactics.v

@@ -626,30 +626,50 @@ Tactic Notation "xseq" "*" constr(H) := xseq H; auto_star.
 
 (** [xval] is used to reason on a let-node binding a value. *)
 
-Tactic Notation "xval" "as" simple_intropattern(x) simple_intropattern(Hx) :=
+Ltac xval_impl x Hx :=
   apply local_erase; intros x Hx.
 
+Tactic Notation "xval" "as" simple_intropattern(x) simple_intropattern(Hx) :=
+  xval_impl x Hx.
+
 Tactic Notation "xval" "as" simple_intropattern(x) :=
-  let Hx := fresh "P" x in xval as x Hx.
+  let Hx := fresh "P" x in xval_impl x Hx.
+
+Ltac xval_anonymous_impl tt :=
+  apply local_erase; intro; let x := get_last_hyp tt in revert x; 
+  let Hx := fresh "P" x in intros x Hx.
 
 Tactic Notation "xval" :=
-  apply local_erase; intro; let x := get_last_hyp tt in revert x; xval as x.
+  xval_anonymous_impl tt.
 
 (** [xvals] substitutes the bound value right away. *)
 
-Tactic Notation "xvals" :=
+Ltac xvals_impl tt :=
   apply local_erase; intro; intro_subst.
 
+Tactic Notation "xvals" :=
+  xvals_impl tt. 
+
 (** [xval_st P] is used to assign an abstract specification to the value *)
 
+Ltac xval_st_core P x Hx :=
+  let E := fresh in intros x E; asserts Hx: (P x); [ subst x | clear E ].
+
+Ltac xval_st_impl P x Hx :=
+  apply local_erase; xval_st_core P x Hx.
+
 Tactic Notation "xval_st" constr(P) "as" simple_intropattern(x) simple_intropattern(Hx) :=
-  apply local_erase; intros x; asserts Hx: (P x); [ intro_subst | intros _ ].
+  xval_st_impl P x Hx.
 
 Tactic Notation "xval_st" constr(P) "as" simple_intropattern(x) :=
-  let Hx := fresh "P" x in xval_st P as x Hx.
+  let Hx := fresh "P" x in xval_st_impl P x Hx.
+
+Ltac xval_st_anonymous_impl P :=
+  apply local_erase; intro; let x := get_last_hyp tt in revert x; 
+  let Hx := fresh "P" x in xval_st_core P x Hx.
 
 Tactic Notation "xval_st" constr(P) :=
-  apply local_erase; intro; let x := get_last_hyp tt in revert x; xval_st P as x.
+  xval_st_anonymous_impl P.
 
 
 (*--------------------------------------------------------*)

lib/coq/Shared.v

 Set Implicit Arguments.
 
+
+(********************************************************************)
+(** Notation for functions expecting tuples as arguments *)
+
+(** Note: this will later move to TLC *)
+
+Notation "'fun' ''' ( x1 , x2 ) ':' T '=>' E" := 
+  (fun p : T => let '(x1,x2) := p in E) 
+  (at level 200) : fun_scope.
+
+Notation "'fun' ''' ( x1 , x2 ) '=>' E" := 
+  (fun p => let '(x1,x2) := p in E) 
+  (at level 200, format "'fun'  ''' ( x1 , x2 )  '=>'  E") : fun_scope.
+
+Notation "'fun' ''' ( x1 , x2 , x3 ) ':' T '=>' E" := 
+  (fun p : T => let '(x1,x2,x3) := p in E) 
+  (at level 200) : fun_scope.
+
+Notation "'fun' ''' ( x1 , x2 , x3 ) '=>' E" := 
+  (fun p => let '(x1,x2,x3) := p in E) 
+  (at level 200, format "'fun'  ''' ( x1 , x2 , x3 )  '=>'  E") : fun_scope.
+
+(* TODO: coqbug?
+Notation "'fun' ''' ( x1 , x2 , x3 , x4) ':' T '=>' E" := 
+  (fun p : T => let '(x1,x2,x3,x4) := p in E) 
+  (at level 60, E at level 200) : fun_scope.
+
+Notation "'fun' ''' ( x1 , x2 , x3 , x4 ) '=>' E" := 
+  (fun p => match p with (x1,x2,x3,x4) => E end) 
+  (at level 60, E at level 200, format "'fun'  ''' ( x1 , x2 , x3 , x4 )  '=>'  E") : fun_scope.
+*)
+
+Open Scope fun_scope.
+
+
+
 (********************************************************************)
 (** Treatment of partially-applied equality *)