Commit 11c5302e authored by Jakob Botsch Nielsen's avatar Jakob Botsch Nielsen
Browse files

Start of modelling oak_any

parent fd2bb5a5
Pipeline #11675 failed with stage
in 5 minutes and 58 seconds
From Coq Require Import List. From Coq Require Import List.
From SmartContracts Require Import Monads.
Import ListNotations. Import ListNotations.
Fixpoint find_first {A B : Type} (f : A -> option B) (l : list A) Fixpoint find_first {A B : Type} (f : A -> option B) (l : list A)
...@@ -20,3 +21,11 @@ Fixpoint map_option {A B : Type} (f : A -> option B) (l : list A) ...@@ -20,3 +21,11 @@ Fixpoint map_option {A B : Type} (f : A -> option B) (l : list A)
end end
| [] => [] | [] => []
end. end.
Fixpoint mapM {A B : Type} (f : A -> option B) (l : list A) : option (list B) :=
match l with
| hd :: tl => do b <- f hd;
do bs <- mapM f tl;
Some (b :: bs)
| [] => Some []
end.
From Coq Require Import ZArith. From Coq Require Import ZArith.
From SmartContracts Require Import Monads. From SmartContracts Require Import Monads.
From SmartContracts Require Import Extras.
From SmartContracts Require Import Containers. From SmartContracts Require Import Containers.
From Coq Require Import List. From Coq Require Import List.
Import ListNotations. Import ListNotations.
Inductive OakType := Inductive OakType :=
| oak_empty : OakType
| oak_unit : OakType
| oak_int : OakType | oak_int : OakType
| oak_bool : OakType | oak_any : OakType
| oak_pair : OakType -> OakType -> OakType | oak_pair : OakType -> OakType -> OakType
| oak_sum : OakType -> OakType -> OakType | oak_sum : OakType -> OakType -> OakType
| oak_list : OakType -> OakType | oak_list : OakType -> OakType.
| oak_set : OakType -> OakType
| oak_map : OakType -> OakType -> OakType. Inductive OakTyped : OakType -> Type -> Type :=
| typ_int : OakTyped oak_int Z
| typ_any :
forall {ot t},
OakTyped ot t ->
OakTyped oak_any t
| typ_pair :
forall {lot rot lt rt},
OakTyped lot lt ->
OakTyped rot rt ->
OakTyped (oak_pair lot rot) (lt * rt)
| typ_sum :
forall {lot rot lt rt},
OakTyped lot lt ->
OakTyped rot rt ->
OakTyped (oak_sum lot rot) (lt + rt)
| typ_list :
forall {ot t},
OakTyped ot t -> OakTyped (oak_list ot) (list t).
Definition eq_oak_type_dec (t1 t2 : OakType) : {t1 = t2} + {t1 <> t2}. Set Primitive Projections.
Proof. decide equality. Defined. Record OakValue :=
build_oak_value {
ov_ot : OakType;
ov_t : Type;
ov_typed : OakTyped ov_ot ov_t;
ov_val : ov_t;
}.
Arguments build_oak_value {_ _} _ _.
Fixpoint interp_type (ot : OakType) : Type :=
match ot with
| oak_int => Z
| oak_any => OakValue
| oak_pair ot1 ot2 => (interp_type ot1) * (interp_type ot2)
| oak_sum ot1 ot2 => (interp_type ot1) + (interp_type ot2)
| oak_list ot => list (interp_type ot)
end.
Proposition eq_oak_type_dec_refl (x : OakType) : Definition extract_from_any
eq_oak_type_dec x x = left eq_refl. (extract_as : OakType)
(t : Type) (typed : OakTyped oak_any t)
(val : t)
(f : forall (extract_as : OakType)
(ot : OakType) (t : Type) (typed : OakTyped ot t)
(val : t), option (interp_type extract_as))
: option (interp_type extract_as).
Proof. Proof.
induction x; inversion typed; subst.
try simpl; try rewrite IHx; try rewrite IHx1; try rewrite IHx2; reflexivity. exact (f extract_as ot t X val).
Qed. Defined.
(* Defining this as a fixpoint instead of by induction over typed
allows us to handle oak_any generally for all cases *)
Fixpoint extract_typed
(extract_as : OakType)
{ot : OakType} {t : Type} (typed : OakTyped ot t)
(val : t) {struct typed}
: option (interp_type extract_as).
Proof.
revert typed val.
refine (
match extract_as, ot
return (forall (typed : OakTyped ot t) (val : t),
option (interp_type extract_as)) with
| oak_any, ot =>
let f (typed : OakTyped ot t) (val : t) : option OakValue :=
Some (build_oak_value typed val) in f
| extract_as, oak_any =>
let f (typed : OakTyped oak_any t) (val : t) : option (interp_type extract_as) :=
extract_from_any extract_as t typed val extract_typed in f
| oak_int, oak_int => _
| oak_pair elot erot, oak_pair lot rot => _
| oak_sum elot erot, oak_sum lot rot => _
| oak_list eot, oak_list ot => _
| _, _ => fun typed val => None
end); intros typed val.
- inversion typed; subst; exact (Some val).
- inversion typed; subst.
exact (do l <- extract_typed elot lot lt X (fst val);
do r <- extract_typed erot rot rt X0 (snd val);
Some (l, r)).
- inversion typed; subst.
destruct val as [l | r].
+ exact (option_map inl (extract_typed elot lot lt X l)).
+ exact (option_map inr (extract_typed erot rot rt X0 r)).
- inversion typed; subst.
exact (mapM (extract_typed eot ot t0 X) val).
Defined.
Definition unpack_value (ot : OakType) (v : OakValue) : option (interp_type ot) :=
match v with
| build_oak_value typed val => extract_typed ot typed val
end.
Definition test_int : OakValue :=
build_oak_value typ_int 10%Z.
Definition test_int_any : OakValue :=
build_oak_value (typ_any typ_int) 10%Z.
Compute unpack_value oak_int test_int.
Compute (unpack_value oak_int test_int_any).
Fixpoint pack_value_full (ot : OakType) (v : interp_type ot) {struct ot}
: { ov : OakValue & ov.(ov_ot) = ot }.
Proof.
destruct ot as [| | t1 t2| t1 t2|ot].
- exact (existT (build_oak_value typ_int v) eq_refl).
- exact (existT (build_oak_value (typ_any v.(ov_typed)) v.(ov_val)) eq_refl).
- destruct v as [l r].
destruct (pack_value_full t1 l) as [[lot lt ltyped lval] lot_eq].
destruct (pack_value_full t2 r) as [[rot rt rtyped rval] rot_eq].
simpl in *; subst.
exact (existT (build_oak_value (typ_pair ltyped rtyped) (lval, rval)) eq_refl).
- destruct v as [l | r].
+ destruct (pack_value_full t1 l) as [[lot lt ltyped lval] lot_eq].
(*
- refine (existT (build_oak_value typ_int v) _).
reflexivity.
- destruct v as [ot t typed v].
refine (existT (build_oak_value (typ_any typed) v) _).
reflexivity.
- destruct v as [l r].
destruct (pack_value_full t1 l) as [[lot lt ltyped lval] l_tsound].
destruct (pack_value_full t2 r) as [[rot rt rtyped rval] r_tsound].
simpl in *; subst.
refine (existT (build_oak_value (typ_pair ltyped rtyped) (lval, rval)) _).
reflexivity.
- destruct v as [l | r].
+ destruct (pack_value_full t1 l) as [[lot lt ltyped lval] l_tsound].
simpl in l_tsound; subst.
refine (existT (build_oak_value (typ_sum ltyped typ_int) (inl lval)) _).
reflexivity.
+ destruct (pack_value_full t2 l) as [[rot rt rtyped rval] r_tsound].
match ot with
| oak_int => build_oak_value oak_int Z typ_int
| oak_any => id
| oak_pair t1 t2 =>
fun (p : interp_type t1 * interp_type t2) =>
let 'build_oak_value lot lt ltyped lval := pack_value t1 (fst p) in
let 'build_oak_value rot rt rtyped rval := pack_value t2 (snd p) in
build_oak_value
(oak_pair t1 t2)
(lt * rt)%type
(typ_pair lot rot lt rt ltyped rtyped)
(lval, rval)
| _ => fun t => build_oak_value oak_int Z typ_int 0
end.
Set Primitive Projections. Set Primitive Projections.
Record OakInterpretation := Record OakInterpretation :=
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment