├── .gitignore ├── .gitmodules ├── Makefile ├── README.md ├── _CoqProject ├── coq-pipes.bib ├── coq-pipes.tex ├── fixtex.pl ├── split.pl └── src ├── Pipes.v └── Pipes ├── Core.v ├── Extras.v ├── Internal.v ├── Lift.v └── Prelude.v /.gitignore: -------------------------------------------------------------------------------- 1 | .*.aux 2 | .coq-native/ 3 | *.d 4 | *.vo 5 | *.glob 6 | /Makefile.coq 7 | /extract 8 | *.v.d 9 | *.v.tex 10 | *.aux 11 | *.log 12 | /coqdoc.sty 13 | /html/ 14 | /Makefile.coq 15 | /coq-pipes.bbl 16 | /coq-pipes.blg 17 | /coq-pipes.idx 18 | /coq-pipes.ilg 19 | /coq-pipes.ind 20 | /coq-pipes.out 21 | /coq-pipes.pdf 22 | /coq-pipes.toc 23 | /latex/ 24 | coqdoc.sty 25 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "Hask"] 2 | path = Hask 3 | url = git://github.com/jwiegley/coq-haskell.git 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MODULES_NODOC = 2 | MODULES_PROSE = 3 | MODULES_CODE = src/Pipes/Internal src/Pipes/Core src/Pipes 4 | MODULES_DOC = $(MODULES_PROSE) $(MODULES_CODE) 5 | MODULES = $(MODULES_NODOC) $(MODULES_DOC) 6 | TEX = $(MODULES:%=%.v.tex) 7 | BIB_FILES = coq-pipes.bib 8 | BIBLIOGRAPHIES = coq-pipes.pdf 9 | BIBLIOGRAPHIES_bbl = $(BIBLIOGRAPHIES:=.bbl) 10 | BIBLIOGRAPHIES_aux = $(BIBLIOGRAPHIES:=.aux) 11 | LATEX_FILES = $(wildcard *.tex src/*.tex src/Pipes/*.tex) 12 | VFILES = $(wildcard src/*.v src/Pipes/*.v) 13 | VOFILES = $(patsubst %.v,%.vo,$(VFILES)) 14 | 15 | COQFLAGS = "" 16 | 17 | MISSING = find src -name '*.v' \ 18 | \( \ 19 | ! -name Extract.v \ 20 | -print \ 21 | \) | \ 22 | xargs egrep -i -Hn '(abort|admit|undefined)' | \ 23 | egrep -v 'Definition undefined' 24 | 25 | all: $(VOFILES) 26 | $(MISSING) || exit 0 27 | 28 | %.vo: %.v Makefile.coq 29 | $(MAKE) -f Makefile.coq OPT=$(COQFLAGS) 30 | 31 | %.v.tex: %.v %.glob 32 | coqdoc --interpolate --latex --utf8 --body-only --light \ 33 | --external https://github.com/jwiegley/coq-pipes P \ 34 | --external https://github.com/jwiegley/coq-haskell Hask \ 35 | -s $*.v -o $*.v.tex 36 | 37 | coq-pipes.pdf: coq-pipes.tex $(TEX) coq-pipes.bib src/coqdoc.sty 38 | mkdir -p latex/Pipes/Internal 39 | (cd latex/Pipes/Internal; \ 40 | perl ../../../split.pl ../../../src/Pipes/Internal.v.tex; \ 41 | for i in *.tex; do perl ../../../fixtex.pl $$i > t; mv t $$i; done) 42 | perl -i -pe 's/\\~{}/∼/g;' src/*.v.tex src/Pipes/*.v.tex 43 | perl -i -pe 's/\\\^{}\\coqdocvar{op}/\\textsuperscript{op}/g;' \ 44 | src/*.v.tex src/Pipes/*.v.tex 45 | perl -i -pe 's#\\\^{}\\coqexternalref{op}{https://github.com/jwiegley/coq-pipes}{\\coqdocdefinition{op}}#\\textsuperscript{op}#g;' \ 46 | src/*.v.tex src/Pipes/*.v.tex 47 | cp -p src/coqdoc.sty . 48 | perl -i -pe 's/textit/texttt/;' coqdoc.sty 49 | while (xelatex -shell-escape coq-pipes && \ 50 | grep -q "Rerun to get" coq-pipes.log ) do true ; \ 51 | done 52 | 53 | %.aux: $(LATEX_FILES) $(BIB_FILES) 54 | xelatex -shell-escape coq-pipes 55 | 56 | %.bbl : $(BIB_FILES) $(BIBLIOGRAPHIES_aux) 57 | bibtex $(@:.bbl=) 58 | 59 | Makefile.coq: _CoqProject 60 | coq_makefile -f _CoqProject -o $@ 61 | 62 | clean: Makefile.coq 63 | $(MAKE) -f Makefile.coq clean 64 | git clean -dfX 65 | find src -depth -name .coq-native -exec rm -fr {} \; 66 | rm -fr latex 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Proof of the Pipes Laws 2 | 3 | This is a formalization in Coq of the Haskell 4 | [pipes](http://hackage.haskell.org/package/pipes) library. Nearly all its 5 | functions have been implemented, and the laws mentioned in the documentation 6 | proven. It relies on the 7 | [coq-haskell](https://github.com/jwiegley/coq-haskell) project, whose aim is 8 | to simplify both the transcoding of Haskell types and functions into Coq, and 9 | the extraction of proven algorithms back into Haskell. 10 | 11 | Much gratitude is given to Gabriel Gonzalez for dialoging with me about this 12 | project over the long months of its inception, and for his 13 | [manual proofs](http://www.haskellforall.com/2013/10/manual-proofs-for-pipes-laws.html) 14 | of the laws, which were an excellent reference. Thanks are also due to Paolo 15 | Capriotti and Dan Burton, with whom I never interacted, but who where the 16 | spiritual fathers of this formalization effort. 17 | 18 | ## Laws proven 19 | 20 | **43** laws were proven, with 7 requiring a compromise documented below. These 21 | are indicated with **bolded** leaders in the following list (all of those 22 | are proofs involving either of the functions `push` or `pull`). 23 | 24 | ### Klesli category 25 | 26 | - Obligation [`functor_1`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L95) 27 | - Obligation [`functor_2`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L96) 28 | 29 | - Obligation [`applicative_1`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L100) 30 | - Obligation [`applicative_2`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L101) (* 3-5 proven by inference *) 31 | 32 | - Obligation [`monad_1`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L109) 33 | - Obligation [`monad_2`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L110) 34 | - Obligation [`monad_4`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Internal.v#L111) (* 3 proven by inference *) 35 | 36 | ### Respond category 37 | 38 | - Theorem [`respond_distrib`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L184) : `(f >=> g) />/ h = (f />/ h) >=> (g />/ h)` 39 | 40 | - Obligation [`(* Right identity: Respond *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L201) 41 | - Obligation [`(* Left identity: Respond *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L205) 42 | - Obligation [`(* Associativity: Respond *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L208) 43 | 44 | - Corollary [`respond_zero`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L213) : `pure />/ f = pure` 45 | 46 | ### Request category 47 | 48 | - Theorem [`request_distrib`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L226) : `h \>\ (f >=> g) = (h \>\ f) >=> (h \>\ g)` 49 | 50 | - Obligation [`(* Right identity: Request *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L243) 51 | - Obligation [`(* Left identity: Request *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L246) 52 | - Obligation [`(* Associativity: Request *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L249) 53 | 54 | - Corollary [`request_zero`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L254) : `f \>\ pure = pure` 55 | 56 | ### Push category 57 | 58 | - Lemma [`push_request`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L292) : `Request x g >>~ f = Request x (g >~> f)` 59 | - Lemma [`push_m`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L298) : `M g h >>~ f = M (g >~> f) h` 60 | 61 | - **Obligation** [`(* Right identity: Push *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L312) 62 | - **Obligation** [`(* Left identity: Push *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L321) 63 | - Obligation [`(* Associativity: Push *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L331) 64 | 65 | ### Pull category 66 | 67 | - Lemma [`pull_respond`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L358) : `f +>> Respond x g = Respond x (f >+> g)` 68 | - Lemma [`pull_m`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L364) : `f +>> M g h = M (f >+> g) h` 69 | 70 | - **Obligation** [`(* Right identity: Pull *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L378) 71 | - **Obligation** [`(* Left identity: Pull *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L388) 72 | - Obligation [`(* Associativity: Pull *)`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L399) 73 | 74 | - **Theorem** [`push_pull_assoc`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L418) : `(f >+> g) >~> h = f >+> (g >~> h)` 75 | 76 | ### Duals 77 | 78 | - Theorem [`request_id`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L453) : `reflect \o request = respond` 79 | - Theorem [`reflect_distrib`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L456) : `reflect (f x >>= g) = reflect (f x) >>= (reflect \o g)` 80 | - Theorem [`request_comp`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L466) : `reflect \o (f \>\ g) = (reflect \o g) />/ (reflect \o f)` 81 | - Theorem [`respond_id`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L475) : `reflect \o respond = request` 82 | - Theorem [`respond_comp`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L478) : `reflect \o (f />/ g) = (reflect \o g) \>\ (reflect \o f)` 83 | - Corollary [`distributivity`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L496) : `reflect \o (f >=> g) = (reflect \o f) >=> (reflect \o g)` 84 | - Theorem [`zero_law`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L502) : `reflect \o pure = pure` 85 | - Theorem [`involution`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Core.v#L505) : `reflect \o reflect = id` 86 | 87 | ### General theorems 88 | 89 | - Theorem [`for_yield_f`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes.v#L72) : `forP (yield x) f = f x` 90 | - Theorem [`for_yield`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes.v#L81) : `forP s yield = s` 91 | - Theorem [`nested_for_a`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes.v#L90) : `forP s (fun a => forP (f a) g) = forP (forP s f) g` 92 | - Theorem [`nested_for_b`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes.v#L104) : `forP (forP s f) g = forP s (f />/ g)` 93 | 94 | ### Prelude functions 95 | 96 | - **Theorem** [`map_id`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Prelude.v#L351) : `map id = cat` 97 | - **Theorem** [`map_compose`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Prelude.v#L360) : `map (g \o f) = map f >-> map g` 98 | 99 | - Theorem [`toListM_each_id`](https://github.com/jwiegley/coq-pipes/blob/master/src/Pipes/Prelude.v#L387) : `toListM \o each = pure` 100 | 101 | ## The Compromise 102 | 103 | `push` and `pull` are necessarily infinite functions. However, representing 104 | them as co-fixpoints makes some other things impossible (for example, 105 | `runEffect` must be a fixpoint). So rather than splitting up the development, 106 | a balance was struck. This compromise is three-fold: 107 | 108 | 1. `push` and `pull` are implemented in terms of "fuel". When fuel 109 | is exhausted, they return `Pure someDefault`. 110 | 111 | 2. An axiom is added such that there is always fuel (i.e., `fuel > 0`). 112 | 113 | 3. A second axiom is added to assert that a "step" of `push` or `pull` 114 | at fuel `N` behaves identically to that at fuel `N+1`. (i.e., 115 | `forall n, n > 0 -> push (fuel:=n) = push (fuel:=n.+1)`) 116 | 117 | This allows `push` and `pull` to be defined inductively, but used in a context 118 | where the "base case" cannot be reached, making them infinite for the purposes 119 | of proof. 120 | 121 | ## History of this work 122 | 123 | **2013 Oct 6**, Gabriel made his hand-written proofs of the `pipes` laws 124 | public. Dan Burton commented that someone should mechanize them in Agda. 125 | Gabriel mentioned he had started down that road already, with help from Paolo 126 | Capriotti. 127 | 128 | **2013 Oct 7**, I also began trying to encode the laws in Agda, so Gabriel and 129 | I began discussing the problems of strict positivity regarding the `Proxy` 130 | type. 131 | 132 | **2014 Nov 16**, after letting the project lie for a while, I started playing 133 | around with teasing `Proxy` into a functor `ProxyF` under the free monad. 134 | Gabriel tells me this is exactly what `pipes` 2.4.0 did, so with that 135 | confirmation I started down the road of how to encode free monads in Coq. I 136 | made the switch to Coq after being inspired by talks at 137 | [OPLSS 2014](https://www.cs.uoregon.edu/research/summerschool/summer14/curriculum.html), 138 | and because I was using it for a large project at work. 139 | 140 | Over the next few months I read several papers by Conor McBride suggesting the 141 | use of *container types*, even 142 | [formalizing](https://github.com/jwiegley/coq-haskell/blob/master/research/Conor.v) 143 | most of his paper 144 | [Kleisli Arrows of Outrageous Fortune](https://personal.cis.strath.ac.uk/conor.mcbride/Kleisli.pdf). 145 | This, plus 146 | [comments](https://github.com/jwiegley/notes/blob/master/agda-free-monad-trick.md) 147 | made by [Paolo Capriotti](http://www.paolocapriotti.com), gave me much food 148 | for thought, although little code was written. 149 | 150 | Around **2015 Mar 1** I read an old paper by 151 | [Venanzio Capretta](http://www.duplavis.com/venanzio/) on 152 | [Universal Algebra in Type Theory](http://www.duplavis.com/venanzio/publications/Universal_Algebra_TPHOLs_1999.pdf) 153 | which made container types far more comprehensible to me, thus energizing me 154 | to consider this project again. 155 | 156 | **2015 May 30**, After a few weeks of trying various free monad encodings 157 | based on container types and universal algebra, I stumbled across a trick 158 | Edward Kmett used for his 159 | [Boehm-Berarducci encoding of the free monad transformer](https://github.com/ekmett/free/issues/86). 160 | It turns out that although he did this to improve GHC roles for an applied 161 | functor, it also solves the strict positivity issue in Coq! 162 | 163 | **2015 May 31**, With this trick in hand, I was able to transcode most of the 164 | `pipes` library directly from Haskell, requiring only minor syntactic 165 | variations to adapt it to the Gallina language. With those done, the laws were 166 | relatively easy, falling into place over a two week period. 167 | 168 | **2015 Jun 12**, all of the laws are complete. 169 | 170 | So in all it took 1.5 years to learn Coq well enough and to find the right 171 | abstraction, and 2 weeks to do the actual work. 172 | 173 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R src P 2 | src/Pipes.v 3 | src/Pipes/Core.v 4 | src/Pipes/Internal.v 5 | src/Pipes/Prelude.v 6 | src/Pipes/Extras.v 7 | -------------------------------------------------------------------------------- /coq-pipes.bib: -------------------------------------------------------------------------------- 1 | @Book{Categories, 2 | author = "Saunders Mac Lane", 3 | title = "Categories for the Working Mathematician", 4 | year = "1998", 5 | publisher = "Springer" 6 | } 7 | 8 | @Book{Awodey, 9 | author = "Steve Awodey", 10 | title = "Category Theory", 11 | year = "2010", 12 | publisher = "Oxford University Press" 13 | } 14 | 15 | @Book{TAPL, 16 | author = "Benjamin C. Pierce", 17 | title = "Types and Programming Languages", 18 | year = "2002", 19 | publisher = "MIT Press" 20 | } 21 | 22 | @Book{Piton, 23 | author={J Strother Moore}, 24 | title = {Piton: A Mechanically Verified Assembly-Level Language}, 25 | year = "1996", 26 | series = "Automated Reasoning Series", 27 | publisher = "Kluwer Academic Publishers" 28 | } 29 | 30 | @Article{AMD, 31 | author = {J Strother Moore and Tom Lynch and Matt Kaufmann}, 32 | title = {A Mechanically Checked Proof of the Correctness of the Kernel of the {AMD5k86} Floating-Point Division Algorithm}, 33 | journal = {IEEE Transactions on Computers}, 34 | volume = {47(9)}, 35 | pages = {913--926}, 36 | year = {1998} 37 | } 38 | 39 | @InBook{deriving, 40 | title = "Haskell 98 Language and Libraries: The Revised Report", 41 | author = "Simon {Peyton Jones} and Lennart Augustsson and Dave Barton and Brian Boutel and Warren Burton and Joseph Fasel and Kevin Hammond and Ralf Hinze and Paul Hudak and John Hughes and Thomas Johnsson and Mark Jones and John Launchbury and Erik Meijer and John Peterson and Alastair Reid and Colin Runciman and Philip Wadler", 42 | year = "1998", 43 | chapter = "4.3.3", 44 | url = {http://www.haskell.org/onlinereport/decls.html#derived-decls} 45 | } 46 | -------------------------------------------------------------------------------- /coq-pipes.tex: -------------------------------------------------------------------------------- 1 | \documentclass[12pt]{article} 2 | 3 | \usepackage{xltxtra} 4 | \defaultfontfeatures{Ligatures=TeX} 5 | \usepackage{fontspec} 6 | \usepackage{xcolor} 7 | \usepackage{fullpage} 8 | \usepackage[color]{coqdoc} 9 | \usepackage{amsmath,amssymb} 10 | \usepackage{url} 11 | \usepackage{makeidx,hyperref} 12 | \usepackage{minted} 13 | \usepackage{changepage} 14 | 15 | \newcommand{\naive}[0]{na\"ive} 16 | \newcommand{\pipes}{\texttt{pipes}} 17 | 18 | \title{Formalizing Pipes in Coq} 19 | \author{John Wiegley \and Gabriel Gonzalez} 20 | 21 | \makeindex 22 | 23 | \begin{document} 24 | 25 | \setlength{\parskip}{0.5ex} 26 | \maketitle 27 | 28 | \thispagestyle{empty} 29 | \mbox{}\vfill 30 | \begin{center} 31 | 32 | Copyright John Wiegley 2015. 33 | 34 | 35 | This work is licensed under a 36 | Creative Commons Attribution-Noncommercial-No Derivative Works 3.0 37 | Unported License. 38 | The license text is available at: 39 | 40 | \end{center} 41 | 42 | \begin{center} \url{http://creativecommons.org/licenses/by-nc-nd/3.0/} \end{center} 43 | 44 | \phantomsection 45 | \tableofcontents 46 | 47 | \section{Introduction} 48 | 49 | %\include{Intro.v} 50 | 51 | \section{Pipes.Internal} 52 | 53 | The first step toward formalization is to transport the core \pipes{} 54 | \verb|Proxy| type into Coq. This represents a difficulty since the Haskell 55 | type is not strictly positive: 56 | 57 | \begin{adjustwidth}{2em}{} 58 | \begin{minted}{haskell} 59 | data Proxy a' a b' b m r 60 | = Request a' (a -> Proxy a' a b' b m r ) 61 | | Respond b (b' -> Proxy a' a b' b m r ) 62 | | M (m (Proxy a' a b' b m r)) 63 | | Pure r 64 | \end{minted} 65 | \end{adjustwidth} 66 | 67 | To work around this, the contravariant Yoneda lemma is used, made applicable 68 | to covariant functors by exchanging the universally quantified function it 69 | represents to an existentially quantified pairing: 70 | 71 | \begin{adjustwidth}{2em}{} 72 | \usemintedstyle{friendly} 73 | \begin{minted}{coq} 74 | Inductive Proxy (a' a b' b : Type) (m : Type -> Type) (r : Type) := 75 | | Request of a' & (a -> Proxy a' a b' b m r) 76 | | Respond of b & (b' -> Proxy a' a b' b m r) 77 | | M x of (x -> Proxy a' a b' b m r) & m x 78 | | Pure of r. 79 | \end{minted} 80 | \end{adjustwidth} 81 | 82 | \section{Pipes.Core} 83 | 84 | %\include{src/Pipes/Core.v} 85 | 86 | \section{Pipes} 87 | 88 | %\include{src/Pipes.v} 89 | 90 | \clearpage 91 | \addcontentsline{toc}{section}{Bibliography} 92 | \bibliographystyle{plain} 93 | \bibliography{coq-pipes} 94 | 95 | \clearpage 96 | \addcontentsline{toc}{section}{Index} 97 | \printindex 98 | 99 | \end{document} 100 | -------------------------------------------------------------------------------- /fixtex.pl: -------------------------------------------------------------------------------- 1 | undef $/; 2 | 3 | while () { 4 | s/(\\coqdocemptyline\n)*\\coqdocnoindent\n$//; 5 | print $_; 6 | } 7 | -------------------------------------------------------------------------------- /split.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | my $out; 4 | 5 | while () { 6 | if ( /^\\coqdockw{([A-Z].+?)} \\coqdocvar{(.+?)}/ ) { 7 | my $name = $2; 8 | $name =~ s/\\_/_/g; 9 | print "Writing $1 definition $name...\n"; 10 | open $out, '>', "${name}.tex" or die $!; 11 | } 12 | print $out $_ if $out; 13 | } 14 | -------------------------------------------------------------------------------- /src/Pipes.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Data.Functor.Identity. 4 | Require Export P.Pipes.Core. 5 | Require Export P.Pipes.Internal. 6 | 7 | Generalizable All Variables. 8 | 9 | Definition yield {a x' x m} (z : a) : Proxy x' x unit a m unit := 10 | let go : Producer' a m unit := fun _ _ => respond z in @go x' x. 11 | 12 | Notation "f ~> g" := (f />/ g) (at level 70). 13 | Notation "f <~ g" := (g ~> f) (at level 70). 14 | 15 | Definition await {a y' y m} : Proxy unit a y' y m a := 16 | let go : Consumer' a m a := fun _ _ => request tt in @go y' y. 17 | 18 | Notation "x >~ y" := ((fun _ : unit => x) >\\ y) (at level 70). 19 | Notation "x ~< y" := (y >~ x) (at level 70). 20 | 21 | Section Cat. 22 | 23 | Variable n : nat. 24 | Variable r : Type. 25 | Variable d : r. 26 | 27 | Definition cat `{Monad m} {a} : Pipe a a m r := 28 | pull (n:=n) (default:=d) tt. 29 | 30 | End Cat. 31 | 32 | Arguments cat {n r d m H a}. 33 | 34 | Definition connect `{Monad m} `(p1 : Proxy a' a unit b m r) 35 | `(p2 : Proxy unit b c' c m r) : Proxy a' a c' c m r := 36 | (fun _ : unit => p1) +>> p2. 37 | 38 | Notation "x >-> y" := (connect x y) (at level 60). 39 | Notation "x <-< y" := (y >-> x) (at level 60). 40 | 41 | Fixpoint next `{Monad m} `(p : Producer a m r) : 42 | m (Either r (a * Producer a m r)) := 43 | match p with 44 | | Request v _ => False_rect _ v 45 | | Respond a fu => return_ $ Right (a, fu tt) 46 | | M _ g h => h >>= (next \o g) 47 | | Pure r => return_ $ Left r 48 | end. 49 | 50 | Definition each `{Monad m} {a} (xs : seq a) : Producer' a m unit := 51 | fun _ _ => mapM_ yield xs. 52 | Arguments each {m _ a} xs {_ _}. 53 | 54 | Definition discard `{Monad m} {a} : a -> m unit := fun _ => return_ tt. 55 | 56 | Definition every `{Monad m} `(xs : seq a) : Producer' a m unit := 57 | fun _ _ => foldM (const yield) tt xs. 58 | Arguments every {m _ a} xs {_ _}. 59 | 60 | (**************************************************************************** 61 | * 62 | * General theorems about functions in the pipes library. 63 | *) 64 | 65 | Module PipesLaws. 66 | 67 | Include PipesLawsCore. 68 | 69 | Require Import FunctionalExtensionality. 70 | 71 | (* Looping over a single yield simplifies to function application *) 72 | Theorem for_yield_f `{MonadLaws m} : 73 | forall `(f : b -> Proxy x' x c' c m unit) x, 74 | forP (yield x) f = f x. 75 | Proof. 76 | move=> *. 77 | by rewrite /yield /respond /= /bind /funcomp join_fmap_pure_x. 78 | Qed. 79 | 80 | (* Re-yielding every element of a stream returns the original stream *) 81 | Theorem for_yield `{MonadLaws m} : forall `(s : Proxy x' x unit b m unit), 82 | forP s yield = s. 83 | Proof. 84 | move=> ? ? ?. 85 | by reduce_proxy IHx (rewrite /yield /respond /= /bind /=). 86 | Qed. 87 | 88 | (* Nested for loops can become a sequential for loops if the inner loop 89 | body ignores the outer loop variable *) 90 | Theorem nested_for_a `{MonadLaws m} : 91 | forall `(s : Proxy x' x b' b m a') 92 | `(f : b -> Proxy x' x c' c m b') 93 | `(g : c -> Proxy x' x d' d m c'), 94 | forP s (fun a => forP (f a) g) = forP (forP s f) g. 95 | Proof. 96 | move=> ? ? ? ? ? s *. 97 | move: s. 98 | reduce_proxy IHx simpl. 99 | rewrite respond_distrib. 100 | move/functional_extensionality in IHx. 101 | by rewrite -IHx. 102 | Qed. 103 | 104 | Theorem nested_for_b `{MonadLaws m} : 105 | forall `(s : Proxy x' x b' b m a') 106 | `(f : b -> Proxy x' x c' c m b') 107 | `(g : c -> Proxy x' x d' d m c'), 108 | forP (forP s f) g = forP s (f />/ g). 109 | Proof. 110 | move=> ? ? ? ? ? s *. 111 | move: s. 112 | reduce_proxy IHx simpl. 113 | rewrite respond_distrib. 114 | move/functional_extensionality in IHx. 115 | by rewrite IHx. 116 | Qed. 117 | 118 | End PipesLaws. 119 | -------------------------------------------------------------------------------- /src/Pipes/Core.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Data.Functor.Identity. 4 | Require Import P.Pipes.Internal. 5 | 6 | Generalizable All Variables. 7 | 8 | Fixpoint runEffect `{Monad m} `(p : Proxy False unit unit False m r) : m r := 9 | match p with 10 | | Request v f => False_rect _ v 11 | | Respond v f => False_rect _ v 12 | | M _ f t => t >>= (runEffect \o f) 13 | | Pure r => pure r 14 | end. 15 | 16 | Definition respond {x' x a' a m} (z : a) : Proxy x' x a' a m a' := 17 | Respond z Pure. 18 | 19 | Definition forP `{Monad m} {x' x a' b' b c' c} (p0 : Proxy x' x b' b m a') 20 | (fb : b -> Proxy x' x c' c m b') : Proxy x' x c' c m a' := 21 | let fix go p := match p with 22 | | Request x' fx => Request x' (go \o fx) 23 | | Respond b fb' => fb b >>= (go \o fb') 24 | | M _ f t => M (go \o f) t 25 | | Pure a => Pure a 26 | end in 27 | go p0. 28 | 29 | Notation "x //> y" := (forP x y) (at level 60). 30 | 31 | Notation "f />/ g" := (fun a => f a //> g) (at level 60). 32 | 33 | Definition request {x' x a' a m} (z : x') : Proxy x' x a' a m x := 34 | Request z Pure. 35 | 36 | Definition rofP `{Monad m} {y' y a' a b' b c} (fb' : b' -> Proxy a' a y' y m b) 37 | (p0 : Proxy b' b y' y m c) : Proxy a' a y' y m c := 38 | let fix go p := match p with 39 | | Request b' fb => fb' b' >>= (go \o fb) 40 | | Respond x fx' => Respond x (go \o fx') 41 | | M _ f t => M (go \o f) t 42 | | Pure a => Pure a 43 | end in 44 | go p0. 45 | 46 | Notation "x >\\ y" := (rofP x y) (at level 60). 47 | 48 | Notation "f \>\ g" := (fun a => f >\\ g a) (at level 60). 49 | 50 | Definition push {a' a m r} {n : nat} {default : r} : 51 | a -> Proxy a' a a' a m r := 52 | let fix go n x := 53 | if n isn't S n' then Pure default else 54 | (Respond ^~ (Request ^~ @go n')) x 55 | in go n. 56 | 57 | (* Very strangly, if the order of [fb] and [p0] is reversed, then the right 58 | identity law for the push category will fail to complete with a universe 59 | inconsistency. *) 60 | Fixpoint pushR {a' a b' b c' c m r} (fb : b -> Proxy b' b c' c m r) 61 | (p0 : Proxy a' a b' b m r) {struct p0} : Proxy a' a c' c m r := 62 | match p0 with 63 | | Request a' fa => Request a' (pushR fb \o fa) 64 | | Respond b fb' => 65 | let fix go' p := match p with 66 | | Request b' fb => pushR fb (fb' b') 67 | | Respond c fc' => Respond c (go' \o fc') 68 | | M _ f t => M (go' \o f) t 69 | | Pure a => Pure a 70 | end in 71 | go' (fb b) 72 | | M _ f t => M (pushR fb \o f) t 73 | | Pure a => Pure a 74 | end. 75 | 76 | Notation "x >>~ y" := (pushR y x) (at level 60). 77 | 78 | Notation "f >~> g" := (fun a => f a >>~ g) (at level 60). 79 | 80 | Definition pull {a' a m r} {n : nat} {default : r} : 81 | a' -> Proxy a' a a' a m r := 82 | let fix go n x := 83 | if n isn't S n' then Pure default else 84 | (Request ^~ (Respond ^~ @go n')) x 85 | in go n. 86 | 87 | Fixpoint pullR {a' a b' b c' c m r} (fb' : b' -> Proxy a' a b' b m r) 88 | (p0 : Proxy b' b c' c m r) {struct p0} : Proxy a' a c' c m r := 89 | match p0 with 90 | | Request b' fb => 91 | let fix go' p := match p with 92 | | Request a' fa => Request a' (go' \o fa) 93 | | Respond b fb' => pullR fb' (fb b) 94 | | M _ f t => M (go' \o f) t 95 | | Pure a => Pure a 96 | end in 97 | go' (fb' b') 98 | | Respond c fc' => Respond c (pullR fb' \o fc') 99 | | M _ f t => M (pullR fb' \o f) t 100 | | Pure a => Pure a 101 | end. 102 | 103 | Notation "x +>> y" := (pullR x y) (at level 60). 104 | 105 | Notation "f >+> g" := (fun a => f +>> g a) (at level 60). 106 | 107 | Definition reflect `{Monad m} `(p : Proxy a' a b' b m r) : 108 | Proxy b b' a a' m r := 109 | let fix go p := match p with 110 | | Request a' fa => Respond a' (go \o fa) 111 | | Respond b fb' => Request b (go \o fb') 112 | | M _ g h => M (go \o g) h 113 | | Pure r => Pure r 114 | end in 115 | go p. 116 | 117 | Definition Effect := Proxy False unit unit False. 118 | Definition Producer := Proxy False unit unit. 119 | Definition Pipe (a b : Type) := Proxy unit a unit b. 120 | Definition Consumer (a : Type) := Proxy unit a unit False. 121 | Definition Client (a' a : Type) := Proxy a' a unit False. 122 | Definition Server := Proxy False unit. 123 | 124 | Definition Effect' m r := forall x' x y' y, Proxy x' x y' y m r. 125 | Definition Producer' b m r := forall x' x, Proxy x' x unit b m r. 126 | Definition Consumer' a m r := forall y' y, Proxy unit a y' y m r. 127 | Definition Client' a' a m r := forall y' y, Proxy a' a y' y m r. 128 | Definition Server' b' b m r := forall x' x, Proxy x' x b' b m r. 129 | 130 | Notation "f \<\ g" := (g />/ f) (at level 60, only parsing). 131 | Notation "f /\ f) (at level 60, only parsing). 132 | Notation "f <~< g" := (g >~> f) (at level 60, only parsing). 133 | Notation "f <+< g" := (g >+> f) (at level 60, only parsing). 134 | Notation "f f) (at level 60, only parsing). 135 | Notation "x //< f" := (f >\\ x) (at level 60, only parsing). 136 | Notation "f ~<< x" := (x >>~ f) (at level 60, only parsing). 137 | Notation "x <<+ f" := (f +>> x) (at level 60, only parsing). 138 | 139 | (**************************************************************************** 140 | **************************************************************************** 141 | ** ** 142 | ** Proofs of the pipes categories and laws ** 143 | ** ** 144 | **************************************************************************** 145 | ****************************************************************************) 146 | 147 | Module PipesLawsCore. 148 | 149 | Include PipesLawsInternal. 150 | 151 | Require Import Hask.Control.Category. 152 | Require Import FunctionalExtensionality. 153 | 154 | (**************************************************************************** 155 | * 156 | * Respond Category 157 | *) 158 | 159 | Ltac applying_monad_laws IHx X := 160 | rewrite ?/kleisli_compose; 161 | move: X; 162 | reduce_proxy IHx 163 | (first [ apply functional_extensionality in IHx; 164 | by rewrite /= /funcomp IHx /bind /funcomp 165 | -join_fmap_fmap_x fmap_comp_x 166 | -join_fmap_join_x fmap_comp_x 167 | | rewrite /bind /= ]). 168 | 169 | Ltac applying_theorem IHx X H := 170 | rewrite ?/kleisli_compose; 171 | move: X; 172 | reduce_proxy IHx 173 | (first [ apply functional_extensionality in IHx; 174 | by rewrite /= /funcomp -IHx H 175 | | rewrite /= ]). 176 | 177 | Ltac mere_extensionality IHx x f := 178 | extensionality x; 179 | move: (f x); 180 | reduce_proxy IHx (rewrite /= /bind /=). 181 | 182 | Section Respond. 183 | 184 | Theorem respond_distrib `{MonadLaws m} : 185 | forall (x' x a' a b' b c' c r : Type) 186 | (f : a -> Proxy x' x b' b m a') 187 | (g : a' -> Proxy x' x b' b m r) 188 | (h : b -> Proxy x' x c' c m b'), 189 | (f >=> g) />/ h =1 (f />/ h) >=> (g />/ h). 190 | Proof. 191 | move=> ? ? ? ? ? ? ? ? ? f ? ? x. 192 | by applying_monad_laws IHx (f x). 193 | Qed. 194 | 195 | Program Instance Respond_Category {x' x} `{MonadLaws m} : Category := { 196 | ob := Type * Type; 197 | hom := fun A B => snd A -> Proxy x' x (fst B) (snd B) m (fst A); 198 | c_id := fun A => @respond x' x (fst A) (snd A) m; 199 | c_comp := fun _ _ _ f g => g />/ f 200 | }. 201 | Obligation 1. (* Right identity *) 202 | extensionality z. 203 | exact: join_fmap_pure_x. 204 | Qed. 205 | Obligation 2. (* Left identity *) 206 | by mere_extensionality IHx z f. 207 | Qed. 208 | Obligation 3. (* Associativity *) 209 | extensionality z. 210 | by applying_theorem IHx (h z) respond_distrib. 211 | Qed. 212 | 213 | Corollary respond_zero `{MonadLaws m} : forall `(f : c -> Proxy a' a b' b m r), 214 | pure />/ f =1 @pure _ Proxy_Applicative r. 215 | Proof. by []. Qed. 216 | 217 | End Respond. 218 | 219 | (**************************************************************************** 220 | * 221 | * Request Category 222 | *) 223 | 224 | Section Request. 225 | 226 | Theorem request_distrib `{MonadLaws m} : 227 | forall (y' y a' a b' b c' c r : Type) 228 | (f : c -> Proxy b' b y' y m c') 229 | (g : c' -> Proxy b' b y' y m r) 230 | (h : b' -> Proxy a' a y' y m b), 231 | h \>\ (f >=> g) =1 (h \>\ f) >=> (h \>\ g). 232 | Proof. 233 | move=> ? ? ? ? ? ? ? ? ? f ? ? x. 234 | by applying_monad_laws IHx (f x). 235 | Qed. 236 | 237 | Program Instance Request_Category {x' x} `{MonadLaws m} : Category := { 238 | ob := Type * Type; 239 | hom := fun A B => fst A -> Proxy (fst B) (snd B) x' x m (snd A); 240 | c_id := fun A => @request (fst A) (snd A) x' x m; 241 | c_comp := fun _ _ _ f g => f \>\ g 242 | }. 243 | Obligation 1. (* Right identity *) 244 | by mere_extensionality IHx z f. 245 | Qed. 246 | Obligation 2. (* Left identity *) 247 | by mere_extensionality IHx z f. 248 | Qed. 249 | Obligation 3. (* Associativity *) 250 | extensionality z. 251 | by applying_theorem IHx (h z) request_distrib. 252 | Qed. 253 | 254 | Corollary request_zero `{MonadLaws m} : forall `(f : c -> Proxy a' a b' b m r), 255 | f \>\ pure =1 @pure _ Proxy_Applicative r. 256 | Proof. by []. Qed. 257 | 258 | End Request. 259 | 260 | (**************************************************************************** 261 | * 262 | * Push Category 263 | *) 264 | 265 | Tactic Notation "reduce_over" constr(f) ident(g) ident(y) ident(IHx) := 266 | move=> ? ? ? ? ? ? ? ? g ?; 267 | congr (f _ _); 268 | by mere_extensionality IHx y g. 269 | 270 | Module Compromise. 271 | 272 | Variable n : nat. 273 | Hypothesis Hn : n > 0. 274 | 275 | Variable r : Type. 276 | Variable d : r. 277 | 278 | Hypothesis Hpush : forall m a' a n d, 279 | @push a' a m r n d = @push a' a m r n.+1 d. 280 | 281 | Hypothesis Hpull : forall m a' a n d, 282 | @pull a' a m r n d = @pull a' a m r n.+1 d. 283 | 284 | Global Ltac assume_infinity := 285 | move: Hn; 286 | case E: n => // [n'] _. 287 | 288 | End Compromise. 289 | 290 | Module Push. 291 | 292 | Lemma push_request `{Monad m} : 293 | forall `(f : b -> Proxy b' b c' c m r) 294 | `(g : a -> Proxy a' a b' b m r) x, 295 | Request x g >>~ f = Request x (g >~> f). 296 | Proof. by reduce_over @Request g y IHx. Qed. 297 | 298 | Lemma push_m `{Monad m} : 299 | forall `(f : b -> Proxy b' b c' c m r) 300 | `(g : x -> Proxy a' a b' b m r) (h : m x), 301 | M g h >>~ f = M (g >~> f) h. 302 | Proof. by move=> x; reduce_over @M g y IHx. Qed. 303 | 304 | Include Compromise. 305 | 306 | Program Instance Push_Category `{MonadLaws m} : Category := { 307 | ob := Type * Type; 308 | hom := fun A B => snd B -> Proxy (fst B) (snd B) (fst A) (snd A) m r; 309 | c_id := fun A => @push (fst A) (snd A) m r n d; 310 | c_comp := fun _ _ _ f g => f >~> g 311 | }. 312 | Obligation 1. (* Right identity *) 313 | mere_extensionality IHx z f. 314 | assume_infinity. 315 | congr (Respond _ _). 316 | rewrite -/push Hpush. 317 | rewrite E in IHx. 318 | move/functional_extensionality in IHx. 319 | exact: IHx. 320 | Qed. 321 | Obligation 2. (* Left identity *) 322 | extensionality z. 323 | assume_infinity => /=. 324 | move: (f z). 325 | reduce_proxy IHx simpl. 326 | congr (Request _ _). 327 | rewrite /flip Hpush. 328 | extensionality w. 329 | by rewrite -IHx. 330 | Qed. 331 | Obligation 3. (* Associativity *) 332 | extensionality z. 333 | move: (f z) g h. 334 | reduce_proxy IHx 335 | (move=> g h; 336 | first [ rewrite 3!push_request; 337 | congr (Request _ _) 338 | | rewrite 3!push_m; 339 | congr (M _ _) 340 | | rewrite /= ]). 341 | move: (g _) h. 342 | reduce_proxy IHy (rewrite /= /flip /=) => h. 343 | - exact: IHx. 344 | - move: (h _). 345 | reduce_proxy IHz (rewrite /= /flip /=). 346 | exact: IHy. 347 | Qed. 348 | 349 | End Push. 350 | 351 | (**************************************************************************** 352 | * 353 | * Pull Category 354 | *) 355 | 356 | Module Pull. 357 | 358 | Lemma pull_respond `{Monad m} : 359 | forall `(f : b' -> Proxy a' a b' b m r) 360 | `(g : c' -> Proxy b' b c' c m r) x, 361 | f +>> Respond x g = Respond x (f >+> g). 362 | Proof. reduce_over @Respond g y IHx. Qed. 363 | 364 | Lemma pull_m `{Monad m} : 365 | forall x `(f : b' -> Proxy a' a b' b m r) 366 | `(g : x -> Proxy b' b c' c m r) (h : m x), 367 | f +>> M g h = M (f >+> g) h. 368 | Proof. move=> x; reduce_over @M g y IHx. Qed. 369 | 370 | Include Push. 371 | 372 | Program Instance Pull_Category `{MonadLaws m} : Category := { 373 | ob := Type * Type; 374 | hom := fun A B => fst A -> Proxy (fst B) (snd B) (fst A) (snd A) m r; 375 | c_id := fun A => @pull (fst A) (snd A) m r n d; 376 | c_comp := fun _ _ _ f g => f >+> g 377 | }. 378 | Obligation 1. (* Right identity *) 379 | extensionality z. 380 | assume_infinity => /=. 381 | move: (f z). 382 | reduce_proxy IHx simpl. 383 | congr (Respond _ _). 384 | rewrite /flip Hpull. 385 | extensionality w. 386 | by rewrite -IHx. 387 | Qed. 388 | Obligation 2. (* Left identity *) 389 | extensionality z. 390 | move: (f z). 391 | reduce_proxy IHx simpl. 392 | assume_infinity. 393 | congr (Request _ _). 394 | rewrite -/pull Hpull. 395 | rewrite E in IHx. 396 | move/functional_extensionality in IHx. 397 | exact: IHx. 398 | Qed. 399 | Obligation 3. (* Associativity *) 400 | extensionality z. 401 | move: (h z) f g. 402 | reduce_proxy IHx 403 | (move=> f g; 404 | first [ rewrite 3!pull_request; 405 | congr (Respond _ _) 406 | | rewrite 3!push_m; 407 | congr (M _ _) 408 | | rewrite /= ]). 409 | rewrite /=. 410 | move: (g _) f. 411 | reduce_proxy IHy (rewrite /= /flip /=) => f. 412 | - move: (f _). 413 | reduce_proxy IHz (rewrite /= /flip /=). 414 | exact: IHy. 415 | - exact: IHx. 416 | Qed. 417 | 418 | Theorem push_pull_assoc `{MonadLaws m} : 419 | forall `(f : b' -> Proxy a' a b' b m r) 420 | `(g : a -> Proxy b' b c' c m r) 421 | (h : c -> Proxy c' c b' b m r), 422 | (f >+> g) >~> h =1 f >+> (g >~> h). 423 | Proof. 424 | move=> ? ? ? ? f ? ? g h ?. 425 | move: (g _) f h. 426 | reduce_proxy IHx 427 | (move=> f h; 428 | try (rewrite pull_m push_m push_m pull_m; 429 | congr (M _ _))) => //. 430 | - rewrite push_request /=. 431 | move: (f _) h. 432 | reduce_proxy IHy simpl => h. 433 | exact: IHx. 434 | - rewrite pull_respond /=. 435 | move: (h _) f. 436 | reduce_proxy IHy simpl => f. 437 | exact: IHx. 438 | Qed. 439 | 440 | End Pull. 441 | 442 | (**************************************************************************** 443 | * 444 | * Reflection (Duals) 445 | *) 446 | 447 | Section Duals. 448 | 449 | Variables a' a b' b r : Type. 450 | Variables m : Type -> Type. 451 | Context `{MonadLaws m}. 452 | 453 | Theorem request_id : reflect \o request =1 @respond a' a b' b m. 454 | Proof. move=> x; by congr (Respond _ _). Qed. 455 | 456 | Theorem reflect_distrib : 457 | forall (f : a -> Proxy a' a b' b m r) 458 | (g : r -> Proxy a' a b' b m r) (x : a), 459 | reflect (f x >>= g) = reflect (f x) >>= (reflect \o g). 460 | Proof. 461 | move=> f ? ?. 462 | move: (f _). 463 | by reduce_proxy IHx (rewrite /bind /=). 464 | Qed. 465 | 466 | Theorem request_comp : 467 | forall (f : a -> Proxy a' a b' b m r) 468 | (g : a -> Proxy a r b' b m r), 469 | reflect \o (f \>\ g) =1 (reflect \o g) />/ (reflect \o f). 470 | Proof. 471 | move=> ? g x /=. 472 | by applying_theorem IHx (g x) reflect_distrib. 473 | Qed. 474 | 475 | Theorem respond_id : reflect \o respond =1 @request a' a b' b m. 476 | Proof. by move=> ?; congr (Request _ _). Qed. 477 | 478 | Theorem respond_comp : 479 | forall (f : a -> Proxy a' a b' b m r) 480 | (g : b -> Proxy a' a b' b m b'), 481 | reflect \o (f />/ g) =1 (reflect \o g) \>\ (reflect \o f). 482 | Proof. 483 | move=> f g ? /=. 484 | move: (f _). 485 | by reduce_proxy IHx 486 | (first [ move/functional_extensionality in IHx; 487 | rewrite /= /funcomp -IHx; 488 | (* jww (2015-06-09): We should be able to use [reflect_distrib] 489 | here, but the types are not general enough, which means the 490 | types of some of these theorems may be insufficient. *) 491 | move: (g _); 492 | reduce_proxy IHy (rewrite /bind /=) 493 | | rewrite /= ]). 494 | Qed. 495 | 496 | Corollary distributivity : 497 | forall (f : a -> Proxy a' a b' b m r) 498 | (g : r -> Proxy a' a b' b m r), 499 | reflect \o (f >=[Proxy_Monad]=> g) =1 (reflect \o f) >=> (reflect \o g). 500 | Proof. exact: reflect_distrib. Qed. 501 | 502 | Theorem zero_law : @reflect m _ a' a b' b r \o pure =1 pure. 503 | Proof. by []. Qed. 504 | 505 | Theorem involution : @reflect m _ a' a b' b r \o reflect =1 id. 506 | Proof. by reduce_proxy IHx simpl. Qed. 507 | 508 | End Duals. 509 | 510 | End PipesLawsCore. -------------------------------------------------------------------------------- /src/Pipes/Extras.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import P.Pipes. 4 | 5 | Generalizable All Variables. 6 | 7 | (* [Sproxy] is a Boehm-Berarducci encoding of pipes' [Proxy] type. In Haskell 8 | it could be optimized further as follows: 9 | 10 | forall s. 11 | (a' -> (a -> m s) -> m s) 12 | -> (b -> (b' -> m s) -> m s) 13 | -> (r -> m s) 14 | -> m s) 15 | 16 | However, this will not work in Coq until use of Universe Polymorphism is 17 | applied throughout the coq-haskell library. *) 18 | 19 | Definition SProxy (a' a b' b : Type) (m : Type -> Type) (r : Type) : Type := 20 | forall s : Type, 21 | (a' -> (a -> s) -> s) (* SRequest *) 22 | -> (b -> (b' -> s) -> s) (* SRespond *) 23 | -> (forall x, (x -> s) -> m x -> s) (* SM *) 24 | -> (r -> s) (* SPure *) 25 | -> s. 26 | 27 | Definition toProxy `(s : SProxy a' a b' b m r) : Proxy a' a b' b m r := 28 | s _ Request Respond (fun _ => M) Pure. 29 | 30 | Definition fromProxy `(p : Proxy a' a b' b m r) : SProxy a' a b' b m r := 31 | fun _ req res mon pur => 32 | let fix go p := match p with 33 | | Request a' fa => req a' (go \o fa) 34 | | Respond b fb' => res b (go \o fb') 35 | | M _ g h => mon _ (go \o g) h 36 | | Pure x => pur x 37 | end in 38 | go p. 39 | 40 | Module SProxyLaws. 41 | 42 | Include PipesLaws. 43 | 44 | Require Import FunctionalExtensionality. 45 | 46 | Lemma SProxy_to_from : forall `(x : Proxy a' a b' b m r), 47 | toProxy (fromProxy x) = x. 48 | Proof. 49 | move=> a' a b' b m r. 50 | by reduce_proxy IHx 51 | (rewrite /toProxy; 52 | first [ congr (Request _) 53 | | congr (Respond _) 54 | | congr (M _) 55 | | congr (Pure _) ]). 56 | Qed. 57 | 58 | Axiom f_const : forall `(f : a -> (b -> s) -> s) (x : a) (y : s), 59 | f x (const y) = y. 60 | 61 | Definition const_f `(f : (b -> s) -> a -> s) (x : a) (y : s) : 62 | f (const y) x = y := f_const (flip f) x y. 63 | 64 | (* As [pur] is the only function that can produce an [s], it must be equal to 65 | reducing the [SProxy]. *) 66 | Axiom SProxy_parametricity : forall `(sp : SProxy a' a b' b m r) (s : Type) 67 | (req : a' -> (a -> s) -> s) 68 | (res : b -> (b' -> s) -> s) 69 | (mon : forall x, (x -> s) -> m x -> s) 70 | (pur : r -> s) (z : r), 71 | pur z = sp s req res mon pur. 72 | 73 | Lemma SProxy_from_to : forall `(x : SProxy a' a b' b m r), 74 | fromProxy (toProxy x) = x. 75 | Proof. 76 | move=> ? ? ? ? ? ? x. 77 | extensionality s. 78 | extensionality req. 79 | extensionality res. 80 | extensionality mon. 81 | extensionality pur. 82 | move: (toProxy x). 83 | reduce_proxy IHx 84 | (rewrite /fromProxy /funcomp /=; 85 | try (move/functional_extensionality in IHx; 86 | rewrite IHx ?f_const ?const_f)). 87 | exact: SProxy_parametricity. 88 | Qed. 89 | 90 | (* Induction hypothesis for the [SProxy] type. *) 91 | Theorem sproxy_ind : 92 | forall (a' a b' b : Type) (m : Type -> Type) (r : Type) 93 | (P : SProxy a' a b' b m r -> Prop), 94 | (forall (x : a') (f : a -> SProxy a' a b' b m r), 95 | P (fun s req res mon pur => req x (fun a => f a s req res mon pur))) -> 96 | (forall (x : b) (f : b' -> SProxy a' a b' b m r), 97 | P (fun s req res mon pur => res x (fun b' => f b' s req res mon pur))) -> 98 | (forall t (f : t -> SProxy a' a b' b m r) (x : m t), 99 | P (fun s req res mon pur => mon _ (fun x => f x s req res mon pur) x)) -> 100 | (forall (x : r), P (fun s _ _ _ pur => pur x)) -> 101 | forall p : SProxy a' a b' b m r, P p. 102 | Proof. 103 | move=> ? ? ? ? ? ? ? Hreq Hres Hmon Hpure p. 104 | rewrite -(SProxy_from_to p). 105 | by elim: (toProxy p) => [*|*|*|*]; 106 | [ exact: Hreq 107 | | exact: Hres 108 | | exact: Hmon 109 | | exact: Hpure ]. 110 | Qed. 111 | 112 | End SProxyLaws. 113 | -------------------------------------------------------------------------------- /src/Pipes/Internal.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Data.Functor.Identity. 4 | 5 | Generalizable All Variables. 6 | 7 | (**************************************************************************** 8 | * 9 | * Proxy 10 | * 11 | * This is almost identical to the equivalent Haskell type, except we have 12 | * applied the contravariant Yoneda lemma to satisfy Coq's strict positivity 13 | * requirement (made applicable to covariant functors by changing it from a 14 | * universally quantified function to an existentially quantified construction 15 | * of two arguments). Therefore, proof of equivalence follows from a proof 16 | * that [f a] is equivalent to [{ x & (x -> r, f x) }]. This proof may be 17 | * found in the coq-haskell project, in the module [Data.Functor.Yoneda]. 18 | *) 19 | 20 | Inductive Proxy (a' a b' b : Type) (m : Type -> Type) (r : Type) := 21 | | Request of a' & (a -> Proxy a' a b' b m r) 22 | | Respond of b & (b' -> Proxy a' a b' b m r) 23 | | M x of (x -> Proxy a' a b' b m r) & m x 24 | | Pure of r. 25 | 26 | Arguments Request {a' a b' b m r} _ _. 27 | Arguments Respond {a' a b' b m r} _ _. 28 | Arguments M {a' a b' b m r x} _ _. 29 | Arguments Pure {a' a b' b m r} _. 30 | 31 | (**************************************************************************** 32 | * 33 | * Fundamental code to operate with Proxy 34 | *) 35 | 36 | Definition foldProxy `{Monad m} 37 | `(ka : a' -> (a -> s) -> s) 38 | `(kb : b -> (b' -> s) -> s) 39 | (km : forall x, (x -> s) -> m x -> s) 40 | `(kp : r -> s) 41 | (p : Proxy a' a b' b m r) : s := 42 | let fix go p := match p with 43 | | Request a' fa => ka a' (go \o fa) 44 | | Respond b fb' => kb b (go \o fb') 45 | | M _ g h => km _ (go \o g) h 46 | | Pure r => kp r 47 | end in 48 | go p. 49 | 50 | (* This is equivalent to [foldProxy Request Respond (fun _ => M)], but using 51 | that definition makes some proofs harder. *) 52 | Definition Proxy_bind `{Monad m} 53 | `(f : c -> Proxy a' a b' b m d) (p0 : Proxy a' a b' b m c) : 54 | Proxy a' a b' b m d := 55 | let fix go p := match p with 56 | | Request a' fa => Request a' (go \o fa) 57 | | Respond b fb' => Respond b (go \o fb') 58 | | M _ f t => M (go \o f) t 59 | | Pure r => f r 60 | end in 61 | go p0. 62 | 63 | (* Proofs of the laws for these are below. *) 64 | Instance Proxy_Functor `{Monad m} {a' a b' b} : Functor (Proxy a' a b' b m) := { 65 | fmap := fun _ _ f => Proxy_bind (Pure \o f) 66 | }. 67 | 68 | Instance Proxy_Applicative `{Monad m} {a' a b' b} : 69 | Applicative (Proxy a' a b' b m) := { 70 | pure := fun _ => Pure; 71 | ap := fun _ _ pf px => Proxy_bind (fmap ^~ px) pf 72 | }. 73 | 74 | Instance Proxy_Monad `{Monad m} {a' a b' b} : Monad (Proxy a' a b' b m) := { 75 | join := fun _ => Proxy_bind id 76 | }. 77 | 78 | Module PipesLawsInternal. 79 | 80 | Include MonadLaws. 81 | 82 | Require Import FunctionalExtensionality. 83 | 84 | Tactic Notation "reduce_proxy" ident(IHx) tactic(T) := 85 | elim=> [? ? IHx|? ? IHx|? ? IHx ?| ?]; try T; 86 | try (f_equal; extensionality RP_A; exact: IHx). 87 | 88 | (**************************************************************************** 89 | * 90 | * Kleisli Category for Proxy a' a b' b m 91 | *) 92 | 93 | Program Instance Proxy_FunctorLaws `{MonadLaws m} {a' a b' b} : 94 | FunctorLaws (Proxy a' a b' b m). 95 | Obligation 1. by reduce_proxy IHx simpl. Qed. 96 | Obligation 2. by reduce_proxy IHx simpl. Qed. 97 | 98 | Program Instance Proxy_ApplicativeLaws `{MonadLaws m} {a' a b' b} : 99 | ApplicativeLaws (Proxy a' a b' b m). 100 | Obligation 1. by reduce_proxy IHx simpl. Qed. 101 | Obligation 2. 102 | move: u; reduce_proxy IHu (rewrite /funcomp /= /funcomp). 103 | move: v; reduce_proxy IHv (rewrite /funcomp /= /funcomp). 104 | by move: w; reduce_proxy IHw simpl. 105 | Qed. 106 | 107 | Program Instance Proxy_MonadLaws `{MonadLaws m} {a' a b' b} : 108 | MonadLaws (Proxy a' a b' b m). 109 | Obligation 1. by reduce_proxy IHx simpl. Qed. 110 | Obligation 2. by reduce_proxy IHx simpl. Qed. 111 | Obligation 4. by reduce_proxy IHx simpl. Qed. 112 | 113 | Require Import Hask.Control.Category. 114 | 115 | Program Instance Kleisli_Category {a' a b' b} `{MonadLaws m} : Category := { 116 | ob := Type; 117 | hom := fun A B => A -> Proxy a' a b' b m B; 118 | c_id := fun _ => pure; 119 | c_comp := fun _ _ _ f g => f <=< g 120 | }. 121 | Obligation 2. 122 | extensionality x. 123 | by rewrite /kleisli_compose /bind join_fmap_pure. 124 | Qed. 125 | Obligation 3. 126 | extensionality x. 127 | by rewrite /kleisli_compose /bind /funcomp 128 | -join_fmap_fmap_x -join_fmap_join_x !fmap_comp_x. 129 | Qed. 130 | 131 | End PipesLawsInternal. -------------------------------------------------------------------------------- /src/Pipes/Lift.v: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jwiegley/coq-pipes/ec4e7884dc2d2c1a55ee075103c964b4f65c7be6/src/Pipes/Lift.v -------------------------------------------------------------------------------- /src/Pipes/Prelude.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Control.Monad.Trans.Class. 4 | Require Import Hask.Data.Functor.Identity. 5 | Require Import P.Pipes. 6 | 7 | Generalizable All Variables. 8 | 9 | Section Bounded. 10 | 11 | Variable n : nat. 12 | Variable r : Type. 13 | Variable d : r. 14 | 15 | (* 16 | Instance Proxy_MonadTrans {a' a b' b} : MonadTrans (Proxy a' a b' b) := 17 | { lift := fun m _ _ A => @M a' a b' b m r A id 18 | }. 19 | 20 | Instance Proxy_MonadTransLaws {a' a b' b} : MonadTrans (Proxy a' a b' b) := 21 | { trans_law_1 := ; 22 | trans_law_2 := 23 | }. 24 | *) 25 | 26 | (* 27 | Definition repeatM `{Monad m} `(x : m a) : Producer' a m r := 28 | fun _ _ => lift x >~ cat (n:=n) (d:=d). 29 | 30 | replicateM :: Monad m => Int -> m a -> Producer' a m () 31 | replicateM n m = lift m >~ take n 32 | *) 33 | 34 | Definition drain `{Monad m} {a} : Consumer' a m r := 35 | fun _ _ => forP (cat (n:=n) (d:=d)) discard. 36 | 37 | Definition map `{Monad m} `(f : a -> b) : 38 | Pipe a b m r := forP (cat (n:=n) (d:=d)) (yield \o f). 39 | 40 | (* 41 | Definition mapM `{Monad m} (f : a -> m b) : Pipe a b m r := 42 | for cat $ fun a => do 43 | b <- lift (f a) ;; 44 | yield b. 45 | 46 | sequence :: Monad m => Pipe (m a) a m r 47 | sequence = mapM id 48 | *) 49 | 50 | Definition mapFoldable `{Monad m} `(f : a -> seq b) : Pipe a b m r := 51 | forP (cat (n:=n) (d:=d)) (fun x => each (f x) (x':=unit) (x:=a)). 52 | 53 | Definition filter `{Monad m} `(p : a -> bool) : Pipe a a m r := 54 | forP (cat (n:=n) (d:=d)) $ fun a => when (p a) (yield a). 55 | 56 | (* 57 | filterM :: Monad m => (a -> m Bool) -> Pipe a a m r 58 | filterM predicate = for cat $ \a -> do 59 | b <- lift (predicate a) 60 | when b (yield a) 61 | *) 62 | 63 | Definition take `{Monad m} (n' : nat) {a} : Pipe a a m unit := 64 | replicateM_ n' (await >>= yield). 65 | 66 | Fixpoint takeWhile `{Monad} `(p : a -> bool) {n : nat} {d : r} : 67 | Pipe a a m unit := 68 | if n isn't S n' then Pure tt else 69 | a <-- await ;; 70 | if p a 71 | then yield a >> takeWhile p (n:=n') (d:=d) 72 | else return_ tt. 73 | 74 | Definition drop `{Monad m} (n : nat) {a} : Pipe a a m r := 75 | replicateM_ n (await >> return_ tt) ;; 76 | cat (n:=n) (d:=d). 77 | 78 | Fixpoint dropWhile `{Monad m} `(p : a -> bool) {n : nat} {d : r} : 79 | Pipe a a m r := 80 | if n isn't S n' then Pure d else 81 | a <-- await ;; 82 | if p a 83 | then dropWhile p (n:=n') (d:=d) 84 | else yield a >> cat (n:=n) (d:=d). 85 | 86 | Definition concat `{Monad m} {a} : Pipe (seq a) a m r := 87 | forP (cat (n:=n) (d:=d)) (fun xs => each xs (x':=unit) (x:=seq a)). 88 | 89 | Fixpoint findIndices `{Monad m} `(p : a -> bool) : Pipe a nat m r := 90 | let fix loop i n := 91 | if n isn't S n' then Pure d else 92 | a <-- await ;; 93 | when (p a) (yield i) ;; 94 | loop (i + 1) n' in 95 | loop 0 n. 96 | 97 | Definition elemIndices `{Monad m} {a : eqType} (x : a) : Pipe a nat m r := 98 | findIndices (eq_op x). 99 | 100 | Definition scan `{Monad m} `(step : x -> a -> x) (begin : x) `(done : x -> b) : 101 | Pipe a b m r := 102 | let fix loop x n := 103 | if n isn't S n' then Pure d else 104 | yield (done x) ;; 105 | a <-- await ;; 106 | let x' := step x a in 107 | loop x' n' in 108 | loop begin n. 109 | 110 | (* 111 | scanM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r 112 | scanM step begin done = do 113 | x <- lift begin 114 | loop x 115 | where 116 | loop x = do 117 | b <- lift (done x) 118 | yield b 119 | a <- await 120 | x' <- lift (step x a) 121 | loop $! x' 122 | 123 | chain :: Monad m => (a -> m ()) -> Pipe a a m r 124 | chain f = for cat $ \a -> do 125 | lift (f a) 126 | yield a 127 | *) 128 | 129 | Definition fold `{Monad m} `(step : x -> a -> x) (begin : x) `(done : x -> b) 130 | (p0 : Producer a m unit) : m b := 131 | let fix loop p x := match p with 132 | | Request v _ => False_rect _ v 133 | | Respond a fu => loop (fu tt) (step x a) 134 | | M _ g h => h >>= fun p' => loop (g p') x 135 | | Pure _ => return_ (done x) 136 | end in 137 | loop p0 begin. 138 | 139 | Definition fold' `{Monad m} `(step : x -> a -> x) (begin : x) `(done : x -> b) 140 | (p0 : Producer a m r) : m (b * r)%type := 141 | let fix loop p x := match p with 142 | | Request v _ => False_rect _ v 143 | | Respond a fu => loop (fu tt) (step x a) 144 | | M _ g h => h >>= fun p' => loop (g p') x 145 | | Pure r => return_ (done x, r) 146 | end in 147 | loop p0 begin. 148 | 149 | Definition foldM `{Monad m} 150 | `(step : x -> a -> m x) (begin : m x) `(done : x -> m b) 151 | (p0 : Producer a m unit) : m b := 152 | let fix loop p x := match p with 153 | | Request v _ => False_rect _ v 154 | | Respond a fu => 155 | x' <-- step x a ;; 156 | loop (fu tt) x' 157 | | M _ g h => h >>= fun p' => loop (g p') x 158 | | Pure _ => done x 159 | end in 160 | x0 <-- begin ;; 161 | loop p0 x0. 162 | 163 | Definition foldM' `{Monad m} 164 | `(step : x -> a -> m x) (begin : m x) `(done : x -> m b) 165 | (p0 : Producer a m r) : m (b * r)%type := 166 | let fix loop p x := match p with 167 | | Request v _ => False_rect _ v 168 | | Respond a fu => 169 | x' <-- step x a ;; 170 | loop (fu tt) x' 171 | | M _ g h => h >>= fun p' => loop (g p') x 172 | | Pure r => 173 | b <-- done x ;; 174 | return_ (b, r) 175 | end in 176 | x0 <-- begin ;; 177 | loop p0 x0. 178 | 179 | Definition null `{Monad m} `(p : Producer a m unit) : m bool := 180 | x <-- next p ;; 181 | return_ $ match x with 182 | | Left _ => true 183 | | Right _ => false 184 | end. 185 | 186 | Definition all `{Monad m} `(p : a -> bool) (p0 : Producer a m unit) : m bool := 187 | null $ p0 >-> (filter (fun a => ~~ (p a)) >> return_ tt). 188 | 189 | Definition any `{Monad m} `(p : a -> bool) (p0 : Producer a m unit) : m bool := 190 | fmap negb $ null $ p0 >-> (filter p >> return_ tt). 191 | 192 | Definition and `{Monad m} : Producer bool m unit -> m bool := all id. 193 | 194 | Definition or `{Monad m} : Producer bool m unit -> m bool := any id. 195 | 196 | Definition elem `{Monad m} {a : eqType} (x : a) : Producer a m unit -> m bool := 197 | any (eq_op x). 198 | 199 | Definition notElem `{Monad m} {a : eqType} (x : a) : 200 | Producer a m unit -> m bool := 201 | all (negb \o eq_op x). 202 | 203 | Definition head `{Monad m} `(p : Producer a m unit) : m (Maybe a) := 204 | x <-- next p ;; 205 | return_ $ match x with 206 | | Left _ => Nothing 207 | | Right (a, _) => Just a 208 | end. 209 | 210 | Definition find `{Monad m} `(p : a -> bool) (p0 : Producer a m unit) : 211 | m (Maybe a) := 212 | head (p0 >-> (filter p >> return_ tt)). 213 | 214 | Definition findIndex `{Monad m} `(p : a -> bool) (p0 : Producer a m unit) : 215 | m (Maybe nat) := 216 | head (p0 >-> (findIndices p >> return_ tt)). 217 | 218 | Definition index `{Monad m} (n : nat) `(p : Producer a m unit) : m (Maybe a) := 219 | head (p >-> (drop n >> return_ tt)). 220 | 221 | Definition last `{Monad m} `(p0 : Producer a m unit) : m (Maybe a) := 222 | let fix loop z p n : m (Maybe a) := 223 | if n isn't S n' then return_ Nothing else 224 | x <-- next p ;; 225 | match x with 226 | | Left _ => return_ (Just z) 227 | | Right (a', p') => loop a' p' n' 228 | end in 229 | x <-- next p0 ;; 230 | match x with 231 | | Left _ => return_ Nothing 232 | | Right (a, p') => loop a p' n 233 | end. 234 | 235 | Definition length `{Monad m} {a} : Producer a m unit -> m nat := 236 | fold (fun n _ => n + 1) 0 id. 237 | 238 | Definition maximum `{Monad m} : Producer nat m unit -> m (Maybe nat) := 239 | let step x z := Just (match x with 240 | | Nothing => z 241 | | Just a' => max z a' 242 | end) in 243 | fold step Nothing id. 244 | 245 | Definition minimum `{Monad m} : Producer nat m unit -> m (Maybe nat) := 246 | let step x z := Just (match x with 247 | | Nothing => z 248 | | Just a' => min z a' 249 | end) in 250 | fold step Nothing id. 251 | 252 | Definition sum `{Monad m} : Producer nat m unit -> m nat := 253 | fold plus 0 id. 254 | 255 | Definition product `{Monad m} : Producer nat m unit -> m nat := 256 | fold mult 1 id. 257 | 258 | Fixpoint toList `(p : Producer a id unit) : seq a := 259 | if n isn't S n' then [::] else 260 | match p with 261 | | Request v _ => False_rect _ v 262 | | Respond a fu => a :: toList (fu tt) 263 | | M _ g h => h >>= (toList \o g) 264 | | Pure _ => [::] 265 | end. 266 | 267 | (* This is the version of toListM defined by the pipes library, but it is not 268 | very amenable to proof. *) 269 | 270 | Definition toListM_fold `{Monad m} {a} : Producer a m unit -> m (seq a) := 271 | let step x a := x \o (cons a) in 272 | let begin := id in 273 | let done x := x [::] in 274 | fold step begin done. 275 | 276 | Fixpoint toListM `{Monad m} `(p : Producer a m unit) : m (seq a) := 277 | match p with 278 | | Request v _ => False_rect _ v 279 | | Respond x fu => cons x <$> toListM (fu tt) 280 | | M _ f t => t >>= (toListM \o f) 281 | | Pure _ => pure [::] 282 | end. 283 | 284 | (* 285 | zip :: Monad m 286 | => (Producer a m r) 287 | -> (Producer b m r) 288 | -> (Producer' (a, b) m r) 289 | zip = zipWith (,) 290 | 291 | zipWith :: Monad m 292 | => (a -> b -> c) 293 | -> (Producer a m r) 294 | -> (Producer b m r) 295 | -> (Producer' c m r) 296 | zipWith f = go 297 | where 298 | go p1 p2 = do 299 | e1 <- lift $ next p1 300 | case e1 of 301 | Left r -> return r 302 | Right (a, p1') -> do 303 | e2 <- lift $ next p2 304 | case e2 of 305 | Left r -> return r 306 | Right (b, p2') -> do 307 | yield (f a b) 308 | go p1' p2' 309 | 310 | tee :: Monad m => Consumer a m r -> Pipe a a m r 311 | tee p = evalStateP Nothing $ do 312 | r <- up >\\ (hoist lift p //> dn) 313 | ma <- lift get 314 | case ma of 315 | Nothing -> return () 316 | Just a -> yield a 317 | return r 318 | where 319 | up () = do 320 | ma <- lift get 321 | case ma of 322 | Nothing -> return () 323 | Just a -> yield a 324 | a <- await 325 | lift $ put (Just a) 326 | return a 327 | dn v = False_rect _ v 328 | 329 | generalize :: Monad m => Pipe a b m r -> x -> Proxy x a x b m r 330 | generalize p x0 = evalStateP x0 $ up >\\ hoist lift p //> dn 331 | where 332 | up () = do 333 | x <- lift get 334 | request x 335 | dn a = do 336 | x <- respond a 337 | lift $ put x 338 | *) 339 | 340 | End Bounded. 341 | 342 | Arguments map {n r d m H a b} f. 343 | 344 | Module PipesLawsPrelude. 345 | 346 | Include PipesLaws. 347 | Include Compromise. 348 | 349 | Require Import FunctionalExtensionality. 350 | 351 | Theorem map_id : forall a, 352 | map (n:=n) (d:=d) (@id a) = cat (n:=n) (d:=d). 353 | Proof. 354 | move=> ?. 355 | rewrite /map /cat /yield /respond /forP. 356 | move: (pull tt). 357 | by reduce_proxy IHx (rewrite /bind /=). 358 | Qed. 359 | 360 | Theorem map_compose `{MonadLaws m} : forall `(f : a -> b) `(g : b -> c), 361 | map (n:=n) (d:=d) (g \o f) 362 | = map (n:=n) (d:=d) f >-> map (n:=n) (d:=d) g. 363 | Proof. 364 | move=> *. 365 | rewrite /map /cat /yield /funcomp. 366 | move: (pull tt). 367 | reduce_proxy IHx (rewrite /= /funcomp); 368 | try move/functional_extensionality in IHx; 369 | assume_infinity. 370 | - rewrite E in IHx. 371 | rewrite IHx. 372 | congr (Request _ _). 373 | rewrite IHx /bind /= /connect /=. 374 | congr (Respond _ _). 375 | rewrite /funcomp /=. 376 | extensionality t. 377 | congr (_ <<+ _). 378 | extensionality u. 379 | by case: t; case: u. 380 | - case: t. 381 | by rewrite E -Hpull. 382 | - rewrite E in IHx. 383 | rewrite IHx. 384 | by congr (M _ _). 385 | Qed. 386 | 387 | (* 388 | filter (pure True) = cat 389 | filter (liftA2 (&&) p1 p2) = filter p1 >-> filter p2 390 | 391 | take 0 = return () 392 | take (m + n) = take m >> take n 393 | take = cat 394 | take (min m n) = take m >-> take n 395 | 396 | takeWhile (pure True) = cat 397 | takeWhile (liftA2 (&&) p1 p2) = takeWhile p1 >-> takeWhile p2 398 | 399 | drop 0 = cat 400 | drop (m + n) = drop m >-> drop n 401 | 402 | dropWhile (pure False) = cat 403 | dropWhile (liftA2 (||) p1 p2) = dropWhile p1 >-> dropWhile p2 404 | *) 405 | 406 | Theorem toListM_each_id : forall a, 407 | toListM \o (fun xs => each (x':=False) (x:=unit) xs) =1 pure (a:=seq a). 408 | Proof. by move=> ?; elim=> //= [? ? ->]. Qed. 409 | 410 | End PipesLawsPrelude. 411 | --------------------------------------------------------------------------------