TImp: Case Studya Typed Imperative Language
Yet another Imp variant, this time with types!
Regular Imp has distinct syntax for boolean and arithmetic expressions,
where only arithmetic expressions can contain variables.
Soundness for Typed Imp (TImp) is a good example of a realistic
conditional property, requiring custom generators for effective testing.
For the type of identifiers of TImp we will use a wrapper around
plain natural numbers.
Inductive aexp := ... | Var : x -> aexp | ...
Inductive bexp := ...
The goal of this case study is to
- collapse the two grammars into a single type exp
- allow variables to range over both booleans and naturals, and
- introduce types to keep things straight.
Identifiers, Types and Contexts
Inductive id :=
| Id : nat → id.
| Id : nat → id.
Fixpoint max_elt (al:list id) : nat :=
match al with
| nil ⇒ 0
| (Id n')::al' ⇒ max n' (max_elt al')
end.
Definition fresh (al:list id) : id :=
Id (S (max_elt al)).
match al with
| nil ⇒ 0
| (Id n')::al' ⇒ max n' (max_elt al')
end.
Definition fresh (al:list id) : id :=
Id (S (max_elt al)).
Instance eq_id_dec (x1 x2 : id) : Dec (x1 = x2).
Proof. dec_eq. Defined.
Proof. dec_eq. Defined.
Identifier Printing and Generation
Instance show_id : Show id :=
{ show x := let '(Id n) := x in show n }.
{ show x := let '(Id n) := x in show n }.
To generate identifiers for TImp, we will not just generate
arbitrary natural numbers. More often than not, we will need to
generate a set of identifiers, or pick an identifier from such a
set. If we represent a set as a list, we can do the former with a
recursive function that generates n fresh nats starting from
the empty list. For the latter, we have QuickChick's elems_
combinator.
Fixpoint get_fresh_ids n l :=
match n with
| 0 ⇒ l
| S n' ⇒ get_fresh_ids n' ((fresh l) :: l)
end.
match n with
| 0 ⇒ l
| S n' ⇒ get_fresh_ids n' ((fresh l) :: l)
end.
Inductive ty := TBool | TNat.
To use ty in testing, we will need Arbitrary, Show, and Dec instances.
Derive (Arbitrary, Show) for ty.
(* ==>
GenSizedty is defined
Shrinkty is defined
Showty is defined
*)
Check GenSizedty.
(* ==> GenSizedty : GenSized ty *)
Check Shrinkty.
(* ==> Shrinkty : Shrink ty *)
Check Showty.
(* ==> Showty : Show ty *)
(* ==>
GenSizedty is defined
Shrinkty is defined
Showty is defined
*)
Check GenSizedty.
(* ==> GenSizedty : GenSized ty *)
Check Shrinkty.
(* ==> Shrinkty : Shrink ty *)
Check Showty.
(* ==> Showty : Show ty *)
Decidable equality instances are not yet derived fully automatically by QuickChick. However, the boilerplate we have to write is largely straightforward. As we saw in the previous chapters, Dec is a typeclass wrapper around ssreflect's decidable and we can use the dec_eq tactic to automate the process.
Instance eq_dec_ty (x y : ty) : Dec (x = y).
Proof. dec_eq. Defined.
Proof. dec_eq. Defined.
List-Based Maps
- access the domain of the map,
- test the map for equality, and
- iterate through the map.
- empty : To create the empty map.
- get : To look up the binding of an element, if any.
- set : To update the binding of an element.
- dom : To get the list of keys in the map.
Definition Map A := list (id × A).
The empty map is the empty list.
Definition map_empty {A} : Map A := [].
Fixpoint map_get {A} (m : Map A) x : option A :=
match m with
| [] ⇒ None
| (k, v) :: m' ⇒ if x = k ? then Some v else map_get m' x
end.
match m with
| [] ⇒ None
| (k, v) :: m' ⇒ if x = k ? then Some v else map_get m' x
end.
Definition map_set {A} (m:Map A) (x:id) (v:A) : Map A := (x, v) :: m.
Fixpoint map_dom {A} (m:Map A) : list id :=
match m with
| [] ⇒ []
| (k', v) :: m' ⇒ k' :: map_dom m'
end.
match m with
| [] ⇒ []
| (k', v) :: m' ⇒ k' :: map_dom m'
end.
We next introduce a simple inductive relation, bound_to m x a, that holds precisely when the binding of some identifier x is equal to a in m
Inductive bound_to {A} : Map A → id → A → Prop :=
| Bind : ∀ x m a, map_get m x = Some a → bound_to m x a.
| Bind : ∀ x m a, map_get m x = Some a → bound_to m x a.
Instance dec_bound_to {A : Type} Gamma x (T : A)
`{D : ∀ (x y : A), Dec (x = y)}
: Dec (bound_to Gamma x T).
`{D : ∀ (x y : A), Dec (x = y)}
: Dec (bound_to Gamma x T).
Proof.
constructor. unfold ssrbool.decidable.
destruct (map_get Gamma x) eqn:Get; solve_sum.
destruct (D a T) as [[Eq | NEq]]; subst; solve_sum.
Defined.
constructor. unfold ssrbool.decidable.
destruct (map_get Gamma x) eqn:Get; solve_sum.
destruct (D a T) as [[Eq | NEq]]; subst; solve_sum.
Defined.
Definition context := Map ty.
Given a context Gamma and a type T, we can try to generate a
random identifier whose binding in Gamma is T.
We use List.filter to extract all of the elements in Gamma
whose type is equal to T and then, for each (a,T') that
remains, return the name a. We use the oneOf_ combinator to
pick an generator from this list at random.
Since the filtered list might be empty we return an option,
we use ret None as the default element for oneOf_.
Definition gen_typed_id_from_context (Gamma : context) (T : ty)
: G (option id) :=
oneOf_ (ret None)
(List.map (fun '(x,T') ⇒ ret (Some x))
(List.filter (fun '(x,T') ⇒ T = T'?) Gamma)).
: G (option id) :=
oneOf_ (ret None)
(List.map (fun '(x,T') ⇒ ret (Some x))
(List.filter (fun '(x,T') ⇒ T = T'?) Gamma)).
- Create its domain (n fresh identifiers)
- Create n arbitrary types
- Zip them together
Definition gen_context (n : nat) : G context :=
let domain := get_fresh_ids n [] in
range <- vectorOf n arbitrary ;;
ret (List.combine domain range).
let domain := get_fresh_ids n [] in
range <- vectorOf n arbitrary ;;
ret (List.combine domain range).
Expressions
Inductive exp : Type :=
| EVar : id → exp
| ENum : nat → exp
| EPlus : exp → exp → exp
| EMinus : exp → exp → exp
| EMult : exp → exp → exp
| ETrue : exp
| EFalse : exp
| EEq : exp → exp → exp
| ELe : exp → exp → exp
| ENot : exp → exp
| EAnd : exp → exp → exp.
Derive Show for exp.
| EVar : id → exp
| ENum : nat → exp
| EPlus : exp → exp → exp
| EMinus : exp → exp → exp
| EMult : exp → exp → exp
| ETrue : exp
| EFalse : exp
| EEq : exp → exp → exp
| ELe : exp → exp → exp
| ENot : exp → exp
| EAnd : exp → exp → exp.
Derive Show for exp.
Reserved Notation "Gamma '|⊢' e '\IN' T" (at level 40).
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → Gamma |⊢ EVar x \IN T
| Ty_Num : ∀ Gamma n,
Gamma |⊢ ENum n \IN TNat
| Ty_Plus : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EPlus e1 e2 \IN TNat
| Ty_Minus : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EMinus e1 e2 \IN TNat
| Ty_Mult : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EMult e1 e2 \IN TNat
| Ty_True : ∀ Gamma, Gamma |⊢ ETrue \IN TBool
| Ty_False : ∀ Gamma, Gamma |⊢ EFalse \IN TBool
| Ty_Eq : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EEq e1 e2 \IN TBool
| Ty_Le : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ ELe e1 e2 \IN TBool
| Ty_Not : ∀ Gamma e,
Gamma |⊢ e \IN TBool → Gamma |⊢ ENot e \IN TBool
| Ty_And : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TBool → Gamma |⊢ e2 \IN TBool →
Gamma |⊢ EAnd e1 e2 \IN TBool
where "Gamma '|⊢' e '\IN' T" := (has_type Gamma e T).
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → Gamma |⊢ EVar x \IN T
| Ty_Num : ∀ Gamma n,
Gamma |⊢ ENum n \IN TNat
| Ty_Plus : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EPlus e1 e2 \IN TNat
| Ty_Minus : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EMinus e1 e2 \IN TNat
| Ty_Mult : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EMult e1 e2 \IN TNat
| Ty_True : ∀ Gamma, Gamma |⊢ ETrue \IN TBool
| Ty_False : ∀ Gamma, Gamma |⊢ EFalse \IN TBool
| Ty_Eq : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ EEq e1 e2 \IN TBool
| Ty_Le : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TNat → Gamma |⊢ e2 \IN TNat →
Gamma |⊢ ELe e1 e2 \IN TBool
| Ty_Not : ∀ Gamma e,
Gamma |⊢ e \IN TBool → Gamma |⊢ ENot e \IN TBool
| Ty_And : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TBool → Gamma |⊢ e2 \IN TBool →
Gamma |⊢ EAnd e1 e2 \IN TBool
where "Gamma '|⊢' e '\IN' T" := (has_type Gamma e T).
While the typing relation is almost entirely standard, there is a
choice to make about the Ty_Eq rule. The Ty_Eq constructor
above requires that the arguments to an equality check are both
arithmetic expressions (just like it was in Imp), which simplifies
some of the discussion in the remainder of the chapter. We could
have allowed for equality checks between booleans as well - that will
become an exercise at the end of this chapter.
Typing in TImp is decidable: given an expression e, a context Gamma
and a type T, we can decide whether has_type Gamma e T holds.
Instance dec_has_type (e : exp) (Gamma : context) (T : ty)
: Dec (Gamma |⊢ e \IN T).
: Dec (Gamma |⊢ e \IN T).
Proof with solve_sum.
constructor.
generalize dependent Gamma.
generalize dependent T.
induction e; intros T Gamma; unfold ssrbool.decidable;
try solve [destruct T; solve_sum];
try solve [destruct T; solve_inductives Gamma].
(* bound_to case: *)
destruct (dec_bound_to Gamma i T); destruct dec; solve_sum.
Defined.
constructor.
generalize dependent Gamma.
generalize dependent T.
induction e; intros T Gamma; unfold ssrbool.decidable;
try solve [destruct T; solve_sum];
try solve [destruct T; solve_inductives Gamma].
(* bound_to case: *)
destruct (dec_bound_to Gamma i T); destruct dec; solve_sum.
Defined.
Generating Typed Expressions
Definition bindGenOpt {A B : Type}
(gma : G (option A)) (k : A → G (option B))
: G (option B) :=
ma <- gma ;;
match ma with
| Some a ⇒ k a
| None ⇒ ret None
end.
(gma : G (option A)) (k : A → G (option B))
: G (option B) :=
ma <- gma ;;
match ma with
| Some a ⇒ k a
| None ⇒ ret None
end.
Print GOpt.
GOpt = fun A : Type => G (option A)
: Type -> Type
Check Monad_GOpt.
Monad_GOpt : Monad GOpt
Module TypePlayground1.
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → has_type Gamma (EVar x) T.
End TypePlayground1.
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → has_type Gamma (EVar x) T.
End TypePlayground1.
To generate e such that has_type Gamma e T holds, we need to
pick one of its constructors (there is only one choice, here) and
then try to satisfy its preconditions by generating more things.
To satisfy Ty_Var (given Gamma and T), we need to generate
x such that bound_to Gamma x T. But we already have such a
generator! We just need to wrap it in an EVar.
Definition gen_typed_evar (Gamma : context) (T : ty) : GOpt exp :=
x <- gen_typed_id_from_context Gamma T;;
ret (EVar x).
x <- gen_typed_id_from_context Gamma T;;
ret (EVar x).
(Note that this is the ret of the GOpt monad.)
Now let's consider an extended typing relation, extending the previous one with all of the constructors of has_type that do not recursively require has_type as a side-condition. These will be the base cases for our final generator.
Module TypePlayground2.
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → has_type Gamma (EVar x) T
| Ty_Num : ∀ Gamma n,
has_type Gamma (ENum n) TNat
| Ty_True : ∀ Gamma, has_type Gamma ETrue TBool
| Ty_False : ∀ Gamma, has_type Gamma EFalse TBool.
End TypePlayground2.
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → has_type Gamma (EVar x) T
| Ty_Num : ∀ Gamma n,
has_type Gamma (ENum n) TNat
| Ty_True : ∀ Gamma, has_type Gamma ETrue TBool
| Ty_False : ∀ Gamma, has_type Gamma EFalse TBool.
End TypePlayground2.
We can already generate values satisfying Ty_Var using
gen_typed_evar. For the rest of the rules, we will need to
pattern match on the input T, since Ty_Num can only be used if
T = TNat, while Ty_True and Ty_False can only be used if T
= TBool.
Definition base' Gamma T : list (GOpt exp) :=
gen_typed_evar Gamma T ::
match T with
| TNat ⇒ [ n <- arbitrary;; ret (Some (ENum n))]
| TBool ⇒ [ ret ETrue ; ret EFalse ]
end.
gen_typed_evar Gamma T ::
match T with
| TNat ⇒ [ n <- arbitrary;; ret (Some (ENum n))]
| TBool ⇒ [ ret ETrue ; ret EFalse ]
end.
backtrack : list (nat × GOpt ?A) → GOpt ?A
Definition base Gamma T :=
(2, gen_typed_evar Gamma T) ::
match T with
| TNat ⇒ [ (2, n <- arbitrary;; ret (Some (ENum n)))]
| TBool ⇒ [ (1, ret ETrue)
; (1, ret EFalse) ]
end.
Definition gen_has_type_2 Gamma T := backtrack (base Gamma T).
(2, gen_typed_evar Gamma T) ::
match T with
| TNat ⇒ [ (2, n <- arbitrary;; ret (Some (ENum n)))]
| TBool ⇒ [ (1, ret ETrue)
; (1, ret EFalse) ]
end.
Definition gen_has_type_2 Gamma T := backtrack (base Gamma T).
To see how we handle recursive rules, let's consider a third sub-relation, has_type_3, with just variables and addition:
Module TypePlayground3.
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → has_type Gamma (EVar x) T
| Ty_Plus : ∀ Gamma e1 e2,
has_type Gamma e1 TNat → has_type Gamma e2 TNat →
has_type Gamma (EPlus e1 e2) TNat.
End TypePlayground3.
Inductive has_type : context → exp → ty → Prop :=
| Ty_Var : ∀ x T Gamma,
bound_to Gamma x T → has_type Gamma (EVar x) T
| Ty_Plus : ∀ Gamma e1 e2,
has_type Gamma e1 TNat → has_type Gamma e2 TNat →
has_type Gamma (EPlus e1 e2) TNat.
End TypePlayground3.
Typing derivations involving EPlus nodes are binary trees, so we
need to add a size parameter to enforce termination. The base
case (Ty_Var3) is handled using gen_typed_evar just like
before. The non-base case can choose between trying to generate
Ty_Var3 and trying to generate Ty_Plus3. For the latter, the
input type T must be TNat, otherwise it is not
applicable. Once again, this leads to a match on T:
Fixpoint gen_has_type_3 size Gamma T : GOpt exp :=
match size with
| O ⇒ gen_typed_evar Gamma T
| S size' ⇒
backtrack
([ (1, gen_typed_evar Gamma T) ]
++ match T with
| TNat ⇒
[ (size, e1 <- gen_has_type_3 size' Gamma TNat;;
e2 <- gen_has_type_3 size' Gamma TNat;;
ret (EPlus e1 e2)) ]
| _ ⇒ []
end)
end.
match size with
| O ⇒ gen_typed_evar Gamma T
| S size' ⇒
backtrack
([ (1, gen_typed_evar Gamma T) ]
++ match T with
| TNat ⇒
[ (size, e1 <- gen_has_type_3 size' Gamma TNat;;
e2 <- gen_has_type_3 size' Gamma TNat;;
ret (EPlus e1 e2)) ]
| _ ⇒ []
end)
end.
Fixpoint gen_exp_typed_sized
(size : nat) (Gamma : context) (T : ty)
: GOpt exp :=
let base := base Gamma T in
let recs size' :=
match T with
| TNat ⇒
[ (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EPlus e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EMinus e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EMult e1 e2)) ]
| TBool ⇒
[ (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EEq e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (ELe e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TBool ;;
ret (ENot e1))
; (size, e1 <- gen_exp_typed_sized size' Gamma TBool ;;
e2 <- gen_exp_typed_sized size' Gamma TBool ;;
ret (EAnd e1 e2)) ]
end in
match size with
| O ⇒
backtrack base
| S size' ⇒
backtrack (base ++ recs size')
end.
(size : nat) (Gamma : context) (T : ty)
: GOpt exp :=
let base := base Gamma T in
let recs size' :=
match T with
| TNat ⇒
[ (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EPlus e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EMinus e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EMult e1 e2)) ]
| TBool ⇒
[ (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (EEq e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
e2 <- gen_exp_typed_sized size' Gamma TNat ;;
ret (ELe e1 e2))
; (size, e1 <- gen_exp_typed_sized size' Gamma TBool ;;
ret (ENot e1))
; (size, e1 <- gen_exp_typed_sized size' Gamma TBool ;;
e2 <- gen_exp_typed_sized size' Gamma TBool ;;
ret (EAnd e1 e2)) ]
end in
match size with
| O ⇒
backtrack base
| S size' ⇒
backtrack (base ++ recs size')
end.
Definition gen_typed_has_type :=
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll arbitrary (fun T ⇒
forAll (gen_exp_typed_sized top_level_size Gamma T) (fun me ⇒
match me with
| Some e ⇒ (has_type Gamma e T)?
| None ⇒ false
end))).
(* QuickChick gen_typed_has_type. *)
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll arbitrary (fun T ⇒
forAll (gen_exp_typed_sized top_level_size Gamma T) (fun me ⇒
match me with
| Some e ⇒ (has_type Gamma e T)?
| None ⇒ false
end))).
(* QuickChick gen_typed_has_type. *)
Values and States
Inductive value := VNat : nat → value | VBool : bool → value.
Derive Show for value.
Derive Show for value.
We can also quickly define a typing relation for values, a Dec instance for it, and a generator for values of a given type.
Inductive has_type_value : value → ty → Prop :=
| TyVNat : ∀ n, has_type_value (VNat n) TNat
| TyVBool : ∀ b, has_type_value (VBool b) TBool.
Instance dec_has_type_value v T : Dec (has_type_value v T).
Definition gen_typed_value (T : ty) : G value :=
match T with
| TNat ⇒ n <- arbitrary;; ret (VNat n)
| TBool ⇒ b <- arbitrary;; ret (VBool b)
end.
| TyVNat : ∀ n, has_type_value (VNat n) TNat
| TyVBool : ∀ b, has_type_value (VBool b) TBool.
Instance dec_has_type_value v T : Dec (has_type_value v T).
Proof. constructor; unfold ssrbool.decidable.
destruct v; destruct T; solve_sum.
Defined.
destruct v; destruct T; solve_sum.
Defined.
Definition gen_typed_value (T : ty) : G value :=
match T with
| TNat ⇒ n <- arbitrary;; ret (VNat n)
| TBool ⇒ b <- arbitrary;; ret (VBool b)
end.
Definition state := Map value.
We introduce an inductive relation that specifies when a state is
well typed in a context (that is, when all of its variables are
mapped to values of appropriate types).
We encode this in an element-by-element style inductive relation:
empty states are only well typed with respect to an empty context,
while non-empty states need to map their head identifier to a value of
the appropriate type (and their tail must similarly be well
typed).
Inductive well_typed_state : context → state → Prop :=
| TS_Empty : well_typed_state map_empty map_empty
| TS_Elem : ∀ x v T st Gamma,
has_type_value v T → well_typed_state Gamma st →
well_typed_state ((x,T)::Gamma) ((x,v)::st).
Instance dec_well_typed_state Gamma st : Dec (well_typed_state Gamma st).
| TS_Empty : well_typed_state map_empty map_empty
| TS_Elem : ∀ x v T st Gamma,
has_type_value v T → well_typed_state Gamma st →
well_typed_state ((x,T)::Gamma) ((x,v)::st).
Instance dec_well_typed_state Gamma st : Dec (well_typed_state Gamma st).
Proof.
constructor; unfold ssrbool.decidable.
generalize dependent Gamma.
induction st; intros; destruct Gamma; solve_sum.
destruct a as [a v]; destruct p as [a' T].
destruct (@dec (a = a') _ ); solve_sum.
subst; specialize (IHst Gamma); destruct IHst; solve_sum.
destruct (dec_has_type_value v T); destruct dec; solve_sum.
Defined.
constructor; unfold ssrbool.decidable.
generalize dependent Gamma.
induction st; intros; destruct Gamma; solve_sum.
destruct a as [a v]; destruct p as [a' T].
destruct (@dec (a = a') _ ); solve_sum.
subst; specialize (IHst Gamma); destruct IHst; solve_sum.
destruct (dec_has_type_value v T); destruct dec; solve_sum.
Defined.
Definition gen_well_typed_state (Gamma : context) : G state :=
sequenceGen (List.map (fun '(x, T) ⇒
v <- gen_typed_value T;;
ret (x, v)) Gamma).
sequenceGen (List.map (fun '(x, T) ⇒
v <- gen_typed_value T;;
ret (x, v)) Gamma).
Evaluation
Fixpoint eval (st : state) (e : exp) : option value :=
match e with
| EVar x ⇒ map_get st x
| ENum n ⇒ Some (VNat n)
| EPlus e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VNat (n1 + n2))
| _, _ ⇒ None
end
| EMinus e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VNat (n1 - n2))
| _, _ ⇒ None
end
| EMult e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VNat (n1 × n2))
| _, _ ⇒ None
end
| ETrue ⇒ Some (VBool true )
| EFalse ⇒ Some (VBool false )
| EEq e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VBool (n1 =? n2))
| _, _ ⇒ None
end
| ELe e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VBool (n1 <? n2))
| _, _ ⇒ None
end
| ENot e ⇒
match eval st e with
| Some (VBool b) ⇒ Some (VBool (negb b))
| _ ⇒ None
end
| EAnd e1 e2 ⇒
match eval st e1, eval st e2 with
(* Let's include a silly bug here! *)
| Some (VBool b), Some (VNat n2) ⇒ Some (VBool (negb b))
(* | Some (VBool b1), Some (VBool b2) => Some (VBool (andb b1 b2)) *)
| _, _ ⇒ None
end
end.
match e with
| EVar x ⇒ map_get st x
| ENum n ⇒ Some (VNat n)
| EPlus e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VNat (n1 + n2))
| _, _ ⇒ None
end
| EMinus e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VNat (n1 - n2))
| _, _ ⇒ None
end
| EMult e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VNat (n1 × n2))
| _, _ ⇒ None
end
| ETrue ⇒ Some (VBool true )
| EFalse ⇒ Some (VBool false )
| EEq e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VBool (n1 =? n2))
| _, _ ⇒ None
end
| ELe e1 e2 ⇒
match eval st e1, eval st e2 with
| Some (VNat n1), Some (VNat n2) ⇒ Some (VBool (n1 <? n2))
| _, _ ⇒ None
end
| ENot e ⇒
match eval st e with
| Some (VBool b) ⇒ Some (VBool (negb b))
| _ ⇒ None
end
| EAnd e1 e2 ⇒
match eval st e1, eval st e2 with
(* Let's include a silly bug here! *)
| Some (VBool b), Some (VNat n2) ⇒ Some (VBool (negb b))
(* | Some (VBool b1), Some (VBool b2) => Some (VBool (andb b1 b2)) *)
| _, _ ⇒ None
end
end.
We will see in a later chapter (QuickChickTool) how we can
use QuickChick to introduce such mutations and have them
automatically checked.
Type soundness states that, if we have an expression e of a given type T as well as a well-typed state st, then evaluating e in st will never fail.
Definition isNone {A : Type} (m : option A) :=
match m with
| None ⇒ true
| Some _ ⇒ false
end.
Conjecture expression_soundness : ∀ Gamma st e T,
well_typed_state Gamma st → Gamma |⊢ e \IN T →
isNone (eval st e) = false.
match m with
| None ⇒ true
| Some _ ⇒ false
end.
Conjecture expression_soundness : ∀ Gamma st e T,
well_typed_state Gamma st → Gamma |⊢ e \IN T →
isNone (eval st e) = false.
To test this property, we construct an appropriate checker:
Definition expression_soundness_exec :=
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll (gen_well_typed_state Gamma) (fun st ⇒
forAll arbitrary (fun T ⇒
forAll (gen_exp_typed_sized 3 Gamma T) (fun me ⇒
match me with
| Some e ⇒ negb (isNone (eval st e))
| _ ⇒ true
end)))).
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll (gen_well_typed_state Gamma) (fun st ⇒
forAll arbitrary (fun T ⇒
forAll (gen_exp_typed_sized 3 Gamma T) (fun me ⇒
match me with
| Some e ⇒ negb (isNone (eval st e))
| _ ⇒ true
end)))).
(* QuickChick expression_soundness_exec. *)
===> QuickChecking expression_soundness_exec [(1,TNat), (2,TNat), (3,TBool), (4,TNat)] [(1,VNat 0), (2,VNat 0), (3,VBool true), (4,VNat 0)] TBool Some EAnd (EAnd (EEq (EVar 4) (EVar 1)) (EEq (ENum 0) (EVar 4))) EFalse *** Failed after 8 tests and 0 shrinks. (0 discards)Where is the bug?? Looks like we need some shrinking!
Shrinking for Expressions
Derive Shrink for exp.
Definition expression_soundness_exec_firstshrink :=
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll (gen_well_typed_state Gamma) (fun st ⇒
forAll arbitrary (fun T ⇒
forAllShrink (gen_exp_typed_sized 3 Gamma T) shrink (fun me ⇒
match me with
| Some e ⇒ negb (isNone (eval st e))
| _ ⇒ true
end)))).
(* QuickChick expression_soundness_exec_firstshrink. *)
Definition expression_soundness_exec_firstshrink :=
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll (gen_well_typed_state Gamma) (fun st ⇒
forAll arbitrary (fun T ⇒
forAllShrink (gen_exp_typed_sized 3 Gamma T) shrink (fun me ⇒
match me with
| Some e ⇒ negb (isNone (eval st e))
| _ ⇒ true
end)))).
(* QuickChick expression_soundness_exec_firstshrink. *)
===> QuickChecking expression_soundness_exec_firsttry [(1,TBool), (2,TNat), (3,TBool), (4,TBool)] [(1,VBool false), (2,VNat 0), (3,VBool true), (4,VBool false)] TBool Some EAnd (ENum 0) ETrue *** Failed after 28 tests and 7 shrinks. (0 discards)
- If e = ENum x for some x, all we can do is try to shrink x.
- If e = ETrue or e = EFalse, we could shrink it to the other. But remember, we don't want to do both, as this would lead to an infinite loop in shrinking! We choose to shrink EFalse to ETrue.
Definition shrink_base (e : exp) : list exp :=
match e with
| ENum n ⇒ map ENum (shrink n)
| ETrue ⇒ []
| EFalse ⇒ [ETrue]
| _ ⇒ []
end.
match e with
| ENum n ⇒ map ENum (shrink n)
| ETrue ⇒ []
| EFalse ⇒ [ETrue]
| _ ⇒ []
end.
The next case, EVar, must take the type T to be preserved into account. To shrink an EVar we could try shrinking the inner identifier, but shrinking an identifier by shrinking its natural number representation makes little sense. Better, we can try to shrink the EVar to a constant of the appropriate type.
Definition shrink_evar (T : ty) (e : exp) : list exp :=
match e with
| EVar x ⇒
match T with
| TNat ⇒ [ENum 0]
| TBool ⇒ [ETrue ; EFalse]
end
| _ ⇒ []
end.
match e with
| EVar x ⇒
match T with
| TNat ⇒ [ENum 0]
| TBool ⇒ [ETrue ; EFalse]
end
| _ ⇒ []
end.
Finally, we need to be able to shrink the recursive cases. Consider EPlus e1 e2:
- We could try (recursively) shrinking e1 or e2 preserving their TNat type.
- We could try to shrink directly to e1 or e2 since their type is the same as EPlus e1 e2.
- Again, we could recursively shrink e1 or e2.
- But we can't shrink to e1 or e2 since they are of a different type.
- For faster shrinking, we can also try to shrink such expressions to boolean constants directly.
Fixpoint shrink_rec (T : ty) (e : exp) : list exp :=
match e with
| EPlus e1 e2 ⇒
e1 :: e2
:: (List.map (fun e1' ⇒ EPlus e1' e2) (shrink_rec T e1))
++ (List.map (fun e2' ⇒ EPlus e1 e2') (shrink_rec T e2))
| EEq e1 e2 ⇒
ETrue :: EFalse
:: (List.map (fun e1' ⇒ EEq e1' e2) (shrink_rec TNat e1))
++ (List.map (fun e2' ⇒ EEq e1 e2') (shrink_rec TNat e2))
| _ ⇒ []
end.
match e with
| EPlus e1 e2 ⇒
e1 :: e2
:: (List.map (fun e1' ⇒ EPlus e1' e2) (shrink_rec T e1))
++ (List.map (fun e2' ⇒ EPlus e1 e2') (shrink_rec T e2))
| EEq e1 e2 ⇒
ETrue :: EFalse
:: (List.map (fun e1' ⇒ EEq e1' e2) (shrink_rec TNat e1))
++ (List.map (fun e2' ⇒ EEq e1 e2') (shrink_rec TNat e2))
| _ ⇒ []
end.
Fixpoint shrink_exp_typed (T : ty) (e : exp) : list exp :=
match e with
| EVar _ ⇒
match T with
| TNat ⇒ [ENum 0]
| TBool ⇒ [ETrue ; EFalse]
end
| ENum _ ⇒ []
| ETrue ⇒ []
| EFalse ⇒ [ETrue]
| EPlus e1 e2 ⇒
e1 :: e2
:: (List.map (fun e1' ⇒ EPlus e1' e2) (shrink_exp_typed T e1))
++ (List.map (fun e2' ⇒ EPlus e1 e2') (shrink_exp_typed T e2))
| EMinus e1 e2 ⇒
e1 :: e2 :: (EPlus e1 e2)
:: (List.map (fun e1' ⇒ EMinus e1' e2) (shrink_exp_typed T e1))
++ (List.map (fun e2' ⇒ EMinus e1 e2') (shrink_exp_typed T e2))
| EMult e1 e2 ⇒
e1 :: e2 :: (EPlus e1 e2)
:: (List.map (fun e1' ⇒ EMult e1' e2) (shrink_exp_typed T e1))
++ (List.map (fun e2' ⇒ EMult e1 e2') (shrink_exp_typed T e2))
| EEq e1 e2 ⇒
ETrue :: EFalse
:: (List.map (fun e1' ⇒ EEq e1' e2) (shrink_exp_typed TNat e1))
++ (List.map (fun e2' ⇒ EEq e1 e2') (shrink_exp_typed TNat e2))
| ELe e1 e2 ⇒
ETrue :: EFalse :: (EEq e1 e2)
:: (List.map (fun e1' ⇒ ELe e1' e2) (shrink_exp_typed TNat e1))
++ (List.map (fun e2' ⇒ ELe e1 e2') (shrink_exp_typed TNat e2))
| ENot e ⇒
ETrue :: EFalse :: e :: (List.map ENot (shrink_exp_typed T e))
| EAnd e1 e2 ⇒
ETrue :: EFalse :: e1 :: e2
:: (List.map (fun e1' ⇒ EAnd e1' e2) (shrink_exp_typed TBool e1))
++ (List.map (fun e2' ⇒ EAnd e1 e2') (shrink_exp_typed TBool e2))
end.
match e with
| EVar _ ⇒
match T with
| TNat ⇒ [ENum 0]
| TBool ⇒ [ETrue ; EFalse]
end
| ENum _ ⇒ []
| ETrue ⇒ []
| EFalse ⇒ [ETrue]
| EPlus e1 e2 ⇒
e1 :: e2
:: (List.map (fun e1' ⇒ EPlus e1' e2) (shrink_exp_typed T e1))
++ (List.map (fun e2' ⇒ EPlus e1 e2') (shrink_exp_typed T e2))
| EMinus e1 e2 ⇒
e1 :: e2 :: (EPlus e1 e2)
:: (List.map (fun e1' ⇒ EMinus e1' e2) (shrink_exp_typed T e1))
++ (List.map (fun e2' ⇒ EMinus e1 e2') (shrink_exp_typed T e2))
| EMult e1 e2 ⇒
e1 :: e2 :: (EPlus e1 e2)
:: (List.map (fun e1' ⇒ EMult e1' e2) (shrink_exp_typed T e1))
++ (List.map (fun e2' ⇒ EMult e1 e2') (shrink_exp_typed T e2))
| EEq e1 e2 ⇒
ETrue :: EFalse
:: (List.map (fun e1' ⇒ EEq e1' e2) (shrink_exp_typed TNat e1))
++ (List.map (fun e2' ⇒ EEq e1 e2') (shrink_exp_typed TNat e2))
| ELe e1 e2 ⇒
ETrue :: EFalse :: (EEq e1 e2)
:: (List.map (fun e1' ⇒ ELe e1' e2) (shrink_exp_typed TNat e1))
++ (List.map (fun e2' ⇒ ELe e1 e2') (shrink_exp_typed TNat e2))
| ENot e ⇒
ETrue :: EFalse :: e :: (List.map ENot (shrink_exp_typed T e))
| EAnd e1 e2 ⇒
ETrue :: EFalse :: e1 :: e2
:: (List.map (fun e1' ⇒ EAnd e1' e2) (shrink_exp_typed TBool e1))
++ (List.map (fun e2' ⇒ EAnd e1 e2') (shrink_exp_typed TBool e2))
end.
As we saw for generators, we can also perform sanity checks on our shrinkers. Here, when the shrinker is applied to an expression of a given type, all of its results should have the same type.
Definition shrink_typed_has_type :=
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll arbitrary (fun T ⇒
forAll (gen_exp_typed_sized top_level_size Gamma T) (fun me ⇒
match me with
| Some e ⇒
List.forallb (fun e' ⇒ (has_type Gamma e' T)?) (shrink_exp_typed T e)
| _ ⇒ false
end))).
(* QuickChick shrink_typed_has_type. *)
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll arbitrary (fun T ⇒
forAll (gen_exp_typed_sized top_level_size Gamma T) (fun me ⇒
match me with
| Some e ⇒
List.forallb (fun e' ⇒ (has_type Gamma e' T)?) (shrink_exp_typed T e)
| _ ⇒ false
end))).
(* QuickChick shrink_typed_has_type. *)
Back to Soundness
To lift the shrinker to optional expressions, QuickChick provides the following function.
Definition lift_shrink {A}
(shr : A → list A) (m : option A)
: list (option A) :=
match m with
| Some x ⇒ List.map Some (shr x)
| _ ⇒ []
end.
(shr : A → list A) (m : option A)
: list (option A) :=
match m with
| Some x ⇒ List.map Some (shr x)
| _ ⇒ []
end.
Armed with shrinking, we can pinpoint the bug in the EAnd branch
of the evaluator.
Definition expression_soundness_exec' :=
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll (gen_well_typed_state Gamma) (fun st ⇒
forAll arbitrary (fun T ⇒
forAllShrink (gen_exp_typed_sized 3 Gamma T)
(lift_shrink (shrink_exp_typed T))
(fun me ⇒
match me with
| Some e ⇒ negb (isNone (eval st e))
| _ ⇒ true
end)))).
(* QuickChick expression_soundness_exec'. *)
let num_vars := 4 in
let top_level_size := 3 in
forAll (gen_context num_vars) (fun Gamma ⇒
forAll (gen_well_typed_state Gamma) (fun st ⇒
forAll arbitrary (fun T ⇒
forAllShrink (gen_exp_typed_sized 3 Gamma T)
(lift_shrink (shrink_exp_typed T))
(fun me ⇒
match me with
| Some e ⇒ negb (isNone (eval st e))
| _ ⇒ true
end)))).
(* QuickChick expression_soundness_exec'. *)
===> QuickChecking expression_soundness_exec' [(1,TNat), (2,TNat), (3,TNat), (4,TBool)] [(1,VNat 0), (2,VNat 0), (3,VNat 0), (4,VBool false)] TBool Some EAnd ETrue ETrue *** Failed after 8 tests and 1 shrinks. (0 discards)
Well-Typed Programs
Inductive com : Type :=
| CSkip : com
| CAsgn : id → exp → com
| CSeq : com → com → com
| CIf : exp → com → com → com
| CWhile : exp → com → com.
Notation "'SKIP'" :=
CSkip.
Notation "x '::=' a" :=
(CAsgn x a) (at level 60).
Notation "c1 ;;; c2" :=
(CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
(CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
(CIf c1 c2 c3) (at level 80, right associativity).
Derive Show for com.
| CSkip : com
| CAsgn : id → exp → com
| CSeq : com → com → com
| CIf : exp → com → com → com
| CWhile : exp → com → com.
Notation "'SKIP'" :=
CSkip.
Notation "x '::=' a" :=
(CAsgn x a) (at level 60).
Notation "c1 ;;; c2" :=
(CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
(CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
(CIf c1 c2 c3) (at level 80, right associativity).
Derive Show for com.
(Of course, the derived Show instance is not going to use these
notations!)
We can now define what it means for a command to be well typed
for a given context. The interesting cases are TAsgn and TIf/TWhile.
The first one, ensures that the type of the variable we are
assigning to is the same as that of the expression. The latter,
requires that the conditional is indeed a boolean expression.
Inductive well_typed_com : context → com → Prop :=
| TSkip : ∀ Gamma, well_typed_com Gamma CSkip
| TAsgn : ∀ Gamma x e T,
bound_to Gamma x T →
Gamma |⊢ e \IN T →
well_typed_com Gamma (CAsgn x e)
| TSeq : ∀ Gamma c1 c2,
well_typed_com Gamma c1 → well_typed_com Gamma c2 →
well_typed_com Gamma (CSeq c1 c2)
| TIf : ∀ Gamma b c1 c2,
Gamma |⊢ b \IN TBool →
well_typed_com Gamma c1 → well_typed_com Gamma c2 →
well_typed_com Gamma (CIf b c1 c2)
| TWhile : ∀ Gamma b c,
Gamma |⊢ b \IN TBool → well_typed_com Gamma c →
well_typed_com Gamma (CWhile b c).
| TSkip : ∀ Gamma, well_typed_com Gamma CSkip
| TAsgn : ∀ Gamma x e T,
bound_to Gamma x T →
Gamma |⊢ e \IN T →
well_typed_com Gamma (CAsgn x e)
| TSeq : ∀ Gamma c1 c2,
well_typed_com Gamma c1 → well_typed_com Gamma c2 →
well_typed_com Gamma (CSeq c1 c2)
| TIf : ∀ Gamma b c1 c2,
Gamma |⊢ b \IN TBool →
well_typed_com Gamma c1 → well_typed_com Gamma c2 →
well_typed_com Gamma (CIf b c1 c2)
| TWhile : ∀ Gamma b c,
Gamma |⊢ b \IN TBool → well_typed_com Gamma c →
well_typed_com Gamma (CWhile b c).
Now, here is a brute-force decision procedure for the typing
relation (which amounts to a simple typechecker).
Instance dec_well_typed_com (Gamma : context) (c : com)
: Dec (well_typed_com Gamma c).
: Dec (well_typed_com Gamma c).
Proof with eauto.
constructor. unfold ssrbool.decidable.
induction c; solve_sum.
- destruct (dec_bound_to Gamma i TNat); destruct dec;
destruct (dec_has_type e Gamma TNat); destruct dec;
destruct (dec_bound_to Gamma i TBool); destruct dec;
destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum;
try solve_det; try congruence;
right; intro Contra; inversion Contra; subst; clear Contra;
try solve_det; try congruence;
destruct T; eauto.
- destruct IHc1; destruct IHc2; subst; eauto; solve_sum.
- destruct IHc1; destruct IHc2; subst; eauto; solve_sum.
destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum.
- destruct IHc;
destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum.
Qed.
constructor. unfold ssrbool.decidable.
induction c; solve_sum.
- destruct (dec_bound_to Gamma i TNat); destruct dec;
destruct (dec_has_type e Gamma TNat); destruct dec;
destruct (dec_bound_to Gamma i TBool); destruct dec;
destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum;
try solve_det; try congruence;
right; intro Contra; inversion Contra; subst; clear Contra;
try solve_det; try congruence;
destruct T; eauto.
- destruct IHc1; destruct IHc2; subst; eauto; solve_sum.
- destruct IHc1; destruct IHc2; subst; eauto; solve_sum.
destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum.
- destruct IHc;
destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum.
Qed.
To complete the tour of testing for TImp, here is a (buggy??) evaluation function for commands given a state. To ensure termination, we've included a "fuel" parameter: if it gets to zero we return OutOfGas, signifying that we're not sure if evaluation would have succeeded, failed, or diverged if we'd gone on evaluating.
Inductive result :=
| Success : state → result
| Fail : result
| OutOfGas : result.
Fixpoint ceval (fuel : nat) (st : state) (c : com) : result :=
match fuel with
| O ⇒ OutOfGas
| S fuel' ⇒
match c with
| SKIP ⇒
Success st
| x ::= e ⇒
match eval st e with
| Some v ⇒ Success (map_set st x v)
| _ ⇒ Fail
end
| c1 ;;; c2 ⇒
match ceval fuel' st c1 with
| Success st' ⇒ ceval fuel' st' c2
| _ ⇒ Fail
end
| TEST b THEN c1 ELSE c2 FI ⇒
match eval st b with
| Some (VBool b) ⇒
ceval fuel' st (if b then c1 else c2)
| _ ⇒ Fail
end
| WHILE b DO c END ⇒
match eval st b with
| Some (VBool b') ⇒
if b'
then ceval fuel' st (c ;;; WHILE b DO c END)
else Success st
| _ ⇒ Fail
end
end
end.
Definition isFail r :=
match r with
| Fail ⇒ true
| _ ⇒ false
end.
| Success : state → result
| Fail : result
| OutOfGas : result.
Fixpoint ceval (fuel : nat) (st : state) (c : com) : result :=
match fuel with
| O ⇒ OutOfGas
| S fuel' ⇒
match c with
| SKIP ⇒
Success st
| x ::= e ⇒
match eval st e with
| Some v ⇒ Success (map_set st x v)
| _ ⇒ Fail
end
| c1 ;;; c2 ⇒
match ceval fuel' st c1 with
| Success st' ⇒ ceval fuel' st' c2
| _ ⇒ Fail
end
| TEST b THEN c1 ELSE c2 FI ⇒
match eval st b with
| Some (VBool b) ⇒
ceval fuel' st (if b then c1 else c2)
| _ ⇒ Fail
end
| WHILE b DO c END ⇒
match eval st b with
| Some (VBool b') ⇒
if b'
then ceval fuel' st (c ;;; WHILE b DO c END)
else Success st
| _ ⇒ Fail
end
end
end.
Definition isFail r :=
match r with
| Fail ⇒ true
| _ ⇒ false
end.
Conjecture well_typed_state_never_stuck :
∀ Gamma st, well_typed_state Gamma st →
∀ c, well_typed_com Gamma c →
∀ fuel, isFail (ceval fuel st c) = false.
∀ Gamma st, well_typed_state Gamma st →
∀ c, well_typed_com Gamma c →
∀ fuel, isFail (ceval fuel st c) = false.
Exercise: 4 stars, standard (well_typed_state_never_stuck)
Write a checker for the above property, find any bugs, and fix them.
(* FILL IN HERE *)
Exercise: 4 stars, standard (ty_eq_polymorphic)
In the has_type relation we allowed equality checks between only arithmetic expressions. Introduce an additional typing rule that allows for equality checks between booleans.| Ty_Eq : ∀ Gamma e1 e2,
Gamma |⊢ e1 \IN TBool → Gamma |⊢ e2 \IN TBool →
Gamma |⊢ EEq e1 e2 \IN TBool Make sure you also update the evaluation relation to compare boolean values. Update the generators and shrinkers accordingly to find counterexamples to the buggy properties above.
Automation (Revisited)
Inductive has_type_value : value → ty → Prop :=
| TyVNat : ∀ n, has_type_value (VNat n) TNat
| TyVBool : ∀ b, has_type_value (VBool b) TBool.
Definition gen_typed_value (T : ty) : G value :=
match T with
| TNat ⇒ n <- arbitrary;; ret (VNat n)
| TBool ⇒ b <- arbitrary;; ret (VBool b)
end. QuickChick includes a derivation mechanism that can automatically produce such generators -- i.e., generators for data structures satisfying inductively defined properties!
Derive ArbitrarySizedSuchThat for (fun v ⇒ has_type_value v T).
===>
GenSizedSuchThathas_type_value is defined.
Let's take a closer look at what is being generated (after doing some renaming and reformatting).
Print GenSizedSuchThathas_type_value.
===> GenSizedSuchThathas_type_value = fun T : ty => {| arbitrarySizeST := let fix aux_arb (size0 : nat) (T : ty) {struct size0} : G (option value) := match size0 with | 0 => backtrack [(1, match T with | TBool => ret None | TNat => n <- arbitrary;; ret (Some (VNat n)) end) ;(1, match T with | TBool => b <- arbitrary;; ret (Some (VBool b))) | TNat => ret None end)] | S _ => backtrack [(1, match T with | TBool => ret None | TNat => n <- arbitrary;; ret (Some (VNat n)) end) ;(1, match T with | TBool => b <- arbitrary;; ret (Some (VBool b))) | TNat => ret None end)] end in fun size0 : nat => aux_arb size0 T |} : forall T : ty, GenSizedSuchThat value (fun v => has_type_value v T)
(More) Typeclasses for Generation
Module GenSTPlayground.
A variant that takes a size,...
Class GenSizedSuchThat (A : Type) (P : A → Prop) :=
{ arbitrarySizeST : nat → G (option A) }.
{ arbitrarySizeST : nat → G (option A) }.
...an unsized variant,...
Class GenSuchThat (A : Type) (P : A → Prop) :=
{ arbitraryST : G (option A) }.
{ arbitraryST : G (option A) }.
...convenient notation,...
Notation "'genST' x" := (@arbitraryST _ x _) (at level 70).
...and a coercion between the two:
Instance GenSuchThatOfBounded (A : Type) (P : A → Prop)
(H : GenSizedSuchThat A P)
: GenSuchThat A P :=
{ arbitraryST := sized arbitrarySizeST }.
End GenSTPlayground.
(H : GenSizedSuchThat A P)
: GenSuchThat A P :=
{ arbitraryST := sized arbitrarySizeST }.
End GenSTPlayground.
Using "SuchThat" Typeclasses
Conjecture conditional_prop_example :
∀ (x y : nat), x = y → x = y.
(* QuickChick conditional_prop_example. *)
∀ (x y : nat), x = y → x = y.
(* QuickChick conditional_prop_example. *)