├── examples ├── extract-io │ ├── io.expected │ ├── dune │ └── IO.v ├── _CoqProject.make ├── extract-threads │ ├── dune │ ├── runthread.expected │ ├── ExtractThreadsExample.v │ └── runthread.ml ├── Makefile ├── dune ├── MultiThreadedPrinting.v ├── ReadmeExample.v ├── LC.v ├── STLC.v └── Nimp.v ├── tutorial ├── extract-imptest │ ├── imp_test.expected │ ├── dune │ └── ImpTest.v ├── dune ├── PrintAssumptions.v ├── _CoqProject.make ├── Makefile ├── README.md ├── CatTheory.v ├── KTreeFin.v └── Imp2Asm.v ├── tests ├── _CoqProject.make ├── Makefile ├── extract-tests │ ├── dune │ └── Tests.v └── extraction-test.sh ├── fixup.sh ├── theories ├── dune ├── Eq.v ├── Basics │ ├── Category.v │ ├── CategoryFunctor.v │ ├── Monad.v │ ├── Function.v │ ├── CategoryKleisli.v │ ├── Utils.v │ ├── FunctionFacts.v │ ├── MonadProp.v │ ├── Basics.v │ └── CategorySub.v ├── ITreeFacts.v ├── ITree.v ├── Indexed │ ├── FunctionFacts.v │ ├── Sum.v │ ├── Function.v │ └── Relation.v ├── Eq │ ├── EqAxiom.v │ ├── EuttExtras.v │ ├── Shallow.v │ └── Paco2.v ├── Props │ └── Cofinite.v ├── Events │ ├── Reader.v │ ├── Dependent.v │ ├── Exception.v │ ├── Map.v │ ├── Nondeterminism.v │ ├── Writer.v │ ├── Concurrency.v │ ├── State.v │ └── MapDefault.v ├── Core │ ├── ITreeMonad.v │ ├── KTree.v │ └── Subevent.v ├── Events.v ├── Axioms.v └── Interp │ ├── Interp.v │ ├── Handler.v │ └── Recursion.v ├── hoare_example ├── Makefile ├── _CoqProject └── ImpIO.v ├── secure_example ├── Makefile ├── _CoqProject ├── CatTheory.v ├── LabelledAsmHandler.v ├── KTreeFin.v ├── LabelledImpInline.v ├── LabelledImp.v ├── Lattice.v └── LabelledImpHandler.v ├── extra ├── dune ├── Secure │ ├── StrongBisimProper.v │ └── Labels.v ├── ITrace │ └── ITraceDefinition.v └── Dijkstra │ ├── DijkstraMonad.v │ ├── PureITreeBasics.v │ └── IterRel.v ├── coq-itree-extra.opam.template ├── _CoqProject.dune ├── meta.yml ├── .gitignore ├── coq-itree-extra.opam ├── _CoqProject.extra ├── dune-project ├── coq-itree.opam ├── .github └── workflows │ ├── build-with-make.yml │ └── docker-action.yml ├── DMonadREADME.md ├── common.mk ├── LICENSE ├── Makefile ├── _CoqProject.itree ├── README.md ├── DEV.md └── CHANGELOG.md /examples/extract-io/io.expected: -------------------------------------------------------------------------------- 1 | OK! 2 | -------------------------------------------------------------------------------- /tutorial/extract-imptest/imp_test.expected: -------------------------------------------------------------------------------- 1 | 2 | X:=0;Y:=3628800; 3 | -------------------------------------------------------------------------------- /tutorial/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name ITreeTutorial) 3 | (theories ITree)) 4 | -------------------------------------------------------------------------------- /tests/_CoqProject.make: -------------------------------------------------------------------------------- 1 | -Q ../theories ITree 2 | -Q src/ ITreeTestExtraction 3 | -------------------------------------------------------------------------------- /fixup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | awk '/\(theories/ { sub(/^/,";") } ; {print}' extra/dune > tmp && mv tmp extra/dune 3 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (coq.theory 4 | (name ITree) 5 | (package coq-itree)) 6 | -------------------------------------------------------------------------------- /hoare_example/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: hoare 2 | 3 | hoare: coq 4 | 5 | include ../common.mk 6 | 7 | clean: clean-coq 8 | -------------------------------------------------------------------------------- /secure_example/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: secure 2 | 3 | secure: coq 4 | 5 | include ../common.mk 6 | 7 | clean: clean-coq 8 | -------------------------------------------------------------------------------- /hoare_example/_CoqProject: -------------------------------------------------------------------------------- 1 | -Q ../theories/ ITree 2 | -Q ../extra ITree.Extra 3 | -R . hoare 4 | 5 | Imp.v 6 | ImpHoare.v 7 | -------------------------------------------------------------------------------- /extra/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (coq.theory 4 | (name ITree.Extra) 5 | (package coq-itree-extra) 6 | (theories ITree) 7 | ) 8 | -------------------------------------------------------------------------------- /coq-itree-extra.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | [ "./fixup.sh" ] 3 | [ "dune" "subst"] {pinned} 4 | [ "dune" "build" "-p" name "-j" jobs "@install" ] 5 | ] 6 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: extraction clean 2 | 3 | extraction: 4 | sh extraction-test.sh 5 | 6 | clean: 7 | rm -rf output 8 | rm -f **/.*.aux **/*.{vo,vos,vok,glob} 9 | -------------------------------------------------------------------------------- /tests/extract-tests/dune: -------------------------------------------------------------------------------- 1 | (coq.extraction 2 | (prelude Tests) 3 | (theories ITree) 4 | (extracted_modules test)) 5 | 6 | (tests 7 | (flags -w -20-33-3) 8 | (names test)) 9 | -------------------------------------------------------------------------------- /theories/Eq.v: -------------------------------------------------------------------------------- 1 | (** * Equivalences for interaction trees *) 2 | 3 | From ITree.Eq Require Export 4 | Shallow 5 | Eqit 6 | UpToTaus 7 | SimUpToTaus 8 | EuttExtras. 9 | -------------------------------------------------------------------------------- /examples/extract-io/dune: -------------------------------------------------------------------------------- 1 | (coq.extraction 2 | (prelude IO) 3 | (extracted_modules io) 4 | (theories ITree) 5 | ) 6 | 7 | (tests 8 | (flags -w -20-33-3) 9 | (names io)) 10 | -------------------------------------------------------------------------------- /tutorial/PrintAssumptions.v: -------------------------------------------------------------------------------- 1 | From ITreeTutorial Require Import Imp2AsmCorrectness AsmOptimization. 2 | 3 | Print Assumptions Imp2AsmCorrectness.compile_correct. 4 | Print Assumptions AsmOptimization.simple_correct. 5 | -------------------------------------------------------------------------------- /_CoqProject.dune: -------------------------------------------------------------------------------- 1 | -Q _build/default/theories ITree 2 | -Q _build/default/extra ITree.Extra 3 | -Q _build/default/examples ITreeExamples 4 | -Q _build/default/tutorial ITreeTutorial 5 | -Q _build/default/tests ITreeTests 6 | -------------------------------------------------------------------------------- /tutorial/extract-imptest/dune: -------------------------------------------------------------------------------- 1 | (coq.extraction 2 | (prelude ImpTest) 3 | (extracted_modules imp_test) 4 | (theories ITree ITreeTutorial) 5 | ) 6 | 7 | (tests 8 | (flags -w -20-33-3) 9 | (names imp_test)) 10 | -------------------------------------------------------------------------------- /examples/_CoqProject.make: -------------------------------------------------------------------------------- 1 | -Q ../theories ITree 2 | -R . ITreeExamples 3 | 4 | ReadmeExample.v 5 | IntroductionSolutions.v 6 | 7 | MultiThreadedPrinting.v 8 | 9 | Nimp.v 10 | LC.v 11 | 12 | ITreePredicatesExample.v 13 | -------------------------------------------------------------------------------- /theories/Basics/Category.v: -------------------------------------------------------------------------------- 1 | (** * Generic library for categories (reexports the three other modules) *) 2 | 3 | From ITree.Basics Require Export 4 | CategoryOps 5 | CategoryTheory 6 | CategoryFacts 7 | CategoryFunctor. 8 | -------------------------------------------------------------------------------- /examples/extract-threads/dune: -------------------------------------------------------------------------------- 1 | (coq.extraction 2 | (prelude ExtractThreadsExample) 3 | (extracted_modules MultiThreadedPrinting) 4 | (theories ITree ITreeExamples) 5 | ) 6 | 7 | (tests 8 | (flags -w -20-33-3) 9 | (names runthread)) 10 | -------------------------------------------------------------------------------- /examples/extract-threads/runthread.expected: -------------------------------------------------------------------------------- 1 | Thread 1 2 | Thread 2 3 | Thread 1 4 | Thread 3 5 | Thread 2 6 | Thread 1 7 | Thread 3 8 | Thread 2 9 | Thread 1 10 | Thread 3 11 | Thread 2 12 | Thread 1 13 | Thread 3 14 | Thread 2 15 | Out of fuel! 16 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: examples clean 2 | 3 | examples: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | _CoqProject: _CoqProject.make 7 | cp _CoqProject.make _CoqProject 8 | 9 | include ../common.mk 10 | 11 | clean: clean-coq 12 | rm -f _CoqProject 13 | -------------------------------------------------------------------------------- /tests/extraction-test.sh: -------------------------------------------------------------------------------- 1 | set -xe 2 | mkdir -p output 3 | cd output/ 4 | 5 | COQOPTS="-Q ../../theories ITree -Q ../ ITreeTestExtraction" 6 | 7 | coqc $COQOPTS ../extract-tests/Tests.v 8 | 9 | ocamlopt test.mli test.ml -o test.native 10 | ./test.native 11 | 12 | # This executable should do absolutely nothing 13 | -------------------------------------------------------------------------------- /tutorial/_CoqProject.make: -------------------------------------------------------------------------------- 1 | -Q ../theories/ ITree 2 | -R . ITreeTutorial 3 | 4 | Introduction.v 5 | 6 | Utils_tutorial.v 7 | Fin.v 8 | KTreeFin.v 9 | CatTheory.v 10 | Imp.v 11 | Asm.v 12 | AsmCombinators.v 13 | Imp2Asm.v 14 | Imp2AsmCorrectness.v 15 | AsmOptimization.v 16 | PrintAssumptions.v 17 | extract-imptest/ImpTest.v 18 | -------------------------------------------------------------------------------- /tutorial/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: tutorial test clean 2 | 3 | tutorial: coq test 4 | 5 | coq: _CoqProject 6 | 7 | test: coq 8 | ocamlopt -w -33-20-3 imp_test.mli imp_test.ml -o imp_test.native 9 | ./imp_test.native 10 | 11 | include ../common.mk 12 | 13 | _CoqProject: 14 | cp _CoqProject.make _CoqProject 15 | 16 | clean: clean-coq 17 | rm -f _CoqProject 18 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name ITreeExamples) 3 | (modules 4 | IntroductionSolutions 5 | Nimp 6 | LC 7 | STLC 8 | ReadmeExample 9 | ITreePredicatesExample 10 | MultiThreadedPrinting) 11 | (theories ITree) 12 | ) 13 | 14 | ; Extraction is in a separate directory (extraction/) because dune's 15 | ; coq.extraction assigns it another library name than ITreeExamples 16 | -------------------------------------------------------------------------------- /examples/extract-threads/ExtractThreadsExample.v: -------------------------------------------------------------------------------- 1 | From Coq Require ExtrOcamlBasic ExtrOcamlString. 2 | 3 | From ITreeExamples Require Import MultiThreadedPrinting. 4 | 5 | Extraction Language OCaml. 6 | Extraction Blacklist String List Char Core Z. 7 | 8 | Set Extraction AccessOpaque. 9 | 10 | Set Warnings "-extraction-default-directory". 11 | Extraction "MultiThreadedPrinting.ml" scheduled_thread. 12 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | fullname: Interaction Trees 2 | shortname: itree 3 | organization: DeepSpec 4 | action: true 5 | ci_test_dependants: 6 | enabled: true 7 | packages: ['coq-ctree', 'coq-itree-extra', 'coq-itree-io'] 8 | dune: true 9 | tested_coq_opam_versions: 10 | - version: '8.14' 11 | - version: '8.15' 12 | - version: '8.16' 13 | - version: '8.17' 14 | - version: '8.18' 15 | - version: '8.19' 16 | - version: '8.20' 17 | tested_rocq_opam_versions: 18 | - version: '9.0' 19 | - version: 'dev' 20 | -------------------------------------------------------------------------------- /theories/ITreeFacts.v: -------------------------------------------------------------------------------- 1 | (** * Main module with theorems *) 2 | 3 | From ITree Require Export 4 | Basics.Utils 5 | Basics.Basics 6 | Basics.Category 7 | Basics.Monad 8 | Basics.CategoryKleisli 9 | Basics.CategoryKleisliFacts 10 | Basics.FunctionFacts 11 | Core.ITreeDefinition 12 | Eq 13 | Core.ITreeMonad 14 | Core.KTreeFacts 15 | Indexed.FunctionFacts 16 | Interp.TranslateFacts 17 | Interp.InterpFacts 18 | Interp.HandlerFacts 19 | Interp.RecursionFacts 20 | . 21 | -------------------------------------------------------------------------------- /theories/ITree.v: -------------------------------------------------------------------------------- 1 | (** * Main module *) 2 | 3 | (** The main definitions to construct programs with are 4 | gathered here. 5 | 6 | Theorems can be accessed via [ITree.ITreeFacts], 7 | and some standard effects via [ITree.Events]. 8 | *) 9 | 10 | From ITree Require Export 11 | Basics.Basics 12 | Basics.CategoryOps 13 | Basics.Function 14 | Core.ITreeDefinition 15 | Core.KTree 16 | Core.Subevent 17 | Eq.UpToTaus 18 | Indexed.Function 19 | Indexed.Sum 20 | Interp.Interp 21 | Interp.Handler 22 | Interp.Recursion 23 | . 24 | -------------------------------------------------------------------------------- /extra/Secure/StrongBisimProper.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Morphisms. 2 | 3 | From ITree Require Import 4 | ITree 5 | ITreeFacts 6 | Eq.EqAxiom 7 | . 8 | 9 | From Paco Require Import paco. 10 | 11 | (* Tau t ≈ t*) 12 | (* eqit_secure (Vis e k) (k a) *) 13 | 14 | (* r => fun (f g : A -> B) => f = g*) 15 | Global Instance strong_bisim_proper_paco {E R1 R2 F r} : 16 | Proper (@eq_itree E R1 R1 eq ==> @eq_itree E R2 R2 eq ==> flip impl) (paco2 F r). 17 | Proof. 18 | repeat intro. apply bisimulation_is_eq in H. apply bisimulation_is_eq in H0. 19 | subst. auto. 20 | Qed. 21 | -------------------------------------------------------------------------------- /hoare_example/ImpIO.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import String. 2 | 3 | Inductive aexp := 4 | | AId : string -> aexp 5 | | ANum : nat -> aexp 6 | | APlus : aexp -> aexp -> aexp 7 | | AMinus : aexp -> aexp -> aexp 8 | | AMult : aexp -> aexp -> aexp 9 | . 10 | 11 | Inductive bexp := 12 | | BEq : aexp -> aexp -> bexp 13 | | BLeq : aexp -> aexp -> bexp 14 | | BNot : bexp -> bexp 15 | | BAnd : bexp -> bexp 16 | | BTrue : bexp 17 | . 18 | 19 | Inductive com := 20 | | CSeq : com -> com -> com 21 | | CIf : bexp -> com -> com -> com 22 | | CAss : string -> aexp -> com 23 | | CWhile : bexp -> com -> com 24 | | CPrint : aexp -> com 25 | | CRead : string -> com 26 | . 27 | -------------------------------------------------------------------------------- /secure_example/_CoqProject: -------------------------------------------------------------------------------- 1 | -Q ../theories/ ITree 2 | -Q ../extra/ ITree.Extra 3 | -R . SecureExample 4 | 5 | Lattice.v 6 | 7 | LabelledImp.v 8 | Fin.v 9 | KTreeFin.v 10 | CatTheory.v 11 | LabelledAsm.v 12 | Utils_tutorial.v 13 | 14 | LabelledAsmCombinators.v 15 | LabelledAsmHandler.v 16 | LabelledImp2Asm.v 17 | LabelledImpHandler.v 18 | LabelledImp2AsmCorrectness.v 19 | 20 | LabelledImpTypes.v 21 | LabelledImpTypesProgInsens.v 22 | LabelledImp2AsmNoninterferencePres.v 23 | 24 | LabelledImpInline.v 25 | LabelledImpInline2Asm.v 26 | LabelledImpInline2AsmCorrectness.v 27 | LabelledImpInline2AsmNoninterferencePres.v 28 | LabelledImpInlineTypes.v 29 | LabelledImpInlineTypesProgInsens.v 30 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | **.vo 2 | **.v.d 3 | **.glob 4 | *.v# 5 | **.cmo 6 | **.cmi 7 | **.cmx 8 | **.null 9 | **/_build 10 | *~ 11 | *.v~ 12 | *.log 13 | *.aux 14 | *.stackdump 15 | *.bbl 16 | *.blg 17 | *.fdb_latexmk 18 | *.fls 19 | *.ml~ 20 | examples.mli 21 | *.gz 22 | **.coq.d 23 | *.vok 24 | *.vos 25 | *.o 26 | .nia.cache 27 | .lia.cache 28 | output 29 | deps.jpg 30 | deps.dot 31 | 32 | .coqdeps.d 33 | Makefile.coq 34 | Makefile.coq.conf 35 | /_CoqProject 36 | examples/_CoqProject 37 | tutorial/_CoqProject 38 | _CoqPath 39 | lib/ 40 | html/ 41 | doc 42 | coqdocjs* 43 | 44 | tests/extraction/*.ml 45 | tests/extraction/*.mli 46 | examples/io.ml 47 | examples/io.mli 48 | examples/extracted/ 49 | tutorial/imp_test.ml 50 | tutorial/imp_test.mli 51 | 52 | *.native 53 | 54 | *.install 55 | -------------------------------------------------------------------------------- /extra/Secure/Labels.v: -------------------------------------------------------------------------------- 1 | (* Shared definitions for the Secure component. *) 2 | 3 | From ITree Require Import 4 | Basics.Utils 5 | Axioms. 6 | 7 | Variant nonempty (A : Type) : Prop := ne (a : A). 8 | 9 | Variant empty (A : Type) : Prop := emp : (A -> False) -> empty A. 10 | 11 | Lemma classic_empty : forall A, empty A \/ nonempty A. 12 | Proof. 13 | intros. destruct (classic (nonempty A)); eauto. 14 | left. constructor. intros. apply H. constructor; auto. 15 | Qed. 16 | 17 | Class Preorder := 18 | { 19 | L : Type; 20 | leq : L -> L -> Prop; 21 | }. 22 | 23 | Ltac contra_size := 24 | match goal with 25 | | [ Hemp : empty ?A, Hne : nonempty ?A |- _ ] => inv Hemp; inv Hne; contradiction 26 | | [ Hemp : empty ?A, a :?A |- _] => inv Hemp; contradiction 27 | end 28 | . 29 | -------------------------------------------------------------------------------- /coq-itree-extra.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: "Extensions to coq-itree" 5 | maintainer: ["Li-yao Xia "] 6 | authors: [ 7 | "Lucas Silver" "Irene Yoon" "Paul He" "Yannick Zakowski" "Steve Zdancewic" 8 | ] 9 | license: "MIT" 10 | tags: ["org:deepspec"] 11 | homepage: "https://github.com/DeepSpec/InteractionTrees" 12 | bug-reports: "https://github.com/DeepSpec/InteractionTrees/issues" 13 | depends: [ 14 | "dune" {>= "2.6"} 15 | "coq" 16 | "coq-ext-lib" 17 | "coq-paco" 18 | "coq-itree" 19 | ] 20 | dev-repo: "git+https://github.com/DeepSpec/InteractionTrees.git" 21 | build: [ 22 | [ "./fixup.sh" ] 23 | [ "dune" "subst"] {pinned} 24 | [ "dune" "build" "-p" name "-j" jobs "@install" ] 25 | ] 26 | -------------------------------------------------------------------------------- /theories/Indexed/FunctionFacts.v: -------------------------------------------------------------------------------- 1 | (** * Theorems for [ITree.Indexed.Function] *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | Setoid 6 | Morphisms. 7 | 8 | From ITree Require Import 9 | Basics.Basics 10 | Indexed.Function 11 | Indexed.Relation. 12 | 13 | Set Universe Polymorphism. 14 | (* end hide *) 15 | 16 | #[global] 17 | Instance Proper_apply_IFun {E F : Type -> Type} {T : Type} 18 | (RE : forall T, E T -> E T -> Prop) 19 | (RF : forall T, F T -> F T -> Prop) 20 | : Proper (i_respectful RE RF ==> RE T ==> RF T) apply_IFun. 21 | Proof. 22 | repeat red; eauto. 23 | Qed. 24 | 25 | Lemma fold_apply_IFun {E F : Type -> Type} {T : Type} 26 | : forall (f : E ~> F) (t : E T), 27 | f _ t = apply_IFun f t. 28 | Proof. 29 | reflexivity. 30 | Qed. 31 | -------------------------------------------------------------------------------- /theories/Eq/EqAxiom.v: -------------------------------------------------------------------------------- 1 | (** * Strong bisimulation is propositional equality *) 2 | 3 | (** This is not provable but admissible as an axiom. 4 | 5 | This axiom is not used by this library, but only exported for 6 | convenience, as it can certainly simplify some developments. 7 | *) 8 | 9 | (* begin hide *) 10 | From ITree Require Import 11 | Core.ITreeDefinition 12 | Eq.Eqit. 13 | (* end hide *) 14 | 15 | (** Strong bisimulation is propositional equality. 16 | The converse is reflexivity of strong bisimulation 17 | (and is provable without axioms). *) 18 | Axiom bisimulation_is_eq : 19 | forall {E : Type -> Type} {R : Type} (t1 t2 : itree E R), 20 | t1 ≅ t2 -> t1 = t2. 21 | 22 | Lemma itree_eta_ {E R} (t : itree E R) : t = go (observe t). 23 | Proof. 24 | apply bisimulation_is_eq. apply itree_eta. 25 | Qed. 26 | -------------------------------------------------------------------------------- /examples/MultiThreadedPrinting.v: -------------------------------------------------------------------------------- 1 | Set Implicit Arguments. 2 | Set Contextual Implicit. 3 | 4 | From Coq Require Import 5 | String. 6 | 7 | From ITree Require Import 8 | ITree 9 | Events.Concurrency. 10 | 11 | Import ITreeNotations. 12 | Local Open Scope itree_scope. 13 | 14 | (* An OCaml-interpreted event that just prints the given string. *) 15 | Variant printE : Type -> Type := 16 | Print : string -> printE unit. 17 | 18 | (* A thread that loops, printing [s] forever. *) 19 | Definition thread {E} `{printE -< E} (s:string) : itree E unit := 20 | ITree.forever (trigger (Print s)). 21 | 22 | (* Run three threads. *) 23 | Definition main_thread : itree (spawnE printE +' printE) unit := 24 | spawn (thread "Thread 1") ;; 25 | spawn (thread "Thread 2") ;; 26 | spawn (thread "Thread 3"). 27 | 28 | Definition scheduled_thread : itree printE unit := run_spawn main_thread. 29 | -------------------------------------------------------------------------------- /tests/extract-tests/Tests.v: -------------------------------------------------------------------------------- 1 | From ITree Require Import 2 | ITree ITreeFacts. 3 | 4 | Import CatNotations. 5 | Local Open Scope cat. 6 | 7 | (* Test that we can indeed rewrite handlers under interp. *) 8 | Lemma interp_id_id {E R} (t : itree E R) : 9 | interp (id_ E >>> id_ E) t ≈ t. 10 | Proof. 11 | rewrite (fold_apply_IFun (interp _)). 12 | rewrite cat_id_r. 13 | rewrite <- fold_apply_IFun. 14 | rewrite interp_id_h. 15 | reflexivity. 16 | Qed. 17 | 18 | (* Regression test for #182 ([ITree.iter] should be executable even when the loop is infinite 19 | (the body is always [Ret (inl _)]) *) 20 | Definition iter_spin : itree void1 void := 21 | iter (C := ktree _) (fun _ : unit => Ret (@inl unit void tt)) tt. 22 | 23 | Require Extraction. 24 | 25 | Set Warnings "-extraction-default-directory". 26 | (* This program should NOT loop forever. *) 27 | Extraction "test.ml" iter_spin. 28 | -------------------------------------------------------------------------------- /theories/Props/Cofinite.v: -------------------------------------------------------------------------------- 1 | (** * Relations between infiniteness and finiteness *) 2 | 3 | From ITree Require Import 4 | Axioms 5 | ITree 6 | Props.Finite 7 | Props.Infinite. 8 | 9 | From Paco Require Import paco. 10 | 11 | Theorem not_all_infinite_any_finite {E A} (t : itree E A) 12 | : all_infinite t -> any_finite t -> False. 13 | Proof. 14 | intros H1 H2. induction H2; punfold H1; inversion H1; try congruence. 15 | all: pclearbot; rewrite H in H0; inversion H0; subst; auto. 16 | ddestruction. exact (IHany_finite (H3 _)). 17 | Qed. 18 | 19 | Theorem not_any_infinite_all_finite {E A} (t : itree E A) 20 | : any_infinite t -> all_finite t -> False. 21 | Proof. 22 | intros H1 H2; induction H2; punfold H1; inversion H1; try congruence. 23 | - pclearbot. rewrite H in H0; inversion H0; subst; auto. 24 | - pclearbot. rewrite H in H3. inversion H3; subst; ddestruction. 25 | exact (H2 _ H4). 26 | Qed. 27 | -------------------------------------------------------------------------------- /tutorial/README.md: -------------------------------------------------------------------------------- 1 | Tutorial for the Interaction Trees library 2 | ========================================== 3 | 4 | This tutorial consists of: 5 | 6 | - [`ITree.Simple`](../theories/Simple.v): 7 | simplified tutorial interface, available as a part of the library itself. 8 | 9 | - [`Introduction.v`](./Introduction.v): 10 | a detailed exposition of the core features. 11 | 12 | - A case study with a small commented compiler from Imp to Asm: 13 | 14 | + [`Imp.v`](./Imp.v): The Imp language definition 15 | (a minimal imperative language from Software Foundations) 16 | + [`Asm.v`](./Asm.v): The Asm language definition 17 | (a control-flow-graph language) 18 | - [`AsmCombinators.v`](./AsmCombinators.v): High-level combinators for Asm 19 | - [`Imp2Asm.v`](./Imp2Asm.v): The compiler 20 | - [`Imp2AsmCorrectness.v`](./Imp2AsmCorrectness.v): 21 | The correctness theorem (`compile_correct`). 22 | -------------------------------------------------------------------------------- /_CoqProject.extra: -------------------------------------------------------------------------------- 1 | -Q extra ITree.Extra 2 | 3 | extra/IForest.v 4 | 5 | extra/ITrace/ITraceDefinition.v 6 | extra/ITrace/ITraceFacts.v 7 | extra/ITrace/ITracePrefix.v 8 | extra/ITrace/ITraceBind.v 9 | extra/ITrace/ITracePreds.v 10 | 11 | extra/Dijkstra/DijkstraMonad.v 12 | extra/Dijkstra/IterRel.v 13 | extra/Dijkstra/PureITreeBasics.v 14 | extra/Dijkstra/PureITreeDijkstra.v 15 | extra/Dijkstra/DelaySpecMonad.v 16 | extra/Dijkstra/StateSpecT.v 17 | extra/Dijkstra/StateDelaySpec.v 18 | extra/Dijkstra/TracesIT.v 19 | extra/Dijkstra/ITreeDijkstra.v 20 | extra/Dijkstra/StateIOTrace.v 21 | 22 | extra/Secure/Labels.v 23 | extra/Secure/StrongBisimProper.v 24 | extra/Secure/SecureEqHalt.v 25 | extra/Secure/SecureEqHaltProgInsens.v 26 | extra/Secure/SecureEqEuttHalt.v 27 | extra/Secure/SecureEqEuttTrans.v 28 | extra/Secure/SecureEqWcompat.v 29 | extra/Secure/SecureEqBind.v 30 | extra/Secure/SecureEqProgInsens.v 31 | extra/Secure/SecureEqProgInsensFacts.v 32 | extra/Secure/SecureStateHandler.v 33 | extra/Secure/SecureStateHandlerPi.v 34 | -------------------------------------------------------------------------------- /theories/Events/Reader.v: -------------------------------------------------------------------------------- 1 | (** * Reader *) 2 | 3 | (** Immutable environment. *) 4 | 5 | (* begin hide *) 6 | Set Implicit Arguments. 7 | Set Contextual Implicit. 8 | 9 | From Coq Require Import List. 10 | Import ListNotations. 11 | 12 | From ITree Require Import 13 | Basics.Basics 14 | Basics.CategoryOps 15 | Core.ITreeDefinition 16 | Indexed.Sum 17 | Core.Subevent 18 | Interp.Interp 19 | Interp.Handler. 20 | (* end hide *) 21 | 22 | Section Reader. 23 | 24 | Variable (Env : Type). 25 | 26 | Variant readerE : Type -> Prop := 27 | | Ask : readerE Env. 28 | 29 | Definition ask {E} `{readerE -< E} : itree E Env := 30 | trigger Ask. 31 | 32 | Definition eval_reader {E} : Env -> Handler readerE E := 33 | fun r _ e => 34 | match e with 35 | | Ask => Ret r 36 | end. 37 | 38 | Definition run_reader {E} : Env -> itree (readerE +' E) ~> itree E := 39 | fun r => interp (case_ (eval_reader r) (id_ _)). 40 | 41 | End Reader. 42 | 43 | Arguments ask {Env E _}. 44 | Arguments run_reader {Env E} _ _ _. 45 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.6) 2 | (using coq 0.2) 3 | (name coq-itree) 4 | (version dev) 5 | (maintainers "Li-yao Xia ") 6 | (source (github DeepSpec/InteractionTrees)) 7 | (license MIT) 8 | 9 | (package 10 | (name coq-itree) 11 | (synopsis "Library for representing recursive and impure programs with equational reasoning") 12 | (depends 13 | (coq (>= 8.14)) 14 | (coq-ext-lib (>= 0.11.1)) 15 | (coq-paco (>= 4.2.1))) 16 | (tags ("org:deepspec")) 17 | (authors 18 | "Li-yao Xia" 19 | "Yannick Zakowski" 20 | "Paul He" 21 | "Chung-Kil Hur" 22 | "Gregory Malecha" 23 | "Steve Zdancewic" 24 | "Benjamin Pierce") 25 | ) 26 | 27 | (package 28 | (name coq-itree-extra) 29 | (synopsis "Extensions to coq-itree") 30 | (depends 31 | coq 32 | coq-ext-lib 33 | coq-paco 34 | coq-itree) 35 | (tags ("org:deepspec")) 36 | (authors 37 | "Lucas Silver" 38 | "Irene Yoon" 39 | "Paul He" 40 | "Yannick Zakowski" 41 | "Steve Zdancewic") 42 | ) 43 | 44 | (generate_opam_files true) 45 | -------------------------------------------------------------------------------- /coq-itree.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: 5 | "Library for representing recursive and impure programs with equational reasoning" 6 | maintainer: ["Li-yao Xia "] 7 | authors: [ 8 | "Li-yao Xia" 9 | "Yannick Zakowski" 10 | "Paul He" 11 | "Chung-Kil Hur" 12 | "Gregory Malecha" 13 | "Steve Zdancewic" 14 | "Benjamin Pierce" 15 | ] 16 | license: "MIT" 17 | tags: ["org:deepspec"] 18 | homepage: "https://github.com/DeepSpec/InteractionTrees" 19 | bug-reports: "https://github.com/DeepSpec/InteractionTrees/issues" 20 | depends: [ 21 | "dune" {>= "2.6"} 22 | "coq" {>= "8.14"} 23 | "coq-ext-lib" {>= "0.11.1"} 24 | "coq-paco" {>= "4.2.1"} 25 | ] 26 | build: [ 27 | ["dune" "subst"] {pinned} 28 | [ 29 | "dune" 30 | "build" 31 | "-p" 32 | name 33 | "-j" 34 | jobs 35 | "@install" 36 | "@runtest" {with-test} 37 | "@doc" {with-doc} 38 | ] 39 | ] 40 | dev-repo: "git+https://github.com/DeepSpec/InteractionTrees.git" 41 | -------------------------------------------------------------------------------- /.github/workflows/build-with-make.yml: -------------------------------------------------------------------------------- 1 | name: Build with Make 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | branches: 9 | - '**' 10 | 11 | jobs: 12 | build-with-make: 13 | # the OS must be GNU/Linux to be able to use the docker-coq-action 14 | runs-on: ubuntu-latest 15 | strategy: 16 | matrix: 17 | image: 18 | - 'coqorg/coq:8.20' 19 | fail-fast: false 20 | steps: 21 | - uses: actions/checkout@v4 22 | - uses: coq-community/docker-coq-action@v1 23 | with: 24 | opam_file: 'coq-itree.opam' 25 | custom_image: ${{ matrix.image }} 26 | before_script: | 27 | startGroup "Workaround permission issue" 28 | sudo chown -R 1000:1000 . 29 | endGroup 30 | script: | 31 | startGroup "Build" 32 | make all 33 | make install 34 | endGroup 35 | after_script: | 36 | startGroup "Clean" 37 | make clean 38 | endGroup 39 | -------------------------------------------------------------------------------- /DMonadREADME.md: -------------------------------------------------------------------------------- 1 | Comparison to paper notes: 2 | All Dijkstra Monad related library code is in the theories/Dijkstra folder 3 | 4 | The Hoare Logic and nat_sqrt example are in examples/ImpHoare.v 5 | 6 | The paper often uses names different from those used in this repo. 7 | We have included an index of translations of all lemmas and several 8 | important definitions in dmf_proof_pointers.txt 9 | 10 | Building Notes: 11 | Follow the instructions in README.md to build the Interaction Trees Library 12 | We have tested that it builds on Coq 8.10 and Coq 8.12, we make no guarantees for any version older < 8.10 13 | 14 | Admitted Proofs Notes: 15 | All Admitted lemmas in the attached code are unrelated to the project (all that I am aware of are tutorial) or commented out. 16 | 17 | Main Toplevel results contained in DelaySpecMonad.v and TraceIT.v.. Our implementation of the Dijkstra Monad Framework implemented with Coq Typeclasses is in DijkstraMonad.v. Each file in the Dijkstra folder contains comments near the top explaining some of the main contributions of the file. 18 | -------------------------------------------------------------------------------- /examples/extract-threads/runthread.ml: -------------------------------------------------------------------------------- 1 | ;; open MultiThreadedPrinting 2 | 3 | (* Taken from Xavier Leroy's Camlcoq library, which is part of CompCert under 4 | Gnu Public License version 2 or later. *) 5 | let camlstring_of_coqstring (s: char list) = 6 | let r = Bytes.create (List.length s) in 7 | let rec fill pos = function 8 | | [] -> r 9 | | c :: s -> Bytes.set r pos c; fill (pos + 1) s 10 | in Bytes.to_string (fill 0 s) 11 | 12 | (* The driver loop ---------------------------------------------------------- *) 13 | 14 | let rec step fuel m : unit = 15 | if fuel <= 0 then 16 | Printf.printf "Out of fuel!\n%!" 17 | else 18 | let step = step (fuel - 1) in 19 | match observe m with 20 | (* Internal steps compute as nothing *) 21 | | TauF x -> step x 22 | 23 | (* We finished the computation *) 24 | | RetF _ -> () 25 | 26 | (* The only residual effect is Print, which carries just a string *) 27 | | VisF (s, k) -> 28 | Printf.printf "%s\n%!" (camlstring_of_coqstring s); 29 | step (k (Obj.magic ())) 30 | 31 | (* Main *) 32 | 33 | ;; step 30 scheduled_thread 34 | -------------------------------------------------------------------------------- /common.mk: -------------------------------------------------------------------------------- 1 | # Shared make commands 2 | 3 | .PHONY: coq clean-coq html 4 | 5 | coq: Makefile.coq 6 | $(MAKE) -f Makefile.coq 7 | 8 | clean-coq: _CoqProject 9 | if [ -e Makefile.coq ] ; then $(MAKE) -f Makefile.coq cleanall ; fi 10 | $(RM) Makefile.coq Makefile.coq.conf 11 | 12 | Makefile.coq: _CoqProject 13 | coq_makefile -f $< -o $@ 14 | 15 | ## coqdoc ------------------------------------------------- 16 | COQDOCEXTRAFLAGS:= \ 17 | -t "Interaction Trees" \ 18 | --toc --toc-depth 2 \ 19 | --index indexpage --no-lib-name --parse-comments \ 20 | 21 | COQDOCJS_DIR:=$(wildcard coqdocjs) 22 | 23 | ifneq ($(COQDOCJS_DIR),) 24 | COQDOCEXTRAFLAGS+=--with-header $(COQDOCJS_DIR)/extra/header.html --with-footer $(COQDOCJS_DIR)/extra/footer.html 25 | 26 | export COQDOCEXTRAFLAGS 27 | 28 | html: Makefile.coq coq 29 | rm -rf html 30 | $(MAKE) -f Makefile.coq html 31 | cp $(COQDOCJS_DIR)/extra/resources/* html 32 | else 33 | 34 | export COQDOCEXTRAFLAGS 35 | 36 | html: Makefile.coq coq 37 | rm -rf html 38 | $(MAKE) -f Makefile.coq html 39 | endif 40 | 41 | ## ------------------------------------------------------- 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 DeepSpec 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /theories/Eq/EuttExtras.v: -------------------------------------------------------------------------------- 1 | (** * More facts about eutt *) 2 | 3 | (** ... that have been added recently and I don't know where to put. *) 4 | 5 | (* TODO: Figure out some way to organize Eq/UpToTaus.v and Eq/Eq.v *) 6 | 7 | From Paco Require Import paco. 8 | 9 | From ITree Require Import 10 | Core.ITreeDefinition 11 | Eq.Eqit. 12 | 13 | Lemma paco2_eqit_refl : forall E R r (t : itree E R), paco2 (eqit_ eq true true id) r t t. 14 | Proof. 15 | intros. eapply paco2_mon with (r := bot2). 16 | { enough (t ≈ t); auto. reflexivity. } 17 | { contradiction. } 18 | Qed. 19 | 20 | Lemma eutt_subrel : forall (E : Type -> Type) (A B : Type) (R1 R2 : A -> B -> Prop) 21 | (ta : itree E A) (tb : itree E B), 22 | (forall a b, R1 a b -> R2 a b) -> eutt R1 ta tb -> eutt R2 ta tb. 23 | Proof. 24 | intros. eapply eqit_mon; eauto. 25 | Qed. 26 | 27 | Lemma eutt_flip : forall (E : Type -> Type) (A B : Type) (R : A -> B -> Prop) 28 | (ta : itree E A) (tb : itree E B), 29 | eutt R ta tb -> eutt (flip R) tb ta. 30 | Proof. 31 | intros. apply eqit_flip. 32 | eapply eutt_subrel with (R1 := R); eauto. 33 | Qed. 34 | -------------------------------------------------------------------------------- /theories/Indexed/Sum.v: -------------------------------------------------------------------------------- 1 | (** * Sums of indexed types *) 2 | 3 | (** In the context of interaction trees, events can be combined 4 | using this sum type. *) 5 | 6 | (* begin hide *) 7 | From ITree Require Import 8 | Basics.Basics. 9 | 10 | Set Implicit Arguments. 11 | Set Contextual Implicit. 12 | (* end hide *) 13 | 14 | (** Sum of type constructors [Type -> Type]. 15 | 16 | [sum1 : (Type -> Type) -> (Type -> Type) -> (Type -> Type)]. *) 17 | Variant sum1 (E1 E2 : Type -> Type) (X : Type) : Type := 18 | | inl1 (_ : E1 X) 19 | | inr1 (_ : E2 X). 20 | Arguments inr1 {E1 E2} [X]. 21 | Arguments inl1 {E1 E2} [X]. 22 | 23 | (** An infix notation for convenience. *) 24 | Notation "E1 +' E2" := (sum1 E1 E2) 25 | (at level 59, right associativity) : type_scope. 26 | 27 | (** The empty indexed type. *) 28 | Variant void1 : Type -> Prop := . 29 | 30 | (** This sum type equips the space of indexed functions [_ ~> _] with 31 | the structure of a cocartesian category, see [Indexed.Function]. 32 | *) 33 | 34 | (* Eliminate [void1]. *) 35 | Polymorphic Definition elim_void1@{u v} {E : Type@{u} -> Type@{v}} 36 | : forall T : Type@{u}, void1 T -> E T := 37 | fun T (v : void1 T) => match v with end. 38 | -------------------------------------------------------------------------------- /theories/Core/ITreeMonad.v: -------------------------------------------------------------------------------- 1 | (* SAZ: I'm not sure where in the library this should live. 2 | The Monad instance for itree is in ITreeDefinition but we want 3 | to define Eq1 and MonadLawsE instances too. 4 | *) 5 | 6 | From ITree Require Import 7 | Basics.Basics 8 | Basics.Monad 9 | Core.ITreeDefinition 10 | Eq.Eqit 11 | Eq.UpToTaus. 12 | 13 | #[global] 14 | Instance Eq1_ITree {E} : Eq1 (itree E) := fun a => eutt eq. 15 | 16 | #[global] 17 | Instance Eq1Equivalence_ITree {E} : Eq1Equivalence (itree E). 18 | Proof. 19 | repeat red. 20 | intros a. 21 | typeclasses eauto. 22 | Qed. 23 | 24 | #[global] 25 | Instance MonadLawsE_ITree {E} : MonadLawsE (itree E). 26 | Proof. 27 | constructor. 28 | - intros a b f x. 29 | unfold Monad.bind, Monad.ret, Monad_itree. 30 | unfold eq1, Eq1_ITree. rewrite bind_ret_l. reflexivity. 31 | - intros a x. unfold Monad.bind, Monad.ret, Monad_itree. 32 | unfold eq1, Eq1_ITree. rewrite bind_ret_r. reflexivity. 33 | - intros a b c x f g. unfold Monad.bind, Monad.ret, Monad_itree. 34 | unfold eq1, Eq1_ITree. rewrite bind_bind. reflexivity. 35 | - unfold Monad.bind, Monad_itree. 36 | intros. 37 | repeat red. 38 | intros. 39 | apply eqit_bind; auto. 40 | Qed. 41 | -------------------------------------------------------------------------------- /theories/Events/Dependent.v: -------------------------------------------------------------------------------- 1 | (** * Dependently-typed events *) 2 | 3 | (** A _type family_ is given by a parameter type [I : Type] and a type function 4 | [F : I -> Type]. 5 | 6 | A type family [(I, F : I -> Type)] can be encoded as an indexed type 7 | [E : Type -> Type]. 8 | A value [i : I] can be seen as a "flat representation" of a value [e : E X] 9 | (for arbitrary [X]), while [F i : Type] gives the type index [X] of this [e]. 10 | 11 | This encoding can be seen as a kind of "dependently-typed event", 12 | although the general use indexed types for event types already provides an 13 | equally expressive form of dependency. 14 | *) 15 | 16 | (* begin hide *) 17 | From ITree Require Import 18 | Basics.Basics 19 | Core.ITreeDefinition 20 | Indexed.Sum 21 | Core.Subevent. 22 | 23 | Import Basics.Basics.Monads. 24 | (* end hide *) 25 | 26 | Variant depE {I : Type} (F : I -> Type) : Type -> Type := 27 | | Dep (i : I) : depE F (F i). 28 | 29 | Arguments Dep {I F} &. 30 | 31 | Definition dep {I F E} `{depE F -< E} (i : I) : itree E (F i) := 32 | trigger (Dep (F := F) i). 33 | 34 | Definition undep {I F} (f : forall i : I, F i) : 35 | depE F ~> identity := 36 | fun _ d => 37 | match d with 38 | | Dep i => f i 39 | end. 40 | -------------------------------------------------------------------------------- /examples/ReadmeExample.v: -------------------------------------------------------------------------------- 1 | (* Example demonstrating the core features of the library. *) 2 | 3 | From ITree Require Import 4 | ITree ITreeFacts. 5 | 6 | Import ITreeNotations. 7 | 8 | (* Custom effects *) 9 | Variant inputE : Type -> Prop := 10 | | Input : inputE nat. 11 | 12 | (* Effectful programs *) 13 | Definition echo : itree inputE nat 14 | := x <- trigger Input ;; 15 | Ret x. 16 | 17 | (* Effect handlers *) 18 | Definition handler {E} (n : nat) 19 | : inputE ~> itree E 20 | := fun _ e => match e with 21 | | Input => Ret n 22 | end. 23 | 24 | (* Interpreters *) 25 | Definition echoed (n : nat) 26 | : itree void1 nat 27 | := interp (handler n) echo. 28 | 29 | (* Equational reasoning *) 30 | Theorem echoed_id : forall n, echoed n ≈ Ret n. 31 | Proof. 32 | intros n. (* echoed n *) 33 | unfold echoed, echo. (* ≈ interp (handler n) (x <- trigger Input ;; Ret x) *) 34 | rewrite interp_bind. (* ≈ x <- interp (handler n) Input ;; interp (handler n) (Ret x) *) 35 | rewrite interp_trigger. 36 | (* ≈ x <- handler n _ Input ;; interp (handler n) (Ret x) *) 37 | cbn. (* ≈ x <- Ret n ;; interp (handler n) (Ret x) *) 38 | rewrite bind_ret_l. (* ≈ interp (handler n) (Ret n) *) 39 | rewrite interp_ret. (* ≈ Ret n *) 40 | reflexivity. 41 | Qed. 42 | -------------------------------------------------------------------------------- /examples/extract-io/IO.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Arith. 2 | From ITree Require Import ITree. 3 | Import ITreeNotations. 4 | 5 | Inductive IO : Type -> Type := 6 | | Read : IO nat 7 | | Write : nat -> IO unit. 8 | 9 | Definition read : itree IO nat := embed Read. 10 | Definition write : nat -> itree IO unit := embed Write. 11 | 12 | Definition example : itree IO unit := 13 | n <- read;; 14 | write n. 15 | 16 | Definition SOME_NUMBER := 13. 17 | 18 | Definition test_interp : itree IO unit -> bool := fun t => 19 | match observe t with 20 | | VisF e k => 21 | match e in IO X return (X -> _) -> _ with 22 | | Read => fun id => 23 | match observe (k (id SOME_NUMBER)) with 24 | | VisF (Write n) _ => n =? SOME_NUMBER 25 | | _ => false 26 | end 27 | | _ => fun _ => false 28 | end (fun x => x) 29 | | _ => false 30 | end. 31 | 32 | Example test : test_interp example = true := eq_refl. 33 | 34 | Require Extraction. 35 | 36 | Parameter exit_success : unit. 37 | Parameter exit_failure : unit. 38 | Extract Inlined Constant exit_success => 39 | "print_endline ""OK!""; exit 0". 40 | Extract Inlined Constant exit_failure => 41 | "print_endline ""IO test failed!""; exit 1". 42 | 43 | Definition test_io := 44 | if test_interp example then 45 | exit_success 46 | else 47 | exit_failure. 48 | 49 | Set Warnings "-extraction-default-directory". 50 | Extraction "io.ml" test_io. 51 | -------------------------------------------------------------------------------- /theories/Basics/CategoryFunctor.v: -------------------------------------------------------------------------------- 1 | (** * Definition of a functor *) 2 | 3 | From Coq Require Import 4 | Setoid 5 | Morphisms. 6 | 7 | From ITree Require Import 8 | CategoryOps. 9 | 10 | Import CatNotations. 11 | Local Open Scope cat_scope. 12 | 13 | Section Functor. 14 | 15 | Context 16 | {obj1 obj2 : Type} 17 | {C1 : obj1 -> obj1 -> Type} 18 | {C2 : obj2 -> obj2 -> Type} 19 | {F : obj1 -> obj2} {fmap : forall a b, C1 a b -> C2 (F a) (F b)} 20 | `{Eq2 _ C1} `{Id_ _ C1} `{Cat _ C1} 21 | `{Eq2 _ C2} `{Id_ _ C2} `{Cat _ C2}. 22 | 23 | Arguments fmap {a b}. 24 | 25 | Class Functor : Prop := 26 | { fmap_id : forall a, fmap (id_ a) ⩯ id_ (F a) 27 | ; fmap_cat : forall a b c (f : C1 a b) (g : C1 b c), fmap (cat f g) ⩯ cat (fmap f) (fmap g) 28 | ; fmap_proper : forall a b, Proper (eq2 ==> eq2) (@fmap a b) 29 | }. 30 | 31 | End Functor. 32 | 33 | Arguments Functor : clear implicits. 34 | Arguments Functor {_ _} C1 C2 F fmap {_ _ _ _ _ _}. 35 | 36 | Section FunctorId. 37 | 38 | Context 39 | {obj : Type} {C1 C2 : obj -> obj -> Type} 40 | {fmap : forall a b, C1 a b -> C2 a b} 41 | `{Eq2 _ C1} `{Id_ _ C1} `{Cat _ C1} 42 | `{Eq2 _ C2} `{Id_ _ C2} `{Cat _ C2} 43 | {Functor_id : Functor C1 C2 (fun x => x) fmap}. 44 | 45 | Lemma fmap_id0 : forall a, fmap _ _ (id_ a) ⩯ id_ a. 46 | Proof. apply fmap_id. Qed. 47 | 48 | Lemma fmap_cat0 : forall a b c (f : C1 a b) (g : C1 b c), 49 | fmap _ _ (f >>> g) ⩯ fmap _ _ f >>> fmap _ _ g. 50 | Proof. apply fmap_cat. Qed. 51 | 52 | End FunctorId. 53 | -------------------------------------------------------------------------------- /theories/Events.v: -------------------------------------------------------------------------------- 1 | (** * Standard event types *) 2 | 3 | (* begin hide *) 4 | From ITree.Events Require 5 | State 6 | Reader 7 | Writer 8 | Exception 9 | Nondeterminism 10 | Map 11 | Concurrency 12 | Dependent. 13 | (* end hide *) 14 | 15 | (** ** State *) 16 | 17 | (** 18 | [[ 19 | Variant stateE (S : Type) : Type -> Type := 20 | | Get : stateE S S 21 | | Put : S -> stateE S unit. 22 | ]] 23 | *) 24 | 25 | (** ** Reader *) 26 | 27 | (** 28 | [[ 29 | Variant readerE (R : Type) : Type -> Type := 30 | | Ask : readerE R R. 31 | ]] 32 | *) 33 | 34 | (** ** Writer *) 35 | 36 | (** 37 | [[ 38 | Variant writerE (W : Type) : Type -> Type := 39 | | Tell : W -> writerE W unit. 40 | ]] 41 | *) 42 | 43 | (** ** Exception *) 44 | 45 | (** 46 | [[ 47 | Variant exceptE (Err : Type) : Type -> Type := 48 | | Throw : Err -> exceptE Err void. 49 | ]] 50 | *) 51 | 52 | (** ** Nondeterminism *) 53 | 54 | (** 55 | [[ 56 | Variant nondetE : Type -> Type := 57 | | Or : nondetE bool. 58 | ]] 59 | *) 60 | 61 | (** ** Map *) 62 | 63 | (** 64 | [[ 65 | Variant mapE (K V : Type) : Type -> Type := 66 | | Insert : K -> V -> mapE unit 67 | | Lookup : K -> mapE (option V) 68 | | Remove : K -> mapE unit 69 | . 70 | ]] 71 | *) 72 | 73 | (** ** Concurrency *) 74 | 75 | (** 76 | [[ 77 | Inductive spawnE (E : Type -> Type) : Type -> Type := 78 | | Spawn : itree (spawnE E +' E) unit -> spawnE E unit. 79 | ]] 80 | *) 81 | 82 | (** ** Dependent *) 83 | 84 | (** 85 | [[ 86 | Variant depE {I : Type} (F : I -> Type) : Type -> Type := 87 | | Dep (i : I) : depE F (F i). 88 | ]] 89 | *) 90 | -------------------------------------------------------------------------------- /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'coqorg/coq:8.14' 21 | - 'coqorg/coq:8.15' 22 | - 'coqorg/coq:8.16' 23 | - 'coqorg/coq:8.17' 24 | - 'coqorg/coq:8.18' 25 | - 'coqorg/coq:8.19' 26 | - 'coqorg/coq:8.20' 27 | - 'rocq/rocq-prover:9.0' 28 | - 'rocq/rocq-prover:dev' 29 | fail-fast: false 30 | steps: 31 | - uses: actions/checkout@v4 32 | - uses: coq-community/docker-coq-action@v1 33 | with: 34 | opam_file: 'coq-itree.opam' 35 | custom_image: ${{ matrix.image }} 36 | after_script: | 37 | startGroup "Test dependants" 38 | PINS=$(opam list -s --pinned --columns=package | xargs | tr ' ' ,) 39 | PACKAGES="coq-ctree coq-itree-extra coq-itree-io " 40 | for PACKAGE in $PACKAGES 41 | do DEPS_FAILED=false 42 | opam install -y --deps-only $PACKAGE || DEPS_FAILED=true 43 | [ $DEPS_FAILED == true ] || opam install -t $PACKAGE 44 | done 45 | endGroup 46 | 47 | 48 | # See also: 49 | # https://github.com/coq-community/docker-coq-action#readme 50 | # https://github.com/erikmd/docker-coq-github-action-demo 51 | -------------------------------------------------------------------------------- /theories/Core/KTree.v: -------------------------------------------------------------------------------- 1 | (** * The category of continuation trees (KTrees) *) 2 | 3 | (** The Kleisli category of ITrees. *) 4 | 5 | (* begin hide *) 6 | From Coq Require Import 7 | Morphisms. 8 | 9 | From ITree Require Import 10 | Basics.Basics 11 | Basics.CategoryOps 12 | Basics.CategoryKleisli 13 | Basics.Monad 14 | Basics.CategoryKleisli 15 | Basics.Function 16 | Core.ITreeDefinition 17 | Eq.Eqit 18 | Eq.UpToTaus. 19 | (* end hide *) 20 | 21 | Implicit Types E : Type -> Type. 22 | Implicit Types a b : Type. 23 | 24 | Notation ktree E := (Kleisli (itree E)). 25 | 26 | Declare Scope ktree_scope. 27 | Bind Scope ktree_scope with ktree. 28 | 29 | Notation ktree_apply := (@Kleisli_apply (itree _)). 30 | Notation lift_ktree := (@pure (itree _) _ _ _). 31 | Notation lift_ktree_ E a b := (@pure (itree E) _ a b). 32 | 33 | (* [ktree E] forms an iterative category, i.e. a cocartesian category with a 34 | loop operator *) 35 | (* Obj ≅ Type *) 36 | (* Arrow: A -> B ≅ terms of type (ktree A B) *) 37 | 38 | 39 | (** ** Categorical operations *) 40 | 41 | Section Operations. 42 | 43 | Context {E : Type -> Type}. 44 | 45 | #[local] Notation ktree := (ktree E). 46 | 47 | (** *** Traced monoidal category *) 48 | 49 | (** The trace operator here is [loop]. 50 | 51 | We can view a [ktree (I + A) (I + B)] as a circuit, drawn below as [###], 52 | with two input wires labeled by [I] and [A], and two output wires 53 | labeled by [I] and [B]. 54 | 55 | The [loop : ktree (I + A) (I + B) -> ktree A B] combinator closes 56 | the circuit, linking the box with itself by plugging the [I] output 57 | back into the input. 58 | [[ 59 | +-----+ 60 | | ### | 61 | +-###-+I 62 | A----###----B 63 | ### 64 | ]] 65 | *) 66 | 67 | End Operations. 68 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: clean all coq test tests examples tutorial hoare_example secure_example install uninstall depgraph for-dune 2 | 3 | COQPATHFILE=$(wildcard _CoqPath) 4 | 5 | build: coq 6 | 7 | include common.mk 8 | 9 | all: 10 | # Build the library before tests 11 | $(MAKE) coq 12 | $(MAKE) test 13 | $(MAKE) hoare_example 14 | $(MAKE) secure_example 15 | 16 | install: Makefile.coq coq 17 | $(MAKE) -f $< $@ 18 | 19 | uninstall: Makefile.coq 20 | $(MAKE) -f $< $@ 21 | 22 | test: examples tests 23 | 24 | tests: 25 | $(MAKE) -C tests 26 | $(MAKE) -C tutorial test 27 | 28 | examples: 29 | $(MAKE) -C examples 30 | 31 | tutorial: 32 | $(MAKE) -C tutorial 33 | 34 | hoare_example: 35 | $(MAKE) -C hoare_example 36 | 37 | secure_example: 38 | $(MAKE) -C secure_example 39 | 40 | clean: clean-coq 41 | $(RM) _CoqProject 42 | $(MAKE) -C tests clean 43 | $(MAKE) -C examples clean 44 | $(MAKE) -C tutorial clean 45 | $(MAKE) -C hoare_example clean 46 | $(MAKE) -C secure_example clean 47 | 48 | _CoqProject: $(COQPATHFILE) _CoqProject.itree _CoqProject.extra Makefile 49 | @ echo "# Generating _CoqProject" 50 | @ rm -f _CoqProject 51 | @ echo "# THIS IS AN AUTOMATICALLY GENERATED FILE" >> _CoqProject 52 | @ echo "# PLEASE EDIT _CoqConfig INSTEAD" >> _CoqProject 53 | @ echo >> _CoqProject 54 | ifneq ("$(COQPATHFILE)","") 55 | @ echo "# including: _CoqPath" 56 | @ cat _CoqPath >> _CoqProject 57 | @ echo >> _CoqProject 58 | endif 59 | @ echo "# including: _CoqConfig" 60 | @ cat _CoqProject.itree _CoqProject.extra >> _CoqProject 61 | 62 | COQDEP=coqdep 63 | DEPS_DOT=deps.dot 64 | DEPS_OUT=deps.jpg 65 | 66 | depgraph: 67 | $(COQDEP) -dumpgraph $(DEPS_DOT) $(shell cat _CoqConfig) > /dev/null 2>&1 68 | sed 's%\("theories/\([^"]*\)/\([^"/]*\)"\[label="\)%\1\2/\\n%' -i $(DEPS_DOT) 69 | dot $(DEPS_DOT) -Tjpg -o$(DEPS_OUT) 70 | -------------------------------------------------------------------------------- /theories/Basics/Monad.v: -------------------------------------------------------------------------------- 1 | (** * Monad laws and associated typeclasses *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | Morphisms. 6 | 7 | From ExtLib Require Export 8 | Structures.Monad. 9 | 10 | From ITree Require Import 11 | Basics.Basics 12 | Basics.CategoryOps. 13 | (* end hide *) 14 | 15 | Set Primitive Projections. 16 | 17 | (* Canonical equivalence relation for a unary type family. *) 18 | Class Eq1 (M : Type -> Type) : Type := 19 | eq1 : forall A, M A -> M A -> Prop. 20 | 21 | Arguments eq1 {M _ _}. 22 | Infix "≈" := eq1 (at level 70) : monad_scope. 23 | 24 | (* Proof that [eq1] is an equivalence relation. *) 25 | Class Eq1Equivalence (M : Type -> Type) `{Monad M} `{Eq1 M} := 26 | eq1_equiv : forall A, Equivalence (eq1 (A := A)). 27 | 28 | #[global] Existing Instance eq1_equiv. 29 | 30 | Section Laws. 31 | 32 | Context (M : Type -> Type). 33 | Context {Eq1 : @Eq1 M}. 34 | Context {Monad : Monad M}. 35 | 36 | Local Open Scope monad_scope. 37 | 38 | (* Monad laws up to [M]'s canonical equivalence relation. *) 39 | (* This differs coq-ext-lib's [MonadLaws] in that the equiv. relation may be 40 | distinct from [eq]. *) 41 | Class MonadLawsE : Prop := 42 | { bind_ret_l : forall A B (f : A -> M B) (x : A), bind (ret x) f ≈ f x 43 | ; bind_ret_r : forall A (x : M A), bind x (fun y => ret y) ≈ x 44 | ; bind_bind : forall A B C (x : M A) (f : A -> M B) (g : B -> M C), 45 | bind (bind x f) g ≈ bind x (fun y => bind (f y) g) 46 | ; Proper_bind : forall {A B}, 47 | (@Proper (M A -> (A -> M B) -> M B) 48 | (eq1 ==> pointwise_relation _ eq1 ==> eq1) 49 | bind) 50 | }. 51 | 52 | End Laws. 53 | 54 | #[global] Existing Instance Proper_bind. 55 | 56 | Arguments bind_ret_l {M _ _ _}. 57 | Arguments bind_ret_r {M _ _ _}. 58 | Arguments bind_bind {M _ _ _}. 59 | Arguments Proper_bind {M _ _ _}. 60 | -------------------------------------------------------------------------------- /theories/Indexed/Function.v: -------------------------------------------------------------------------------- 1 | (** * The Category of Indexed Functions *) 2 | 3 | (** Indexed functions have type [E ~> F], i.e., [forall T, E T -> F T], 4 | for some [E] and [F]. Like regular functions ([Basics.Function]), 5 | they form a cocartesian category. *) 6 | 7 | (* begin hide *) 8 | From ITree Require Import 9 | Basics.Basics 10 | Basics.Category 11 | Indexed.Relation 12 | Indexed.Sum. 13 | 14 | Set Universe Polymorphism. 15 | (* end hide *) 16 | 17 | (** The name of the category. *) 18 | Definition IFun (E F : Type -> Type) : Type := E ~> F. 19 | 20 | (** Unwrap [IFun], potentially useful for type inference. *) 21 | Definition apply_IFun {E F T} (f : IFun E F) : E T -> F T := f T. 22 | 23 | (** Unwrap [IFun] as [~>]. *) 24 | Definition apply_IFun' {E F} (f : IFun E F) : E ~> F := f. 25 | 26 | (** Wrap [~>] as [IFun]. *) 27 | Definition as_IFun {E F} (f : E ~> F) : IFun E F := f. 28 | 29 | (** Equivalence of indexed functions is extensional equality. *) 30 | #[global] Instance Eq2_IFun : Eq2 IFun := 31 | fun E F => i_pointwise (fun T => @eq (F T)). 32 | 33 | (** The identity function. *) 34 | #[global] Instance Id_IFun : Id_ IFun := 35 | fun E _ e => e. 36 | 37 | (** Function composition. *) 38 | #[global] Instance Cat_IFun : Cat IFun := 39 | fun E F G f1 f2 R e => f2 _ (f1 _ e). 40 | 41 | (** [void1] is the initial object. *) 42 | #[global] Instance Initial_void1 : Initial IFun void1 := @elim_void1. 43 | 44 | (** The coproduct is case analysis on sums. *) 45 | Definition case_sum1 {A B C : Type -> Type} (f : A ~> C) (g : B ~> C) 46 | : A +' B ~> C 47 | := fun _ ab => 48 | match ab with 49 | | inl1 a => f _ a 50 | | inr1 b => g _ b 51 | end. 52 | 53 | #[global] Instance Case_sum1 : Case IFun sum1 := @case_sum1. 54 | #[global] Instance Inl_sum1 : Inl IFun sum1 := @inl1. 55 | #[global] Instance Inr_sum1 : Inr IFun sum1 := @inr1. 56 | -------------------------------------------------------------------------------- /theories/Axioms.v: -------------------------------------------------------------------------------- 1 | (** * Axioms used in the ITree library. *) 2 | 3 | (** Other ITree modules should import this to avoid accidentally using more 4 | axioms elsewhere. *) 5 | 6 | From Coq Require Import 7 | Logic.Classical_Prop 8 | Logic.ClassicalChoice 9 | Logic.EqdepFacts 10 | Logic.FunctionalExtensionality 11 | . 12 | 13 | (* Must be imported to use [ddestruction] *) 14 | From Coq Require Export 15 | Program.Equality 16 | . 17 | 18 | Set Implicit Arguments. 19 | 20 | (* The following tactics may be used: 21 | - [dependent destruction] 22 | - [dependent induction] *) 23 | Ltac ddestruction := 24 | repeat lazymatch goal with | H : existT _ _ _ = _ |- _ => dependent destruction H end. 25 | 26 | (* Consequence of UIP; used by tactic [dependent destrcution] *) 27 | Definition eq_rect_eq := Eqdep.Eq_rect_eq.eq_rect_eq. 28 | 29 | Definition classic := Classical_Prop.classic. 30 | 31 | Definition choice := ClassicalChoice.choice. 32 | 33 | Definition functional_extensionality := @FunctionalExtensionality.functional_extensionality. 34 | 35 | (* From Coq.Logic.ChoiceFacts *) 36 | Definition GuardedFunctionalChoice_on {A B} := 37 | forall P : A -> Prop, forall R : A -> B -> Prop, 38 | inhabited B -> 39 | (forall x : A, P x -> exists y : B, R x y) -> 40 | (exists f : A->B, forall x, P x -> R x (f x)). 41 | Axiom guarded_choice : forall {A B}, @GuardedFunctionalChoice_on A B. 42 | 43 | Inductive mwitness : Type := 44 | | Witness (P : Type) (_ : P) 45 | | NoWitness. 46 | 47 | Lemma classicT_inhabited : inhabited (forall (P : Type), P + (P -> False)). 48 | Proof. 49 | destruct (choice (fun (P : Type) (b : mwitness) => 50 | match b with @Witness Q _ => P = Q | NoWitness => P -> False end)) as [f H]. 51 | { intros P; destruct (classic (inhabited P)) as [[x] | ]; 52 | [exists (Witness x) | exists NoWitness]; auto. } 53 | constructor. intros P; specialize (H P); destruct (f P); [subst | ]; auto. 54 | Qed. 55 | -------------------------------------------------------------------------------- /examples/LC.v: -------------------------------------------------------------------------------- 1 | (* Big-step reduction of untyped lambda terms. *) 2 | 3 | From Coq Require Import Arith. 4 | 5 | From ExtLib.Structures Require Import 6 | Monad. 7 | Import MonadNotation. 8 | Open Scope monad_scope. 9 | 10 | From ITree Require Import 11 | ITree 12 | Interp.Recursion. 13 | 14 | Inductive term : Type := 15 | | Var : nat -> term 16 | (* DeBruijn indexed *) 17 | 18 | | App : term -> term -> term 19 | 20 | | Lam : term -> term 21 | . 22 | 23 | Inductive headvar : Type := 24 | | VVar : nat -> headvar 25 | | VApp : headvar -> value -> headvar 26 | with value : Type := 27 | | VHead : headvar -> value 28 | | VLam : term -> value 29 | . 30 | 31 | Fixpoint to_term (v : value) : term := 32 | match v with 33 | | VHead hv => hv_to_term hv 34 | | VLam t => Lam t 35 | end 36 | with hv_to_term (hv : headvar) : term := 37 | match hv with 38 | | VVar n => Var n 39 | | VApp hv v => App (hv_to_term hv) (to_term v) 40 | end. 41 | 42 | Fixpoint shift (n m : nat) (s : term) := 43 | match s with 44 | | Var p => 45 | if p App (shift n m t1) (shift n m t2) 48 | | Lam t => Lam (shift n (S m) t) 49 | end. 50 | 51 | Fixpoint subst (n : nat) (s t : term) := 52 | match t with 53 | | Var m => 54 | if m App (subst n s t1) (subst n s t2) 58 | | Lam t => Lam (subst (S n) s t) 59 | end. 60 | 61 | (* big-step call-by-value *) 62 | Definition big_step : term -> itree void1 value := 63 | rec (fun t => 64 | match t with 65 | | Var n => ret (VHead (VVar n)) 66 | | App t1 t2 => 67 | t2' <- trigger (Call t2);; 68 | t1' <- trigger (Call t1);; 69 | match t1' with 70 | | VHead hv => ret (VHead (VApp hv t2')) 71 | | VLam t1'' => 72 | trigger (Call (subst O (to_term t2') t1'')) 73 | end 74 | | Lam t => ret (VLam t) 75 | end). 76 | -------------------------------------------------------------------------------- /theories/Events/Exception.v: -------------------------------------------------------------------------------- 1 | (** * Exception event *) 2 | 3 | (* begin hide *) 4 | From ITree Require Import ITree. 5 | 6 | Set Implicit Arguments. 7 | (* end hide *) 8 | 9 | (** Throw exceptions of type [Err]. *) 10 | Variant exceptE (Err : Type) : Type -> Type := 11 | | Throw : Err -> exceptE Err void. 12 | 13 | (** Since the output type of [Throw] is [void], we can make it an action 14 | with any return type. *) 15 | Definition throw {Err : Type} {E : Type -> Type} `{exceptE Err -< E} {X} 16 | (e : Err) 17 | : itree E X 18 | := vis (Throw e) (fun v : void => match v with end). 19 | 20 | Definition try_catch {Err R : Type } {E : Type -> Type} 21 | (ttry : itree (exceptE Err +' E) R) (kcatch : Err -> itree (exceptE Err +' E) R) : itree (exceptE Err +' E) R := 22 | (* the problem is kcatch is actually not a handler, need basic iter?*) 23 | let catch_body (t : itree (exceptE Err +' E) R) : itree (exceptE Err +' E) ((itree (exceptE Err +' E) R) + R ) := 24 | match observe t with 25 | | RetF r => Ret (inr r) 26 | | TauF t' => Ret (inl t') 27 | | VisF e k => 28 | match e with 29 | | inl1 (Throw exc) => Functor.fmap inr (kcatch exc) 30 | | inr1 e' => Functor.fmap (fun x => inl (k x) ) (trigger e) end end 31 | 32 | in 33 | ITree.iter catch_body ttry. 34 | 35 | Definition throw_prefix {Err R : Type} {E : Type -> Type} 36 | (t : itree (exceptE Err +' E) R) : itree (exceptE Err +' E) (R + Err) := 37 | let prefix_body (t' : itree (exceptE Err +' E) R ) : itree (exceptE Err +' E) ((itree (exceptE Err +' E) R) + (R + Err) ) := 38 | match observe t' with 39 | | RetF r => Ret (inr (inl r) ) 40 | | TauF t' => Ret (inl t') 41 | | VisF e k => 42 | match e with 43 | | inl1 (Throw exc) => Ret (inr (inr exc) ) 44 | | inr1 e' => Functor.fmap (fun x => inl (k x) ) (trigger e) 45 | end 46 | end in 47 | ITree.iter prefix_body t. 48 | -------------------------------------------------------------------------------- /theories/Events/Map.v: -------------------------------------------------------------------------------- 1 | (** * Mutable map *) 2 | 3 | (* begin hide *) 4 | Set Implicit Arguments. 5 | Set Contextual Implicit. 6 | 7 | From Coq Require Import List. 8 | Import ListNotations. 9 | 10 | From ExtLib.Structures Require Maps. 11 | 12 | From ITree Require Import 13 | Basics.Basics 14 | Basics.CategoryOps 15 | Basics.MonadState 16 | Indexed.Sum 17 | Core.ITreeDefinition 18 | Core.Subevent 19 | Interp.Interp 20 | Events.State. 21 | 22 | Import ITree.Basics.Basics.Monads. 23 | (* end hide *) 24 | 25 | Section Map. 26 | 27 | Variables (K V : Type). 28 | 29 | Variant mapE : Type -> Type := 30 | | Insert : K -> V -> mapE unit 31 | | Lookup : K -> mapE (option V) 32 | | Remove : K -> mapE unit 33 | . 34 | 35 | Definition insert {E} `{mapE -< E} : K -> V -> itree E unit := embed Insert. 36 | Definition lookup {E} `{mapE -< E} : K -> itree E (option V) := embed Lookup. 37 | Definition remove {E} `{mapE -< E} : K -> itree E unit := embed Remove. 38 | 39 | Definition lookup_def {E} `{mapE -< E} : K -> V -> itree E V 40 | := fun k v => 41 | ITree.bind (lookup k) (fun ov => 42 | Ret (match ov with 43 | | None => v 44 | | Some v' => v' 45 | end)). 46 | 47 | Import Structures.Maps. 48 | 49 | Context {map : Type}. 50 | Context {M : Map K V map}. 51 | 52 | Definition handle_map {E} : mapE ~> stateT map (itree E) := 53 | fun _ e env => 54 | match e with 55 | | Insert k v => Ret (Maps.add k v env, tt) 56 | | Lookup k => Ret (env, Maps.lookup k env) 57 | | Remove k => Ret (Maps.remove k env, tt) 58 | end. 59 | 60 | Definition run_map {E} : itree (mapE +' E) ~> stateT map (itree E) := 61 | interp_state (case_ handle_map pure_state). 62 | 63 | End Map. 64 | 65 | Arguments insert {K V E _}. 66 | Arguments lookup {K V E _}. 67 | Arguments remove {K V E _}. 68 | Arguments lookup_def {K V E _}. 69 | Arguments run_map {K V map M _} [T]. 70 | -------------------------------------------------------------------------------- /theories/Events/Nondeterminism.v: -------------------------------------------------------------------------------- 1 | (** * Nondeterminism *) 2 | 3 | (** Actually, bounded nondeterminism. *) 4 | 5 | (* begin hide *) 6 | Set Implicit Arguments. 7 | Set Contextual Implicit. 8 | 9 | From Coq Require Import List. 10 | Import ListNotations. 11 | 12 | From ITree Require Import 13 | Basics.Basics 14 | Core.ITreeDefinition 15 | Indexed.Sum 16 | Core.Subevent 17 | Events.Exception. 18 | (* end hide *) 19 | 20 | (** Make nondeterministic choices. *) 21 | Variant nondetE : Type -> Prop := 22 | | Or : nondetE bool. 23 | 24 | (** Choose one of two computations. *) 25 | Definition or {E} `{nondetE -< E} {R} (t1 t2 : itree E R) 26 | : itree E R := 27 | vis Or (fun b : bool => if b then t1 else t2). 28 | 29 | (** Choose an element from a nonempty list (with the head and tail 30 | as separate arguments), so it cannot fail. *) 31 | Definition choose1 {E} `{nondetE -< E} {X} 32 | : X -> list X -> itree E X 33 | := fix choose1' x xs : itree E X := 34 | match xs with 35 | | [] => Ret x 36 | | x' :: xs => or (Ret x) (choose1' x' xs) 37 | end. 38 | 39 | (** Pick any element in a list apart from the others. *) 40 | Definition remove_from {X} : list X -> list (X * list X) := 41 | let fix remove_from_ pre xs := 42 | match xs with 43 | | [] => [] 44 | | x :: xs' => (x, pre ++ xs') :: remove_from_ (pre ++ [x]) xs' 45 | end in 46 | remove_from_ []. 47 | 48 | (** ** Empty nondeterminism *) 49 | 50 | (** We can use [exceptE] events to model nullary branching. *) 51 | 52 | (** Exception thrown by [choose]. *) 53 | Variant no_choice : Set := NoChoice. 54 | 55 | (** Choose an element from a list. 56 | 57 | This can fail if the list is empty, using the [exceptE no_choice] event. 58 | *) 59 | Definition choose {E} `{nondetE -< E} `{exceptE no_choice -< E} {X} 60 | : list X -> itree E X 61 | := fix choose' xs : itree E X := 62 | match xs with 63 | | [] => throw NoChoice 64 | | x :: xs => 65 | or (Ret x) (choose' xs) 66 | end. 67 | -------------------------------------------------------------------------------- /tutorial/CatTheory.v: -------------------------------------------------------------------------------- 1 | (* begin hide *) 2 | From Coq Require Import 3 | Morphisms. 4 | 5 | From ITree Require Import 6 | Basics.Category 7 | Basics.CategorySub. 8 | 9 | Import CatNotations. 10 | Local Open Scope cat. 11 | (* end hide *) 12 | 13 | Section CategoryTheory. 14 | 15 | Context 16 | {obj : Type} {C : obj -> obj -> Type} 17 | {bif : obj -> obj -> obj} 18 | {Eq2_C : Eq2 C} 19 | `{forall a b, Equivalence (eq2 (a := a) (b := b))} 20 | `{Category obj C (Eq2C := _)} 21 | `{Coproduct obj C (Eq2_C := _) (Cat_C := _) bif}. 22 | 23 | Lemma aux_app_asm_correct1 (I J A B : obj) : 24 | (assoc_r >>> 25 | bimap (id_ I) (assoc_l >>> bimap swap (id_ B) >>> assoc_r) >>> 26 | assoc_l) 27 | ⩯ bimap swap (id_ (bif A B)) >>> 28 | (assoc_r >>> 29 | (bimap (id_ J) assoc_l >>> 30 | (assoc_l >>> (bimap swap (id_ B) >>> assoc_r)))). 31 | Proof. cat_auto. Qed. 32 | 33 | Lemma aux_app_asm_correct2 (I J B D : obj) : 34 | (assoc_r >>> 35 | bimap (id_ I) (assoc_l >>> bimap swap (id_ D) >>> assoc_r) >>> 36 | assoc_l) 37 | ⩯ assoc_l >>> 38 | (bimap swap (id_ D) >>> 39 | (assoc_r >>> 40 | (bimap (id_ J) assoc_r >>> 41 | (assoc_l >>> bimap swap (id_ (bif B D)))))). 42 | Proof. cat_auto. Qed. 43 | 44 | End CategoryTheory. 45 | 46 | (** [(A + B) + (C + D) -> (A + C) + (B + D)]*) 47 | Notation swap4 := 48 | (assoc_r >>> bimap (id_ _) (assoc_l >>> bimap swap (id_ _) >>> assoc_r) >>> assoc_l). 49 | 50 | Require Import KTreeFin. 51 | 52 | Lemma subpure_swap4 {E A B C D} : 53 | subpure (E := E) (n := (A + B) + (C + D)) swap4 ⩯ swap4. 54 | Proof. 55 | rewrite !fmap_cat0, !fmap_assoc_r, !fmap_assoc_l. 56 | do 2 (apply category_proper_cat; try reflexivity). 57 | rewrite fmap_bimap, fmap_id0. 58 | rewrite fmap_cat0. 59 | apply (bifunctor_proper_bimap _ _); try reflexivity. 60 | rewrite fmap_cat0, fmap_assoc_l, fmap_assoc_r, fmap_bimap. 61 | rewrite fmap_swap, fmap_id0. 62 | reflexivity. 63 | Qed. 64 | -------------------------------------------------------------------------------- /secure_example/CatTheory.v: -------------------------------------------------------------------------------- 1 | (* begin hide *) 2 | From Coq Require Import 3 | Morphisms. 4 | 5 | From ITree Require Import 6 | Basics.Category 7 | Basics.CategorySub. 8 | 9 | Require Import SecureExample.KTreeFin. 10 | 11 | Import CatNotations. 12 | Local Open Scope cat. 13 | (* end hide *) 14 | 15 | Section CategoryTheory. 16 | 17 | Context 18 | {obj : Type} {C : obj -> obj -> Type} 19 | {bif : obj -> obj -> obj} 20 | {Eq2_C : Eq2 C} 21 | `{forall a b, Equivalence (eq2 (a := a) (b := b))} 22 | `{Category obj C (Eq2C := _)} 23 | `{Coproduct obj C (Eq2_C := _) (Cat_C := _) bif}. 24 | 25 | Lemma aux_app_asm_correct1 (I J A B : obj) : 26 | (assoc_r >>> 27 | bimap (id_ I) (assoc_l >>> bimap swap (id_ B) >>> assoc_r) >>> 28 | assoc_l) 29 | ⩯ bimap swap (id_ (bif A B)) >>> 30 | (assoc_r >>> 31 | (bimap (id_ J) assoc_l >>> 32 | (assoc_l >>> (bimap swap (id_ B) >>> assoc_r)))). 33 | Proof. cat_auto. Qed. 34 | 35 | Lemma aux_app_asm_correct2 (I J B D : obj) : 36 | (assoc_r >>> 37 | bimap (id_ I) (assoc_l >>> bimap swap (id_ D) >>> assoc_r) >>> 38 | assoc_l) 39 | ⩯ assoc_l >>> 40 | (bimap swap (id_ D) >>> 41 | (assoc_r >>> 42 | (bimap (id_ J) assoc_r >>> 43 | (assoc_l >>> bimap swap (id_ (bif B D)))))). 44 | Proof. cat_auto. Qed. 45 | 46 | End CategoryTheory. 47 | 48 | (** [(A + B) + (C + D) -> (A + C) + (B + D)]*) 49 | Notation swap4 := 50 | (assoc_r >>> bimap (id_ _) (assoc_l >>> bimap swap (id_ _) >>> assoc_r) >>> assoc_l). 51 | 52 | Lemma subpure_swap4 {E A B C D} : 53 | subpure (E := E) (n := (A + B) + (C + D)) swap4 ⩯ swap4. 54 | Proof. 55 | rewrite !fmap_cat0, !fmap_assoc_r, !fmap_assoc_l. 56 | do 2 (apply category_proper_cat; try reflexivity). 57 | rewrite fmap_bimap, fmap_id0. 58 | rewrite fmap_cat0. 59 | apply (bifunctor_proper_bimap _ _); try reflexivity. 60 | rewrite fmap_cat0, fmap_assoc_l, fmap_assoc_r, fmap_bimap. 61 | rewrite fmap_swap, fmap_id0. 62 | reflexivity. 63 | Qed. 64 | -------------------------------------------------------------------------------- /theories/Basics/Function.v: -------------------------------------------------------------------------------- 1 | (** * The Category of Functions *) 2 | 3 | (** Definitions to work with Coq functions [A -> B] categorically. 4 | *) 5 | 6 | (* begin hide *) 7 | From ITree Require Import 8 | Basics.Basics 9 | Basics.CategoryOps. 10 | 11 | Import CatNotations. 12 | #[local] Open Scope cat_scope. 13 | (* end hide *) 14 | 15 | (** The name of the category. *) 16 | Definition Fun (A B : Type) : Type := A -> B. 17 | 18 | (** The identity function, but can sometimes help type inference. *) 19 | Definition apply_Fun {A B : Type} (f : Fun A B) : A -> B := f. 20 | 21 | (** Extensional function equality *) 22 | #[global] Instance eeq : Eq2 Fun := 23 | fun A B f g => forall a : A, f a = g a. 24 | 25 | (** Identity function *) 26 | #[global] Instance Id_Fun : Id_ Fun := 27 | fun A => fun a => a. 28 | 29 | (** Function composition *) 30 | #[global] Instance Cat_Fun : Cat Fun := 31 | fun A B C f g => fun a => g (f a). 32 | 33 | (** [void] as an initial object. *) 34 | #[global] Instance Initial_void : Initial Fun void := 35 | fun _ v => match v : void with end. 36 | 37 | (** [unit] as a final object. *) 38 | #[global] Instance Terminal_unit : Terminal Fun unit := 39 | fun _ x => tt. 40 | 41 | (** ** The [sum] coproduct. *) 42 | 43 | (** Coproduct elimination *) 44 | #[global] Instance case_sum : Case Fun sum := 45 | fun {A B C} (f : A -> C) (g : B -> C) (x : A + B) => 46 | match x with 47 | | inl a => f a 48 | | inr b => g b 49 | end. 50 | 51 | (** Injections *) 52 | #[global] Instance sum_inl : Inl Fun sum := @inl. 53 | #[global] Instance sum_inr : Inr Fun sum := @inr. 54 | 55 | (** ** The [pair] product. *) 56 | #[global] Instance Pair_Fun : Pair Fun prod := 57 | fun {A B C} l r c => (l c, r c). 58 | 59 | #[global] Instance Fst_Fun : Fst Fun prod := @fst. 60 | #[global] Instance Snd_Fun : Snd Fun prod := @snd. 61 | 62 | 63 | (** ** Cartesian closure. *) 64 | (** The [exponential] is just [_ -> _], which is a just another name for [Fun] *) 65 | #[global] Instance Apply_Fun : Apply Fun prod Fun := 66 | fun {A B} '(f, b) => f b. 67 | 68 | #[global] Instance Curry_Fun : Curry Fun prod Fun := 69 | fun {A B C} f => fun c a => f (c, a). 70 | -------------------------------------------------------------------------------- /_CoqProject.itree: -------------------------------------------------------------------------------- 1 | -Q theories ITree 2 | 3 | theories/Simple.v 4 | theories/ITree.v 5 | theories/ITreeFacts.v 6 | theories/Axioms.v 7 | 8 | theories/Basics/Utils.v 9 | theories/Basics/Basics.v 10 | theories/Basics/HeterogeneousRelations.v 11 | theories/Basics/Category.v 12 | theories/Basics/CategoryOps.v 13 | theories/Basics/CategoryTheory.v 14 | theories/Basics/CategoryFacts.v 15 | theories/Basics/CategorySub.v 16 | theories/Basics/CategoryFunctor.v 17 | theories/Basics/CategoryRelations.v 18 | theories/Basics/Monad.v 19 | theories/Basics/MonadProp.v 20 | theories/Basics/MonadState.v 21 | theories/Basics/CategoryKleisli.v 22 | theories/Basics/CategoryKleisliFacts.v 23 | theories/Basics/Function.v 24 | theories/Basics/FunctionFacts.v 25 | 26 | theories/Core/ITreeDefinition.v 27 | theories/Core/KTree.v 28 | theories/Core/KTreeFacts.v 29 | theories/Core/Subevent.v 30 | theories/Core/ITreeMonad.v 31 | 32 | theories/Eq.v 33 | theories/Eq/Paco2.v 34 | theories/Eq/Shallow.v 35 | theories/Eq/Eqit.v 36 | theories/Eq/UpToTaus.v 37 | theories/Eq/SimUpToTaus.v 38 | theories/Eq/EqAxiom.v 39 | theories/Eq/EuttExtras.v 40 | theories/Eq/Rutt.v 41 | theories/Eq/RuttFacts.v 42 | 43 | theories/Props/Leaf.v 44 | theories/Props/Finite.v 45 | theories/Props/HasPost.v 46 | theories/Props/Infinite.v 47 | theories/Props/Cofinite.v 48 | theories/Props/EuttNoRet.v 49 | 50 | theories/Indexed/Sum.v 51 | theories/Indexed/Relation.v 52 | theories/Indexed/Function.v 53 | theories/Indexed/FunctionFacts.v 54 | 55 | theories/Interp/Interp.v 56 | theories/Interp/TranslateFacts.v 57 | theories/Interp/InterpFacts.v 58 | theories/Interp/Handler.v 59 | theories/Interp/HandlerFacts.v 60 | theories/Interp/Recursion.v 61 | theories/Interp/RecursionFacts.v 62 | theories/Interp/Traces.v 63 | 64 | theories/Events.v 65 | theories/Events/State.v 66 | theories/Events/StateFacts.v 67 | theories/Events/Reader.v 68 | theories/Events/Writer.v 69 | theories/Events/Exception.v 70 | theories/Events/ExceptionFacts.v 71 | theories/Events/Nondeterminism.v 72 | theories/Events/Map.v 73 | theories/Events/MapDefault.v 74 | theories/Events/MapDefaultFacts.v 75 | theories/Events/Concurrency.v 76 | theories/Events/Dependent.v 77 | theories/Events/FailFacts.v 78 | -------------------------------------------------------------------------------- /tutorial/extract-imptest/ImpTest.v: -------------------------------------------------------------------------------- 1 | From ITree Require Import ITree. 2 | From ITreeTutorial Require Import Imp. 3 | From Coq Require Import NArith String. 4 | 5 | Local Open Scope string_scope. 6 | 7 | Import ImpNotations. 8 | 9 | Definition loopy : stmt := 10 | WHILE 1 DO Skip. 11 | 12 | Fixpoint run {A} (n : nat) (t : itree void1 A) : option A := 13 | match n, observe t with 14 | | O, _ => None 15 | | S _, RetF a => Some a 16 | | S n, TauF t => run n t 17 | | S _, VisF e _ => match e with end 18 | end. 19 | 20 | Definition run_ (n : N) (s : stmt) : option env := 21 | option_map fst (run (N.to_nat n) (eval_imp s)). 22 | 23 | Require Extraction. 24 | Require ExtrOcamlBasic. 25 | Require ExtrOcamlString. 26 | Require ExtrOcamlNatInt. 27 | 28 | Parameter io : Type. 29 | Extract Inlined Constant io => "(unit -> unit)". 30 | 31 | Parameter seq : io -> io -> io. 32 | Extract Constant seq => "fun a b () -> a (); b ()". 33 | 34 | Parameter print_binding : var -> nat -> io. 35 | Extract Constant print_binding => 36 | "fun v n () -> 37 | let to_string l = 38 | let l_ = ref l in 39 | String.init (List.length l) (fun _ -> 40 | match !l_ with 41 | | h :: t -> l_ := t; h 42 | | [] -> assert false) in 43 | let v = to_string v in 44 | print_string v; 45 | print_string "":=""; 46 | print_int n; 47 | print_string "";""". 48 | 49 | Parameter print_newline : io. 50 | Extract Inlined Constant print_newline => "print_newline". 51 | 52 | Parameter nit : Type. 53 | Extract Inlined Constant nit => "unit". 54 | 55 | Parameter run_io : io -> nit. 56 | Extract Constant run_io => "fun w -> w ()". 57 | 58 | Fixpoint print_env (e : env) : io := 59 | match e with 60 | | nil => print_newline 61 | | cons (v, n) e => seq (print_binding v n) (print_env e) 62 | end. 63 | 64 | Definition run' (n : N) (s : stmt) : io := 65 | match run_ n s with 66 | | None => print_newline 67 | | Some e => print_env e 68 | end. 69 | 70 | Definition test : nit := 71 | run_io ( 72 | seq (run' 100 loopy) 73 | (run' 1000 (fact "X" "Y" 10)%string) 74 | ). 75 | 76 | Set Warnings "-extraction-default-directory". 77 | Extraction "imp_test.ml" test. 78 | -------------------------------------------------------------------------------- /extra/ITrace/ITraceDefinition.v: -------------------------------------------------------------------------------- 1 | From ITree Require Import 2 | ITree 3 | ITreeFacts 4 | Eq.Rutt 5 | Props.Infinite 6 | . 7 | 8 | 9 | From Paco Require Import paco. 10 | 11 | Import Monads. 12 | Import MonadNotation. 13 | Local Open Scope monad_scope. 14 | 15 | Variant EvAns (E : Type -> Type) : Type -> Type := 16 | | evans : forall {A : Type} (ev : E A) (ans : A), EvAns E unit 17 | (*if you can prove there is no answers, don't need to proved one*) 18 | | evempty : forall {A : Type} (Hempty : A -> void) (ev : E A), EvAns E void 19 | . 20 | 21 | Arguments evans {E}. 22 | Arguments evempty {E}. 23 | 24 | Definition itrace (E : Type -> Type) (R : Type) := itree (EvAns E) R. 25 | 26 | Definition itrace' (E : Type -> Type) (R : Type) := itree' (EvAns E) R. 27 | 28 | Definition ev_stream (E : Type -> Type) := itrace E unit. 29 | 30 | Definition Nil {E : Type -> Type} : ev_stream E := Ret tt. 31 | 32 | Definition ev_list (E : Type -> Type) := list (EvAns E unit). 33 | 34 | Fixpoint ev_list_to_stream {E : Type -> Type} (l : ev_list E) : ev_stream E := 35 | match l with 36 | | nil => Ret tt 37 | | cons e t => Vis e (fun _ => ev_list_to_stream t) end. 38 | 39 | (*one append for traces and streams, get associativity for free from bind_bind*) 40 | Definition append {E R} (s : itrace E unit) (b : itrace E R) := 41 | ITree.bind s (fun _ => b). 42 | 43 | Notation "s ++ b" := (append s b). 44 | 45 | Variant REvRef (E : Type -> Type) : forall (A B : Type), EvAns E A -> E B -> Prop := 46 | | rer {A : Type} (e : E A) (a : A) : REvRef E unit A (evans A e a) e 47 | | ree {A : Type} (e : E A) (Hempty : A -> void) : REvRef E void A (evempty A Hempty e) e 48 | . 49 | #[global] Hint Constructors REvRef : itree. 50 | 51 | (*shouldn't need an empty case*) 52 | Variant RAnsRef (E : Type -> Type) : forall (A B : Type), EvAns E A -> A -> E B -> B -> Prop := 53 | | rar {A : Type} (e : E A) (a : A) : RAnsRef E unit A (evans A e a) tt e a. 54 | #[global] Hint Constructors RAnsRef : itree. 55 | 56 | Definition trace_refine {E R} (t : itree E R) (b : itrace E R) := 57 | rutt (REvRef E) (RAnsRef E) eq b t. 58 | 59 | 60 | Notation "b ⊑ t" := (trace_refine t b) (at level 70). 61 | 62 | Definition finite {E : Type -> Type} (s : ev_stream E) : Prop := may_converge tt s. 63 | 64 | #[global] Instance itrace_eq {E} : Eq1 (itrace E) := ITreeMonad.Eq1_ITree. 65 | -------------------------------------------------------------------------------- /theories/Events/Writer.v: -------------------------------------------------------------------------------- 1 | (** * Writer *) 2 | 3 | (** Output events. *) 4 | 5 | (* begin hide *) 6 | Set Implicit Arguments. 7 | Set Contextual Implicit. 8 | 9 | From Coq Require Import 10 | List. 11 | Import ListNotations. 12 | 13 | From ExtLib Require Import 14 | Structures.Functor 15 | Structures.Monad 16 | Structures.Monoid. 17 | 18 | From ITree Require Import 19 | Basics.Basics 20 | Basics.CategoryOps 21 | Basics.MonadState 22 | Indexed.Function 23 | Indexed.Sum 24 | Core.ITreeDefinition 25 | Core.Subevent 26 | Interp.Interp 27 | Interp.Handler 28 | Events.State. 29 | 30 | Import Basics.Basics.Monads. 31 | (* end hide *) 32 | 33 | (** Event to output values of type [W]. *) 34 | Variant writerE (W : Type) : Type -> Type := 35 | | Tell : W -> writerE W unit. 36 | 37 | (** Output action. *) 38 | Definition tell {W E} `{writerE W -< E} : W -> itree E unit := 39 | fun w => trigger (Tell w). 40 | 41 | (** One interpretation is to accumulate outputs in a list. *) 42 | 43 | (** Note that this handler appends new outputs to the front of the list. *) 44 | Definition handle_writer_list {W E} 45 | : writerE W ~> stateT (list W) (itree E) 46 | := fun _ e s => 47 | match e with 48 | | Tell w => Ret (w :: s, tt) 49 | end. 50 | 51 | Definition run_writer_list_state {W E} 52 | : itree (writerE W +' E) ~> stateT (list W) (itree E) 53 | := interp_state (case_ handle_writer_list pure_state). 54 | 55 | Arguments run_writer_list_state {W E} [T]. 56 | 57 | (** Returns the outputs in order: the first output at the head, the last 58 | output and the end of the list. *) 59 | Definition run_writer_list {W E} 60 | : itree (writerE W +' E) ~> writerT (list W) (itree E) 61 | := fun _ t => 62 | ITree.map (fun wsx => (rev' (fst wsx), snd wsx)) 63 | (run_writer_list_state t []). 64 | 65 | Arguments run_writer_list {W E} [T]. 66 | 67 | (** When [W] is a monoid, we can also use that to append the outputs together. *) 68 | 69 | Definition handle_writer {W E} (Monoid_W : Monoid W) 70 | : writerE W ~> stateT W (itree E) 71 | := fun _ e s => 72 | match e with 73 | | Tell w => Ret (monoid_plus Monoid_W s w, tt) 74 | end. 75 | 76 | Definition run_writer {W E} (Monoid_W : Monoid W) 77 | : itree (writerE W +' E) ~> writerT W (itree E) 78 | := fun _ t => 79 | interp_state (M := itree E) 80 | (case_ (handle_writer Monoid_W) pure_state) t 81 | (monoid_unit Monoid_W). 82 | 83 | Arguments run_writer {W E} Monoid_W [T]. 84 | -------------------------------------------------------------------------------- /theories/Indexed/Relation.v: -------------------------------------------------------------------------------- 1 | (** * Relations on indexed types *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | Relations 6 | Setoid. 7 | 8 | From ITree Require Import 9 | Basics.Basics. 10 | 11 | Set Universe Polymorphism. 12 | (* end hide *) 13 | 14 | (** This is an indexed generalization of the standard [respectful] 15 | relation ([==>]). *) 16 | Definition i_respectful {A B : Type -> Type} 17 | (RA : forall T, A T -> A T -> Prop) 18 | (RB : forall T, B T -> B T -> Prop) 19 | (f1 f2 : A ~> B) 20 | : Prop 21 | := forall T (a1 a2 : A T), RA T a1 a2 -> (RB T) (f1 T a1) (f2 T a2). 22 | 23 | Definition i_pointwise {A B : Type -> Type} 24 | (RB : forall T, B T -> B T -> Prop) 25 | (f1 f2 : A ~> B) 26 | : Prop 27 | := forall T (a : A T), (RB T) (f1 T a) (f2 T a). 28 | 29 | #[global] 30 | Instance Reflexive_i_pointwise {A B : Type -> Type} 31 | (RB : forall T, B T -> B T -> Prop) 32 | {Reflexive_R : forall T, Reflexive (RB T)} 33 | : Reflexive (@i_pointwise A B RB). 34 | Proof. 35 | repeat red; intros; red in Reflexive_R; eauto. 36 | Qed. 37 | 38 | #[global] 39 | Instance Symmetric_i_pointwise {A B : Type -> Type} 40 | (RB : forall T, B T -> B T -> Prop) 41 | {Symmetric_R : forall T, Symmetric (RB T)} 42 | : Symmetric (@i_pointwise A B RB). 43 | Proof. 44 | repeat red; intros; red in Symmetric_R; eauto. 45 | Qed. 46 | 47 | #[global] 48 | Instance Transitive_i_pointwise {A B : Type -> Type} 49 | (RB : forall T, B T -> B T -> Prop) 50 | {Transitive_R : forall T, Transitive (RB T)} 51 | : Transitive (@i_pointwise A B RB). 52 | Proof. 53 | repeat red; intros; red in Transitive_R; eauto. 54 | Qed. 55 | 56 | #[global] 57 | Instance Equivalence_i_pointwise {A B : Type -> Type} 58 | (RB : forall T, B T -> B T -> Prop) 59 | {Equivalence_R : forall T, Equivalence (RB T)} 60 | : Equivalence (@i_pointwise A B RB). 61 | Proof. 62 | split; try typeclasses eauto. 63 | Qed. 64 | 65 | #[global] 66 | Instance subrelation_i_pointwise_i_respectful {A B : Type -> Type} 67 | (RB : forall T, B T -> B T -> Prop) 68 | : subrelation (i_pointwise RB) (i_respectful (fun T => @eq (A T)) RB). 69 | Proof. 70 | repeat red; intros; subst; auto. 71 | Qed. 72 | 73 | (* This is not an instance, to avoid instance resolution loops. *) 74 | Definition subrelation_i_respectful_i_pointwise {A B : Type -> Type} 75 | (RB : forall T, B T -> B T -> Prop) 76 | : subrelation (i_respectful (fun T => @eq (A T)) RB) (i_pointwise RB). 77 | Proof. 78 | repeat red; auto. 79 | Qed. 80 | -------------------------------------------------------------------------------- /theories/Basics/CategoryKleisli.v: -------------------------------------------------------------------------------- 1 | (** * Kleisli category *) 2 | 3 | (** The category of "effectful functions", of type [a -> m b], 4 | for some monad [m]. *) 5 | 6 | (** Note that this is not quite a Kleisli category over the 7 | category [Fun], as the notion of morphism equivalence is 8 | different. The category [Fun] uses pointwise equality, 9 | [eq ==> eq], while [Kleisli m] uses pointwise equivalence, 10 | [eq ==> eq1], for an equivalence relation [eq1] associated 11 | with the monad [m]. The right underlying category for [Kleisli] 12 | would be a category of setoids and respectful functions, but 13 | this seems awkward to program with. Investigating this 14 | question further is future work. 15 | *) 16 | 17 | (* begin hide *) 18 | From Coq Require Import 19 | Morphisms. 20 | 21 | From ExtLib Require Import 22 | Structures.Monad. 23 | 24 | From ITree Require Import 25 | Basics.Basics 26 | Basics.CategoryOps 27 | Basics.Function 28 | Basics.Monad. 29 | (* end hide *) 30 | 31 | Implicit Types m : Type -> Type. 32 | Implicit Types a b c : Type. 33 | 34 | Definition Kleisli m a b : Type := a -> m b. 35 | 36 | (* SAZ: We need to show how these are intended to be used. *) 37 | (** A trick to allow rewriting in pointful contexts. *) 38 | Definition Kleisli_arrow {m a b} : (a -> m b) -> Kleisli m a b := fun f => f. 39 | Definition Kleisli_apply {m a b} : Kleisli m a b -> (a -> m b) := fun f => f. 40 | 41 | 42 | Definition pure {m} `{Monad m} {a b} (f : a -> b) : Kleisli m a b := 43 | fun x => ret (f x). 44 | 45 | Section Instances. 46 | Context {m : Type -> Type}. 47 | Context `{Monad m}. 48 | Context `{Eq1 m}. 49 | 50 | #[global] Instance Eq2_Kleisli : Eq2 (Kleisli m) := 51 | fun _ _ => pointwise_relation _ eq1. 52 | 53 | #[global] Instance Cat_Kleisli : Cat (Kleisli m) := 54 | fun _ _ _ u v x => 55 | bind (u x) (fun y => v y). 56 | 57 | Definition map {a b c} (g:b -> c) (ab : Kleisli m a b) : Kleisli m a c := 58 | cat ab (pure g). 59 | 60 | #[global] Instance Initial_Kleisli : Initial (Kleisli m) void := 61 | fun _ v => match v : void with end. 62 | 63 | #[global] Instance Id_Kleisli : Id_ (Kleisli m) := 64 | fun _ => pure id. 65 | 66 | #[global] Instance Case_Kleisli : Case (Kleisli m) sum := 67 | fun _ _ _ l r => case_sum _ _ _ l r. 68 | 69 | #[global] Instance Inl_Kleisli : Inl (Kleisli m) sum := 70 | fun _ _ => pure inl. 71 | 72 | #[global] Instance Inr_Kleisli : Inr (Kleisli m) sum := 73 | fun _ _ => pure inr. 74 | 75 | #[global] Instance Iter_Kleisli `{MonadIter m} : Iter (Kleisli m) sum := 76 | fun a b => Basics.iter. 77 | 78 | End Instances. 79 | -------------------------------------------------------------------------------- /theories/Events/Concurrency.v: -------------------------------------------------------------------------------- 1 | (** * Concurrency *) 2 | 3 | (* begin hide *) 4 | Set Implicit Arguments. 5 | Set Contextual Implicit. 6 | 7 | From Coq Require Import List. 8 | Import ListNotations. 9 | 10 | From ITree Require Import 11 | Core.ITreeDefinition 12 | Indexed.Sum 13 | Subevent. 14 | (* end hide *) 15 | 16 | (* An event that spawns a unit-producing thread with events in [E]. *) 17 | Inductive spawnE E : Type -> Type := 18 | | Spawn : forall (t: itree (spawnE E +' E) unit), spawnE E unit. 19 | 20 | Definition spawn {F E} `{(spawnE F) -< E} (t:itree (spawnE F +' F) unit) : itree E unit := 21 | trigger (Spawn t). 22 | 23 | (* A simple round-robin scheduler: 24 | 25 | This scheduler runs a queue of threads that contain Spawn events. Each such 26 | spawned child threads cannot themselves Spwan events (at least not ones 27 | handled by this scheduler). Each thread may terminate by returning [tt]. If 28 | all children threads _and_ the parent thread return, then execution 29 | terminates, yielding [tt]. If any of the threads diverge, the whole 30 | scheduled pool diverges. 31 | 32 | With this implementation, the threads could communicate via a shared memory 33 | via their events [E], but there are no real synchronization primitives that 34 | could be used to prevent races. 35 | 36 | 37 | Another variant: if, in the TauF case, we do: 38 | Tau (rr ([u] ++ ts)) 39 | We get a different scheduler that only gets control when a thread yields 40 | by returning or blocking on an external event. If the first thread silently 41 | diverges, then the whole system does too. 42 | *) 43 | Definition rr_match {E} (rr : list (itree ((spawnE E) +' E) unit) -> itree E unit) 44 | (q:list (itree ((spawnE E) +' E) unit)) : itree E unit 45 | := 46 | match q with 47 | | [] => Ret tt 48 | | t::ts => 49 | match observe t with 50 | | RetF _ => Tau (rr ts) 51 | | TauF u => Tau (rr (ts ++ [u])) 52 | | @VisF _ _ _ X o k => 53 | match o with 54 | | inl1 s => 55 | match s in spawnE _ Y return X = Y -> itree E unit with 56 | | (Spawn u) => fun pf => Tau (rr (ts 57 | ++ [u] 58 | ++ [k (eq_rect_r (fun T => T) tt pf)])) 59 | end eq_refl 60 | | inr1 o => Vis o (fun x => rr (ts ++ [k x])) 61 | end 62 | end 63 | end. 64 | 65 | CoFixpoint round_robin {E} (q:list (itree ((spawnE E) +' E) unit)) : itree E unit := 66 | rr_match round_robin q. 67 | 68 | Definition run_spawn {E} (t : itree ((spawnE E) +' E) unit) : itree E unit := 69 | round_robin [t]. 70 | -------------------------------------------------------------------------------- /theories/Events/State.v: -------------------------------------------------------------------------------- 1 | (** * State *) 2 | 3 | (** Events to read and update global state. *) 4 | 5 | (* begin hide *) 6 | From ExtLib Require Import 7 | Structures.Functor 8 | Structures.Monad. 9 | 10 | From ITree Require Import 11 | Basics.Basics 12 | Basics.CategoryOps 13 | Basics.CategoryKleisli 14 | Core.ITreeDefinition 15 | Indexed.Function 16 | Indexed.Sum 17 | Core.Subevent 18 | Interp.Interp. 19 | 20 | Import ITree.Basics.Basics.Monads. 21 | 22 | Local Open Scope itree_scope. 23 | (* end hide *) 24 | 25 | (* Stateful handlers [E ~> stateT S (itree F)] and morphisms 26 | [E ~> state S] define stateful itree morphisms 27 | [itree E ~> stateT S (itree F)]. *) 28 | 29 | Definition interp_state {E M S} 30 | {FM : Functor M} {MM : Monad M} 31 | {IM : MonadIter M} (h : E ~> stateT S M) : 32 | itree E ~> stateT S M := interp h. 33 | 34 | Arguments interp_state {E M S FM MM IM} h [T]. 35 | 36 | Section State. 37 | 38 | Variable (S : Type). 39 | 40 | Variant stateE : Type -> Type := 41 | | Get : stateE S 42 | | Put : S -> stateE unit. 43 | 44 | Definition get {E} `{stateE -< E} : itree E S := embed Get. 45 | Definition put {E} `{stateE -< E} : S -> itree E unit := embed Put. 46 | 47 | Definition h_state {E} : stateE ~> stateT S (itree E) := 48 | fun _ e s => 49 | match e with 50 | | Get => Ret (s, s) 51 | | Put s' => Ret (s', tt) 52 | end. 53 | 54 | (* SAZ: this is the instance for the hypothetical "Trigger E M" typeclass. 55 | Class Trigger E M := trigger : E ~> M 56 | *) 57 | Definition pure_state {S E} : E ~> stateT S (itree E) 58 | := fun _ e s => Vis e (fun x => Ret (s, x)). 59 | 60 | Definition run_state {E} 61 | : itree (stateE +' E) ~> stateT S (itree E) 62 | := interp_state (case_ h_state pure_state). 63 | 64 | End State. 65 | 66 | Arguments get {S E _}. 67 | Arguments put {S E _}. 68 | Arguments run_state {S E} [_] _ _. 69 | 70 | 71 | (** An extensional stateful handler *) 72 | Section eff_hom_e. 73 | Context {E F : Type -> Type}. 74 | 75 | (* note(gmm): you should be able to add events here 76 | * using a monad transformer. In that case, the type 77 | * of `eval` is: 78 | * 79 | * forall t, E t -> m (itree F) (t * eff_hom_e) 80 | * 81 | * but you have the usual conditions on strictly positive uses 82 | *) 83 | CoInductive eff_hom_e : Type := 84 | { eval : forall t, E t -> itree F (eff_hom_e * t) }. 85 | 86 | Definition interp_e (h : eff_hom_e) : itree E ~> itree F := fun R t => 87 | ITree.iter (fun '(s, t) => 88 | match observe t with 89 | | RetF r => Ret (inr r) 90 | | TauF t => Ret (inl (s, t)) 91 | | VisF e k => ITree.map (fun '(s, x) => inl (s, k x)) (h.(eval) _ e) 92 | end) (h, t). 93 | 94 | End eff_hom_e. 95 | -------------------------------------------------------------------------------- /theories/Events/MapDefault.v: -------------------------------------------------------------------------------- 1 | (** * Mutable map whose lookup operation provides a default value.*) 2 | 3 | (* begin hide *) 4 | Set Implicit Arguments. 5 | Set Contextual Implicit. 6 | 7 | From ExtLib Require Import 8 | Core.RelDec. 9 | 10 | From ExtLib.Structures Require 11 | Functor Monoid Maps. 12 | 13 | From ITree Require Import 14 | Basics.Basics 15 | Basics.CategoryOps 16 | Basics.CategoryKleisli 17 | Basics.Monad 18 | Indexed.Function 19 | Indexed.Sum 20 | Core.ITreeDefinition 21 | Core.Subevent 22 | Interp.Interp 23 | Interp.Handler 24 | Events.State. 25 | 26 | Import ITree.Basics.Basics.Monads. 27 | (* end hide *) 28 | 29 | Section Map. 30 | 31 | Variables (K V : Type). 32 | 33 | Variant mapE (d:V) : Type -> Type := 34 | | Insert : K -> V -> mapE d unit 35 | | LookupDef : K -> mapE d V 36 | | Remove : K -> mapE d unit 37 | . 38 | 39 | Arguments Insert {d}. 40 | Arguments LookupDef {d}. 41 | Arguments Remove {d}. 42 | 43 | Definition insert {E d} `{(mapE d) -< E} : K -> V -> itree E unit := embed Insert. 44 | Definition lookup_def {E d} `{(mapE d) -< E} : K -> itree E V := embed LookupDef. 45 | Definition remove {E d} `{(mapE d) -< E} : K -> itree E unit := embed Remove. 46 | 47 | Import Structures.Maps. 48 | 49 | Context {map : Type}. 50 | Context {M : Map K V map}. 51 | 52 | Definition lookup_default {K V} `{Map K V} k d m := 53 | match Maps.lookup k m with 54 | | Some v' => v' 55 | | None => d 56 | end. 57 | 58 | Definition handle_map {E d} : mapE d ~> stateT map (itree E) := 59 | fun _ e env => 60 | match e with 61 | | Insert k v => Ret (Maps.add k v env, tt) 62 | | LookupDef k => Ret (env, lookup_default k d env) 63 | | Remove k => Ret (Maps.remove k env, tt) 64 | end. 65 | 66 | (* SAZ: I think that all of these [run_foo] functions should be renamed 67 | [interp_foo]. That would be more consistent with the idea that 68 | we define semantics by nested interpretation. Also, it seems a bit 69 | strange to define [interp_map] in terms of [interp_state]. 70 | *) 71 | Definition interp_map {E d} : itree (mapE d +' E) ~> stateT map (itree E) := 72 | interp_state (case_ (C := IFun) handle_map pure_state). 73 | 74 | 75 | (* The appropriate notation of the equivalence on the state associated with 76 | the MapDefault effects. Two maps are equivalent if they yield the same 77 | answers under [lookup_default] *) 78 | Definition eq_map (d:V) (m1 m2 : map) : Prop := 79 | forall k, lookup_default k d m1 = lookup_default k d m2. 80 | 81 | End Map. 82 | 83 | Arguments insert {K V E d _}. 84 | Arguments lookup_def {K V E d _}. 85 | Arguments remove {K V E d _}. 86 | Arguments interp_map {K V map M _ _ } [T]. 87 | Arguments eq_map {K V map M d}. 88 | -------------------------------------------------------------------------------- /extra/Dijkstra/DijkstraMonad.v: -------------------------------------------------------------------------------- 1 | (** * Dijkstra monad hierarchy *) 2 | 3 | (** Implementation of Dijkstra Monad framework in a series of Typeclasses *) 4 | 5 | From ExtLib Require Import 6 | Structures.Monad. 7 | 8 | From ITree Require Import 9 | Basics.Basics 10 | Basics.Monad. 11 | 12 | Import MonadNotation. 13 | 14 | Declare Scope dijkstra_scope. 15 | Delimit Scope dijkstra_scope with dijkstra. 16 | 17 | #[local] Open Scope dijkstra_scope. 18 | #[local] Open Scope monad_scope. 19 | 20 | (** ** Ordered monads *) 21 | 22 | Class OrderM (M : Type -> Type) := 23 | lem : forall A, M A -> M A -> Prop. 24 | 25 | Arguments lem { M OrderM A }. 26 | 27 | Infix "<≈" := lem (at level 70) : dijkstra_scope. 28 | 29 | Section OrderedMonad. 30 | 31 | Context (W : Type -> Type). 32 | Context {Eq : Eq1 W}. 33 | Context {MonadW : Monad W}. 34 | Context {MonadLawsW : MonadLawsE W}. 35 | Context {OrderW : OrderM W}. 36 | Class OrderedMonad := 37 | { 38 | reflex : forall A (w : W A), w <≈ w; 39 | trans : forall A (w1 w2 w3 : W A), w1 <≈ w2 -> w2 <≈ w3 -> w1 <≈ w3; 40 | monot : forall A B w1 w2 (f1 f2 : A -> W B), w1 <≈ w2 -> 41 | (forall (a : A), (f1 a) <≈ (f2 a) ) -> (bind w1 f1) <≈ (bind w2 f2) 42 | }. 43 | 44 | End OrderedMonad. 45 | 46 | (** ** Specification monads *) 47 | 48 | Section SpecMonad. 49 | 50 | Context (W : Type -> Type). 51 | Context {MonadW : Monad W}. 52 | Context {OrderW : OrderM W}. 53 | Context {OrderedMonadW : OrderedMonad W}. 54 | Class SpecMonad := 55 | { 56 | Input : Type -> Type; 57 | In : forall {A : Type}, Input A -> W A -> Prop 58 | }. 59 | 60 | Infix "∈" := In (at level 70) : dijkstra_scope. 61 | End SpecMonad. 62 | 63 | (** ** Effect observations *) 64 | 65 | Class EffectObs (M W : Type -> Type) := 66 | obs : M ~> W. 67 | 68 | Section EffectObservation. 69 | 70 | Context (M W : Type -> Type). 71 | Context {MMonad : Monad M}. 72 | Context {WMonad : Monad W}. 73 | Context {EqW : Eq1 W}. 74 | Context {MonadLawsW : MonadLawsE W}. 75 | Context {WOrder : OrderM W}. 76 | Context {WOrderLaws : OrderedMonad W}. 77 | Context (Obs : EffectObs M W). 78 | 79 | Class MonadMorphism := 80 | { 81 | ret_pres : forall A (a : A), obs A (ret a) ≈ ret a; 82 | bind_pres : forall A B (m : M A) (f : A -> M B), 83 | obs _ (bind m f) ≈ bind (obs _ m) (fun a => obs _ (f a)) 84 | }. 85 | 86 | End EffectObservation. 87 | 88 | (** ** Dijkstra monads *) 89 | 90 | Section DijkstraMonad. 91 | Context (M W : Type -> Type). 92 | Context {MMonad : Monad M}. 93 | Context {WMonad : Monad W}. 94 | Context {EqW : Eq1 W}. 95 | Context {MonadLawsW : MonadLawsE W}. 96 | Context {WOrder : OrderM W}. 97 | Context { WOrderLaws : OrderedMonad W }. 98 | Context ( Obs : EffectObs M W ). 99 | 100 | 101 | (*Note that the Dijkstra Monad is only a monad-like structure 102 | not an actual monad*) 103 | Definition DijkstraMonad (A : Type) (w : W A) := 104 | { m : M A | obs A m <≈ w }. 105 | 106 | Definition DijkstraProp (A : Type) (w : W A) (m : M A) : Prop := 107 | obs A m <≈ w. 108 | 109 | End DijkstraMonad. 110 | -------------------------------------------------------------------------------- /theories/Interp/Interp.v: -------------------------------------------------------------------------------- 1 | (** * Monadic interpretations of interaction trees *) 2 | 3 | (** We can derive semantics for an interaction tree [itree E ~> M] 4 | from semantics given for every individual event [E ~> M], 5 | when [M] is a monad (actually, with some more structure). 6 | 7 | We define the following terminology for this library. 8 | Other sources may have different usages for the same or related 9 | words. 10 | 11 | The notation [E ~> F] stands for [forall T, E T -> F T] 12 | (in [ITree.Basics]). 13 | It can mean many things, including the following: 14 | 15 | - The semantics of itrees are given as monad morphisms 16 | [itree E ~> M], also called "interpreters". 17 | 18 | - "ITree interpreters" (or "itree morphisms") are monad morphisms 19 | where the codomain is made of ITrees: [itree E ~> itree F]. 20 | 21 | Interpreters can be obtained from handlers: 22 | 23 | - In general, "event handlers" are functions [E ~> M] where 24 | [M] is a monad. 25 | 26 | - "ITree event handlers" are functions [E ~> itree F]. 27 | 28 | Categorically, this boils down to saying that [itree] is a free 29 | monad (not quite, but close enough). 30 | *) 31 | 32 | (* begin hide *) 33 | From ExtLib Require Import 34 | Structures.Functor 35 | Structures.Monad. 36 | 37 | From ITree Require Import 38 | Basics.Basics 39 | Core.ITreeDefinition 40 | Indexed.Relation. 41 | (* end hide *) 42 | 43 | (** ** Translate *) 44 | 45 | (** An event morphism [E ~> F] lifts to an itree morphism [itree E ~> itree F] 46 | by applying the event morphism to every visible event. We call this 47 | process _event translation_. 48 | 49 | Translation is a special case of interpretation: 50 | [[ 51 | translate h t ≈ interp (trigger ∘ h) t 52 | ]] 53 | However this definition of [translate] yields strong bisimulations 54 | more often than [interp]. 55 | For example, [translate (id_ E) t ≅ id_ (itree E)]. 56 | *) 57 | 58 | (** A plain event morphism [E ~> F] defines an itree morphism 59 | [itree E ~> itree F]. *) 60 | Definition translateF {E F R} (h : E ~> F) (rec: itree E R -> itree F R) (t : itreeF E R _) : itree F R := 61 | match t with 62 | | RetF x => Ret x 63 | | TauF t => Tau (rec t) 64 | | VisF e k => Vis (h _ e) (fun x => rec (k x)) 65 | end. 66 | 67 | Definition translate {E F} (h : E ~> F) 68 | : itree E ~> itree F 69 | := fun R => cofix translate_ t := translateF h translate_ (observe t). 70 | 71 | Arguments translate {E F} & h [T]. 72 | 73 | (** ** Interpret *) 74 | 75 | (** An event handler [E ~> M] defines a monad morphism 76 | [itree E ~> M] for any monad [M] with a loop operator. *) 77 | 78 | Definition interp {E M : Type -> Type} 79 | {FM : Functor M} {MM : Monad M} {IM : MonadIter M} 80 | (h : E ~> M) : 81 | itree E ~> M := fun R => 82 | iter (fun t => 83 | match observe t with 84 | | RetF r => ret (inr r) 85 | | TauF t => ret (inl t) 86 | | VisF e k => fmap (fun x => inl (k x)) (h _ e) 87 | end). 88 | (* TODO: this does a map, and aloop does a bind. We could fuse those 89 | by giving aloop a continuation to compose its bind with. 90 | (coyoneda...) *) 91 | 92 | Arguments interp {E M FM MM IM} & h [T]. 93 | -------------------------------------------------------------------------------- /secure_example/LabelledAsmHandler.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List 3 | Morphisms. 4 | 5 | From ITree Require Import 6 | ITree 7 | ITreeFacts. 8 | 9 | From ITree.Extra Require Import 10 | Secure.SecureEqHalt 11 | . 12 | 13 | From SecureExample Require Import 14 | LabelledImp 15 | LabelledAsm 16 | LabelledImpHandler. 17 | 18 | Import Monads. 19 | Import MonadNotation. 20 | Local Open Scope monad_scope. 21 | 22 | From Paco Require Import paco. 23 | 24 | (* Note that this definition sets considers all registers to be private *) 25 | 26 | Definition priv_asm (priv : privacy_map sensitivity_lat) (A : Type) (e : (Reg +' Memory +' (IOE sensitivity_lat)) A ) := 27 | match e with 28 | | inl1 _ => Private 29 | | inr1 (inl1 (Load x)) => priv x 30 | | inr1 (inl1 (Store x _ )) => priv x 31 | | inr1 (inr1 (LabelledPrint _ s _ ) ) => s 32 | end. 33 | 34 | Definition low_reg_mem_equiv (priv : privacy_map sensitivity_lat) : (registers * memory) -> (registers * memory) -> Prop := fun '(reg1, mem1) '(reg2, mem2) => forall x, priv x = Public -> mem1 x = mem2 x. 35 | 36 | Definition reg_mem : Type := registers * memory. 37 | 38 | #[local] Notation lat := sensitivity_lat. 39 | 40 | Definition low_eqit_secure_asmstate (b1 b2 : bool) (priv : var -> sensitivity) {R1 R2 : Type} (RR : R1 -> R2 -> Prop ) 41 | (m1 : stateT reg_mem (itree (IOE lat)) R1) (m2 : stateT reg_mem (itree (IOE lat)) R2) : Prop := 42 | forall s1 s2, low_reg_mem_equiv priv s1 s2 -> eqit_secure (Lattice.PreOrderOfLattice lat) (priv_io _) (product_rel (low_reg_mem_equiv priv) RR) b1 b2 Public (m1 s1) (m2 s2). 43 | 44 | Lemma low_reg_mem_equiv_update_public: 45 | forall (priv_map : privacy_map lat) (x : addr) (v : value), 46 | priv_map x = Public -> 47 | forall (reg1 : registers) (mem1 : memory) (reg2 : registers) (mem2 : memory), 48 | low_reg_mem_equiv priv_map (reg1, mem1) (reg2, mem2) -> 49 | low_reg_mem_equiv priv_map (reg1, update x v mem1) (reg2, update x v mem2). 50 | Proof. 51 | intros priv_map x v Hx reg1 mem1 reg2 mem2 Hs. 52 | red. red in Hs. intros. unfold update. rewrite Hs; auto. 53 | Qed. 54 | 55 | Lemma low_reg_mem_equiv_update_priv_l: 56 | forall (priv_map : privacy_map lat) (x : addr) (v : value), 57 | priv_map x = Private -> 58 | forall (reg1 : registers) (mem1 : memory) (reg2 : registers) (mem2 : memory), 59 | low_reg_mem_equiv priv_map (reg1, mem1) (reg2, mem2) -> 60 | low_reg_mem_equiv priv_map (reg1, update x v mem1) (reg2, mem2). 61 | Proof. 62 | intros priv_map x v Hx reg1 mem1 reg2 mem2 Hs. 63 | red. red in Hs. intros. unfold update. 64 | assert (x <> x0). 65 | { intro. subst. rewrite Hx in H. discriminate. } 66 | apply String.eqb_neq in H0. rewrite H0. auto. 67 | Qed. 68 | 69 | Lemma low_reg_mem_equiv_update_priv_r: 70 | forall (priv_map : privacy_map lat) (x : addr) (v : value), 71 | priv_map x = Private -> 72 | forall (reg1 : registers) (mem1 : memory) (reg2 : registers) (mem2 : memory), 73 | low_reg_mem_equiv priv_map (reg1, mem1) (reg2, mem2) -> 74 | low_reg_mem_equiv priv_map (reg1, mem1) (reg2, update x v mem2). 75 | Proof. 76 | intros priv_map x v Hx reg1 mem1 reg2 mem2 Hs. 77 | red. red in Hs. intros. unfold update. 78 | assert (x <> x0). 79 | { intro. subst. rewrite Hx in H. discriminate. } 80 | apply String.eqb_neq in H0. rewrite H0. auto. 81 | Qed. 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Interaction Trees 2 | 3 | [![project chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com/#narrow/stream/394939-Interaction-Trees) 4 | [![BUILD](https://circleci.com/gh/DeepSpec/InteractionTrees.svg?style=shield)](https://circleci/gh/DeepSpec/InteractionTrees) 5 | 6 | A Library for Representing Recursive and Impure Programs in Coq 7 | 8 | ## Introduction 9 | 10 | For a quick overview of the core features of the library, see 11 | [`examples/ReadmeExample.v`](./examples/ReadmeExample.v). 12 | 13 | See also [the tutorial](./tutorial/README.md). 14 | 15 | [The coqdoc documentation for this library is available here.](https://deepspec.github.io/InteractionTrees/) 16 | 17 | Join the Interaction Trees channel on 18 | [Rocq's Zulip server](https://coq.zulipchat.com/#narrow/channel/394939-Interaction-Trees) 19 | if you have any questions. 20 | 21 | ### Top-level modules 22 | 23 | - `ITree.ITree`: Definitions to program with interaction trees. 24 | - `ITree.ITreeFacts`: Theorems to reason about interaction trees. 25 | - `ITree.Events`: Some standard event types. 26 | 27 | ## Installation 28 | 29 | ### Via opam 30 | 31 | ``` 32 | opam install coq-itree 33 | ``` 34 | 35 | ### Dependencies 36 | 37 | - [coq](https://coq.inria.fr/) 38 | - [coq-paco](https://github.com/snu-sf/paco) 39 | - [coq-ext-lib](https://github.com/coq-community/coq-ext-lib) 40 | 41 | See [`coq-itree.opam`](./coq-itree.opam) for version details. 42 | 43 | ## Axioms 44 | 45 | This library currently depends on UIP, functional extensionality, excluded middle, 46 | and choice; see also [`theories/Axioms.v`](./theories/Axioms.v). 47 | 48 | ### UIP 49 | 50 | This library depends on UIP for the inversion lemma: 51 | 52 | ```coq 53 | Lemma eqit_inv_Vis 54 | : eutt eq (Vis e k1) (Vis e k2) -> 55 | forall x, eutt eq (k1 x) (k2 x). 56 | ``` 57 | 58 | There are a few more lemmas that depend on it, but you might not actually need 59 | it. For example, the compiler proof in `tutorial` doesn't need it and is 60 | axiom-free. 61 | 62 | That lemma also has a weaker, but axiom-free version using heterogeneous 63 | equality: `eqit_inv_Vis_weak`. 64 | 65 | The axiom that's technically used here is `eq_rect_eq` (and also `JMeq_eq` in 66 | old versions of Coq), which is equivalent to UIP. 67 | 68 | ### Functional extensionality 69 | 70 | The closed category of functions assumes `functional_extensionality`, 71 | in [`Basics.FunctionFacts.CartesianClosed_Fun`](./theories/Basics/FunctionFacts.v). 72 | 73 | ### Excluded middle and choice 74 | 75 | In the `itree-extra` library, the theory of traces (`extra/ITrace/`)—which Dijkstra monads for ITree 76 | depend on (`extra/Dijkstra`)—assumes excluded middle, to decide whether an 77 | itree diverges, and a type-theoretic axiom of choice, which provides a strong 78 | excluded middle in propositional contexts: 79 | 80 | ```coq 81 | Theorem classicT_inhabited : inhabited (forall T : Type, T + (T -> False)). 82 | ``` 83 | 84 | ### Exported: strong bisimulation is propositional equality 85 | 86 | The library exports the following axiom for convenience, though it's unlikely 87 | you'll need it, and the rest of the library does not depend on it: 88 | 89 | ```coq 90 | Axiom bisimulation_is_eq : t1 ≅ t2 -> t1 = t2. 91 | ``` 92 | 93 | ## Contributions welcome 94 | 95 | Feel free to open an issue or a pull request! 96 | 97 | See also [`DEV.md`](./DEV.md) for working on this library. 98 | -------------------------------------------------------------------------------- /tutorial/KTreeFin.v: -------------------------------------------------------------------------------- 1 | (** * Subcategory of KTrees indexed by finite types *) 2 | 3 | (* Definition of the [subpure] function, mapping [sub Fun fin] (functions between finite 4 | types) to [sub (ktree E) fin] (KTrees between finite types) and proves that 5 | it commutes with the various combinators from [ITree.Basics.Category]. 6 | *) 7 | 8 | (* begin hide *) 9 | From Coq Require Import 10 | Setoid 11 | Morphisms. 12 | 13 | From ITree Require Import 14 | ITree 15 | ITreeFacts 16 | Basics.CategorySub. 17 | 18 | Require Import Fin. 19 | 20 | Import CatNotations. 21 | Local Open Scope cat_scope. 22 | (* end hide *) 23 | 24 | (* General theory. Functors which preserve coproducts. 25 | Here we assume that the functor's object mapping is the identity function. 26 | *) 27 | Section CocartesianFunctor. 28 | 29 | Context 30 | {obj : Type} {C D : obj -> obj -> Type} 31 | {bif : obj -> obj -> obj} 32 | `{Eq2 _ C} `{Case _ C bif} `{Inl _ C bif} `{Inr _ C bif} 33 | `{Eq2 _ D} `{Case _ D bif} `{Inl _ D bif} `{Inr _ D bif} 34 | {fmap : forall a b, C a b -> D a b}. 35 | 36 | Arguments fmap {a b}. 37 | 38 | Class CocartesianFunctor : Prop := 39 | { fmap_case : forall a b c (f : C a c) (g : C b c), 40 | fmap (case_ f g) ⩯ case_ (fmap f) (fmap g) 41 | ; fmap_inl : forall a b, 42 | fmap (inl_ (a := a) (b := b)) ⩯ inl_ 43 | ; fmap_inr : forall a b, 44 | fmap (inr_ (a := a) (b := b)) ⩯ inr_ 45 | }. 46 | 47 | Context 48 | `{forall a b, Equivalence (eq2 (C := D) (a := a) (b := b))} 49 | `{Id_ _ C} `{Cat _ C} 50 | `{Id_ _ D} `{Cat _ D} 51 | `{forall a b c, Proper (eq2 ==> eq2 ==> eq2) (cat (C := D) (a := a) (b := b) (c := c))} 52 | `{@Coproduct _ D _ _ bif _ _ _} 53 | `{@Functor _ _ C D (fun x => x) (@fmap) _ _ _ _ _ _} 54 | `{CocartesianFunctor}. 55 | 56 | Lemma fmap_swap {n m} 57 | : fmap swap ⩯ swap (a := n) (b := m). 58 | Proof. 59 | unfold swap, Swap_Coproduct. 60 | rewrite fmap_case, fmap_inl, fmap_inr. 61 | reflexivity. 62 | Qed. 63 | 64 | Lemma fmap_bimap {n m p q} (f : C n m) (g : C p q) 65 | : fmap (bimap f g) ⩯ bimap (fmap f) (fmap g). 66 | Proof. 67 | unfold bimap, Bimap_Coproduct. 68 | rewrite fmap_case, !fmap_cat0, fmap_inl, fmap_inr. 69 | reflexivity. 70 | Qed. 71 | 72 | Lemma fmap_assoc_l {n m p} 73 | : fmap (a := (bif n (bif m p))) assoc_l ⩯ assoc_l. 74 | Proof. 75 | unfold assoc_l, AssocL_Coproduct. 76 | rewrite !fmap_case, !fmap_cat0, !fmap_inl, !fmap_inr. 77 | reflexivity. 78 | Qed. 79 | 80 | Lemma fmap_assoc_r {n m p} 81 | : fmap (a := (bif (bif n m) p)) assoc_r ⩯ assoc_r. 82 | Proof. 83 | unfold assoc_r, AssocR_Coproduct. 84 | rewrite !fmap_case, !fmap_cat0, !fmap_inl, !fmap_inr. 85 | reflexivity. 86 | Qed. 87 | 88 | End CocartesianFunctor. 89 | 90 | Notation Fun_fin := (sub Fun fin). 91 | Notation ktree_fin E := (sub (ktree E) fin). 92 | 93 | Section PureKF. 94 | 95 | Context {E : Type -> Type}. 96 | 97 | Definition subpure {n m} (f : Fun_fin n m) : ktree_fin E n m := 98 | subm (pure (unsubm f)). 99 | 100 | Global Instance Functor_pure : Functor _ _ _ (@subpure). 101 | Proof. 102 | constructor; intros. 103 | - reflexivity. 104 | - unfold subpure. rewrite fmap_cat, fmap_cat0. reflexivity. 105 | - hnf; intros. apply Proper_subm, Proper_pure. auto. 106 | Qed. 107 | 108 | Global Instance CocartesianFunctor_pure : CocartesianFunctor (fmap := @subpure). 109 | Proof. 110 | constructor; intros. 111 | - intros []; cbn. 112 | unfold unsubm, case_, Case_Kleisli, case_sum, Case_sub, case_. 113 | unfold cat, Cat_sub, Cat_Fun. 114 | unfold to_bif, ToBifunctor_ktree_fin, ToBifunctor_Fun_fin. 115 | rewrite bind_ret_l. 116 | destruct split_fin_sum; reflexivity. 117 | - intros ?; cbn. rewrite bind_ret_l. reflexivity. 118 | - intros ?; cbn; rewrite bind_ret_l; reflexivity. 119 | Qed. 120 | 121 | End PureKF. 122 | -------------------------------------------------------------------------------- /secure_example/KTreeFin.v: -------------------------------------------------------------------------------- 1 | (** * Subcategory of KTrees indexed by finite types *) 2 | 3 | (* Definition of the [subpure] function, mapping [sub Fun fin] (functions between finite 4 | types) to [sub (ktree E) fin] (KTrees between finite types) and proves that 5 | it commutes with the various combinators from [ITree.Basics.Category]. 6 | *) 7 | 8 | (* begin hide *) 9 | From Coq Require Import 10 | Setoid 11 | Morphisms. 12 | 13 | From ITree Require Import 14 | ITree 15 | ITreeFacts 16 | Basics.CategorySub 17 | . 18 | 19 | Require Import Fin. 20 | 21 | Import CatNotations. 22 | Local Open Scope cat_scope. 23 | (* end hide *) 24 | 25 | (* General theory. Functors which preserve coproducts. 26 | Here we assume that the functor's object mapping is the identity function. 27 | *) 28 | Section CocartesianFunctor. 29 | 30 | Context 31 | {obj : Type} {C D : obj -> obj -> Type} 32 | {bif : obj -> obj -> obj} 33 | `{Eq2 _ C} `{Case _ C bif} `{Inl _ C bif} `{Inr _ C bif} 34 | `{Eq2 _ D} `{Case _ D bif} `{Inl _ D bif} `{Inr _ D bif} 35 | {fmap : forall a b, C a b -> D a b}. 36 | 37 | Arguments fmap {a b}. 38 | 39 | Class CocartesianFunctor : Prop := 40 | { fmap_case : forall a b c (f : C a c) (g : C b c), 41 | fmap (case_ f g) ⩯ case_ (fmap f) (fmap g) 42 | ; fmap_inl : forall a b, 43 | fmap (inl_ (a := a) (b := b)) ⩯ inl_ 44 | ; fmap_inr : forall a b, 45 | fmap (inr_ (a := a) (b := b)) ⩯ inr_ 46 | }. 47 | 48 | Context 49 | `{forall a b, Equivalence (eq2 (C := D) (a := a) (b := b))} 50 | `{Id_ _ C} `{Cat _ C} 51 | `{Id_ _ D} `{Cat _ D} 52 | `{forall a b c, Proper (eq2 ==> eq2 ==> eq2) (cat (C := D) (a := a) (b := b) (c := c))} 53 | `{@Coproduct _ D _ _ bif _ _ _} 54 | `{@Functor _ _ C D (fun x => x) (@fmap) _ _ _ _ _ _} 55 | `{CocartesianFunctor}. 56 | 57 | Lemma fmap_swap {n m} 58 | : fmap swap ⩯ swap (a := n) (b := m). 59 | Proof. 60 | unfold swap, Swap_Coproduct. 61 | rewrite fmap_case, fmap_inl, fmap_inr. 62 | reflexivity. 63 | Qed. 64 | 65 | Lemma fmap_bimap {n m p q} (f : C n m) (g : C p q) 66 | : fmap (bimap f g) ⩯ bimap (fmap f) (fmap g). 67 | Proof. 68 | unfold bimap, Bimap_Coproduct. 69 | rewrite fmap_case, !fmap_cat0, fmap_inl, fmap_inr. 70 | reflexivity. 71 | Qed. 72 | 73 | Lemma fmap_assoc_l {n m p} 74 | : fmap (a := (bif n (bif m p))) assoc_l ⩯ assoc_l. 75 | Proof. 76 | unfold assoc_l, AssocL_Coproduct. 77 | rewrite !fmap_case, !fmap_cat0, !fmap_inl, !fmap_inr. 78 | reflexivity. 79 | Qed. 80 | 81 | Lemma fmap_assoc_r {n m p} 82 | : fmap (a := (bif (bif n m) p)) assoc_r ⩯ assoc_r. 83 | Proof. 84 | unfold assoc_r, AssocR_Coproduct. 85 | rewrite !fmap_case, !fmap_cat0, !fmap_inl, !fmap_inr. 86 | reflexivity. 87 | Qed. 88 | 89 | End CocartesianFunctor. 90 | 91 | Notation Fun_fin := (sub Fun fin). 92 | Notation ktree_fin E := (sub (ktree E) fin). 93 | 94 | Section PureKF. 95 | 96 | Context {E : Type -> Type}. 97 | 98 | Definition subpure {n m} (f : Fun_fin n m) : ktree_fin E n m := 99 | subm (pure (unsubm f)). 100 | 101 | Global Instance Functor_pure : Functor _ _ _ (@subpure). 102 | Proof. 103 | constructor; intros. 104 | - reflexivity. 105 | - unfold subpure. rewrite fmap_cat, fmap_cat0. reflexivity. 106 | - hnf; intros. apply Proper_subm, Proper_pure. auto. 107 | Qed. 108 | 109 | Global Instance CocartesianFunctor_pure : CocartesianFunctor (fmap := @subpure). 110 | Proof. 111 | constructor; intros. 112 | - intros []; cbn. 113 | unfold unsubm, case_, Case_Kleisli, case_sum, Case_sub, case_. 114 | unfold cat, Cat_sub, Cat_Fun. 115 | unfold to_bif, ToBifunctor_ktree_fin, ToBifunctor_Fun_fin. 116 | rewrite bind_ret_l. 117 | destruct split_fin_sum; reflexivity. 118 | - intros ?; cbn. rewrite bind_ret_l. reflexivity. 119 | - intros ?; cbn; rewrite bind_ret_l; reflexivity. 120 | Qed. 121 | 122 | End PureKF. 123 | -------------------------------------------------------------------------------- /theories/Basics/Utils.v: -------------------------------------------------------------------------------- 1 | From Paco Require Import paco. 2 | 3 | Ltac inv H := inversion H; clear H; subst. 4 | 5 | Global Tactic Notation "intros !" := repeat intro. 6 | 7 | Ltac flatten_goal := 8 | match goal with 9 | | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq 10 | end. 11 | 12 | Ltac flatten_hyp h := 13 | match type of h with 14 | | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq 15 | end. 16 | 17 | Ltac flatten_all := 18 | match goal with 19 | | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq 20 | | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq 21 | end. 22 | 23 | (* inv by name of the Inductive relation *) 24 | Ltac invn f := 25 | match goal with 26 | | [ id: f |- _ ] => inv id 27 | | [ id: f _ |- _ ] => inv id 28 | | [ id: f _ _ |- _ ] => inv id 29 | | [ id: f _ _ _ |- _ ] => inv id 30 | | [ id: f _ _ _ _ |- _ ] => inv id 31 | | [ id: f _ _ _ _ _ |- _ ] => inv id 32 | | [ id: f _ _ _ _ _ _ |- _ ] => inv id 33 | | [ id: f _ _ _ _ _ _ _ |- _ ] => inv id 34 | | [ id: f _ _ _ _ _ _ _ _ |- _ ] => inv id 35 | end. 36 | 37 | (* destruct by name of the Inductive relation *) 38 | Ltac destructn f := 39 | match goal with 40 | | [ id: f |- _ ] => destruct id 41 | | [ id: f _ |- _ ] => destruct id 42 | | [ id: f _ _ |- _ ] => destruct id 43 | | [ id: f _ _ _ |- _ ] => destruct id 44 | | [ id: f _ _ _ _ |- _ ] => destruct id 45 | | [ id: f _ _ _ _ _ |- _ ] => destruct id 46 | | [ id: f _ _ _ _ _ _ |- _ ] => destruct id 47 | | [ id: f _ _ _ _ _ _ _ |- _ ] => destruct id 48 | | [ id: f _ _ _ _ _ _ _ _ |- _ ] => destruct id 49 | end. 50 | 51 | (* apply by name of the Inductive relation *) 52 | Ltac appn f := 53 | match goal with 54 | | [ id: f |- _ ] => apply id 55 | | [ id: f _ |- _ ] => apply id 56 | | [ id: f _ _ |- _ ] => apply id 57 | | [ id: f _ _ _ |- _ ] => apply id 58 | | [ id: f _ _ _ _ |- _ ] => apply id 59 | | [ id: f _ _ _ _ _ |- _ ] => apply id 60 | | [ id: f _ _ _ _ _ _ |- _ ] => apply id 61 | | [ id: f _ _ _ _ _ _ _ |- _ ] => apply id 62 | | [ id: f _ _ _ _ _ _ _ _ |- _ ] => apply id 63 | end. 64 | 65 | (* eapply by name of the Inductive relation *) 66 | Ltac eappn f := 67 | match goal with 68 | | [ id: f |- _ ] => eapply id 69 | | [ id: f _ |- _ ] => eapply id 70 | | [ id: f _ _ |- _ ] => eapply id 71 | | [ id: f _ _ _ |- _ ] => eapply id 72 | | [ id: f _ _ _ _ |- _ ] => eapply id 73 | | [ id: f _ _ _ _ _ |- _ ] => eapply id 74 | | [ id: f _ _ _ _ _ _ |- _ ] => eapply id 75 | | [ id: f _ _ _ _ _ _ _ |- _ ] => eapply id 76 | | [ id: f _ _ _ _ _ _ _ _ |- _ ] => eapply id 77 | end. 78 | 79 | 80 | Ltac crunch := 81 | repeat match goal with 82 | | [ H : exists X, _ |- _ ] => destruct H 83 | | [ H : _ /\ _ |- _ ] => destruct H 84 | | [ H : _ \/ _ |- _ ] => destruct H 85 | | [ |- _ /\ _ ] => split 86 | end. 87 | 88 | Ltac saturate H := 89 | match goal with 90 | | [ H1 : forall a b, ?R a b -> _, 91 | H2 : forall a b, ?R b a -> _, 92 | H : ?R ?A ?B |- _ ] => pose proof (H1 A B H); 93 | pose proof (H2 B A H); 94 | clear H; crunch 95 | end. 96 | 97 | Lemma pacobot1 (T0 : Type) (gf : rel1 T0 -> rel1 T0) (r : rel1 T0) 98 | : paco1 gf bot1 <1= paco1 gf r. 99 | Proof. 100 | intros x0 H. apply (paco1_mon _ H); contradiction. 101 | Qed. 102 | 103 | Lemma pacobot2 (T0 : Type) (T1 : T0 -> Type) (gf : rel2 T0 T1 -> rel2 T0 T1) (r : rel2 T0 T1) 104 | : paco2 gf bot2 <2= paco2 gf r. 105 | Proof. 106 | intros x0 x1 H. eapply (paco2_mon _ H); contradiction. 107 | Qed. 108 | -------------------------------------------------------------------------------- /secure_example/LabelledImpInline.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import String. 2 | 3 | From ITree Require Import 4 | ITree 5 | ITreeFacts 6 | Events.StateFacts 7 | Events.Exception 8 | . 9 | 10 | From SecureExample Require Import 11 | Lattice 12 | LabelledAsm 13 | . 14 | 15 | Import Monads. 16 | Import MonadNotation. 17 | Local Open Scope monad_scope. 18 | Local Open Scope string_scope. 19 | 20 | Section LabelledImp. 21 | 22 | Definition var : Set := string. 23 | 24 | Definition value : Type := nat. 25 | 26 | (** Expressions are made of variables, constant literals, and arithmetic operations. *) 27 | Inductive expr : Type := 28 | | Var (_ : var) 29 | | Lit (_ : value) 30 | | Plus (_ _ : expr) 31 | | Minus (_ _ : expr) 32 | | Mult (_ _ : expr). 33 | 34 | (** The statements are straightforward. The [While] statement is the only 35 | potentially diverging one. *) 36 | 37 | Inductive stmt : Type := 38 | | Assign (x : var) (e : expr) (* x = e *) 39 | | Seq (a b : stmt) (* a ; b *) 40 | | If (i : expr) (t e : stmt) (* if (i) then { t } else { e } *) 41 | | While (t : expr) (b : stmt) (* while (t) { b } *) 42 | | Skip (* ; *) 43 | | Output (s : sensitivity) (e : expr) 44 | (* exceptions *) 45 | | Raise (s : sensitivity) 46 | | TryCatch (t c : stmt) 47 | (* Inline *) 48 | | AsmInline (p : asm 1 1) 49 | . 50 | 51 | Variant ClearRegs : Type -> Type := 52 | | Clear : ClearRegs unit. 53 | 54 | Section LabelledImpInlineSemantics. 55 | Context {E : Type -> Type}. 56 | Context {HasReg : Reg -< E}. 57 | (* thought I might need this, but without it things get simpler *) 58 | (* Context {HasClearRegs : ClearRegs -< E}. *) 59 | Context {HasMemory : Memory -< E}. 60 | Context {HasIOE : LabelledImp.IOE sensitivity_lat -< E}. 61 | 62 | Notation impExcE := (LabelledImp.impExcE sensitivity_lat ). 63 | 64 | Notation privacy_map := LabelledImp.privacy_map. 65 | 66 | 67 | 68 | 69 | Fixpoint denote_expr (e : expr) : itree (impExcE +' E) value := 70 | match e with 71 | | Var x => trigger (Load x) 72 | | Lit v => Ret v 73 | | Plus e1 e2 => x <- denote_expr e1;; 74 | y <- denote_expr e2;; 75 | Ret (x + y) 76 | | Minus e1 e2 => x <- denote_expr e1;; 77 | y <- denote_expr e2;; 78 | Ret (x - y) 79 | | Mult e1 e2 => x <- denote_expr e1;; 80 | y <- denote_expr e2;; 81 | Ret (x * y) end. 82 | 83 | 84 | Definition is_true (v : value) : bool := 85 | Nat.ltb 0 v. 86 | 87 | Definition while {E} (t : itree E (unit + unit) ) : itree E unit := 88 | ITree.iter (fun _ => t) tt. 89 | 90 | (* so I need to make sure *) 91 | Program Definition denote_asm_inline {A B} (p : asm A B) : Fin.fin A -> itree (impExcE +' E) (Fin.fin B) := 92 | @denote_asm (impExcE +' E) _ _ _ _ A B p. 93 | 94 | Fixpoint denote_stmt (s : stmt) : itree (impExcE +' E) unit := 95 | match s with 96 | | Assign x e => y <- denote_expr e;; trigger (HasMemory _ (Store x y)) 97 | | Seq s1 s2 => denote_stmt s1 ;; denote_stmt s2 98 | | If e c1 c2 => b <- denote_expr e;; 99 | if (is_true b) 100 | then denote_stmt c1 101 | else denote_stmt c2 102 | | Skip => Ret tt 103 | | Output s e => v <- denote_expr e;; trigger (inr1 (HasIOE _ (LabelledImp.LabelledPrint sensitivity_lat s v)) ) 104 | | While b c => while ( 105 | b <- denote_expr b;; 106 | if (is_true b) 107 | then denote_stmt c;; Ret (inl tt) 108 | else Ret (inr tt) ) 109 | | Raise s => trigger (Throw s);; Ret tt 110 | | TryCatch t c => try_catch (denote_stmt t) (fun _ => denote_stmt c) 111 | | AsmInline p => denote_asm_inline p Fin.f0;; Ret tt 112 | end. 113 | 114 | (* very inefficient, but not sure I really care about extraction so whatever *) 115 | Definition map : Type := var -> value. 116 | 117 | 118 | End LabelledImpInlineSemantics. 119 | 120 | End LabelledImp. 121 | 122 | Definition interp_imp_inline {E1 E2 : Type -> Type} {A : Type} : 123 | itree (E1 +' Reg +' Memory +' E2) A -> 124 | stateT (registers * memory) (itree (E1 +' E2)) A := @interp_asm E1 E2 A. 125 | -------------------------------------------------------------------------------- /theories/Interp/Handler.v: -------------------------------------------------------------------------------- 1 | (** * Event handlers *) 2 | 3 | (** Events types [E, F : Type -> Type] and itree [E ~> itree F] 4 | form a category. *) 5 | 6 | (* begin hide *) 7 | From Coq Require Import 8 | Morphisms. 9 | 10 | From ITree Require Import 11 | Basics.Basics 12 | Basics.Category 13 | Core.ITreeDefinition 14 | Eq.Eqit 15 | Eq.UpToTaus 16 | Indexed.Sum 17 | Indexed.Relation 18 | Interp.Interp 19 | Interp.Recursion. 20 | 21 | Import ITree.Basics.Basics.Monads. 22 | 23 | Local Open Scope itree_scope. 24 | 25 | (* end hide *) 26 | 27 | (** ** Handler combinators *) 28 | 29 | Module Handler. 30 | (** These are defined primarily for documentation. Except for [htrigger], 31 | it is recommended to use the [CategoryOps] classes instead 32 | (with the same function names). *) 33 | 34 | (** Lift an _event morphism_ into an _event handler_. *) 35 | Definition htrigger {A B} (m : A ~> B) : A ~> itree B := 36 | fun _ e => ITree.trigger (m _ e). 37 | 38 | (** Trivial handler, triggering any event it's given, so 39 | the resulting interpretation is the identity function: 40 | [interp (id_ E) _ t ≈ t]. *) 41 | Definition id_ (E : Type -> Type) : E ~> itree E := ITree.trigger. 42 | 43 | (** Chain handlers: [g] handles the events produced by [f]. *) 44 | Definition cat {E F G : Type -> Type} 45 | (f : E ~> itree F) (g : F ~> itree G) 46 | : E ~> itree G 47 | := fun R e => interp g (f R e). 48 | 49 | (** Wrap events to the left of a sum. *) 50 | Definition inl_ {E F : Type -> Type} : E ~> itree (E +' F) 51 | := htrigger inl1. 52 | 53 | (** Wrap events to the right of a sum. *) 54 | Definition inr_ {E F : Type -> Type} : F ~> itree (E +' F) 55 | := htrigger inr1. 56 | 57 | (** Case analysis on sums of events. *) 58 | Definition case_ {E F G : Type -> Type} 59 | (f : E ~> itree G) (g : F ~> itree G) 60 | : E +' F ~> itree G 61 | := fun _ ab => match ab with 62 | | inl1 a => f _ a 63 | | inr1 b => g _ b 64 | end. 65 | 66 | (* Definition case_' {E F G : Type -> Type} 67 | (f : E ~> itree G) (g : F ~> itree G) 68 | : E +' F ~> itree G 69 | := @case_sum1 E F (itree G) f g. 70 | (* TODO: why is there a universe inconsistency if this is before [inl_] and [inr_]? *) 71 | *) 72 | 73 | (** Handle events independently, with disjoint sets of output events. *) 74 | Definition bimap {E F G H : Type -> Type} 75 | (f : E ~> itree G) (g : F ~> itree H) 76 | : E +' F ~> itree (G +' H) 77 | := case_ (Handler.cat f inl_) (Handler.cat g inr_). 78 | 79 | (** Handle [void1] events (of which there are none). *) 80 | Definition empty {E : Type -> Type} 81 | : void1 ~> itree E 82 | := fun _ e => match e : void1 _ with end. 83 | 84 | End Handler. 85 | 86 | (** ** Category instances *) 87 | 88 | Definition Handler (E F : Type -> Type) := E ~> itree F. 89 | 90 | (** Conversion functions between [Handler] and [_ ~> itree _]. 91 | Although they are the identity function, they guide type inference 92 | and type class search. *) 93 | Definition handle {E F} (f : Handler E F) : E ~> itree F := f. 94 | Definition handling {E F} (f : E ~> itree F) : Handler E F := f. 95 | 96 | Definition eq_Handler {E F : Type -> Type} 97 | : Handler E F -> Handler E F -> Prop 98 | := i_pointwise (fun R => eq_itree eq). 99 | 100 | Definition eutt_Handler {E F : Type -> Type} 101 | : Handler E F -> Handler E F -> Prop 102 | := i_pointwise (fun R => eutt eq). 103 | 104 | (** The default handler equivalence is [eutt]. *) 105 | #[global] 106 | Instance Eq2_Handler : Eq2 Handler 107 | := @eutt_Handler. 108 | 109 | #[global] 110 | Instance Id_Handler : Id_ Handler 111 | := @Handler.id_. 112 | 113 | #[global] 114 | Instance Cat_Handler : Cat Handler 115 | := @Handler.cat. 116 | 117 | #[global] 118 | Instance Case_sum1_Handler : Case Handler sum1 119 | := @Handler.case_. 120 | 121 | #[global] 122 | Instance Inl_sum1_Handler : Inl Handler sum1 123 | := @Handler.inl_. 124 | 125 | #[global] 126 | Instance Inr_sum1_Handler : Inr Handler sum1 127 | := @Handler.inr_. 128 | 129 | #[global] 130 | Instance Initial_void1_Handler : Initial Handler void1 131 | := @Handler.empty. 132 | 133 | #[global] 134 | Instance Iter_Handler : Iter Handler sum1 135 | := @mrec. 136 | -------------------------------------------------------------------------------- /secure_example/LabelledImp.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import String. 2 | 3 | From ITree Require Import 4 | ITree 5 | ITreeFacts 6 | Events.MapDefault 7 | Events.StateFacts 8 | Events.Exception 9 | . 10 | 11 | From SecureExample Require Import 12 | Lattice. 13 | 14 | Import Monads. 15 | Import MonadNotation. 16 | Local Open Scope monad_scope. 17 | Local Open Scope string_scope. 18 | 19 | Section LabelledImp. 20 | 21 | Definition var : Set := string. 22 | 23 | Definition value : Type := nat. 24 | 25 | (** Expressions are made of variables, constant literals, and arithmetic operations. *) 26 | Inductive expr : Type := 27 | | Var (_ : var) 28 | | Lit (_ : value) 29 | | Plus (_ _ : expr) 30 | | Minus (_ _ : expr) 31 | | Mult (_ _ : expr). 32 | 33 | (** The statements are straightforward. The [While] statement is the only 34 | potentially diverging one. *) 35 | 36 | Context (Labels : Lattice). 37 | 38 | Notation label := (@T Labels). 39 | 40 | Inductive stmt : Type := 41 | | Assign (x : var) (e : expr) (* x = e *) 42 | | Seq (a b : stmt) (* a ; b *) 43 | | If (i : expr) (t e : stmt) (* if (i) then { t } else { e } *) 44 | | While (t : expr) (b : stmt) (* while (t) { b } *) 45 | | Skip (* ; *) 46 | | Output (s : label) (e : expr) 47 | (* exceptions *) 48 | | Raise (s : label) 49 | | TryCatch (t c : stmt) 50 | . 51 | 52 | 53 | 54 | Definition privacy_map : Type := var -> label. 55 | 56 | Variant stateE : Type -> Type := 57 | | Get (x : var) : stateE value 58 | | Put (x : var) (v : value) : stateE unit. 59 | 60 | Variant IOE : Type -> Type := 61 | | LabelledPrint : label -> value -> IOE unit. 62 | 63 | Definition impExcE : Type -> Type := exceptE label. 64 | 65 | Fixpoint denote_expr (e : expr) : itree (impExcE +' stateE +' IOE) value := 66 | match e with 67 | | Var x => trigger (Get x) 68 | | Lit v => Ret v 69 | | Plus e1 e2 => x <- denote_expr e1;; 70 | y <- denote_expr e2;; 71 | Ret (x + y) 72 | | Minus e1 e2 => x <- denote_expr e1;; 73 | y <- denote_expr e2;; 74 | Ret (x - y) 75 | | Mult e1 e2 => x <- denote_expr e1;; 76 | y <- denote_expr e2;; 77 | Ret (x * y) end. 78 | 79 | 80 | Definition is_true (v : value) : bool := 81 | Nat.ltb 0 v. 82 | 83 | Definition while {E} (t : itree E (unit + unit) ) : itree E unit := 84 | ITree.iter (fun _ => t) tt. 85 | 86 | Fixpoint denote_stmt (s : stmt) : itree (impExcE +' stateE +' IOE) unit := 87 | match s with 88 | | Assign x e => y <- denote_expr e;; trigger (Put x y) 89 | | Seq s1 s2 => denote_stmt s1 ;; denote_stmt s2 90 | | If e c1 c2 => b <- denote_expr e;; 91 | if (is_true b) 92 | then denote_stmt c1 93 | else denote_stmt c2 94 | | Skip => Ret tt 95 | | Output s e => v <- denote_expr e;; trigger (LabelledPrint s v) 96 | | While b c => while ( 97 | b <- denote_expr b;; 98 | if (is_true b) 99 | then denote_stmt c;; Ret (inl tt) 100 | else Ret (inr tt) ) 101 | | Raise s => trigger (Throw s);; Ret tt 102 | | TryCatch t c => try_catch (denote_stmt t) (fun _ => denote_stmt c) 103 | end. 104 | 105 | (* very inefficient, but not sure I really care about extraction so whatever *) 106 | Definition map : Type := var -> value. 107 | 108 | Definition get (x : var) (s : map) := s x. 109 | Definition update (x : var) (v : value) (s : map) := 110 | fun y => if x =? y then v else s y . 111 | 112 | Definition handleState {E} (A : Type) (e : stateE A) : stateT map (itree E ) A := 113 | match e with 114 | | Get x => fun s => Ret (s, get x s) 115 | | Put x v => fun s => Ret (update x v s, tt) end. 116 | 117 | 118 | Definition priv_imp (p : privacy_map) (A : Type) (e : (impExcE +' stateE +' IOE) A ) : label := 119 | match e with 120 | | inl1 (Throw s) => s 121 | | inr1 (inl1 (Get x)) => p x 122 | | inr1 (inl1 (Put x _)) => p x 123 | | inr1 (inr1 (LabelledPrint s _ )) => s 124 | end. 125 | 126 | End LabelledImp. 127 | 128 | Arguments Skip {Labels}. 129 | Arguments Output {Labels}. 130 | Arguments While {Labels}. 131 | Arguments Raise {Labels}. 132 | Arguments TryCatch {Labels}. 133 | Arguments Assign {Labels}. 134 | Arguments Seq {Labels}. 135 | Arguments If {Labels}. 136 | -------------------------------------------------------------------------------- /theories/Core/Subevent.v: -------------------------------------------------------------------------------- 1 | (** * Extensible effects *) 2 | 3 | (** Notations to handle large sums and classes for extensible effects. *) 4 | 5 | (* begin hide *) 6 | From ITree Require Import 7 | Basics.Basics 8 | Basics.CategoryOps 9 | Core.ITreeDefinition 10 | Indexed.Sum 11 | Indexed.Function. 12 | (* end hide *) 13 | 14 | (** Automatic application of commutativity and associativity for 15 | sums types constructed with [sum1]. 16 | 17 | N.B. This is prone to infinite instance resolution loops. 18 | Put the following option at the top of your [.v] files to 19 | bound the instance search depth: 20 | 21 | [[ 22 | Typeclasses eauto := 5. 23 | ]] 24 | 25 | Higher numbers allow bigger instances but grow the search 26 | space exponentially. 27 | *) 28 | 29 | Notation Subevent E F := (@ReSum (Type -> Type) IFun E F) 30 | (only parsing). 31 | Notation "E -< F" := (Subevent E F) 32 | (at level 92, left associativity) : type_scope. 33 | 34 | Definition subevent {E F : Type -> Type} `{E -< F} : E ~> F := resum IFun. 35 | 36 | (** Notations to construct and pattern-match on nested sums. *) 37 | Module Import SumNotations. 38 | 39 | Declare Scope sum_scope. 40 | Delimit Scope sum_scope with sum. 41 | Bind Scope sum_scope with sum1. 42 | 43 | Notation "(| x )" := (inr1 x) : sum_scope. 44 | Notation "( x |)" := (inl1 x) : sum_scope. 45 | Notation "(| x |)" := (inr1 (inl1 x)) : sum_scope. 46 | Notation "(|| x )" := (inr1 (inr1 x)) : sum_scope. 47 | Notation "(|| x |)" := (inr1 (inr1 (inl1 x))) : sum_scope. 48 | Notation "(||| x )" := (inr1 (inr1 (inr1 x))) : sum_scope. 49 | Notation "(||| x |)" := (inr1 (inr1 (inr1 (inl1 x)))) : sum_scope. 50 | Notation "(|||| x )" := (inr1 (inr1 (inr1 (inr1 x)))) : sum_scope. 51 | Notation "(|||| x |)" := 52 | (inr1 (inr1 (inr1 (inr1 (inl1 x))))) : sum_scope. 53 | Notation "(||||| x )" := 54 | (inr1 (inr1 (inr1 (inr1 (inr1 x))))) : sum_scope. 55 | Notation "(||||| x |)" := 56 | (inr1 (inr1 (inr1 (inr1 (inr1 (inl1 x)))))) : sum_scope. 57 | Notation "(|||||| x )" := 58 | (inr1 (inr1 (inr1 (inr1 (inr1 (inr1 x)))))) : sum_scope. 59 | Notation "(|||||| x |)" := 60 | (inr1 (inr1 (inr1 (inr1 (inr1 (inr1 (inl1 x))))))) : sum_scope. 61 | Notation "(||||||| x )" := 62 | (inr1 (inr1 (inr1 (inr1 (inr1 (inr1 (inr1 x))))))) : sum_scope. 63 | 64 | End SumNotations. 65 | 66 | Local Open Scope sum_scope. 67 | 68 | (** A polymorphic version of [Vis]. *) 69 | Notation vis e k := (Vis (subevent _ e) k). 70 | 71 | (* Called [send] in Haskell implementations of Freer monads. *) 72 | Notation trigger e := (ITree.trigger (subevent _ e)). 73 | 74 | (* Embedding events into trees. 75 | 76 | For example: 77 | [[ 78 | embed : 79 | (forall x y z, E (f x y z)) -> 80 | (forall x y z, itree E (f x y z)) 81 | ]] 82 | *) 83 | Class Embeddable U V := 84 | embed : U -> V. 85 | 86 | #[global] 87 | Instance Embeddable_forall {A : Type} {U : A -> Type} {V : A -> Type} 88 | `(forall a, Embeddable (U a) (V a)) : 89 | Embeddable (forall a, U a) (forall a, V a) := 90 | fun u a => embed (u a). 91 | 92 | #[global] 93 | Instance Embeddable_itree {E F : Type -> Type} {R : Type} 94 | `(E -< F) : 95 | Embeddable (E R) (itree F R) := 96 | fun e => trigger e. 97 | 98 | (* Some rewriting lemmas sometimes expose [resum]. The following lemmas help reshape the goal properly *) 99 | Lemma resum_to_subevent : forall (E F : Type -> Type) H T e, 100 | @resum _ IFun E F H T e = subevent _ e. 101 | Proof. 102 | intros; reflexivity. 103 | Qed. 104 | 105 | Lemma subevent_subevent' : forall {E F} `{E -< F} {X} (e : E X), 106 | @subevent F F _ X (@subevent E F _ X e) = subevent X e. 107 | Proof. 108 | reflexivity. 109 | Qed. 110 | 111 | Lemma subevent_subevent : forall {E F G :Type -> Type} (SEF: E -< F) (SFG: F -< G) T (e : E T), 112 | @subevent F G SFG T (@subevent E F SEF T e) = 113 | @subevent E G (fun x f => SFG _ (SEF _ f)) T e. 114 | Proof. 115 | reflexivity. 116 | Qed. 117 | 118 | #[global] Instance subevent_void1 {E}: void1 -< E := fun T e => match e with end. 119 | 120 | Lemma subevent_left {E F R} (e: E R): 121 | @subevent E (E +' F) (ReSum_inl _ _ _ _ _) R e = inl1 e. 122 | Proof. 123 | reflexivity. 124 | Qed. 125 | 126 | Lemma subevent_right {E F R} (e: F R): 127 | @subevent F (E +' F) (ReSum_inr _ _ _ _ _) R e = inr1 e. 128 | Proof. 129 | reflexivity. 130 | Qed. 131 | -------------------------------------------------------------------------------- /examples/STLC.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | Arith 3 | Lia 4 | List. 5 | 6 | From ExtLib Require Import 7 | Monad 8 | Traversable 9 | Data.List. 10 | 11 | From ITree Require Import 12 | ITree 13 | ITreeFacts 14 | Basics.Basics 15 | Basics.Category 16 | Basics.CategoryKleisli 17 | Basics.CategoryKleisliFacts. 18 | 19 | Import Basics.Basics.Monads. 20 | Import ListNotations. 21 | Import ITreeNotations. 22 | Local Open Scope itree_scope. 23 | 24 | Section SYNTAX. 25 | 26 | Inductive typ := 27 | | Base 28 | | Arr (s:typ) (t:typ). 29 | 30 | Variable V : typ -> Type. (* PHOAS variables *) 31 | Inductive tm : typ -> Type := 32 | | Lit (n:nat) : tm Base 33 | | Var : forall (t:typ), V t -> tm t 34 | | App : forall t1 t2 (m1 : tm (Arr t1 t2)) (m2 : tm t1), tm t2 35 | | Lam : forall t1 t2 (body : V t1 -> tm t2), tm (Arr t1 t2) 36 | | Opr : forall (m1 : tm Base) (m2 : tm Base), tm Base 37 | . 38 | 39 | Fixpoint open_tm (G : list typ) (u:typ) : Type := 40 | match G with 41 | | [] => tm u 42 | | t::ts => V t -> (open_tm ts u) 43 | end. 44 | 45 | End SYNTAX. 46 | 47 | Definition Term (G : list typ) (u:typ) := forall (V : typ -> Type), open_tm V G u. 48 | 49 | Arguments Lit {V}. 50 | Arguments Var {V t}. 51 | Arguments App {V t1 t2}. 52 | Arguments Lam {V t1 t2}. 53 | Arguments Opr {V}. 54 | 55 | Section DENOTATION. 56 | Fixpoint denote_typ E (t:typ) : Type := 57 | match t with 58 | | Base => nat 59 | | Arr s t => (denote_typ E s) -> itree E (denote_typ E t) 60 | end. 61 | 62 | Fixpoint denotation_tm_typ E (V:typ -> Type) (G : list typ) (u:typ) := 63 | match G with 64 | | [] => itree E (V u) 65 | | t::ts => (V t) -> denotation_tm_typ E V ts u 66 | end. 67 | 68 | Fixpoint denote_closed_term {E} {u:typ} (m : tm (denote_typ E) u) : itree E (denote_typ E u) := 69 | match m with 70 | | Lit n => Ret n 71 | | Var x => Ret x 72 | | App m1 m2 => f <- (denote_closed_term m1) ;; 73 | x <- (denote_closed_term m2) ;; 74 | ans <- f x ;; 75 | ret ans 76 | | Lam body => ret (fun x => denote_closed_term (body x)) 77 | | Opr m1 m2 => x <- (denote_closed_term m1) ;; 78 | y <- (denote_closed_term m2) ;; 79 | Ret (x + y) 80 | end. 81 | 82 | Program Fixpoint denote_rec 83 | (V:typ -> Type) E 84 | (base : forall u (m : tm V u), itree E (V u)) 85 | (G: list typ) (u:typ) (m : open_tm V G u) : denotation_tm_typ E V G u := 86 | match G with 87 | | [] => base u _ 88 | | t::ts => fun (x : V t) => denote_rec V E base ts u _ 89 | end. 90 | Next Obligation. 91 | simpl in m. 92 | exact m. 93 | Defined. 94 | Next Obligation. 95 | unfold Term in m. 96 | simpl in m. 97 | apply m in x. 98 | exact x. 99 | Defined. 100 | 101 | Program Definition denote E (G : list typ) (u:typ) (m : Term G u) 102 | : denotation_tm_typ E (denote_typ E) G u := 103 | denote_rec (denote_typ E) E (@denote_closed_term E) G u _. 104 | Next Obligation. 105 | unfold Term in m. 106 | specialize (m (denote_typ E)). 107 | exact m. 108 | Defined. 109 | 110 | End DENOTATION. 111 | 112 | 113 | Definition id_tm : Term [] (Arr Base Base) := 114 | fun V => Lam (fun x => Var x). 115 | 116 | Definition example : Term [] Base := 117 | fun V => App (id_tm V) (Lit 3). 118 | 119 | Lemma example_equiv E : (denote E [] Base example) ≈ Ret 3. 120 | Proof. 121 | cbn. 122 | repeat rewrite bind_ret_l. 123 | reflexivity. 124 | Qed. 125 | 126 | Definition twice : Term [] (Arr (Arr Base Base) (Arr Base Base)) := 127 | fun V => Lam (fun f => Lam (fun x => App (Var f) (App (Var f) (Var x)))). 128 | 129 | Definition example2 : Term [] Base := 130 | fun V => App (App (twice V) (id_tm V)) (Lit 3). 131 | 132 | Lemma big_example_equiv E : (denote E [] Base example2) ≈ Ret 3. 133 | Proof. 134 | cbn. 135 | repeat rewrite bind_ret_l. 136 | reflexivity. 137 | Qed. 138 | 139 | Definition add_2_tm : Term [] (Arr Base Base) := 140 | fun V => Lam (fun x => (Opr (Var x) (Lit 2))). 141 | 142 | Definition example3 : Term [] Base := 143 | fun V => App (App (twice V) (add_2_tm V)) (Lit 3). 144 | 145 | Lemma big_example2_equiv E : (denote E [] Base example3) ≈ Ret 7. 146 | Proof. 147 | cbn. 148 | repeat rewrite bind_ret_l. 149 | reflexivity. 150 | Qed. 151 | 152 | -------------------------------------------------------------------------------- /theories/Basics/FunctionFacts.v: -------------------------------------------------------------------------------- 1 | (** * Theorems for [ITree.Basics.Function] *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | Morphisms. 6 | 7 | From ITree Require Import 8 | Axioms 9 | Basics.Basics 10 | Basics.Category 11 | Basics.Function. 12 | 13 | Import CatNotations. 14 | Local Open Scope cat_scope. 15 | (* end hide *) 16 | 17 | #[global] 18 | Instance subrelation_eeq_eqeq {A B} : 19 | @subrelation (A -> B) eq2 (@eq A ==> @eq B)%signature. 20 | Proof. congruence. Qed. 21 | 22 | #[global] 23 | Instance Equivalence_eeq {A B} : @Equivalence (Fun A B) eq2. 24 | Proof. constructor; congruence. Qed. 25 | 26 | #[global] 27 | Instance Proper_cat {A B C : Type} : 28 | @Proper (Fun A B -> Fun B C -> Fun A C) (eq2 ==> eq2 ==> eq2) cat. 29 | Proof. cbv; congruence. Qed. 30 | 31 | #[global] 32 | Instance cat_Fun_CatIdL : CatIdL Fun. 33 | Proof. red; reflexivity. Qed. 34 | 35 | #[global] 36 | Instance cat_Fun_CatIdR : CatIdR Fun. 37 | Proof. red; reflexivity. Qed. 38 | 39 | #[global] 40 | Instance cat_Fun_assoc : CatAssoc Fun. 41 | Proof. red; reflexivity. Qed. 42 | 43 | #[global] 44 | Instance InitialObject_void : InitialObject Fun void := 45 | fun _ _ v => match v : void with end. 46 | 47 | #[global] 48 | Instance TerminalObject_unit : TerminalObject Fun unit. 49 | Proof. red. intros. intro. destruct (f a0). reflexivity. Qed. 50 | 51 | #[global] 52 | Instance eeq_case_sum {A B C} : 53 | @Proper (Fun A C -> Fun B C -> Fun (A + B) C) 54 | (eq2 ==> eq2 ==> eq2) case_. 55 | Proof. cbv; intros; subst; destruct _; auto. Qed. 56 | 57 | #[global] 58 | Instance Category_Fun : Category Fun. 59 | Proof. 60 | constructor; typeclasses eauto. 61 | Qed. 62 | 63 | #[global] 64 | Instance Coproduct_Fun : Coproduct Fun sum. 65 | Proof. 66 | constructor. 67 | - intros a b c f g. 68 | cbv; reflexivity. 69 | - intros a b c f g. 70 | cbv; reflexivity. 71 | - intros a b c f g fg Hf Hg [x | y]; cbv in *; auto. 72 | - typeclasses eauto. 73 | Qed. 74 | 75 | #[global] 76 | Instance PairFst_Fun : PairFst Fun prod. 77 | Proof. 78 | split. 79 | Qed. 80 | 81 | #[global] 82 | Instance PairSnd_Fun : PairSnd Fun prod. 83 | Proof. 84 | split. 85 | Qed. 86 | 87 | #[global] 88 | Instance PairUniversal_Fun : PairUniversal Fun prod. 89 | Proof. 90 | repeat intro. 91 | unfold pair_, Pair_Fun. specialize (H a0). specialize (H0 a0). rewrite <- H. 92 | rewrite <- H0. unfold cat, Cat_Fun. 93 | destruct (fg a0). reflexivity. 94 | Qed. 95 | 96 | #[global] 97 | Instance Proper_pair_Fun : forall a b c, Proper (eq2 ==> eq2 ==> eq2) (@pair_ _ _ _ _ a b c). 98 | Proof. 99 | intros ? ? ? f1 f2 F g1 g2 G c. 100 | unfold pair_, Pair_Fun. rewrite F. rewrite G. reflexivity. 101 | Qed. 102 | 103 | Section Products. 104 | Existing Instance Bimap_Product. 105 | 106 | #[global] 107 | Instance BimapId_Fun_prod : BimapId Fun prod. 108 | Proof. 109 | repeat intro. 110 | destruct a0. reflexivity. 111 | Qed. 112 | 113 | #[global] 114 | Instance BimapCat_Fun_prod : BimapCat Fun prod. 115 | Proof. 116 | repeat intro. 117 | destruct a. 118 | reflexivity. 119 | Qed. 120 | 121 | #[global] 122 | Instance BimapProper_Fun_prod : 123 | forall A B C D, 124 | @Proper ((A -> C) -> (B -> D) -> (A * B -> C * D)) (eq2 ==> eq2 ==> eq2) bimap. 125 | Proof. 126 | repeat intro. 127 | unfold bimap, Bimap_Product. rewrite H. rewrite H0. reflexivity. 128 | Qed. 129 | 130 | #[global] 131 | Instance Bifunctor_Fun_prod : Bifunctor Fun prod. 132 | Proof. 133 | constructor. 134 | - exact BimapId_Fun_prod. 135 | - exact BimapCat_Fun_prod. 136 | - exact BimapProper_Fun_prod. 137 | Qed. 138 | 139 | #[global] 140 | Instance Product_Fun : Product Fun prod. 141 | Proof. 142 | constructor; typeclasses eauto. 143 | Qed. 144 | 145 | End Products. 146 | 147 | Section CartesianClosure. 148 | 149 | #[global] 150 | Instance CurryApply_Fun : CurryApply Fun prod Fun. 151 | Proof. 152 | red. repeat intro. destruct a0. unfold curry_, Curry_Fun, cat, Cat_Fun. reflexivity. 153 | Qed. 154 | 155 | (* Properness of currying requires(?) functional extensionality *) 156 | #[global] 157 | Instance CartesianClosed_Fun : CartesianClosed Fun unit prod Fun. 158 | Proof. 159 | constructor; try typeclasses eauto. 160 | repeat intro. unfold curry_, Curry_Fun. apply functional_extensionality. 161 | intros. apply H. 162 | Qed. 163 | End CartesianClosure. 164 | -------------------------------------------------------------------------------- /secure_example/Lattice.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Morphisms. 2 | 3 | From ITree.Extra Require Import Secure.Labels. 4 | 5 | Class Lattice := { 6 | T : Type; 7 | join : T -> T -> T; 8 | meet : T -> T -> T; 9 | eqlat : T -> T -> Prop; 10 | top : T; 11 | bot : T; 12 | 13 | }. 14 | 15 | Class LatticeLaws (Lat : Lattice) := { 16 | eq_equiv : Equivalence eqlat; 17 | join_proper : Proper (eqlat ==> eqlat ==> eqlat) join; 18 | meet_proper : Proper (eqlat ==> eqlat ==> eqlat) meet; 19 | eqlat_dec : forall l1 l2, {eqlat l1 l2} + {~ eqlat l1 l2}; 20 | join_comm : forall l1 l2, eqlat (join l1 l2) (join l2 l1); 21 | join_assoc : forall l1 l2 l3, eqlat (join l1 (join l2 l3)) (join (join l1 l2) l3 ); 22 | meet_comm : forall l1 l2, eqlat (meet l1 l2) (meet l2 l1); 23 | meet_assoc : forall l1 l2 l3, eqlat (meet l1 (meet l2 l3) ) (meet (meet l1 l2) l3 ); 24 | join_unit : forall l, eqlat l (join l bot); 25 | meet_unit : forall l, eqlat l (meet l top); 26 | absorb1 : forall l1 l2, eqlat (join l1 (meet l1 l2) ) l1; 27 | absorb2 : forall l1 l2, eqlat (meet l1 (join l1 l2) ) l1; 28 | }. 29 | 30 | 31 | #[global] Instance PreOrderOfLattice (Lat : Lattice) : Preorder := 32 | {| 33 | L := T; 34 | leq := fun l1 l2 => eqlat (join l1 l2) l2; 35 | |}. 36 | 37 | Lemma join_idempot (Lat : Lattice) {HLat : LatticeLaws Lat} (l : L) : 38 | eqlat (join l l) l. 39 | Proof. 40 | destruct HLat. setoid_rewrite meet_unit0 at 3. apply absorb3. 41 | Qed. 42 | 43 | Lemma meet_idempot (Lat : Lattice) {HLat : LatticeLaws Lat} (l : L) : 44 | eqlat (meet l l) l. 45 | Proof. 46 | destruct HLat. setoid_rewrite join_unit0 at 3. apply absorb4. 47 | Qed. 48 | 49 | Lemma leq_trans_lat (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 l3 : L) : 50 | leq l1 l2 -> leq l2 l3 -> leq l1 l3. 51 | Proof. 52 | cbn. intros H12 H23. destruct HLat. setoid_rewrite <- H23. 53 | rewrite join_assoc0. rewrite H12. reflexivity. 54 | Qed. 55 | 56 | Lemma leq_join_l (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 : L) : 57 | leq l1 (join l1 l2). 58 | Proof. 59 | cbn. assert (LatticeLaws Lat). auto. destruct HLat. rewrite join_assoc0. rewrite join_idempot; auto. 60 | reflexivity. 61 | Qed. 62 | 63 | Lemma leq_join_r (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 : L) : 64 | leq l2 (join l1 l2). 65 | Proof. 66 | cbn. assert (LatticeLaws Lat). auto. destruct HLat. rewrite join_comm0. rewrite <- join_assoc0. 67 | rewrite join_idempot; auto. reflexivity. 68 | Qed. 69 | 70 | Lemma leq_refl_lat (Lat : Lattice) {HLat : LatticeLaws Lat} l : 71 | leq l l. 72 | Proof. 73 | cbn. apply join_idempot; auto. 74 | Qed. 75 | 76 | Lemma leq_join_and (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 l3 : L) : 77 | leq (join l1 l2) l3 -> leq l1 l3 /\ leq l2 l3. 78 | Proof. 79 | intros. split. 80 | eapply leq_trans_lat; eauto. apply leq_join_l; auto. 81 | eapply leq_trans_lat; eauto. apply leq_join_r; auto. 82 | Qed. 83 | 84 | Lemma leqlat_join_or (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 l3 : L) : 85 | ~ (leq (join l1 l2) l3) -> ~ leq l1 l3 \/ ~ leq l2 l3. 86 | Proof. 87 | intros. cbn. destruct HLat. destruct (eqlat_dec0 (join l1 l3) l3); eauto. 88 | right. intro. cbn in H. rewrite <- join_assoc0 in H. 89 | rewrite H0 in H. contradiction. 90 | Qed. 91 | 92 | Lemma leq_dec (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 : L) : 93 | {leq l1 l2} + {~ leq l1 l2}. 94 | Proof. 95 | cbn. destruct HLat. auto. 96 | Qed. 97 | 98 | Lemma leq_bot (Lat : Lattice) {HLat : LatticeLaws Lat} l : 99 | leq bot l. 100 | Proof. 101 | cbn. destruct HLat. rewrite join_comm0. rewrite <- join_unit0. 102 | reflexivity. 103 | Qed. 104 | 105 | Lemma leq_top (Lat : Lattice) {HLat : LatticeLaws Lat} l : 106 | leq l top. 107 | Proof. 108 | cbn. destruct HLat. rewrite join_comm0. rewrite (meet_unit0 l). 109 | rewrite meet_comm0. rewrite absorb3. reflexivity. 110 | Qed. 111 | 112 | Lemma leq_join_lub (Lat : Lattice) {HLat : LatticeLaws Lat} l1 l2 l3 : 113 | leq l1 l3 -> leq l2 l3 -> leq (join l1 l2) l3. 114 | Proof. 115 | cbn. intros. destruct HLat. rewrite <- join_assoc0. rewrite H0. auto. 116 | Qed. 117 | 118 | #[global] Instance proper_leq1 (Lat : Lattice) {HLat : LatticeLaws Lat} : Proper (eqlat ==> eqlat ==> Basics.flip Basics.impl) leq. 119 | Proof. 120 | cbn. repeat intro. destruct HLat. rewrite H, H0. auto. 121 | Qed. 122 | 123 | #[global] Instance proper_leq2 (Lat : Lattice) {HLat : LatticeLaws Lat} : Proper (eqlat ==> eqlat ==> Basics.impl) leq. 124 | Proof. 125 | cbn. repeat intro. destruct HLat. rewrite <- H. rewrite <- H0. auto. 126 | Qed. 127 | -------------------------------------------------------------------------------- /extra/Dijkstra/PureITreeBasics.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | Morphisms. 3 | 4 | From ExtLib Require Import 5 | Structures.Monad. 6 | 7 | From Paco Require Import paco. 8 | 9 | From ITree Require Import 10 | Axioms 11 | ITree 12 | ITreeFacts 13 | Props.Infinite. 14 | 15 | Import Monads. 16 | Import MonadNotation. 17 | #[local] Open Scope monad_scope. 18 | 19 | Set Implicit Arguments. 20 | 21 | (* Contains some useful definitions and lemmas regarding ITrees with no events*) 22 | 23 | (** The itree Tau (Tau (Tau ...))*) 24 | #[local] Notation spin := ITree.spin. 25 | 26 | (*this implies that if a spec w accepts spin, then bind w f should too? *) 27 | Lemma spin_bind : forall (E : Type -> Type) (A B : Type) (f : A -> itree E B), spin ≈ ITree.bind spin f. 28 | Proof. 29 | intros. pcofix CIH. pfold. unfold bind. simpl. red. 30 | cbn. constructor. right. auto. 31 | Qed. 32 | 33 | (*Depreacated predicate on itree predicates. Intended to denote that a predicate is invariant wrt adding 34 | or subtracting a finite number of Tau's. Replaced with resp_eutt*) 35 | Definition tau_invar (E : Type -> Type) (A : Type) (P : itree E A -> Prop) : Prop := 36 | forall (t : itree E A), (P t -> (P (Tau t))) /\(P (Tau t) -> P t). 37 | 38 | (*Characterizes predicates that respect the eutt relation on itrees. Captures the notion that a predicate 39 | is invariant wrt adding or subtracting a finite number of Tau's*) 40 | Notation resp_eutt P := (Proper (eutt eq ==> iff) P). 41 | 42 | Lemma tau_invar_resp_eutt1: forall (E : Type -> Type) (A : Type) (P : itree E A -> Prop), 43 | (forall t1 t2, t1 ≈ t2 ->(P t1 <-> P t2)) -> tau_invar P. 44 | Proof. 45 | intros. unfold tau_invar. split; intros; 46 | eapply H; try eassumption; rewrite tau_eutt; reflexivity. 47 | Qed. 48 | 49 | (*spin is the only divergent itree with the void1 event type,*) 50 | Lemma div_spin_eutt : forall (A : Type) (t : itree void1 A), any_infinite t -> t ≈ spin. 51 | Proof. 52 | intros A. pcofix CIH. intros. pfold. red. cbn. 53 | destruct (observe t) eqn : Heqt. 54 | - specialize (itree_eta t) as H. rewrite Heqt in H. rewrite H in H0. pinversion H0. 55 | - constructor. right. apply CIH. specialize (itree_eta t) as H. rewrite Heqt in H. 56 | assert (t ≈ Tau t0). 57 | + rewrite H. reflexivity. 58 | + rewrite <- tau_eutt. rewrite <- H1. auto. 59 | - destruct e. 60 | Qed. 61 | 62 | Lemma eutt_reta_or_div_aux : forall A (t : itree void1 A), ~(exists a, ret a ≈ t) -> any_infinite t. 63 | Proof. 64 | intro A. pcofix CIH. pfold. unfold any_infinite_. intros. destruct (observe t) eqn : Heqt. 65 | - exfalso. specialize (itree_eta t) as H. rewrite Heqt in H. apply H0. 66 | exists r0. rewrite H. reflexivity. 67 | - constructor. right. eapply CIH; eauto. intro. apply H0. 68 | destruct H as [a Ha]. exists a. specialize (itree_eta t) as Ht. rewrite Heqt in Ht. 69 | rewrite Ht. rewrite tau_eutt. auto. 70 | - destruct e. 71 | Qed. 72 | 73 | (*All itrees with void1 event type either just return a value a, or they diverge (requires the law of the excluded middle to prove) *) 74 | Lemma eutt_reta_or_div : forall A (t : itree void1 A), (exists a, ret a ≈ t) \/ (any_infinite t). 75 | Proof. 76 | intros A t. specialize (classic (exists a, ret a ≈ t) ) as Hlem. destruct Hlem; auto. 77 | right. apply eutt_reta_or_div_aux. auto. 78 | Qed. 79 | 80 | Lemma ret_not_div : forall (A : Type) (E : Type -> Type) (a : A), ~ (@any_infinite E A (ret a)). 81 | Proof. 82 | intros. intro Hcontra. pinversion Hcontra. 83 | Qed. 84 | 85 | Lemma not_ret_eutt_spin : forall A E (a : A), ~ (Ret a ≈ @spin E A). 86 | Proof. 87 | intros. intro Hcontra. symmetry in Hcontra. revert Hcontra; apply no_infinite_ret. 88 | apply spin_infinite. 89 | Qed. 90 | 91 | Lemma eutt_ret_euttge : forall (E : Type -> Type) (A : Type) (a : A) (t : itree E A), 92 | t ≈ Ret a -> t ≳ Ret a. 93 | Proof. 94 | intros. generalize dependent t. pcofix CIH. intros. pfold. red. pinversion H0; subst; auto. 95 | - cbn. auto with itree. 96 | - cbn. apply EqTauL; auto. 97 | genobs t1 ot1. genobs (go (@RetF E A _ a)) ot2. clear H1. 98 | generalize dependent t1. generalize dependent t. 99 | induction REL; intros; subst; auto; try discriminate. 100 | + constructor. inversion Heqot2. auto. 101 | + constructor; auto. eapply IHREL; eauto. 102 | Qed. 103 | 104 | Lemma unfold_spin : forall (E : Type -> Type) (A : Type), (@spin E A) ≅ Tau spin. 105 | Proof. 106 | intros. pcofix CIH. cbn. pfold. red. cbn. apply EqTau. cbn. 107 | left. pcofix CIH'. pfold. red. cbn. auto with itree. 108 | Qed. 109 | 110 | Lemma burn_eutt_r : forall (A : Type) (t t' : itree void1 A) (n : nat), t≈ t' -> burn n t ≈ t'. 111 | Proof. 112 | intros. generalize dependent t. generalize dependent t'. induction n; intros; simpl; auto. 113 | destruct (observe t) eqn : Heq; try destruct e. 114 | - specialize (itree_eta t) as Ht. rewrite Heq in Ht. rewrite <- Ht. auto. 115 | - apply IHn. specialize (itree_eta t) as Ht. rewrite Heq in Ht. rewrite Ht in H. 116 | rewrite tau_eutt in H. auto. 117 | Qed. 118 | -------------------------------------------------------------------------------- /secure_example/LabelledImpHandler.v: -------------------------------------------------------------------------------- 1 | From ITree Require Import 2 | ITree 3 | ITreeFacts 4 | Events.State 5 | Events.StateFacts 6 | Events.Exception 7 | . 8 | 9 | From SecureExample Require Import 10 | LabelledImp 11 | Lattice 12 | . 13 | 14 | Import Monads. 15 | Import MonadNotation. 16 | Local Open Scope monad_scope. 17 | 18 | Section LabelledImpHandler. 19 | 20 | Context (Labels : Lattice). 21 | 22 | Definition priv_io (A : Type) (e : IOE Labels A) := 23 | match e with 24 | | LabelledPrint _ s _ => s end. 25 | 26 | 27 | Definition priv_exc (A : Type) (e : impExcE Labels A ) := 28 | match e with 29 | | Throw s => s end. 30 | 31 | Definition priv_exc_io := case_ priv_exc priv_io. 32 | 33 | Definition product_rel {R1 R2 S1 S2} (RR1: R1 -> S1 -> Prop) (RR2 : R2 -> S2 -> Prop) 34 | (p1 : R1 * R2) (p2 : S1 * S2) : Prop := 35 | RR1 (fst p1) (fst p2) /\ RR2 (snd p1) (snd p2). 36 | 37 | Definition handle_case {E1 E2 : Type -> Type} {M : Type -> Type} (hl : E1 ~> M) (hr : E2 ~> M) : (E1 +' E2) ~> M := 38 | fun _ e => match e with 39 | | inl1 el => hl _ el 40 | | inr1 er => hr _ er end. 41 | 42 | Definition handle_state_io : forall A, (stateE +' (IOE Labels)) A -> 43 | stateT map (itree ((impExcE Labels) +' (IOE Labels))) A := 44 | fun _ e => match e with 45 | | inl1 el => handleState _ el 46 | | inr1 er => fun s => r <- ITree.trigger (inr1 er);; Ret (s, r) end. 47 | 48 | Definition handle_imp : forall A, ((impExcE Labels) +' stateE +' (IOE Labels)) A -> 49 | stateT map (itree ((impExcE Labels) +' (IOE Labels)) ) A := 50 | fun _ e => match e with 51 | | inl1 el => fun s => r <- ITree.trigger (inl1 el);; Ret (s, r) 52 | | inr1 er => handle_state_io _ er end. 53 | 54 | Definition interp_imp {R} (t : itree ((impExcE Labels) +' stateE +' (IOE Labels)) R ) : stateT map (itree ((impExcE Labels) +' (IOE Labels))) R := 55 | interp_state handle_imp t. 56 | 57 | Hint Unfold interp_imp : core. 58 | Hint Unfold handle_state_io : core. 59 | Hint Unfold handle_imp : core. 60 | Hint Unfold product_rel : core. 61 | (* 62 | Ltac use_simpobs := 63 | repeat match goal with 64 | | H : TauF _ = observe ?t |- _ => apply simpobs in H 65 | | H : RetF _ = observe ?t |- _ => apply simpobs in H 66 | | H : VisF _ _ = observe ?t |- _ => apply simpobs in H 67 | end. 68 | 69 | Ltac destruct_imp_ev := repeat match goal with 70 | | e : (?E1 +' ?E2) ?A |- _ => destruct e 71 | | exc : impExcE ?A |- _ => destruct exc 72 | | st : stateE ?A |- _ => destruct st 73 | | io : IOE ?A |- _ => destruct io 74 | end. 75 | 76 | (* TODO : replace with labelled equiv *) 77 | Lemma interp_eqit_secure_imp : forall (R1 R2 : Type) (RR : R1 -> R2 -> Prop) (priv_map : privacy_map) 78 | (t1 : itree (impExcE +' stateE +' IOE) R1 ) 79 | (t2 : itree (impExcE +' stateE +' IOE) R2), 80 | eqit_secure sense_preorder (priv_imp priv_map) RR true true Public t1 t2 -> 81 | low_eqit_secure_impstate true true priv_map RR (interp_imp t1 ) (interp_imp t2). 82 | Proof. 83 | red. intros. 84 | eapply interp_eqit_secure_state; eauto. 85 | - constructor; red; intros; cbv; intros; auto. red in H1. rewrite H1; auto. 86 | rewrite H1; auto. 87 | - intros. destruct_imp_ev. 88 | + destruct s. 89 | * eapply respect_public'. cbv. auto. red. intros. cbn. 90 | setoid_rewrite bind_trigger. apply eqit_secure_public_Vis. cbv. auto. 91 | intros []. 92 | * eapply respect_private_e. cbv. auto. constructor. intros []. 93 | intros. setoid_rewrite bind_trigger. pfold. constructor. intros []. 94 | cbv. auto. 95 | + destruct (priv_map x) eqn : Hl. 96 | * apply respect_public'. cbv. rewrite Hl. auto. 97 | red. intros. cbn. apply secure_eqit_ret. split; auto. cbv. rewrite H1; auto. 98 | * apply respect_private_ne. cbv. rewrite Hl. auto. 99 | constructor. exact 0. intros. cbn. apply terminates_ret. red. intros. auto. 100 | + destruct (priv_map x) eqn : Hl. 101 | * apply respect_public'. cbv. rewrite Hl. auto. 102 | red. intros. cbn. apply secure_eqit_ret. split; auto. 103 | cbn. apply low_equiv_update_public; auto. 104 | * apply respect_private_ne. cbv. rewrite Hl. auto. 105 | constructor. exact tt. intros. cbn. apply terminates_ret. 106 | apply low_equiv_update_private_r; auto. red; intros; auto. 107 | + destruct s. 108 | * eapply respect_public'. cbv. auto. red. intros. cbn. 109 | setoid_rewrite bind_trigger. apply eqit_secure_public_Vis. cbv. auto. 110 | intros []. apply secure_eqit_ret. split; auto. 111 | * eapply respect_private_ne. cbv. auto. constructor. exact tt. 112 | intros. cbn. setoid_rewrite bind_trigger. apply terminates_vis. 113 | intros []. apply terminates_ret. red; intros; auto. 114 | cbn. split; auto. constructor. exact tt. 115 | Qed. 116 | *) 117 | End LabelledImpHandler. 118 | -------------------------------------------------------------------------------- /examples/Nimp.v: -------------------------------------------------------------------------------- 1 | (* A nondeterministic Imp *) 2 | 3 | From Coq Require Import 4 | Relations. 5 | 6 | From ITree Require Import 7 | ITree 8 | ITreeFacts. 9 | 10 | Import ITreeNotations. 11 | 12 | Inductive com : Type := 13 | | loop : com -> com (* Nondeterministically, continue or stop. *) 14 | | choose : com -> com -> com 15 | | skip : com 16 | | seq : com -> com -> com 17 | . 18 | 19 | Declare Scope com_scope. 20 | Infix ";;" := seq (at level 61, right associativity) : com_scope. 21 | Delimit Scope com_scope with com. 22 | Open Scope com_scope. 23 | 24 | Example one_loop : com := loop skip. 25 | Example two_loops : com := loop (loop skip). 26 | Example loop_choose : com := loop (choose skip skip). 27 | Example choose_loop : com := choose (loop skip) skip. 28 | 29 | (* Unlabeled small-step *) 30 | Module Unlabeled. 31 | 32 | Reserved Infix "-->" (at level 80, no associativity). 33 | 34 | Inductive step : relation com := 35 | | step_loop_stop c : 36 | loop c --> skip 37 | | step_loop_go c : 38 | loop c --> (c ;; loop c) 39 | | step_choose_l c1 c2 : 40 | choose c1 c2 --> c1 41 | | step_choose_r c1 c2 : 42 | choose c1 c2 --> c2 43 | | step_seq_go c1 c1' c2 : 44 | c1 --> c2 -> 45 | (c1 ;; c2) --> (c1' ;; c2) 46 | | step_seq_next c2 : 47 | (skip ;; c2) --> c2 48 | 49 | where "x --> y" := (step x y). 50 | 51 | CoInductive infinite_steps (c : com) : Type := 52 | | more c' : step c c' -> infinite_steps c' -> infinite_steps c. 53 | 54 | Lemma infinite_simple_loop : infinite_steps one_loop. 55 | Proof. 56 | cofix self. 57 | eapply more. 58 | { eapply step_loop_go. } 59 | eapply more. 60 | { eapply step_seq_next. } 61 | apply self. 62 | Qed. 63 | 64 | End Unlabeled. 65 | 66 | Module Labeled. 67 | 68 | Reserved Notation "s --> t" (at level 80, no associativity). 69 | Reserved Notation "s ! b --> t" (at level 80, b at next level, no associativity). 70 | Reserved Notation "s ? b --> t" (at level 80, b at next level, no associativity). 71 | 72 | Variant label := tau | bit (b : bool). 73 | 74 | Inductive step : label -> relation com := 75 | | step_loop_stop c : 76 | loop c ! true --> skip 77 | | step_loop_go c : 78 | loop c ! false --> (c ;; loop c) 79 | | step_choose_l c1 c2 : 80 | choose c1 c2 ! true --> c1 81 | | step_choose_r c1 c2 : 82 | choose c1 c2 ! false --> c2 83 | | step_seq_go b c1 c1' c2 : 84 | c1 ? b --> c2 -> 85 | (c1 ;; c2) ? b --> (c1' ;; c2) 86 | | step_seq_next c2 : 87 | (skip ;; c2) --> c2 88 | 89 | where "x --> y" := (step tau x y) 90 | and "x ! b --> y" := (step (bit b) x y) 91 | and "x ? b --> y" := (step b x y). 92 | 93 | CoInductive infinite_steps (c : com) : Type := 94 | | more b c' : step b c c' -> infinite_steps c' -> infinite_steps c. 95 | 96 | Lemma infinite_simple_loop : infinite_steps one_loop. 97 | Proof. 98 | cofix self. 99 | eapply more. 100 | { eapply step_loop_go. } 101 | eapply more. 102 | { eapply step_seq_next. } 103 | apply self. 104 | Qed. 105 | 106 | End Labeled. 107 | 108 | From Paco Require Import paco. 109 | 110 | Module Tree. 111 | 112 | Variant nd : Type -> Prop := 113 | | Or : nd bool. 114 | 115 | Definition or {R : Type} (t1 t2 : itree nd R) : itree nd R := 116 | Vis Or (fun b : bool => if b then t1 else t2). 117 | 118 | (* Flip a coin *) 119 | Definition choice {E} `{nd -< E} : itree E bool := trigger Or. 120 | 121 | Definition eval_def : com -> itree (callE _ _ +' nd) unit := (fun (c : com) => 122 | match c with 123 | | loop c => 124 | (b <- choice;; 125 | if b : bool 126 | then Ret tt 127 | else (trigger (Call c);; trigger (Call (loop c))))%itree 128 | | choose c1 c2 => 129 | (b <- choice;; 130 | if b : bool 131 | then trigger (Call c1) 132 | else trigger (Call c2))%itree 133 | | (t1 ;; t2)%com => (trigger (Call t1);; trigger (Call t2))%itree 134 | | skip => Ret tt 135 | end 136 | ). 137 | Definition eval : com -> itree nd unit := rec eval_def. 138 | 139 | (* [itree] semantics of [one_loop]. *) 140 | Definition one_loop_tree : itree nd unit := 141 | rec (fun _ : unit => 142 | (* note: [or] is not allowed under [mfix]. *) 143 | b <- choice;; 144 | if b : bool then 145 | Ret tt 146 | else 147 | trigger (Call tt))%itree tt. 148 | 149 | Import Coq.Classes.Morphisms. 150 | 151 | Lemma eval_skip: rec eval_def skip ≈ Ret tt. 152 | Proof. 153 | rewrite rec_as_interp. cbn. rewrite interp_ret. reflexivity. 154 | Qed. 155 | 156 | (* SAZ: the [~] notation for eutt wasn't working here. *) 157 | Lemma eval_one_loop : eval one_loop ≈ one_loop_tree. 158 | Proof. 159 | einit. ecofix CIH. edrop. 160 | setoid_rewrite rec_as_interp. 161 | setoid_rewrite interp_bind. 162 | setoid_rewrite interp_vis. 163 | setoid_rewrite tau_eutt. 164 | setoid_rewrite interp_ret. 165 | setoid_rewrite bind_bind. 166 | setoid_rewrite bind_ret_l. 167 | setoid_rewrite bind_vis. 168 | evis. intros. 169 | setoid_rewrite bind_ret_l. 170 | destruct v. 171 | - setoid_rewrite interp_ret. apply reflexivity. 172 | - setoid_rewrite interp_bind. 173 | setoid_rewrite interp_recursive_call. 174 | setoid_rewrite eval_skip. 175 | setoid_rewrite bind_ret_l. 176 | eauto with paco. 177 | Qed. 178 | 179 | End Tree. 180 | -------------------------------------------------------------------------------- /theories/Interp/Recursion.v: -------------------------------------------------------------------------------- 1 | (* begin hide *) 2 | From ITree Require Import 3 | Basics.Basics 4 | Basics.Category 5 | Core.ITreeDefinition 6 | Indexed.Sum. 7 | 8 | Import ITreeNotations. 9 | #[local] Open Scope itree_scope. 10 | (* end hide *) 11 | 12 | (** * General recursion *) 13 | 14 | (** *** Mutual recursion *) 15 | 16 | (* Implementation of the fixpoint combinator over interaction 17 | * trees. 18 | * 19 | * The implementation is based on the discussion here 20 | * https://gmalecha.github.io/reflections/2018/compositional-coinductive-recursion-in-coq 21 | *) 22 | 23 | (* The indexed type [D : Type -> Type] gives the signature of 24 | a set of functions. For example, a pair of mutually recursive 25 | [even : nat -> bool] and [odd : nat -> bool] can be declared 26 | as follows: 27 | 28 | [[ 29 | Inductive D : Type -> Type := 30 | | Even : nat -> D bool 31 | | Odd : nat -> D bool. 32 | ]] 33 | 34 | Their mutually recursive definition can then be written finitely 35 | (without [Fixpoint]): 36 | 37 | [[ 38 | Definition def : D ~> itree (D +' void1) := fun _ d => 39 | match d with 40 | | Even n => match n with 41 | | O => ret true 42 | | S m => trigger (Odd m) 43 | end 44 | | Odd n => match n with 45 | | O => ret false 46 | | S m => trigger (Even m) 47 | end 48 | end. 49 | ]] 50 | 51 | The function [interp_mrec] below then ties the knot. 52 | 53 | [[ 54 | Definition f : D ~> itree void1 := 55 | interp_mrec def. 56 | 57 | Definition even (n : nat) : itree void1 bool := f _ (Even n). 58 | Definition odd (n : nat) : itree void1 bool := f _ (Odd n). 59 | ]] 60 | 61 | The result is still in the [itree] monad of possibly divergent 62 | computations, because [mutfix_itree] doesn't care whether 63 | the mutually recursive definition is well-founded. 64 | 65 | *) 66 | 67 | (** Interpret an itree in the context of a mutually recursive 68 | definition ([ctx]). *) 69 | Definition interp_mrec {D E : Type -> Type} 70 | (ctx : D ~> itree (D +' E)) : itree (D +' E) ~> itree E := 71 | fun R => 72 | ITree.iter (fun t : itree (D +' E) R => 73 | match observe t with 74 | | RetF r => Ret (inr r) 75 | | TauF t => Ret (inl t) 76 | | VisF (inl1 d) k => Ret (inl (ctx _ d >>= k)) 77 | | VisF (inr1 e) k => Vis e (fun x => Ret (inl (k x))) 78 | end). 79 | 80 | Arguments interp_mrec {D E} & ctx [T]. 81 | 82 | (** Unfold a mutually recursive definition into separate trees, 83 | resolving the mutual references. *) 84 | Definition mrec {D E : Type -> Type} 85 | (ctx : D ~> itree (D +' E)) : D ~> itree E := 86 | fun R d => interp_mrec ctx (ctx _ d). 87 | 88 | Arguments mrec {D E} & ctx [T]. 89 | 90 | (** Make a recursive call in the handler argument of [mrec]. *) 91 | Definition trigger_inl1 {D E : Type -> Type} : D ~> itree (D +' E) 92 | := fun _ d => ITree.trigger (inl1 d). 93 | 94 | Arguments trigger_inl1 {D E} [T]. 95 | 96 | (** Here's some syntactic sugar with a notation [mrec-fix]. *) 97 | 98 | (** Short for endofunctions, used in [mrec_fix] and [rec_fix]. *) 99 | Local Notation endo T := (T -> T). 100 | 101 | Definition mrec_fix {D E : Type -> Type} 102 | (ctx : endo (D ~> itree (D +' E))) 103 | : D ~> itree E 104 | := mrec (ctx trigger_inl1). 105 | 106 | Arguments mrec_fix {D E} &. 107 | 108 | Notation "'mrec-fix' f d := g" := 109 | (let D := _ in 110 | mrec_fix (D := D) (fun (f : forall T, D T -> _) T (d : D T) => g)) 111 | (at level 200, f name, d pattern). 112 | (* No idea what a good level would be. *) 113 | 114 | (** *** Simple recursion *) 115 | 116 | Inductive callE (A B : Type) : Type -> Type := 117 | | Call : A -> callE A B B. 118 | 119 | Arguments Call {A B}. 120 | 121 | (** Get the [A] contained in a [callE A B]. *) 122 | Definition unCall {A B T} (e : callE A B T) : A := 123 | match e with 124 | | Call a => a 125 | end. 126 | 127 | (** Lift a function on [A] to a morphism on [callE]. *) 128 | Definition calling {A B} {F : Type -> Type} 129 | (f : A -> F B) : callE A B ~> F := 130 | fun _ e => 131 | match e with 132 | | Call a => f a 133 | end. 134 | 135 | (* TODO: This is identical to [callWith] but [rec] finds a universe 136 | inconsistency with [calling], and not with [calling']. 137 | The inconsistency now pops up later (currently in [Events.Env]) *) 138 | Definition calling' {A B} {F : Type -> Type} 139 | (f : A -> itree F B) : callE A B ~> itree F := 140 | fun _ e => 141 | match e with 142 | | Call a => f a 143 | end. 144 | 145 | (* Interpret a single recursive definition. *) 146 | Definition rec {E : Type -> Type} {A B : Type} 147 | (body : A -> itree (callE A B +' E) B) : 148 | A -> itree E B := 149 | fun a => mrec (calling' body) (Call a). 150 | 151 | Arguments rec {E A B} &. 152 | 153 | (** An easy way to construct an event suitable for use with [rec]. 154 | [call] is an event representing the recursive call. Since in general, the 155 | function might have other events of type [E], the resulting itree has 156 | type [(callE A B +' E)]. 157 | *) 158 | Definition call {E A B} (a:A) : itree (callE A B +' E) B := ITree.trigger (inl1 (Call a)). 159 | 160 | (** Here's some syntactic sugar with a notation [mrec-fix]. *) 161 | 162 | Definition rec_fix {E : Type -> Type} {A B : Type} 163 | (body : endo (A -> itree (callE A B +' E) B)) 164 | : A -> itree E B 165 | := rec (body call). 166 | 167 | Arguments rec_fix {E A B} &. 168 | 169 | Notation "'rec-fix' f a := g" := (rec_fix (fun f a => g)) 170 | (at level 200, f name, a pattern). 171 | (* No idea what a good level would be. *) 172 | -------------------------------------------------------------------------------- /extra/Dijkstra/IterRel.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Arith Lia. 2 | From Paco Require Import paco. 3 | 4 | From ITree Require Import Axioms. 5 | 6 | Create HintDb not_wf. 7 | 8 | Set Implicit Arguments. 9 | 10 | (* Contains well founded from and not well founded from predicate definitions and reasoning principles *) 11 | Section IterRel. 12 | 13 | Context (A : Type). 14 | Context (r : A -> A -> Prop). 15 | 16 | Variant not_wf_F (F : A -> Prop) (a : A) : Prop := 17 | | not_wf (a' : A) (Hrel : r a a') (Hcorec : F a') . 18 | Hint Constructors not_wf_F : not_wf. 19 | 20 | Lemma not_wf_F_mono sim sim' a 21 | (IN : not_wf_F sim a) 22 | (LE : sim <1= sim') : not_wf_F sim' a. 23 | Proof. 24 | destruct IN. eauto with not_wf. 25 | Qed. 26 | 27 | Lemma not_wf_F_mono' : monotone1 not_wf_F. 28 | Proof. 29 | red. intros. eapply not_wf_F_mono; eauto. 30 | Qed. 31 | Hint Resolve not_wf_F_mono' : paco. 32 | 33 | Definition not_wf_from : A -> Prop := 34 | paco1 not_wf_F bot1. 35 | 36 | Inductive wf_from (a : A) : Prop := 37 | | base : (forall a', ~ (r a a')) -> wf_from a 38 | | step : (forall a', r a a' -> wf_from a') -> wf_from a 39 | . 40 | Hint Constructors wf_from : not_wf. 41 | Lemma neg_wf_from_not_wf_from_l : forall (a : A), 42 | ~(wf_from a) -> not_wf_from a. 43 | Proof. 44 | pcofix CIH. intros. pfold. destruct (classic (exists a', r a a' /\ ~ ( wf_from a') )). 45 | - destruct H as [a' [Hr Hwf] ]. econstructor; eauto. 46 | - assert (forall a', ~ r a a' \/ wf_from a'). 47 | { 48 | intros. 49 | destruct (classic (r a a')); auto. destruct (classic (wf_from a')); auto. 50 | exfalso. apply H. exists a'. auto. 51 | } 52 | clear H. 53 | exfalso. apply H0. clear H0. apply step. intros. destruct (H1 a'); auto with not_wf. 54 | Qed. 55 | 56 | Lemma neg_wf_from_not_wf_from_r : forall (a : A), 57 | not_wf_from a -> ~ (wf_from a). 58 | Proof. 59 | intros. intro Hcontra. punfold H. inversion H. pclearbot. clear H. generalize dependent a'. 60 | induction Hcontra; intros. 61 | - apply H in Hrel. auto. 62 | - punfold Hcorec. inversion Hcorec. pclearbot. specialize (H0 a' Hrel a'0 Hrel0). 63 | auto. 64 | Qed. 65 | 66 | Lemma neg_wf_from_not_wf_from : forall (a : A), 67 | not_wf_from a <-> ~(wf_from a). 68 | Proof. 69 | split; try apply neg_wf_from_not_wf_from_r; try apply neg_wf_from_not_wf_from_l. 70 | Qed. 71 | 72 | Lemma classic_wf : forall (a : A), wf_from a \/ not_wf_from a. 73 | Proof. 74 | intros. destruct (classic (wf_from a)); auto. 75 | apply neg_wf_from_not_wf_from in H. auto. 76 | Qed. 77 | 78 | Lemma intro_not_wf : forall (P : A -> Prop) (f : A -> A) (a : A), 79 | P a -> (forall a1 a2, P a1 -> r a1 a2 -> P a2 ) -> (forall a, P a -> r a (f a)) -> 80 | not_wf_from a. 81 | Proof. 82 | intros. generalize dependent a. pcofix CIH. intros. pfold. 83 | apply not_wf with (a' := f a). 84 | - auto using H1. 85 | - right. apply CIH. eapply H0; eauto. 86 | Qed. 87 | 88 | Lemma intro_wf : forall (P : A-> Prop) (m : A -> nat) (a : A), 89 | P a -> (forall a1 a2, P a1 -> r a1 a2 -> P a2 ) -> 90 | (forall a1 a2, P a1 -> r a1 a2 -> m a2 < m a1) -> wf_from a. 91 | Proof. 92 | intros P m a. remember (m a) as ma eqn:Hma. revert a Hma. 93 | induction ma using lt_wf_ind; intros a -> H0 HS Hlt. 94 | apply step; eauto. 95 | Qed. 96 | 97 | End IterRel. 98 | 99 | Definition rel_rev {A : Type} (r : A -> A -> Prop) : A -> A -> Prop := fun a0 a1 => r a1 a0. 100 | 101 | (*note that my notion of well_founded is sort of reverse of theres*) 102 | Lemma well_found_wf_from : forall (A : Type) (r : A -> A -> Prop), 103 | well_founded (rel_rev r) -> forall a, wf_from r a. 104 | Proof. 105 | intros A r Hwf a. unfold well_founded in Hwf. 106 | unfold rel_rev in *. induction (Hwf a). apply step. intros. 107 | apply H0 in H1. auto. 108 | Qed. 109 | 110 | (*Less than is well founded*) 111 | 112 | (*my well founded should be closed under subrelation*) 113 | 114 | Lemma wf_from_sub_rel : forall (A : Type) (r0 r1 : A -> A -> Prop) (a : A), 115 | subrelation r0 r1 -> wf_from r1 a -> wf_from r0 a. 116 | Proof. 117 | intros. induction H0. 118 | - apply base. intros a' Hcontra. apply H in Hcontra. eapply H0; eauto. 119 | - apply step. intros a' Hr0aa'. apply H in Hr0aa'. auto. 120 | Qed. 121 | 122 | Lemma wf_from_gt : forall (n : nat), wf_from (fun n0 n1 => n0 > n1) n. 123 | Proof. 124 | intros. 125 | enough (forall n', n' <= n -> wf_from (fun n0 n1 => n0 > n1) n' ); auto. 126 | induction n; intros. 127 | - assert (n' = 0); try lia. subst. apply base. intros. lia. 128 | - apply step. intros n'' Hn''. assert (n'' <= n); try lia. auto. 129 | Qed. 130 | (*induct on f a*) 131 | Lemma no_inf_dec_seq_aux : forall (r : nat -> nat -> Prop) (n: nat), 132 | (forall n1 n2, r n1 n2 -> n1 > n2) -> 133 | wf_from r n. 134 | Proof. 135 | intros. eapply wf_from_sub_rel; try apply wf_from_gt. 136 | repeat intro. auto. 137 | Qed. 138 | 139 | (*Possibly uses some kind of transitivity in > that is missing in my more general proofs, 140 | a more general proof would be nice but I think the nat captures most of what people want*) 141 | Lemma wf_intro_gt : forall (A : Type) (r : A -> A -> Prop) (f : A -> nat) (P : A -> Prop) (a : A), 142 | (forall a1 a2, P a1 -> r a1 a2 -> P a2) -> 143 | (forall a1 a2, P a1 -> r a1 a2 -> f a1 > f a2) -> 144 | P a -> wf_from r a. 145 | Proof. 146 | intros A r f inv a Hinv Hgt Ha. 147 | remember (f a) as n0. 148 | generalize dependent a. 149 | enough (forall a, f a <= n0 -> inv a -> wf_from r a). 150 | { 151 | intros. apply H. lia. auto. 152 | } 153 | induction n0; intros. 154 | - apply base. assert (f a = 0); try lia. 155 | intros a' Hcontra. 156 | specialize (Hgt a a' H0 Hcontra). lia. 157 | - apply step. intros a' Ha'. 158 | apply IHn0; eauto. 159 | assert (f a > f a'); eauto. lia. 160 | Qed. 161 | -------------------------------------------------------------------------------- /DEV.md: -------------------------------------------------------------------------------- 1 | # Notes for developers 2 | 3 | ## Build 4 | 5 | This project is built using the `dune` build system. 6 | There is also a build using `make`, mainly for legacy reasons, 7 | and also to generate documentation. 8 | 9 | Install dependencies with `opam`. 10 | 11 | ``` 12 | opam install coq-paco coq-ext-lib dune 13 | ``` 14 | 15 | Then `dune build` will compile everything: library, tutorial (toy compiler from 16 | Imp to Asm), and tests. 17 | 18 | ``` 19 | dune build 20 | ``` 21 | 22 | To be able to edit Coq files interactively, copy the `_CoqProject` file: 23 | 24 | ``` 25 | cp _CoqProject.dune _CoqProject 26 | ``` 27 | 28 | (`_CoqProject` is not included by default because it can also be generated by 29 | the `make` build. Clean the project when switching between `make` and 30 | `dune` builds.) 31 | 32 | Other build targets (note all of them will build `theories` as a dependency): 33 | 34 | ``` 35 | dune build theories 36 | dune build tutorial 37 | dune build tests 38 | dune build examples 39 | ``` 40 | 41 | Run tests (a bunch of extracted examples): 42 | 43 | ``` 44 | dune runtest 45 | ``` 46 | 47 | ### Build with make 48 | 49 | This uses the same dependencies, minus `dune`. 50 | 51 | ``` 52 | opam install coq-paco coq-ext-lib 53 | ``` 54 | 55 | Build everything with `make all`. 56 | 57 | ``` 58 | make all -j # Build the library, tutorial (example compiler), and tests. 59 | ``` 60 | 61 | Other targets: 62 | 63 | ``` 64 | make # Build the library 65 | make tutorial 66 | make tests 67 | ``` 68 | 69 | The above commands run any extracted test executables too. 70 | 71 | ### Build the Documentation 72 | 73 | #### 1. Basic Documention 74 | 75 | Build the `coqdoc` generated html files by doing: 76 | 77 | ``` 78 | make html 79 | ``` 80 | 81 | Then visit `html/toc.html` in your web browser. 82 | 83 | #### 2. Prettier Documentation 84 | 85 | [coqdocjs](https://github.com/coq-community/coqdocjs) adds some modern-looking 86 | CSS and JS to coqdoc's output. 87 | 88 | 1. Download and unzip 89 | [coqdocjs-master.zip](https://github.com/coq-community/coqdocjs/archive/master.zip). 90 | 91 | 2. Create a link to the unzipped directory (or move the directory into this repo): 92 | 93 | ``` 94 | ln -s path/to/coqdocjs-master coqdocjs 95 | ``` 96 | 97 | 2. Run 98 | 99 | ``` 100 | make html 101 | ``` 102 | 103 | #### 3. Updating Github pages 104 | 105 | The documentation is stored in the `gh-pages` branch. 106 | The recommended setup is to create a fresh clone in the `doc` directory. 107 | 108 | ``` 109 | git clone -b gh-pages git@github.com:DeepSpec/InteractionTrees doc 110 | ``` 111 | 112 | There is a script in that branch to update the documentation. 113 | 114 | ``` 115 | cd doc 116 | sh ./update.sh 117 | git add -u 118 | git commit -m "Update" 119 | ``` 120 | 121 | It will run "make html" in the parent directory and move the output where it 122 | should go, in `doc/docs/master`. 123 | Past releases are maintained in `doc/docs/$VERSION`. 124 | 125 | ## Library internal organization 126 | 127 | We keep most theorems separated into `*Facts` modules, to allow 128 | parallel compilation and to contain potential universe 129 | inconsistencies, so the computational definitions may still be usable 130 | for testing. 131 | 132 | - `Basics`: General-purpose definitions not tied to interaction trees. 133 | 134 | + `Basics`: The `~>` notation and names of common monad transformers. 135 | + `Category`: A simple theory of categories, monoidal and iterative. 136 | 137 | * `CategoryOps`: Interfaces of operations to define categories. 138 | * `CategoryTheory`: Properties of categories. 139 | * `CategoryFacts`: General facts about categories. 140 | * `CategoryFunctor`: Classes of functors. 141 | * `CategorySub`: Definition of sub-categories. 142 | * `CategoryKleisli`: Kleisli categories (for monads in the category of functions). 143 | * `CategoryKleisliFacts` 144 | 145 | + `Function`: The category of Coq functions `A -> B`. 146 | + `FunctionFacts` 147 | 148 | + `Monad`: Properties of monads (in the category of functions). 149 | + `MonadState`: The state monad transformer. 150 | + `MonadProp`: The nondeterminism monad. 151 | 152 | - `Core`: Main definitions for interaction trees. 153 | 154 | + `ITreeDefinition`: Interaction trees, type declaration and primitives. 155 | + `KTree`: Continuation trees `A -> itree E B`, the first Kleisli category 156 | of `itree`. 157 | + `KTreeFacts` 158 | + `Subevent`: Combinators for extensible effects, injecting events into 159 | sums. 160 | + `ITreeMonad`: Instantiation of the `Basics.Monad` interface with 161 | `itree`. 162 | 163 | - `Eq`: Equational theory of interaction trees. 164 | 165 | + `Shallow`: One-step unfolding of cofixpoints. 166 | + `Eq`: Strong bisimulation. 167 | + `UpToTaus`: Weak bisimulation. 168 | + `SimUpToTaus`: Weak simulation. 169 | + `EqAxiom`: Axiom that strong bisimulation is propositional equality. 170 | The library exports that axiom but does not itself make use of it. 171 | 172 | - `Indexed`: Indexed types `Type -> Type`. 173 | 174 | + `Sum`: Sum of indexed types. 175 | + `Function`: The category of parametric functions between indexed types, 176 | i.e., event morphisms `E ~> F`. 177 | + `FunctionFacts` 178 | + `Relation`: Relations on indexed types, i.e., 179 | `forall T, E T -> E T -> Prop`. 180 | 181 | - `Interp`: Interaction tree transformations. 182 | 183 | + `Interp`: Interpret itrees (`translate`, `interp`). 184 | + `TranslateFacts`, `InterpFacts` 185 | + `Handlers`: Event handlers `E ~> itree F`, the second Kleisli category 186 | of `itree`. 187 | + `HandlerFacts` 188 | + `Recursion`: Recursion combinators (`mrec`, `rec`). 189 | + `RecursionFacts` 190 | + `Traces`: Interpretation of itrees as sets of traces. 191 | 192 | - `Events`: Common event types (see [`theories/Events.v`](./theories/Events.v) for a summary). 193 | -------------------------------------------------------------------------------- /theories/Basics/MonadProp.v: -------------------------------------------------------------------------------- 1 | (* begin hide *) 2 | From Coq Require Import 3 | Ensembles 4 | Setoid 5 | Morphisms. 6 | 7 | From ExtLib Require Import 8 | Structures.Monad. 9 | 10 | From ITree Require Import 11 | Basics.Basics 12 | Basics.Category 13 | Basics.CategoryKleisli 14 | Basics.Monad. 15 | 16 | Import ITree.Basics.Basics.Monads. 17 | Import CatNotations. 18 | Local Open Scope cat_scope. 19 | Local Open Scope cat. 20 | 21 | Section prop. 22 | Global Instance Monad_Prop : Monad Ensemble := 23 | {| 24 | ret := fun _ x y => x = y; 25 | bind := fun _ _ Pa K b => exists a, In _ Pa a /\ In _ (K a) b 26 | |}. 27 | 28 | Global Instance Eq1_Prop : Eq1 Ensemble := Same_set. 29 | 30 | Global Instance Eq1Equivalence_Prop : Eq1Equivalence Ensemble. 31 | Proof. 32 | constructor. 33 | - split; repeat intro; auto. 34 | - repeat intro. destruct H. split; auto. 35 | - repeat intro. destruct H, H0. split; repeat intro; auto. 36 | Qed. 37 | 38 | Instance MonadLawsE_Prop : MonadLawsE Ensemble. 39 | Proof. 40 | constructor. 41 | - split; repeat intro; simpl in *. 42 | + destruct H as (? & ? & ?). red in H. subst; auto. 43 | + eexists; split; eauto. reflexivity. 44 | - split. repeat intro; simpl in *. 45 | + destruct H as (? & ? & ?). red in H0; subst; auto. 46 | + red. repeat intro. eexists; split; eauto. reflexivity. 47 | - intros; split; repeat intro; simpl in *; 48 | [destruct H as (? & (? & ? & ?) & ?) | destruct H as (? & ? & (? & ? & ?))]; 49 | do 2 (eexists; split; eauto). 50 | - repeat intro; auto. destruct H. 51 | split; simpl; repeat red; intros; 52 | destruct H2 as (? & ? & ?); eexists; split; eauto; apply H0; auto. 53 | Qed. 54 | 55 | Global Instance Proper_Iter_stateTM : forall a b, 56 | @Proper (Kleisli Ensemble a (a + b) -> (Kleisli Ensemble a b)) (eq2 ==> eq2) iter. 57 | Proof. 58 | repeat red; split; repeat intro; 59 | (induction H0; [constructor 1 | econstructor 2; eauto]; apply H; auto). 60 | Qed. 61 | 62 | Global Instance IterUnfold_Prop : IterUnfold (Kleisli Ensemble) sum. 63 | Proof. 64 | repeat red; split; repeat intro. 65 | - repeat red in H |- *. destruct H. 66 | + exists (inr x). split; repeat red; auto. 67 | + eexists; split; eauto. 68 | - repeat red in H |- *. decompose [ex and] H; clear H. destruct x0. 69 | + econstructor 2; eauto. 70 | + constructor 1. repeat red in H2. subst; auto. 71 | Qed. 72 | 73 | Global Instance IterNatural_Prop : IterNatural (Kleisli Ensemble) sum. 74 | Proof. 75 | repeat red; split; repeat intro. 76 | - repeat red in H |- *. decompose [ex and] H; clear H. induction H1. 77 | + constructor 1. eexists; split; eauto. eexists; split; eauto. reflexivity. 78 | + econstructor 2; repeat red; eauto. 79 | eexists; split; eauto. eexists; split; reflexivity. 80 | - repeat red in H |- *. 81 | induction H; repeat red in H; decompose [ex and] H; clear H. 82 | + destruct x; destruct H2 as (? & ? & H'); inversion H'; subst. 83 | eexists; split; eauto. constructor 1. auto. 84 | + destruct x; destruct H3 as (? & ? & H'); inversion H'; clear H'; subst. 85 | decompose [ex and] IHiter_Prop; clear IHiter_Prop. 86 | inversion H; clear H; subst. 87 | eexists; split; eauto. econstructor 2; eauto. 88 | Qed. 89 | 90 | Global Instance IterDinatural_Prop : IterDinatural (Kleisli Ensemble) sum. 91 | Proof. 92 | repeat red; split; repeat intro. 93 | - induction H; destruct H as (? & ? & ?). 94 | + destruct x; repeat red in H0. 95 | * eexists; split; eauto. constructor; auto. eexists; split; eauto. reflexivity. 96 | * inversion H0; subst. eexists; split; eauto. constructor; auto. 97 | + destruct x; repeat red in H1; try inversion H1. 98 | destruct IHiter_Prop as (? & ? & ?). destruct x; eexists; split; eauto. 99 | * econstructor 2; eauto. eexists; split; eauto. 100 | * repeat red in H3. subst. repeat red. constructor 1. eexists; split; eauto. 101 | - destruct H as (? & ? & ?). destruct x0; repeat red in H0. 102 | + generalize dependent a0. induction H0; intros; destruct H as (? & ? & ?). 103 | * destruct x. 104 | -- econstructor 2; eauto. eexists; split; eauto. 105 | constructor 1. eexists; split; eauto. reflexivity. 106 | -- inversion H1; clear H1; subst. constructor 1. eexists; split; eauto. 107 | * destruct x; try inversion H2. 108 | econstructor 2; eauto. 2: { apply IHiter_Prop. apply H2. } 109 | eexists; split; eauto. 110 | + subst. constructor 1. eexists; split; eauto. reflexivity. 111 | Qed. 112 | 113 | Global Instance IterCodiagonal_stateTM : IterCodiagonal (Kleisli Ensemble) sum. 114 | Proof. 115 | repeat red; split; repeat intro. 116 | - induction H. 117 | + remember (inr r). generalize dependent r. induction H; intros; subst. 118 | * constructor 1. eexists; split; eauto; reflexivity. 119 | * econstructor 2. 2: { apply IHiter_Prop; auto. } 120 | eexists; split; eauto; reflexivity. 121 | + remember (inl i'). generalize dependent i'. induction H; intros; subst. 122 | * econstructor 2; eauto. eexists; split; eauto; reflexivity. 123 | * econstructor 2. 2: { eapply IHiter_Prop; eauto. } 124 | eexists; split; eauto; reflexivity. 125 | - induction H. 126 | + destruct H as (? & ? & ?). destruct x as [? | [? | ?]]; inversion H0; clear H0; subst. 127 | constructor 1. constructor 1. auto. 128 | + destruct H as (? & ? & ?). 129 | destruct x as [? | [? | ?]]; inversion H1; clear H1; subst. 130 | * destruct IHiter_Prop. 131 | -- constructor 1. econstructor 2; eauto. 132 | -- econstructor 2; eauto. econstructor 2; eauto. 133 | * econstructor 2; eauto. constructor 1. apply H. 134 | Qed. 135 | 136 | Global Instance Iterative_Prop : Iterative (Kleisli Ensemble) sum. 137 | Proof. 138 | constructor; typeclasses eauto. 139 | Qed. 140 | 141 | End prop. 142 | -------------------------------------------------------------------------------- /theories/Eq/Shallow.v: -------------------------------------------------------------------------------- 1 | (** * Shallow equivalence *) 2 | 3 | (** Equality under [observe]: 4 | 5 | [[ 6 | observing eq t1 t2 <-> t1.(observe) = t2.(observe) 7 | ]] 8 | 9 | We actually define a more general relation transformer 10 | [observing] to lift arbitrary relations through [observe]. 11 | *) 12 | 13 | (* begin hide *) 14 | From Coq Require Import Morphisms. 15 | 16 | From ITree Require Import Core.ITreeDefinition. 17 | 18 | Set Implicit Arguments. 19 | (* end hide *) 20 | 21 | Definition eqeq {A : Type} (P : A -> Type) {a1 a2 : A} (p : a1 = a2) : P a1 -> P a2 -> Prop := 22 | match p with 23 | | eq_refl => eq 24 | end. 25 | 26 | Definition pweqeq {R1 R2} (RR : R1 -> R2 -> Prop) {X1 X2 : Type} (p : X1 = X2) 27 | : (X1 -> R1) -> (X2 -> R2) -> Prop := 28 | match p with 29 | | eq_refl => fun k1 k2 => forall x, RR (k1 x) (k2 x) 30 | end. 31 | 32 | Lemma pweqeq_mon {R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) X1 X2 (p : X1 = X2) k1 k2 33 | : (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> pweqeq RR1 p k1 k2 -> pweqeq RR2 p k1 k2. 34 | Proof. 35 | destruct p; cbn; auto. 36 | Qed. 37 | 38 | Lemma eq_inv_VisF_weak {E R X1 X2} (e1 : E X1) (e2 : E X2) (k1 : X1 -> itree E R) (k2 : X2 -> itree E R) 39 | : VisF (R := R) e1 k1 = VisF (R := R) e2 k2 -> 40 | exists p : X1 = X2, eqeq E p e1 e2 /\ eqeq (fun X => X -> itree E R) p k1 k2. 41 | Proof. 42 | refine (fun H => 43 | match H in _ = t return 44 | match t with 45 | | VisF e2 k2 => _ 46 | | _ => True 47 | end 48 | with 49 | | eq_refl => _ 50 | end); cbn. 51 | exists eq_refl; cbn; auto. 52 | Qed. 53 | 54 | Ltac inv_Vis := 55 | discriminate + 56 | match goal with 57 | | [ E : VisF _ _ = VisF _ _ |- _ ] => 58 | apply eq_inv_VisF_weak in E; destruct E as [ <- [<- <-]] 59 | end. 60 | 61 | (** ** [observing]: Lift relations through [observe]. *) 62 | Record observing {E R1 R2} 63 | (eq_ : itree' E R1 -> itree' E R2 -> Prop) 64 | (t1 : itree E R1) (t2 : itree E R2) : Prop := 65 | observing_intros 66 | { observing_observe : eq_ (observe t1) (observe t2) }. 67 | #[global] Hint Constructors observing : itree. 68 | 69 | Section observing_relations. 70 | 71 | Context {E : Type -> Type} {R : Type}. 72 | Variable (eq_ : itree' E R -> itree' E R -> Prop). 73 | 74 | #[global] 75 | Instance observing_observe_ : 76 | Proper (observing eq_ ==> eq_) (@observe E R). 77 | Proof. intros ? ? []; cbv; auto. Qed. 78 | 79 | #[global] 80 | Instance observing_go : Proper (eq_ ==> observing eq_) (@go E R). 81 | Proof. cbv; auto with itree. Qed. 82 | 83 | #[global] 84 | Instance monotonic_observing eq_' : 85 | subrelation eq_ eq_' -> 86 | subrelation (observing eq_) (observing eq_'). 87 | Proof. intros ? ? ? []; cbv; eauto with itree. Qed. 88 | 89 | #[global] 90 | Instance Equivalence_observing : 91 | Equivalence eq_ -> Equivalence (observing eq_). 92 | Proof with (auto with itree). 93 | intros []; split; cbv... 94 | - intros ? ? []; auto... 95 | - intros ? ? ? [] []; eauto with itree. 96 | Qed. 97 | 98 | End observing_relations. 99 | 100 | (** ** Unfolding lemmas for [bind] *) 101 | 102 | Lemma observe_bind {E : Type -> Type} {R S : Type} (t : itree E R) (k : R -> itree E S) 103 | : observe (ITree.bind t k) 104 | = observe (match observe t with 105 | | RetF r => k r 106 | | TauF t0 => Tau (ITree.bind t0 k) 107 | | @VisF _ _ _ X e ke => Vis e (fun x : X => ITree.bind (ke x) k) 108 | end). 109 | Proof. reflexivity. Qed. 110 | 111 | #[global] 112 | Instance observing_bind {E R S} : 113 | Proper (observing eq ==> eq ==> observing eq) (@ITree.bind E R S). 114 | Proof. 115 | repeat intro; subst. constructor. unfold observe. cbn. 116 | rewrite (observing_observe H). reflexivity. 117 | Qed. 118 | 119 | Lemma bind_ret_ {E R S} (r : R) (k : R -> itree E S) : 120 | observing eq (ITree.bind (Ret r) k) (k r). 121 | Proof. constructor; reflexivity. Qed. 122 | 123 | Lemma bind_tau_ {E R} U t (k: U -> itree E R) : 124 | observing eq (ITree.bind (Tau t) k) (Tau (ITree.bind t k)). 125 | Proof. constructor; reflexivity. Qed. 126 | 127 | Lemma bind_vis_ {E R U V} (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : 128 | observing eq 129 | (ITree.bind (Vis e ek) k) 130 | (Vis e (fun x => ITree.bind (ek x) k)). 131 | Proof. constructor; reflexivity. Qed. 132 | 133 | (** Unfolding lemma for [aloop]. There is also a variant [unfold_aloop] 134 | without [Tau]. *) 135 | Lemma unfold_aloop_ {E A B} (f : A -> itree E (A + B)) (x : A) : 136 | observing eq 137 | (ITree.iter f x) 138 | (ITree.bind (f x) (fun lr => ITree.on_left lr l (Tau (ITree.iter f l)))). 139 | Proof. constructor; reflexivity. Qed. 140 | 141 | (** Unfolding lemma for [forever]. *) 142 | Lemma unfold_forever_ {E R S} (t: itree E R): 143 | observing eq (@ITree.forever E R S t) (ITree.bind t (fun _ => Tau (ITree.forever t))). 144 | Proof. econstructor. reflexivity. Qed. 145 | 146 | (** ** [going]: Lift relations through [go]. *) 147 | 148 | Inductive going {E R1 R2} (r : itree E R1 -> itree E R2 -> Prop) 149 | (ot1 : itree' E R1) (ot2 : itree' E R2) : Prop := 150 | | going_intros : r (go ot1) (go ot2) -> going r ot1 ot2. 151 | #[global] Hint Constructors going : itree. 152 | 153 | Lemma observing_going {E R1 R2} (eq_ : itree' E R1 -> itree' E R2 -> Prop) ot1 ot2 : 154 | going (observing eq_) ot1 ot2 <-> eq_ ot1 ot2. 155 | Proof. 156 | split; auto with itree. 157 | intros [[]]; auto. 158 | Qed. 159 | 160 | Section going_relations. 161 | 162 | Context {E : Type -> Type} {R : Type}. 163 | Variable (eq_ : itree E R -> itree E R -> Prop). 164 | 165 | #[global] 166 | Instance going_go : Proper (going eq_ ==> eq_) (@go E R). 167 | Proof. intros ? ? []; auto. Qed. 168 | 169 | #[global] 170 | Instance monotonic_going eq_' : 171 | subrelation eq_ eq_' -> 172 | subrelation (going eq_) (going eq_'). 173 | Proof. intros ? ? ? []; eauto with itree. Qed. 174 | 175 | #[global] 176 | Instance Equivalence_going : 177 | Equivalence eq_ -> Equivalence (going eq_). 178 | Proof. 179 | intros []; constructor; cbv; eauto with itree. 180 | - intros ? ? []; auto with itree. 181 | - intros ? ? ? [] []; eauto with itree. 182 | Qed. 183 | 184 | End going_relations. 185 | -------------------------------------------------------------------------------- /tutorial/Imp2Asm.v: -------------------------------------------------------------------------------- 1 | (** * Compilation of Imp to Asm *) 2 | 3 | (** We are now ready to define our compiler. 4 | The compilation of [expr]essions is of little interest. 5 | The interesting part is in the structure of the 6 | compilation of instructions: we build higher level 7 | [asm] combinators from the primitive ones defined 8 | in [AsmCombinators.v]. Each of these combinator 9 | transcribes a control flow construct of the _Imp_ 10 | language as a linking operation over _Asm_. 11 | Their correctness will be shown in the same style as 12 | the elementary combinators, isolating the control 13 | flow reasoning. 14 | Additionally, although naturally their choice here 15 | is tied to _Imp_, they are fairly generic constructs 16 | and could therefore be reused. 17 | *) 18 | 19 | (* begin hide *) 20 | From ITreeTutorial Require Import Imp Asm Fin Utils_tutorial AsmCombinators. 21 | 22 | From Coq Require Import 23 | Psatz 24 | List 25 | String 26 | Morphisms 27 | Setoid 28 | Decimal 29 | Numbers.DecimalString 30 | ZArith 31 | RelationClasses. 32 | 33 | From ITree Require Import 34 | ITree. 35 | 36 | Import ListNotations. 37 | Open Scope string_scope. 38 | (* end hide *) 39 | 40 | (* ================================================================= *) 41 | (** ** Compilation of expressions *) 42 | 43 | Section compile_assign. 44 | 45 | (** Expressions are compiled straightforwardly. 46 | The argument [l] is the number of registers already introduced to compile 47 | the expression, and is used for the name of the next one. 48 | The result of the computation [compile_expr l e] always ends up stored in [l]. 49 | *) 50 | Fixpoint compile_expr (l:reg) (e: expr): list instr := 51 | match e with 52 | | Var x => [Iload l x] 53 | | Lit n => [Imov l (Oimm n)] 54 | | Plus e1 e2 => 55 | let instrs1 := compile_expr l e1 in 56 | let instrs2 := compile_expr (1 + l) e2 in 57 | instrs1 ++ instrs2 ++ [Iadd l l (Oreg (1 + l))] 58 | | Minus e1 e2 => 59 | let instrs1 := compile_expr l e1 in 60 | let instrs2 := compile_expr (1 + l) e2 in 61 | instrs1 ++ instrs2 ++ [Isub l l (Oreg (1 + l))] 62 | | Mult e1 e2 => 63 | let instrs1 := compile_expr l e1 in 64 | let instrs2 := compile_expr (1 + l) e2 in 65 | instrs1 ++ instrs2 ++ [Imul l l (Oreg (1 + l))] 66 | end. 67 | 68 | (** Compiles the expression and then moves the result (in register [0]) to address 69 | [x]. Note: here we assume a one-to-one mapping of _Imp_ global variable names 70 | and _Asm_ addresses. 71 | *) 72 | Definition compile_assign (x: Imp.var) (e: expr): list instr := 73 | let instrs := compile_expr 0 e in 74 | instrs ++ [Istore x (Oreg 0)]. 75 | 76 | End compile_assign. 77 | 78 | (* ================================================================= *) 79 | (** ** Control flow combinators *) 80 | 81 | 82 | (** Sequencing of blocks: the program [seq_asm ab bc] links the 83 | exit points of [ab] with the entry points of [bc]. 84 | 85 | [[ 86 | B 87 | A---ab-----bc---C 88 | ]] 89 | 90 | ... can be implemented using just [app_asm], [relabel_asm] and [loop_asm]. 91 | 92 | Indeed, [app_asm ab bc] can be visualized as: 93 | [[ 94 | A---ab---B 95 | B---bc---C 96 | ]] 97 | i.e. a [asm (A + B) (B + C)]. To link them, we need first to swap the entry points. 98 | 99 | We obtain the following diagram: 100 | [seq_asm ab bc] 101 | [[ 102 | +------+ 103 | | | 104 | A------ab--+B 105 | | 106 | B+--bc------C 107 | ]] 108 | 109 | Which translates to: 110 | *) 111 | Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) 112 | : asm A C := 113 | loop_asm (relabel_asm swap (id_ _) (app_asm ab bc)). 114 | 115 | 116 | (** Location of temporary for [if]. *) 117 | Definition tmp_if := 0. 118 | 119 | (** Turns the list of instructions resulting from the conditional 120 | expression of a _if_ to a block with two exit points. 121 | *) 122 | Definition cond_asm (e : list instr) : asm 1 2 := 123 | raw_asm_block (after e (Bbrz tmp_if (fS f0) f0)). 124 | 125 | 126 | (** Conditional branch of blocks. 127 | The program [if_asm e tp fp] creates a block out of [e] jumping 128 | either left or right. 129 | Using [seq_asm], this block is sequenced with the vertical 130 | composition [app_asm] of [tp] and [fp]. 131 | Remains one mismatch: [app_asm] duplicates the domain of outputs, 132 | although they share the same. We hence use [relabel_asm] to collapse 133 | them together. 134 | 135 | [if_asm e tp fp] 136 | [[ 137 | true 138 | /ee-------tp---A\ 139 | 1-- --A 140 | \ee-------fp---A/ 141 | false 142 | ]] 143 | *) 144 | Definition if_asm {A} 145 | (e : list instr) (tp : asm 1 A) (fp : asm 1 A) : 146 | asm 1 A := 147 | seq_asm (cond_asm e) 148 | (relabel_asm (id_ _) merge (app_asm tp fp)). 149 | 150 | (* Conditional looping of blocks. 151 | The program [while_asm e p] composes vertically two programs: 152 | an [if_asm] construct with [p] followed by a jump on the true branch, 153 | and a unique jump on the false branch. 154 | The loop is then closed with [loop_asm] by matching the jump from the 155 | true branch to the entry point. 156 | 157 | [while_asm e p] 158 | [[ 159 | +-------------+ 160 | | | 161 | | true | 162 | | e-------p--+ 163 | 1---+--e--------------1 164 | false 165 | ]] 166 | *) 167 | Definition while_asm (e : list instr) (p : asm 1 1) : 168 | asm 1 1 := 169 | loop_asm (relabel_asm (id_ _) merge 170 | (app_asm (if_asm e 171 | (relabel_asm (id_ _) inl_ p) 172 | (pure_asm inr_)) 173 | (pure_asm inl_))). 174 | 175 | (** Equipped with our combinators, the compiler writes itself 176 | by induction on the structure of the statement. 177 | *) 178 | Fixpoint compile (s : stmt) {struct s} : asm 1 1 := 179 | match s with 180 | | Skip => id_asm 181 | | Assign x e => raw_asm_block (after (compile_assign x e) (Bjmp f0)) 182 | | Seq l r => seq_asm (compile l) (compile r) 183 | | If e l r => if_asm (compile_expr 0 e) (compile l) (compile r) 184 | | While e b => while_asm (compile_expr 0 e) (compile b) 185 | end. 186 | 187 | (** We now consider its proof of correctness in [Imp2AsmCorrectness.v]. *) 188 | -------------------------------------------------------------------------------- /theories/Basics/Basics.v: -------------------------------------------------------------------------------- 1 | (** * General-purpose definitions *) 2 | 3 | (** Not specific to itrees. *) 4 | 5 | (* begin hide *) 6 | From Coq Require 7 | Ensembles. 8 | 9 | From Coq Require Import 10 | RelationClasses. 11 | 12 | From ExtLib Require Import 13 | Structures.Functor 14 | Structures.Monad 15 | Data.Monads.StateMonad 16 | Data.Monads.ReaderMonad 17 | Data.Monads.OptionMonad 18 | Data.Monads.EitherMonad. 19 | 20 | Import 21 | FunctorNotation 22 | MonadNotation. 23 | Local Open Scope monad. 24 | (* end hide *) 25 | 26 | (** ** Parametric functions *) 27 | 28 | (** A notation for a certain class of parametric functions. 29 | Some common names of things that can be represented by such a type: 30 | 31 | - Natural transformations (functor morphisms) 32 | - Monad morphisms 33 | - Event morphisms (if [E] and [F] are simply 34 | indexed types with no particular structure) 35 | - Event handlers (if [F] is a monad) 36 | *) 37 | Notation "E ~> F" := (forall T, E T -> F T) 38 | (at level 99, right associativity, only parsing) : type_scope. 39 | (* The same level as [->]. *) 40 | (* This might actually not be such a good idea. *) 41 | 42 | (** Identity morphism. *) 43 | Definition idM {E : Type -> Type} : E ~> E := fun _ e => e. 44 | 45 | (** [void] is a shorthand for [Empty_set]. *) 46 | Notation void := Empty_set. 47 | 48 | (** ** Common monads and transformers. *) 49 | 50 | Module Monads. 51 | 52 | Definition identity (a : Type) : Type := a. 53 | 54 | Definition stateT (s : Type) (m : Type -> Type) (a : Type) : Type := 55 | s -> m (prod s a). 56 | Definition state (s a : Type) := s -> prod s a. 57 | 58 | Definition run_stateT {s m a} (x : stateT s m a) : s -> m (s * a)%type := x. 59 | 60 | Definition liftState {s a f} `{Functor f} (fa : f a) : Monads.stateT s f a := 61 | fun s => pair s <$> fa. 62 | 63 | Definition readerT (r : Type) (m : Type -> Type) (a : Type) : Type := 64 | r -> m a. 65 | Definition reader (r a : Type) := r -> a. 66 | 67 | Definition writerT (w : Type) (m : Type -> Type) (a : Type) : Type := 68 | m (prod w a). 69 | Definition writer := prod. 70 | 71 | #[global] Instance Functor_stateT {m s} {Fm : Functor m} : Functor (stateT s m) 72 | := {| 73 | fmap _ _ f := fun run s => fmap (fun sa => (fst sa, f (snd sa))) (run s) 74 | |}. 75 | 76 | #[global] Instance Monad_stateT {m s} {Fm : Monad m} : Monad (stateT s m) 77 | := {| 78 | ret _ a := fun s => ret (s, a) 79 | ; bind _ _ t k := fun s => 80 | sa <- t s ;; 81 | k (snd sa) (fst sa) 82 | |}. 83 | 84 | End Monads. 85 | 86 | (** ** Loop operator *) 87 | 88 | (** [iter]: A primitive for general recursion. 89 | Iterate a function updating an accumulator [I], until it produces 90 | an output [R]. 91 | *) 92 | Polymorphic Class MonadIter (M : Type -> Type) : Type := 93 | iter : forall {R I: Type}, (I -> M (I + R)%type) -> I -> M R. 94 | 95 | #[global] Hint Mode MonadIter ! : typeclass_instances. 96 | 97 | (** *** Transformer instances *) 98 | 99 | (** And the standard transformers can lift [iter]. 100 | 101 | Quite easily in fact, no [Monad] assumption needed. 102 | *) 103 | 104 | #[global] Instance MonadIter_stateT {M S} {MM : Monad M} {AM : MonadIter M} 105 | : MonadIter (stateT S M) := 106 | fun _ _ step i => mkStateT (fun s => 107 | iter (fun is => 108 | let i := fst is in 109 | let s := snd is in 110 | is' <- runStateT (step i) s ;; 111 | ret match fst is' with 112 | | inl i' => inl (i', snd is') 113 | | inr r => inr (r, snd is') 114 | end) (i, s)). 115 | 116 | #[global] Polymorphic Instance MonadIter_stateT0 {M S} {MM : Monad M} {AM : MonadIter M} 117 | : MonadIter (Monads.stateT S M) := 118 | fun _ _ step i s => 119 | iter (fun si => 120 | let s := fst si in 121 | let i := snd si in 122 | si' <- step i s;; 123 | ret match snd si' with 124 | | inl i' => inl (fst si', i') 125 | | inr r => inr (fst si', r) 126 | end) (s, i). 127 | 128 | #[global] Instance MonadIter_readerT {M S} {AM : MonadIter M} : MonadIter (readerT S M) := 129 | fun _ _ step i => mkReaderT (fun s => 130 | iter (fun i => runReaderT (step i) s) i). 131 | 132 | #[global] Instance MonadIter_optionT {M} {MM : Monad M} {AM : MonadIter M} 133 | : MonadIter (optionT M) := 134 | fun _ _ step i => mkOptionT ( 135 | iter (fun i => 136 | oi <- unOptionT (step i) ;; 137 | ret match oi with 138 | | None => inr None 139 | | Some (inl i) => inl i 140 | | Some (inr r) => inr (Some r) 141 | end) i). 142 | 143 | #[global] Instance MonadIter_eitherT {M E} {MM : Monad M} {AM : MonadIter M} 144 | : MonadIter (eitherT E M) := 145 | fun _ _ step i => mkEitherT ( 146 | iter (fun i => 147 | ei <- unEitherT (step i) ;; 148 | ret match ei with 149 | | inl e => inr (inl e) 150 | | inr (inl i) => inl i 151 | | inr (inr r) => inr (inr r) 152 | end) i). 153 | 154 | (** And the nondeterminism monad [_ -> Prop] also has one. *) 155 | 156 | Inductive iter_Prop {R I : Type} (step : I -> I + R -> Prop) (i : I) (r : R) 157 | : Prop := 158 | | iter_done 159 | : step i (inr r) -> iter_Prop step i r 160 | | iter_step i' 161 | : step i (inl i') -> 162 | iter_Prop step i' r -> 163 | iter_Prop step i r 164 | . 165 | 166 | #[global] Polymorphic Instance MonadIter_Prop : MonadIter Ensembles.Ensemble := @iter_Prop. 167 | 168 | (* Elementary constructs for predicates. To be moved in their own file eventually *) 169 | Definition equiv_pred {A : Type} (R S: A -> Prop): Prop := 170 | forall a, R a <-> S a. 171 | 172 | Definition sum_pred {A B : Type} (PA : A -> Prop) (PB : B -> Prop) : A + B -> Prop := 173 | fun x => match x with | inl a => PA a | inr b => PB b end. 174 | 175 | Definition prod_pred {A B : Type} (PA : A -> Prop) (PB : B -> Prop) : A * B -> Prop := 176 | fun '(a,b) => PA a /\ PB b. 177 | 178 | Definition TT {A : Type} : A -> Prop := fun _ => True. 179 | Global Hint Unfold TT sum_pred prod_pred: core. 180 | 181 | #[global] Instance equiv_pred_refl {A} : Reflexive (@equiv_pred A). 182 | Proof. 183 | split; auto. 184 | Qed. 185 | #[global] Instance equiv_pred_symm {A} : Symmetric (@equiv_pred A). 186 | Proof. 187 | red; intros * EQ; split; intros; eapply EQ; auto. 188 | Qed. 189 | #[global] Instance equiv_pred_trans {A} : Transitive (@equiv_pred A). 190 | Proof. 191 | red; intros * EQ1 EQ2; split; intros; (apply EQ1,EQ2 || apply EQ2,EQ1); auto. 192 | Qed. 193 | #[global] Instance equiv_pred_equiv {A} : Equivalence (@equiv_pred A). 194 | Proof. 195 | split; typeclasses eauto. 196 | Qed. 197 | 198 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 5.2.1 - February 2025 2 | ===================== 3 | 4 | - Compatibility with Coq 8.20 and Paco 4.2.1-4.2.3 5 | 6 | 5.2.0 - April 2024 7 | ================== 8 | 9 | - Compatibility with Coq 8.19 10 | - Add `Hint Mode` on `MonadIter`, avoiding some infinite instance resolution loops 11 | - Rename `ITree.Basics.Tacs` to `ITree.Basics.Utils` 12 | 13 | 5.1.2 - October 2023 14 | ==================== 15 | 16 | - Compatibility with Coq 8.18 17 | 18 | 5.1.1 - Mars 2023 19 | ================= 20 | 21 | - Compatibility with Coq 8.16, 8.17, and paco 4.2.0 22 | - Remove redundant `RelDec_string` instances 23 | 24 | 5.1.0 - December 2022 25 | ===================== 26 | 27 | - In `ITree.Extra`: 28 | + Refactor `IForest` to reuse `ITree.Props.Leaf`. 29 | 30 | - Add `Eq.RuttFacts`: properties of `rutt`. 31 | 32 | - Add more lemmas about `eutt` and `Leaf`. 33 | 34 | 5.0.0 - May 2022 35 | ================ 36 | 37 | - Create `coq-itree-extra`. Under the namespace `ITree.Extra`: 38 | + `ITrace`: ITrees as sets of traces 39 | + `Dijkstra`: Dijkstra monads forever (POPL 2021) 40 | + `Secure`: Indistinguishability relation on ITrees 41 | + `IForest`: The "sets of itrees" monad 42 | 43 | - Add `Hint Mode` on `ReSum`, preventing some infinite loops in instance resolution. 44 | 45 | - Add `rutt`, a generalization of `eutt` relating trees with different event types, 46 | `rutt RE RA RS : itree E R -> itree F S -> Prop`. 47 | 48 | - Add `Props.Divergence` and `Props.Finite`, with predicates (`may_diverge`, 49 | `must_diverge`, `BoxFinite`, `DiamondFinite`) about infinite and finite itrees. 50 | 51 | - Add `Props.HasPost`, a predicate transformer semantics for itree. 52 | 53 | - Add `Props.Leaf`, a membership relation on trees; `Leaf` can be seen as a dual to `has_post`. 54 | 55 | - Add classes for cartesian closed categories in `Basics.CategoryTheory`. 56 | 57 | - Add `Axioms`, collecting all axioms used by this library and associated tactics. 58 | 59 | - Add `Events.ExceptionFacts`. 60 | 61 | 4.0.0 - March 2021 62 | ================== 63 | 64 | - Change `ITree.bind` from a notation to a function. This may break some proofs. 65 | 66 | + After simplifications, if there is `ITree.subst` in the goal, use the tactic 67 | `ITree.fold_subst` to change it back to `ITree.bind` 68 | + After applying `eqit_bind`, the goals are reversed. 69 | 70 | - Reduce dependency on axioms. Basically, we require UIP for one inversion 71 | lemma `ITree.Eq.Eq.eqit_inv_Vis` (and one notable corollary of it is 72 | `ITree.Eq.UpToTaus.eutt_conj`). 73 | 74 | - Fixed: scopes are not opened globally anymore; add `Local Open Scope itree_scope` 75 | (also `cat_scope`, `monad_scope` (from ext-lib)) to use those scopes. 76 | 77 | - Drop support for Coq 8.8 and 8.9. 78 | (This version technically still builds with Coq 8.9 using `make`, or Dune 2.8.4) 79 | 80 | - Change the build system from `make` to `dune`. 81 | 82 | - Deploy [coqdoc documentation on Github Pages](https://DeepSpec.github.io/InteractionTrees/). 83 | 84 | - Add modules: 85 | + `ITree.Basics.HeterogeneousRelations` 86 | + `ITree.Basics.CategoryRelations` (the category of relations between types) 87 | + `ITree.Events.FailFacts` 88 | 89 | - Add constructs for cartesian categories (i.e., categories with products) in 90 | `ITree.Basics.CategoryTheory`. 91 | 92 | Miscellaneous changes 93 | --------------------- 94 | 95 | - Change `eqit_Vis` from `<->` to `->`; the converse is `eqit_inv_Vis`. 96 | 97 | - Rename theorems in `ITree.Eq.Eq` (trying to make them more consistent; 98 | mostly, uppercase initial of constructors, and lowercase `l`/`r`): 99 | + `eqitree_inv_Ret` 100 | + `eqitree_inv_Ret_r` 101 | + `eqitree_inv_Vis_r` 102 | + `eqitree_inv_Tau_r` 103 | + `eqit_inv_Ret` 104 | + `eqit_inv_Vis` 105 | + `eqit_inv_Tau` 106 | + `eqit_inv_Tau_l` 107 | + `eqit_inv_Tau_r` 108 | + `eqit_Tau_l` 109 | + `eqit_Tau_r` 110 | + `eutt_inv_Ret` 111 | + Contradiction lemmas (where the two sides in an `eqit` equation don't 112 | match) are refactored into `eqit_inv`. 113 | 114 | - Add functions and theorems: 115 | + `ITree.Basics.liftState` 116 | + `ITree.Core.KTreeFacts.cat_iter` 117 | + `ITree.Eq.UpToTaus.eutt_conj`, `eutt_disj_l`, `eutt_disj_r`, `eutt_equiv`, `eutt_Proper_R` 118 | 119 | - Add theorems in `ITree.Eq.Eq`: 120 | + `eqit_inv_Vis_weak` and `eqit_Vis_gen`, 121 | generalizing `eqit_inv_Vis` and `eqit_Vis`. 122 | + `eq_itree_inv_bind_Vis` 123 | + `eqit_inv_bind_Tau` 124 | + `eutt_inv_bind_Tau` 125 | + `eqitree_inv_bind_Tau` 126 | 127 | 3.2.0 - September 2020 128 | ====================== 129 | 130 | - Add module `ITree.Basics.MonadProp`: the nondeterminism monad (`_ -> Prop`) 131 | 132 | - Rename concepts related to monad-specific equivalence: 133 | 134 | + `EqM` -> `Eq1` 135 | + `eqm` -> `eq1` 136 | + `EqMProps` -> `Eq1Equivalence` 137 | + `MonadLaws` -> `MonadLawsE` (to avoid confusion with coq-ext-lib) 138 | 139 | - Fix the definition of `iter` to be more extractable. 140 | It no longer loops when the body always evaluates to a simple `Ret _`. 141 | 142 | - Add some inversion lemmas 143 | 144 | - Add `handle` and `handling` to convert explicitly between `Handler` and `_ ~> itree _` 145 | 146 | - In `Simple.v`, fix the precedence level of the infix notation for `eutt` to 70. 147 | 148 | 3.1.0 149 | ===== 150 | 151 | - Require coq-ext-lib >= 0.11.1 152 | - Change precedence of `>>=` to level 58 (previously at level 50). 153 | - Add `tau_eutt` and `tau_euttge` (the latter was actually renamed from 154 | `tau_eutt`). 155 | 156 | 3.0.0 157 | ===== 158 | 159 | - Add compatibility with Coq 8.10 and 8.11 160 | 161 | - Require coq-ext-lib 0.10.3 (only this one version, not 0.10.2 or 0.11.0!) 162 | for notation compatibility. 163 | 164 | - Notation changes 165 | 166 | + Notation convention (from coq-ext-lib, PR 68): odd is right, even is left. 167 | 168 | + Change precedence of monad notations in `ITreeNotations`. 169 | + `x <- t1 ;; t2`, `t1 ;; t2`, `' p <- t1 ;; t2`, `>=>` at level 61 170 | (previously level 60). 171 | 172 | + Change precedence of notation `-<` at level 92 (previously level 90, but it 173 | is currently used by math-classes with right associativity). 174 | 175 | + Remove notations `KTree.iter` and `KTree.loop` (use `iter (C := ktree _)` 176 | instead for example). 177 | 178 | - Add `pure_inl`, `pure_inr`. 179 | - Add `eutt_interp_state` and `eutt_interp_state_eq` (the latter was actually 180 | renamed from `eutt_interp_state`). 181 | 182 | 2.0.0 183 | ===== 184 | 185 | The previous release was not that stable... Too many changes to count. 186 | 187 | Version 2.0.0 corresponds to our POPL20 paper. 188 | 189 | 1.0.0 190 | ===== 191 | 192 | First stable release 193 | -------------------------------------------------------------------------------- /theories/Eq/Paco2.v: -------------------------------------------------------------------------------- 1 | (** Redefinition of [pcofix] and [pcofix] without using the [JMeq_eq] axiom. 2 | Both tactics are now called [pcofix]. The same core is reused to define [ecofix] 3 | in [Eq.UpToTaus]. *) 4 | 5 | From Paco Require Import paco. 6 | 7 | Ltac debug_goal := 8 | match goal with 9 | | [ |- ?G ] => idtac G 10 | end. 11 | 12 | (* A variant of [paco2_acc] that is more convenient to use in the [pcofix] tactic. *) 13 | Lemma paco2_accF 14 | : forall {T0 : Type} {T1 : forall a : T0, Type} 15 | (gf : rel2 T0 T1 -> rel2 T0 T1) (r : rel2 T0 T1) 16 | (X : Type) 17 | (f0 : X -> T0) (f1 : forall x : X, T1 (f0 x)), 18 | (forall rr : rel2 T0 T1, 19 | (forall a0 a1, r a0 a1 -> rr a0 a1) -> 20 | (forall x, rr (f0 x) (f1 x)) -> 21 | forall x : X, paco2 gf rr (f0 x) (f1 x)) -> 22 | forall x : X, paco2 gf r (f0 x) (f1 x). 23 | Proof. 24 | intros. 25 | apply paco2_acc with 26 | (l := fun a0 (a1 : T1 a0) => exists x, existT _ (f0 x) (f1 x) = existT _ a0 a1); [ | eauto ]. 27 | intros rr INC CIH x0 x1 PR. change (paco2 gf rr (projT1 (existT _ _ x1)) (projT2 (existT _ _ x1))). 28 | destruct PR as [? <-]. 29 | eauto. 30 | Qed. 31 | 32 | Lemma gpaco2_accF 33 | : forall {T0 : Type} {T1 : forall a : T0, Type} 34 | (gf : rel2 T0 T1 -> rel2 T0 T1), 35 | monotone2 gf -> 36 | forall (clo : rel2 T0 T1 -> rel2 T0 T1) (r rg : rel2 T0 T1) 37 | (X : Type) 38 | (f0 : X -> T0) (f1 : forall x : X, T1 (f0 x)) 39 | (OBG : forall rr : rel2 T0 T1, 40 | (forall x y, rg x y -> rr x y) -> 41 | (forall x, rr (f0 x) (f1 x)) -> 42 | forall x : X, gpaco2 gf clo r rr (f0 x) (f1 x)), 43 | forall x : X, gpaco2 gf clo r rg (f0 x) (f1 x). 44 | Proof. 45 | intros. 46 | apply gpaco2_cofix with 47 | (l := fun a0 (a1 : T1 a0) => exists x, existT _ (f0 x) (f1 x) = existT _ a0 a1); [ eauto | | eauto ]. 48 | intros. change (gpaco2 gf clo r rr (projT1 (existT _ _ x1)) (projT2 (existT _ _ x1))). 49 | destruct PR as [? <-]. 50 | eauto. 51 | Qed. 52 | 53 | Ltac apply_paco_acc self unpack_goal unpack_hyp := 54 | let unpack _tt := 55 | let r := fresh "r" in 56 | let self_ := fresh "_tmp_" self in 57 | let self := fresh self in 58 | intros r self_ self; 59 | let self1 := fresh self in 60 | rename self_ into self1; 61 | unpack_goal tt; 62 | unpack_hyp self in 63 | lazymatch goal with 64 | | [ |- forall _, paco2 ?gf ?r0 _ _ ] => apply paco2_accF; unpack tt 65 | | [ |- forall _, gpaco2 ?gf ?clo _ _ _ _ ] => apply gpaco2_accF; [ eauto with paco | unpack tt ] 66 | (* TODO: other arities *) 67 | | _ => fail "paco not found at the head of the goal" 68 | end. 69 | 70 | Lemma curry_sig {A : Type} {P : A -> Type} {Q : forall (a : A) (b : P a), Prop} 71 | : (forall x : sigT P, Q (projT1 x) (projT2 x)) -> forall (a : A) (p : P a), Q a p. 72 | Proof. 73 | exact (fun H a p => H (existT _ a p)). 74 | Qed. 75 | 76 | (* [pcofix self]: Apply coinduction to a goal with [paco] at the head of the conclusion 77 | (possibly after unfolding definitions). 78 | The parameter [self] is the name of the coinduction hypothesis. *) 79 | 80 | (* Internal definition of [pcofix_]: 81 | Example initial goal: 82 | << 83 | =========== 84 | forall (x : X) (y : Y), hyp x y -> paco2 gf bot2 (f0 x y) (f1 x y) 85 | >> 86 | 1. [pcofix_] first recursively introduces all hypotheses [H], being careful to 87 | preserve existing names, and at the same time builds up continuations 88 | to process the goal once we reach the conclusion. This technique has the 89 | benefit that the name of each hypothesis is available, so it does 90 | not need to be guessed repeatedly. 91 | Goal after step 1: 92 | << 93 | x : X 94 | y : Y 95 | H : hyp x y 96 | =========== 97 | paco2 gf bot2 (f0 x y) (f1 x y) 98 | >> 99 | 2. Having reached the conclusion, we use the [pack_goal0] continuation to 100 | regeneralize the hypotheses we introduced into a single sigma type 101 | (a chain of [{_ & _}]/[sigT]), 102 | Goal after step 2: 103 | << 104 | =========== 105 | forall (u : {x : X & {y : Y & {_ : hyp x y & unit}}}), 106 | paco2 gf bot2 (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u)) 107 | >> 108 | 3. We can now apply [paco2_accF] (depending on the arity of paco) 109 | Goal after step 3: 110 | << 111 | r : rel2 T0 T1 112 | _pacotmp_SELF: forall (u : _), r (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u)) 113 | ========== 114 | forall (u : {x : X & {y : Y & {_ : hyp x y & unit}}}), 115 | paco2 gf r (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u)) 116 | >> 117 | 4. We decompose the tuple in the goal using the [unpack_goal0] continuation 118 | (basically the reverse of [pack_goal0]) and [revert_tmp0]. 119 | Goal after step 4: 120 | << 121 | r : rel2 T0 T1 122 | _pacotmp_SELF: forall (u : _), r (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u)) 123 | ========== 124 | forall x y, hyp x y -> paco2 gf r (f0 x y) (f1 x y) 125 | >> 126 | 5. We decompose the tuple in the coinduction hypothesis 127 | Goal after step 5: 128 | << 129 | r : rel2 T0 T1 130 | SELF: forall x y, hyp x y -> r (f0 x y) (f1 x y) 131 | ========== 132 | forall x y, hyp x y -> paco2 gf r (f0 x y) (f1 x y) 133 | >> 134 | tODO: Currently this step does not preserve variable names, 135 | so the actual hypothesis looks more like this: 136 | << 137 | SELF: forall x0 x1, hyp x0 x1 -> r (f0 x0 x1) (f1 x0 x1) 138 | >> 139 | *) 140 | Ltac pcofix_ apply_paco_acc0 pack_goal0 unpack_goal0 revert_tmp0 unpack_hyp0 := 141 | hnf; 142 | lazymatch goal with 143 | | [ |- forall H : ?X, _ ] => 144 | (* 1. *) 145 | let H := fresh H in 146 | intros H; 147 | let pack_goal := (revert H; apply curry_sig; pack_goal0) in 148 | let unpack_goal H0 := ltac:(unpack_goal0 H0; destruct H0 as [H H0]; cbn [projT1 projT2]) in 149 | let revert_tmp := revert H; revert_tmp0 in 150 | let unpack_hyp tmp_self := 151 | intros H; 152 | let tmp := fresh tmp_self in 153 | rename tmp_self into tmp; 154 | assert (tmp_self := fun TMP => tmp (existT _ H TMP)); 155 | clear tmp; 156 | unpack_hyp0 tmp_self in 157 | pcofix_ apply_paco_acc0 pack_goal unpack_goal revert_tmp unpack_hyp 158 | | _ => 159 | let (* 4 *) unpack_goal _tt := 160 | let tmp_H0 := fresh "_pacotmp_" in 161 | intros tmp_H0; unpack_goal0 tmp_H0; clear tmp_H0; 162 | revert_tmp0 in 163 | let (* 5 *) unpack_hyp HYP := 164 | let tmp_prop := fresh HYP "_prop_" in 165 | let tmp_hyp := fresh HYP "_v_" in 166 | evar (tmp_prop : Prop); assert (tmp_hyp : tmp_prop); subst tmp_prop; 167 | [ unpack_hyp0 HYP; cbn in HYP; exact (HYP tt) 168 | | clear HYP ]; 169 | try rename tmp_hyp into HYP in 170 | (* 2. pack_goal *) assert (tmp_H0 := tt); revert tmp_H0; pack_goal0; 171 | (* 3. paco_acc *) apply_paco_acc0 unpack_goal unpack_hyp 172 | end. 173 | 174 | Ltac pcofix_with apply_paco_acc0 := 175 | let pack_goal0 := idtac in 176 | let unpack_goal0 _ := idtac in 177 | let revert_tmp0 := idtac in 178 | let unpack_hyp0 _ := idtac in 179 | pcofix_ apply_paco_acc0 pack_goal0 unpack_goal0 revert_tmp0 unpack_hyp0. 180 | 181 | Tactic Notation "pcofix" ident(self) := 182 | pcofix_with ltac:(apply_paco_acc self). 183 | -------------------------------------------------------------------------------- /theories/Basics/CategorySub.v: -------------------------------------------------------------------------------- 1 | (** * Full subcategories *) 2 | 3 | (** The category described by a subset of objects of an existing category. *) 4 | 5 | (* begin hide *) 6 | From Coq Require Import 7 | Setoid 8 | Morphisms. 9 | 10 | From ITree Require Import 11 | Category 12 | CategoryFunctor. 13 | 14 | Import CatNotations. 15 | Local Open Scope cat_scope. 16 | (* end hide *) 17 | 18 | Set Universe Polymorphism. 19 | 20 | Section Subcategory. 21 | 22 | (** A function [Embed : sobj -> obj] from some collection of objects [sobj] 23 | to objects of a category [C] induces a category on [sobj]. 24 | When that function [Embed] is injective, that is a subcategory. *) 25 | Context 26 | {obj : Type} 27 | (C : obj -> obj -> Type) 28 | {sobj : Type} 29 | (Embed : sobj -> obj). 30 | 31 | Definition sub (a b : sobj) : Type := C (Embed a) (Embed b). 32 | 33 | Definition subm (a b : sobj) (f : C (Embed a) (Embed b)) : sub a b := f. 34 | Definition unsubm (a b : sobj) (f : sub a b) : C (Embed a) (Embed b) := f. 35 | 36 | Context 37 | {Eq2_C : Eq2 C} 38 | {Id_C : Id_ C} 39 | {Cat_C : Cat C}. 40 | 41 | Global Instance Eq2_sub : Eq2 sub := 42 | fun _ _ => eq2 (C := C). 43 | 44 | Global Instance Id_sub : Id_ sub := 45 | fun _ => id_ (C := C) _. 46 | 47 | Global Instance Cat_sub : Cat sub := 48 | fun _ _ _ => cat (C := C). 49 | 50 | Context 51 | (bif : obj -> obj -> obj) 52 | (sbif : sobj -> sobj -> sobj). 53 | 54 | Class ToBifunctor : Type := 55 | to_bif : forall a b, C (Embed (sbif a b)) (bif (Embed a) (Embed b)). 56 | 57 | Class FromBifunctor : Type := 58 | from_bif : forall a b, C (bif (Embed a) (Embed b)) (Embed (sbif a b)). 59 | 60 | Arguments to_bif {_ a b}. 61 | Arguments from_bif {_ a b}. 62 | 63 | Context 64 | {ToBif : ToBifunctor} 65 | {FromBif : FromBifunctor} 66 | {IsoBif : forall a b, Iso C (a := Embed (sbif a b)) to_bif from_bif}. 67 | 68 | Section Bimap. 69 | 70 | Context 71 | {Bimap_C : Bimap C bif}. 72 | 73 | Definition Bimap_sub : Bimap sub sbif := 74 | fun _ _ _ _ f g => to_bif >>> bimap (C := C) f g >>> from_bif. 75 | 76 | End Bimap. 77 | 78 | Context 79 | {Case_C : Case C bif} 80 | {Inl_C : Inl C bif} 81 | {Inr_C : Inr C bif}. 82 | 83 | Global Instance Case_sub : Case sub sbif := 84 | fun _ _ _ f g => to_bif >>> case_ (C := C) f g. 85 | 86 | Global Instance Inl_sub : Inl sub sbif := 87 | fun _ _ => inl_ (C := C) >>> from_bif. 88 | 89 | Global Instance Inr_sub : Inr sub sbif := 90 | fun _ _ => inr_ (C := C) >>> from_bif. 91 | 92 | Context 93 | {Iter_C : Iter C bif}. 94 | 95 | Global Instance Iter_sub : Iter sub sbif := 96 | fun _ _ f => iter (C := C) (cat (C := C) f to_bif). 97 | 98 | Section CatLaws. 99 | 100 | Context 101 | {Equivalence_C : forall a b, @Equivalence (C a b) eq2} 102 | {Category_C : Category C}. 103 | 104 | Global Instance Equivalence_sub {a b} : @Equivalence (sub a b) eq2 := 105 | Equivalence_C _ _. 106 | 107 | Global Instance Category_sub : Category sub. 108 | Proof. 109 | destruct Category_C; constructor; red; eauto. 110 | do 2 red. intros. eapply category_proper_cat; eauto. 111 | Qed. 112 | 113 | Global Instance Proper_subm {a b} : Proper (eq2 ==> eq2) (subm a b). 114 | Proof. hnf; auto. Qed. 115 | 116 | Global Instance Proper_unsubm {a b} : Proper (eq2 ==> eq2) (subm a b). 117 | Proof. hnf; auto. Qed. 118 | 119 | Global Instance Functor_unsubm : Functor sub C Embed unsubm. 120 | Proof. 121 | constructor; reflexivity + typeclasses eauto. 122 | Qed. 123 | 124 | End CatLaws. 125 | 126 | Ltac unfold_sub := 127 | repeat progress ( 128 | try change (eq2 (C := sub) (a := ?a) (b := ?b)) 129 | with (eq2 (C := C) (a := Embed a) (b := Embed b)); 130 | try change (id_ (C := sub) ?a) 131 | with (id_ (C := C) (Embed a)); 132 | try change (cat (C := sub) (a := ?a) (b := ?b) (c := ?c)) 133 | with (cat (C := C) (a := Embed a) (b := Embed b) (c := Embed c)); 134 | try change (case_ (C := sub) (a := ?a) (b := ?b) (c := ?c) ?f ?g) 135 | with (to_bif >>> case_ (C := C) (a := Embed a) (b := Embed b) (c := Embed c) f g); 136 | try change (inl_ (C := sub) (a := ?a) (b := ?b)) 137 | with (inl_ (C := C) (a := Embed a) (b := Embed b) >>> from_bif); 138 | try change (inr_ (C := sub) (a := ?a) (b := ?b)) 139 | with (inr_ (C := C) (a := Embed a) (b := Embed b) >>> from_bif); 140 | try change (iter (C := sub) (a := ?a) (b := ?b) ?f) 141 | with (iter (C := C) (cat (C := C) f to_bif)) 142 | ). 143 | 144 | 145 | Ltac simpl_bif := 146 | try rewrite <- (cat_assoc to_bif from_bif), (semi_iso to_bif from_bif); 147 | try rewrite <- (cat_assoc from_bif to_bif), (semi_iso from_bif to_bif); 148 | rewrite cat_id_l. 149 | 150 | Section CoproductLaws. 151 | 152 | Context 153 | {Equivalence_C : forall a b, @Equivalence (C a b) eq2} 154 | {Category_C : Category C} 155 | {Coproduct_C : Coproduct C bif}. 156 | 157 | Global Instance Coproduct_sub : Coproduct sub sbif. 158 | Proof. 159 | destruct Coproduct_C; constructor; red; intros. 160 | all: unfold Morphisms.respectful. 161 | all: unfold_sub. 162 | all: try rewrite !cat_assoc. 163 | all: try simpl_bif; eauto. 164 | - enough (from_bif >>> fg ⩯ case_ (C := C) f g). 165 | { rewrite <- H1, <- cat_assoc, (semi_iso _ _), cat_id_l. reflexivity. } 166 | apply case_universal; rewrite <- cat_assoc; eauto. 167 | - intros. unfold case_, Case_sub. 168 | apply category_proper_cat. reflexivity. 169 | eapply coproduct_proper_case; eauto. 170 | Qed. 171 | 172 | Lemma bimap_sub_unfold a b c d (f : sub a c) (g : sub b d) : 173 | eq2 (C := C) (bimap (C := sub) f g) 174 | (to_bif >>> bimap (C := C) f g >>> from_bif). 175 | Proof. 176 | unfold bimap at 1, Bimap_Coproduct at 1. 177 | unfold_sub. 178 | rewrite <- 2 cat_assoc. 179 | rewrite <- cat_case. rewrite cat_assoc. 180 | reflexivity. 181 | Qed. 182 | 183 | Context 184 | {Iterative_C : Iterative C bif}. 185 | 186 | Global Instance Iterative_sub : Iterative sub sbif. 187 | Proof. 188 | constructor; red; intros. 189 | all: unfold Morphisms.respectful; unfold_sub. 190 | - rewrite iter_unfold, cat_assoc at 1. reflexivity. 191 | - rewrite bimap_sub_unfold. 192 | rewrite !(cat_assoc to_bif). 193 | rewrite <- (cat_assoc (C := C) f). 194 | rewrite cat_assoc, (cat_assoc _ from_bif). 195 | rewrite (semi_iso _ _), cat_id_r. 196 | rewrite iter_natural. 197 | reflexivity. 198 | - rewrite <- !(cat_assoc _ to_bif). 199 | rewrite !(cat_assoc _ _ to_bif). 200 | rewrite !cat_case. 201 | rewrite !(cat_assoc _ from_bif), !(semi_iso _ _), !cat_id_r. 202 | rewrite iter_dinatural. 203 | reflexivity. 204 | - rewrite <- !(cat_assoc _ to_bif). 205 | rewrite (cat_assoc _ _ to_bif). 206 | rewrite cat_case, cat_id_l. 207 | rewrite (cat_assoc _ _ to_bif), (semi_iso _ _), cat_id_r. 208 | rewrite iter_natural, iter_codiagonal. 209 | rewrite (cat_assoc _ (bimap _ _)), bimap_case, cat_id_l, cat_id_r. 210 | reflexivity. 211 | - intros; unfold iter, Iter_sub. 212 | apply iterative_proper_iter, category_proper_cat; auto; reflexivity. 213 | Qed. 214 | 215 | End CoproductLaws. 216 | 217 | End Subcategory. 218 | 219 | Arguments subm {obj C sobj Embed a b}. 220 | Arguments unsubm {obj C sobj Embed a b}. 221 | Arguments to_bif {_ C _ _ _ _ _ a b}. 222 | Arguments from_bif {_ C _ _ _ _ _ a b}. 223 | --------------------------------------------------------------------------------