├── .gitignore ├── LICENSE ├── README.md ├── doc ├── Makefile ├── README.md ├── bool.ott ├── data.ott ├── epsilon.ott ├── equality.v ├── let.ott ├── listproc.sty ├── lsthaskell.sty ├── lstparams.sty ├── lstpi.sty ├── oplss.mng ├── oplss.pdf ├── oplss.zip ├── ottalt.sty ├── pi-rules.tex ├── pi.ott ├── sigma.ott ├── template.ott ├── tyeq.ott └── weirich.bib ├── full ├── LICENSE ├── README.md ├── app │ └── Main.hs ├── pi-forall.cabal ├── pi │ ├── BoolLib.pi │ ├── Equal.pi │ ├── Equality.pi │ ├── Fin.pi │ ├── FinHw.pi │ ├── Fix.pi │ ├── Hurkens.pi │ ├── Hw1.pi │ ├── Hw2.pi │ ├── Lambda.pi │ ├── Lambda0.pi │ ├── Lambda1.pi │ ├── Lambda2.pi │ ├── Lec1.pi │ ├── Lec2.pi │ ├── Lec3.pi │ ├── Lec4.pi │ ├── Lennart.pi │ ├── List.pi │ ├── Logic.pi │ ├── Makefile │ ├── Nat.pi │ ├── NatChurch.pi │ ├── Product.pi │ ├── Product1.pi │ ├── Sigma.pi │ └── Vec.pi ├── src │ ├── Arbitrary.hs │ ├── Environment.hs │ ├── Equal.hs │ ├── LayoutToken.hs │ ├── Modules.hs │ ├── Parser.hs │ ├── PrettyPrint.hs │ ├── Syntax.hs │ └── TypeCheck.hs ├── stack.yaml └── test │ └── Main.hs ├── main ├── LICENSE ├── Makefile ├── README.md ├── app │ └── Main.hs ├── pi-forall.cabal ├── pi │ ├── BoolLib.pi │ ├── Equal.pi │ ├── Equality.pi │ ├── Fin.pi │ ├── FinHw.pi │ ├── Fix.pi │ ├── Hurkens.pi │ ├── Hw1.pi │ ├── Hw2.pi │ ├── Lambda.pi │ ├── Lambda0.pi │ ├── Lambda1.pi │ ├── Lambda2.pi │ ├── Lec1.pi │ ├── Lec2.pi │ ├── Lec3.pi │ ├── Lec4.pi │ ├── Lennart.pi │ ├── List.pi │ ├── Logic.pi │ ├── Makefile │ ├── Maybe.pi │ ├── Nat.pi │ ├── NatChurch.pi │ ├── Prelude.pi │ ├── Product.pi │ ├── Product1.pi │ ├── Sigma.pi │ └── Vec.pi ├── src │ ├── Arbitrary.hs │ ├── Environment.hs │ ├── Equal.hs │ ├── LayoutToken.hs │ ├── Lexer.hs │ ├── Modules.hs │ ├── Parser.hs │ ├── PrettyPrint.hs │ ├── Syntax.hs │ ├── TODO │ └── TypeCheck.hs ├── stack.yaml └── test │ └── Main.hs ├── old ├── compose.md ├── compose15.pdf ├── compose15.pptx ├── notes.md ├── notes2.md ├── notes3.md └── notes4.md ├── version1 ├── LICENSE ├── README.md ├── app │ └── Main.hs ├── pi-forall.cabal ├── pi │ ├── Hw1.pi │ └── Lec1.pi ├── src │ ├── Arbitrary.hs │ ├── Environment.hs │ ├── Equal.hs │ ├── LayoutToken.hs │ ├── Modules.hs │ ├── Parser.hs │ ├── PrettyPrint.hs │ ├── Syntax.hs │ └── TypeCheck.hs ├── stack.yaml └── test │ └── Main.hs ├── version2 ├── LICENSE ├── README.md ├── app │ └── Main.hs ├── pi-forall.cabal ├── pi │ ├── Hw1.pi │ ├── Hw2.pi │ ├── Lec1.pi │ ├── Lec2.pi │ ├── NatChurch.pi │ └── Sigma.pi ├── src │ ├── Arbitrary.hs │ ├── Environment.hs │ ├── Equal.hs │ ├── LayoutToken.hs │ ├── Modules.hs │ ├── Parser.hs │ ├── PrettyPrint.hs │ ├── Syntax.hs │ └── TypeCheck.hs ├── stack.yaml └── test │ └── Main.hs └── version3 ├── LICENSE ├── Makefile ├── README.md ├── app └── Main.hs ├── pi-forall.cabal ├── pi ├── Hw1.pi ├── Hw2.pi ├── Lec1.pi ├── Lec2.pi ├── Lec3.pi ├── NatChurch.pi └── Sigma.pi ├── src ├── Arbitrary.hs ├── Environment.hs ├── Equal.hs ├── LayoutToken.hs ├── Main.hs ├── Modules.hs ├── Parser.hs ├── PrettyPrint.hs ├── Syntax.hs └── TypeCheck.hs ├── stack.yaml └── test ├── Hw1.pi ├── Hw2.pi ├── Lec1.pi ├── Lec2.pi ├── Main.hs └── NatChurch.pi /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | .DS_Store 13 | doc/oplss.tex 14 | doc/pi-rules.tex 15 | .stack-work/ 16 | dist-newstyle/ 17 | stack.yaml.lock 18 | *~ 19 | *.bbl 20 | **/.vscode/** 21 | *.synctex.gz 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2022, University of Pennsylvania 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the University of Pennsylvania nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL UNIVERSITY OF PENNSYLVANIA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | pi-forall language 2 | ------------------ 3 | 4 | This language implementation is designed to accompany four lectures at 5 | OPLSS during Summer 2023. Notes for these lectures are included in the 6 | distribution: 7 | 8 | - [oplss.pdf](doc/oplss.pdf) 9 | 10 | (The documentation [README.md](doc/README.md) includes details about 11 | how the notes are typeset.) 12 | 13 | These lecture notes correspond to an increasingly expressive demo 14 | implementation of a dependently-typed lambda calculus. Each of the 15 | following subdirectories is a self-contained implementation and all 16 | are generated from the same source, located in the [main/](main/) 17 | directory. 18 | 19 | - [version1/](version1/): Basic language implementation 20 | - [version2/](version2/): Basic language extended with nontrivial definitional equality 21 | - [version3/](version3/): Above, extended with irrelevant arguments 22 | - [full/](full/): Full language with datatypes 23 | 24 | The implementation [README.md](main/README.md) includes instructions about 25 | how to compile and work with these implementations. Edits should only be for 26 | versions in the [main/](main/) directory. 27 | 28 | VS Code 29 | ------- 30 | 31 | There is a [VS Code plugin](https://github.com/dunhamsteve/pi-forall-vscode) for pi-forall. 32 | 33 | History 34 | ------- 35 | 36 | This is a revised version of lecture notes originally presented at OPLSS 37 | during 2023, 2022, 2014, and 2013. 38 | 39 | Videos from the [2022](https://www.cs.uoregon.edu/research/summerschool/summer22/topics.php) and [2014](https://www.cs.uoregon.edu/research/summerschool/summer14/curriculum.html) lectures are available from the 40 | OPLSS website. If you watch these videos, you should look at the 41 | corresponding branch of this repository. Unfortunately, the [2023](https://www.cs.uoregon.edu/research/summerschool/summer23/topics.php) recordings include only audio, and only for part of the lectures. 42 | 43 | An abridged version of these lectures was also given at the Compose 44 | Conference, January 2015. [Notes](old/compose.md) from this version are also available. 45 | 46 | -- 47 | Stephanie Weirich 48 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | ## Makefile for paper 2 | 3 | OTT_SOURCE = pi sigma bool tyeq epsilon data let 4 | BIBFILES = weirich.bib 5 | 6 | OTTFILES = $(foreach i, $(OTT_SOURCE), $(i).ott) 7 | OTTIFLAGS = $(foreach i, $(OTT_SOURCE), -i $(i).ott) -merge true 8 | RULESFILE = pi-rules.tex 9 | 10 | PAPER_MNG = $(wildcard *.mng) 11 | PAPER_SOURCE = $(patsubst %.mng,%.tex,$(PAPER_MNG)) 12 | OTT_FILTER := $(subst .mng,.mng ,$(addprefix -tex_filter ,$(join $(PAPER_MNG), $(PAPER_SOURCE)))) 13 | 14 | TOP=oplss 15 | PDFS=oplss.pdf 16 | 17 | all: $(TOP).pdf 18 | 19 | $(TOP).tex: $(RULESFILE) $(TOP).mng Makefile 20 | ott $(OTTIFLAGS) \ 21 | -tex_wrap false \ 22 | -tex_show_meta false \ 23 | -tex_filter $*.mng $*.tex 24 | 25 | %.tex : $(RULESFILE) %.mng Makefile 26 | rm -f $(PAPER_SOURCE) 27 | ott -tex_wrap false \ 28 | -tex_show_meta false \ 29 | $(OTTIFLAGS) \ 30 | $(OTT_FILTER) 31 | chmod a-w $(PAPER_SOURCE) 32 | 33 | $(RULESFILE): $(OTTFILES) 34 | ott $(OTTIFLAGS) -o $(RULESFILE) \ 35 | -tex_wrap false \ 36 | -tex_show_meta false 37 | 38 | $(TOP).pdf : $(TOP).tex $(BIBFILES) $(PAPER_SOURCE) Makefile lstparams.sty lstpi.sty 39 | echo $(PAPER_SOURCE) 40 | latexmk -pdflatex="texfot pdflatex" -bibtex -pdf $(TOP).tex -synctex=1 && latexmk -c 41 | 42 | deps: 43 | echo $(PAPER_SOURCE) 44 | 45 | paperclean: 46 | rm -if *-rules.tex $(TOP).tex *.log ./*~ *.aux $(PDFS) *.bbl *.blg *.fdb_latexmk *.fls *.out *-input.tex *~ 47 | 48 | 49 | clean: paperclean 50 | -------------------------------------------------------------------------------- /doc/README.md: -------------------------------------------------------------------------------- 1 | Source files for Lecture Notes, PDF [oplss.pdf](oplss.pdf) 2 | ----------------------------------------------------------- 3 | 4 | To typeset these notes, you will need to have installed LaTeX and the Ott tool. The easiest way to install Ott is through [opam](https://opam.ocaml.org/). 5 | 6 | The Ott tool assists with typesetting mathematical specifications of type systems. All typing rules that appear in the lecture notes are specified within the following source files. 7 | 8 | [Ott](https://www.cl.cam.ac.uk/~pes20/ott/top2.html) specifications: 9 | + [pi.ott](pi.ott) - Core system 10 | + [bool.ott](bool.ott) - Booleans 11 | + [sigma.ott](sigma.ott) - Sigma types 12 | + [tyeq.ott](tyeq.ott) - Propositional equality 13 | + [epsilon.ott](epsilon.ott) - Irrelevance 14 | + [data.ott](data.ott) - Data types 15 | 16 | LaTeX source files 17 | + [oplss.mng](oplss.mng) - Main text of the document 18 | + [lstpi.sty](lstpi.sty) - [Listings](https://ctan.mirrors.hoobly.com/macros/latex/contrib/listings/listings.pdf) specification for typesetting `pi-forall` source code 19 | + [ottalt.sty](ottalt.sty) - [Auxiliary style file](https://users.cs.northwestern.edu/~jesse/code/latex/ottalt/ottalt.pdf) for working with Ott produced LaTeX macros 20 | + [weirich.bib](weirich.bib) - BibTeX data 21 | + Makefile - how to put everything together 22 | -------------------------------------------------------------------------------- /doc/epsilon.ott: -------------------------------------------------------------------------------- 1 | % Language additions for irrelevant arguments 2 | 3 | grammar 4 | 5 | ep {{ tex \epsilon }} :: '' ::= 6 | | Rel :: :: Rel {{ tex + }} 7 | | Irr :: :: Irr {{ tex - }} 8 | 9 | tm, a , b , A , B , u , v :: '' ::= {{ com terms and types }} 10 | 11 | | \ [ x ] . a :: :: ELam 12 | {{ tex \lambda [ [[x]] ] . [[a]] }} 13 | 14 | | a [ b ] :: :: EApp 15 | 16 | | [ x : A ] -> B :: :: EPi 17 | {{ tex [ [[x]]\!:\![[A]] ] \rightarrow [[B]] }} 18 | 19 | % this is a bit of a hack --- we're overloading contexts to 20 | % include those annotated with epsilons 21 | 22 | context, G {{ tex \Gamma }} :: 'ctx_' ::= {{ com contexts }} 23 | 24 | | G , x : ep A :: :: ECons 25 | {{ tex [[G]], [[x]]\! :^[[ep]]\![[A]] }} 26 | 27 | | x : ep A :: :: ESingle 28 | {{ tex [[x]]\! :^[[ep]]\! [[A]] }} 29 | 30 | | G ep :: :: Demotion 31 | {{ tex [[G]]^[[ep]] }} 32 | 33 | formula :: 'formula_' ::= 34 | 35 | | x : ep A elem G :: :: inEG 36 | {{ tex [[x]]:^[[ep]][[A]] [[elem]] [[G]] }} 37 | 38 | | ep1 <= ep2 :: :: SubE 39 | {{ tex [[ep1]] \leq [[ep2]] }} 40 | 41 | 42 | defns 43 | Jwhnf :: '' ::= 44 | 45 | defn 46 | whnf G |- a ~> nf :: :: whnf :: 'whnf_' 47 | by 48 | 49 | defns 50 | JOp :: '' ::= 51 | 52 | defn 53 | a ~> b :: :: step :: 's_' 54 | {{ com single-step operational semantics, i. e. head reduction }} 55 | by 56 | 57 | defns 58 | JEq :: '' ::= 59 | 60 | defn 61 | G |- A = B :: :: eq :: 'e_' 62 | {{ com Definitional equality }} 63 | by 64 | 65 | G |- a1 = a2 66 | --------------------------- :: eapp 67 | G |- a1 [b1] = a2 [b2] 68 | 69 | G , x:Irr A |- a1 = a2 70 | ------------------------- :: elam 71 | G |- \[x].a1 = \[x].a2 72 | 73 | G |- A1 = A2 74 | G , x:Rel A1 |- B1 = B2 75 | ---------------------------------- :: epi 76 | G |- [x:A1] -> B1 = [x:A2] -> B2 77 | 78 | 79 | defns 80 | JTyping :: '' ::= 81 | 82 | defn 83 | G |- a : A :: :: typing :: 't_' 84 | {{ com Typing }} 85 | by 86 | 87 | x : Rel A elem G 88 | ------------------------- :: evar 89 | G |- x : A 90 | 91 | G, x:Irr A |- a : B 92 | G Rel |- A : Type 93 | ------------------------ :: elambda 94 | G |- \[x].a : [x:A] -> B 95 | 96 | 97 | G |- a : [x:A] -> B 98 | G Rel |- b : A 99 | --------------------------- :: eapp 100 | G |- a [b] : B [ b / x ] 101 | 102 | 103 | G |- A : Type 104 | G, x:Rel A |- B : Type 105 | -------------------------------------- :: epi 106 | G |- [x:A] -> B : Type 107 | 108 | 109 | defns 110 | JBidirectional :: '' ::= 111 | 112 | defn 113 | G |- a => A :: :: inferType :: 'i_' 114 | {{ com type synthesis (algorithmic) }} 115 | by 116 | 117 | defn 118 | G |- a <= B :: :: checkType :: 'c_' 119 | {{ com type checking (algorithmic) }} 120 | by 121 | 122 | -------------------------------------------------------------------------------- /doc/equality.v: -------------------------------------------------------------------------------- 1 | 2 | Print bool_rect. 3 | 4 | (* 5 | bool_rect = 6 | fun (P : bool -> Type) (f : P true) (f0 : P false) (b : bool) => if b as b0 return (P b0) then f else f0 7 | : forall P : bool -> Type, P true -> P false -> forall b : bool, P b 8 | *) 9 | 10 | Section MyEq. 11 | 12 | Polymorphic Inductive myeq (A :Type)(a:A) : A -> Type := 13 | | myrefl : myeq A a a. 14 | 15 | Check myeq_rect. 16 | 17 | Lemma my_k : forall (A:Type) (x:A) (p : myeq A x x), myeq (myeq A x x) p (myrefl A x). 18 | Proof. 19 | intros. 20 | pose (h := myeq_rect). 21 | specialize h with (y := x) (m := p). 22 | specialize h with (P := fun a p0 => myeq (myeq A x a) p0 p0). simpl in h. 23 | 24 | Polymorphic Inductive myeq : forall (A :Type)(a:A), A -> Type := 25 | | myrefl : forall A a, myeq A a a. 26 | 27 | Check myeq_rect. 28 | 29 | (* 30 | myeq_rect 31 | : forall (a : A) (P : forall a0 : A, myeq A a a0 -> Type), P a (myrefl A a) -> forall (y : A) (m : myeq A a y), P y m 32 | *) 33 | 34 | Lemma my_k : forall (A:Type) (x:A) (p : myeq A x x), myeq (myeq A x x) p (myrefl A x). 35 | Proof. 36 | intros. 37 | pose (h := myeq_rect). 38 | 39 | specialize h with (m := p). 40 | specialize (h (fun A x y p0 => myeq (myeq A x y) p0 (myrefl A x))). 41 | (* goal is 42 | 43 | myeq (myeq A x x) p (myrefl A x) 44 | 45 | P (y : A) (m : myeq A x y) will be instantiated by x and p 46 | 47 | fun y m => myeq (myeq A x y) m m 48 | 49 | *) 50 | specialize (h (fun y m => myeq (myeq A x y) m m)). simpl in h. 51 | specialize (h (myrefl (myeq A x x) (myrefl A x))). 52 | specialize (h x p). 53 | 54 | specialize (h (fun a0 e => myeq (myeq A x x) p (myrefl A x))). simpl in h. 55 | eapply h. 56 | eapply myeq_rect with (P := fun (a0 : A) (p0 : myeq A a0 a0) => myeq _ p (myrefl A x)). 57 | 58 | k : [A:Type] -> [x:A] -> (p : x = x) -> (p = Refl) 59 | k = \ [A][x] p . 60 | subst Refl by p 61 | 62 | 63 | 64 | 65 | Check eq_rect. 66 | 67 | (* 68 | eq_rect 69 | : forall (A : Type) (x : A) (P : A -> Type), P x -> forall y : A, x = y -> P y 70 | *) 71 | 72 | 73 | 74 | Definition sym : forall A (x y : A), x = y -> y = x := 75 | 76 | fun (A : Type) (x y : A) (H : x = y) => 77 | match H in (_ = y0) return (y0 = x) with 78 | | eq_refl => eq_refl 79 | end. 80 | 81 | Definition trans := 82 | fun (A : Type) (x y z : A) (H : x = y) (H0 : y = z) => 83 | match H0 in (_ = y0) return (x = y0) with 84 | | eq_refl => H 85 | end. 86 | 87 | 88 | 89 | 90 | Definition uip : forall A (x y : A) (p : x = y) (q :x = y), p = q. 91 | Proof. 92 | intros. 93 | Search eq eq_refl. 94 | match q in (_ = y0) return (p = q) with 95 | | eq_refl => 96 | -------------------------------------------------------------------------------- /doc/let.ott: -------------------------------------------------------------------------------- 1 | % Language additions for 2 | 3 | grammar 4 | 5 | tm, a , b , A , B , u , v :: '' ::= {{ com terms and types }} 6 | 7 | | let x = a in b :: :: Let 8 | {{ com name an expression }} 9 | 10 | context, G {{ tex \Gamma }} :: 'ctx_' ::= {{ com contexts }} 11 | 12 | | G , x = a :: :: Def 13 | 14 | 15 | formula :: 'formula_' ::= 16 | | x = a elem G :: :: Def 17 | 18 | defns 19 | Jwhnf :: '' ::= 20 | 21 | defn 22 | whnf G |- a = v :: :: whnf :: 'whnf_' 23 | by 24 | 25 | x = a elem G 26 | whnf G |- a ~> v 27 | ------------- :: def 28 | whnf G |- x ~> v 29 | 30 | whnf G |- (b[a/x]) ~> v 31 | ------------------------------- :: let_beta 32 | whnf G |- (let x = a in b) ~> v 33 | 34 | defns 35 | JOp :: '' ::= 36 | 37 | defn 38 | a ~> b :: :: step :: 's_' 39 | {{ com single-step operational semantics, i. e. head reduction }} 40 | by 41 | 42 | 43 | --------------------------------- :: letbeta 44 | let x = a in b ~> b [ a / x ] 45 | 46 | 47 | defns 48 | JEq :: '' ::= 49 | 50 | defn 51 | G |- A = B :: :: eq :: 'e_' 52 | {{ com Definitional equality }} 53 | by 54 | 55 | x = a elem G 56 | --------------------------------- :: var 57 | G |- x = a 58 | 59 | --------------------------------- :: letbeta 60 | G |- let x = a in b = b [ a / x ] 61 | 62 | 63 | G |- a1 = a2 64 | G, x:A, x = a1 |- b1 = b2 65 | --------------------------------------------- :: let 66 | G |- let x = a1 in b1 = let x = a2 in b2 67 | 68 | 69 | defns 70 | JTyping :: '' ::= 71 | 72 | defn 73 | 74 | G |- a : A :: :: typing :: 't_' 75 | {{ com Typing }} 76 | by 77 | 78 | G |- a : A 79 | G , x : A |- b : B 80 | G |- B : Type 81 | -------------------------- :: let_simple 82 | G |- let x = a in b : B 83 | 84 | G |- a : A 85 | G , x : A, x = a |- b : B 86 | G |- B : Type 87 | -------------------------- :: let_def 88 | G |- let x = a in b : B 89 | 90 | 91 | defns 92 | JBidirectional :: '' ::= 93 | 94 | defn 95 | G |- a => A :: :: inferType :: 'i_' 96 | {{ com type synthesis (algorithmic) }} 97 | by 98 | 99 | 100 | G |- a => A 101 | G , x : A |- b => B 102 | G |- B <= Type 103 | ----------------------------------- :: let_simple 104 | G |- let x = a in b => B 105 | 106 | G |- a => A 107 | G , x : A, x = a |- b => B 108 | ----------------------------------- :: let 109 | G |- let x = a in b => B [ a / x ] 110 | 111 | 112 | 113 | defn 114 | G |- a <= B :: :: checkType :: 'c_' 115 | {{ com type checking (algorithmic) }} 116 | by 117 | 118 | G |- a => A 119 | G , x : A, x = a |- b <= B 120 | -------------------------- :: let 121 | G |- let x = a in b <= B 122 | 123 | G |- x <= Bool 124 | G, x = True |- b1 <= A 125 | G, x = False |- b2 <= A 126 | ------------------------------ :: if_def 127 | G |- if x then b1 else b2 <= A 128 | 129 | G |- z => { x : A1 | A2 } 130 | G, x:A1, y:A2, z = (x,y) |- b <= B 131 | -------------------------------------- :: letpair_def 132 | G |- let (x,y) = z in b <= B 133 | -------------------------------------------------------------------------------- /doc/lsthaskell.sty: -------------------------------------------------------------------------------- 1 | \lstdefinelanguage{Haskell}{ 2 | % 3 | % 4 | % 5 | % Anything betweeen $ becomes LaTeX math mode 6 | mathescape=true, 7 | % 8 | % Comments may or not include Latex commands 9 | texcl=false, 10 | % 11 | % 12 | morekeywords=[1]{class,data,default,deriving,hiding,infix,infixl,infixr,import,instance,type,where,forall},% 13 | morekeywords=[2]{if,then,else,case,if,in,let,module,newtype,of,qualified,do,otherwise},% 14 | % 15 | % Comments delimiter 16 | morecomment=[s]{{-}{-}}, 17 | morecomment=[l]{--}, 18 | % 19 | % Spaces are not displayed as a special character 20 | showstringspaces=false, 21 | % 22 | upquote = true, 23 | % String delimiters 24 | morestring=[b]", 25 | % 26 | % Size of tabulations 27 | tabsize=3, 28 | % 29 | % Enables ASCII chars 128 to 255 30 | extendedchars=false, 31 | % 32 | % Case sensitivity 33 | sensitive=true, 34 | % 35 | % Automatic breaking of long lines 36 | breaklines=false, 37 | % 38 | % Default style fors listings 39 | basicstyle=\ttfamily, 40 | % 41 | % Position of captions is bottom 42 | captionpos=b, 43 | % 44 | % flexible columns 45 | columns=[l]flexible, 46 | % 47 | % Style for (listings') identifiers 48 | identifierstyle={\ttfamily\color{black}}, 49 | % Style for declaration keywords 50 | keywordstyle=[1]{\ttfamily\color{Plum}}, 51 | % Style for gallina keywords 52 | keywordstyle=[2]{\ttfamily\color{PineGreen}}, 53 | % Style for strings 54 | stringstyle=\ttfamily, 55 | % Style for comments 56 | commentstyle={\ttfamily\color{PineGreen}}, 57 | % 58 | %moredelim=**[is][\ttfamily\color{red}]{/&}{&/}, 59 | literate= 60 | {\\}{{$\lambda$}}1 61 | {\\forall}{{\color{green}{$\forall\;$}}}1 62 | {\\exists}{{$\exists\;$}}1 63 | {<-}{{$\leftarrow\;$}}1 64 | {=>}{{$\Rightarrow\;$}}1 65 | {==}{{\code{==}\;}}1 66 | {==>}{{\code{==>}\;}}1 67 | % {:>}{{\code{:>}\;}}1 68 | {->}{{$\rightarrow\;$}}1 69 | {<->}{{$\leftrightarrow\;$}}1 70 | {<==}{{$\leq\;$}}1 71 | {\#}{{$^\star$}}1 72 | {\\o}{{$\circ\;$}}1 73 | {\@}{{$\cdot$}}1 74 | {\/\\}{{$\wedge\;$}}1 75 | {\\\/}{{$\vee\;$}}1 76 | {++}{{\code{++}}}1 77 | {~}{{\ }}1 78 | {\@\@}{{$@$}}1 79 | {\\mapsto}{{$\mapsto\;$}}1 80 | {\\hline}{{\rule{\linewidth}{0.5pt}}}1 81 | % 82 | }[keywords,comments,strings] 83 | 84 | \lstnewenvironment{haskell}{\lstset{language=Haskell}}{} 85 | -------------------------------------------------------------------------------- /doc/lstparams.sty: -------------------------------------------------------------------------------- 1 | \RequirePackage{etoolbox} 2 | 3 | \colorlet{StringColor}{blue} 4 | \colorlet{CommentColor}{red} 5 | %\colorlet{Keyword1Color}{violet} 6 | %\colorlet{Keyword2Color}{Green} 7 | 8 | 9 | \newcommand*{\basecodestyle}{\ttfamily} 10 | \newcommand*{\codestyle}{\small\basecodestyle} 11 | \newcommand*{\footnotecodestyle}{\footnotesize\basecodestyle} 12 | 13 | \lstset{ 14 | language = haskell, 15 | basicstyle = \codestyle, 16 | showspaces = false, 17 | showstringspaces = false, 18 | upquote = true, 19 | keepspaces = true, 20 | breaklines = false, 21 | columns = fullflexible, 22 | aboveskip = \medskipamount, 23 | mathescape = true, 24 | % 25 | stringstyle = {\codestyle\color{StringColor}}, 26 | commentstyle = {\codestyle\itshape\color{CommentColor}}, 27 | xleftmargin = .15in, 28 | morekeywords = {unit,Unit,zero,suc,Nat,Type}, 29 | literate =% 30 | {∀}{$\forall$}1 31 | {Σ}{$\Sigma$}1 32 | {Π}{$\Pi$}1 33 | {→}{$\rightarrow$}1 34 | {⇒}{$\Rightarrow$}1 35 | {×}{$\times$}1 36 | {∈}{$\in$}1 37 | {ℂ}{$\mathbb{C}$}1 38 | {α}{$\alpha$}1 39 | {λ}{$\lambda$}1 40 | {⊤}{$\top$}1 41 | {⊥}{$\bot$}1 42 | } 43 | 44 | \pretocmd{\@makefntext}{\lstset{basicstyle=\footnotecodestyle}} 45 | {} 46 | {\PackageError{lstparams} 47 | {Could not set up footnote-sized code font} 48 | {I either couldn't find the \protect\@makefntext\space command or 49 | couldn't patch it.}} 50 | -------------------------------------------------------------------------------- /doc/lstpi.sty: -------------------------------------------------------------------------------- 1 | % lstlisting pi-forall style 2 | % Based on Coq lstlisting style 3 | % 4 | \lstdefinelanguage{PiForall}{ 5 | % 6 | % Anything betweeen $ becomes LaTeX math mode 7 | mathescape=true, 8 | % 9 | % Comments may or not include Latex commands 10 | texcl=false, 11 | % 12 | morekeywords=[1]{module,import}, 13 | morekeywords=[2]{let, in, if, then, else, case, of, data, where, Type}, 14 | morekeywords=[3]{}, 15 | morekeywords=[4]{True, False, Refl, Cons, Nil, Zero, Succ}, 16 | morekeywords=[5]{Bool, Vec, Nat, Unit, Fin}, 17 | % 18 | % Comments delimiter 19 | morecomment=[s]{{-}{-}}, 20 | morecomment=[l]{--}, 21 | % 22 | % Spaces are not displayed as a special character 23 | showstringspaces=false, 24 | % 25 | upquote = true, 26 | % String delimiters 27 | morestring=[b]", 28 | % 29 | % Size of tabulations 30 | tabsize=3, 31 | % 32 | % Enables ASCII chars 128 to 255 33 | extendedchars=false, 34 | % 35 | % Case sensitivity 36 | sensitive=true, 37 | % 38 | % Automatic breaking of long lines 39 | breaklines=false, 40 | % 41 | % Default style for listings 42 | basicstyle=\small\ttfamily, 43 | % 44 | % Position of captions is bottom 45 | captionpos=b, 46 | % 47 | % flexible columns 48 | columns=[l]flexible, 49 | % 50 | % Style for (listings') identifiers 51 | identifierstyle={\ttfamily\color{black}}, 52 | keywordstyle=[1]{\ttfamily\color{Plum}}, 53 | keywordstyle=[2]{\ttfamily\color{PineGreen}}, 54 | keywordstyle=[3]{\ttfamily\color{BlueGreen}}, 55 | keywordstyle=[4]{\ttfamily\color{BlueViolet}}, 56 | keywordstyle=[5]{\ttfamily\color{Maroon}}, 57 | % Style for strings 58 | stringstyle=\ttfamily, 59 | % Style for comments 60 | commentstyle={\ttfamily\color{PineGreen}}, 61 | % 62 | literate= 63 | {\\}{{\color{PineGreen}{$\lambda$}}}1 64 | {\\forall}{{\color{green}{$\forall\;$}}}1 65 | {\\exists}{{$\exists\;$}}1 66 | {<-}{{$\leftarrow\;$}}1 67 | {=>}{{$\Rightarrow\;$}}1 68 | {==}{{\code{==}\;}}1 69 | {==>}{{\code{==>}\;}}1 70 | {->}{{$\rightarrow\;$}}1 71 | {<->}{{$\leftrightarrow\;$}}1 72 | {<==}{{$\leq\;$}}1 73 | {\#}{{$^\star$}}1 74 | {\\o}{{$\circ\;$}}1 75 | {\/\\}{{$\wedge\;$}}1 76 | {\\\/}{{$\vee\;$}}1 77 | {++}{{\code{++}}}1 78 | {\\mapsto}{{$\mapsto\;$}}1 79 | {\\hline}{{\rule{\linewidth}{0.5pt}}}1 80 | % 81 | }[keywords,comments,strings] 82 | 83 | \lstnewenvironment{piforall}{\lstset{language=PiForall}}{} 84 | 85 | \def\piforalle{\lstinline[language=PiForall, basicstyle=\small]} 86 | \def\piforalls{\lstinline[language=PiForall, basicstyle=\scriptsize]} 87 | -------------------------------------------------------------------------------- /doc/oplss.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/pi-forall/75feff0f86f10d02c9e69999f0a112d0d289c948/doc/oplss.pdf -------------------------------------------------------------------------------- /doc/oplss.zip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/pi-forall/75feff0f86f10d02c9e69999f0a112d0d289c948/doc/oplss.zip -------------------------------------------------------------------------------- /doc/sigma.ott: -------------------------------------------------------------------------------- 1 | % Language additions for Sigma types 2 | 3 | grammar 4 | 5 | tm, a , b , A , B :: '' ::= {{ com terms and types }} 6 | 7 | 8 | %% Sigma types 9 | | { x : A | B } :: :: Sigma 10 | {{ tex \{ [[x]]\!:\![[A]]\ |\ [[B]] \} }} 11 | {{ com $\Sigma$-type (i.e. dependent products/dependent sums) }} 12 | | ( a , b ) :: :: Prod 13 | {{ com products }} 14 | | let ( x , y ) = a in b :: :: LetPair 15 | {{ com elimination form for pairs }} 16 | | A * B :: M :: Times 17 | {{ com syntactic sugar for product types }} 18 | 19 | v :: 'v_' ::= 20 | | { x : A | B } :: :: Sigma 21 | | ( a , b ) :: :: Prod 22 | 23 | neutral, ne :: 'n_' ::= 24 | | let ( x , y ) = ne in a :: :: LetPair 25 | 26 | nf :: 'nf_' ::= 27 | | { x : A | B } :: :: Sigma 28 | | ( a , b ) :: :: Prod 29 | | let ( x , y ) = ne in a :: :: LetPair 30 | 31 | 32 | defns 33 | Jwhnf :: '' ::= 34 | 35 | defn 36 | whnf G |- a ~> nf :: :: whnf :: 'whnf_' 37 | by 38 | 39 | whnf G |- a ~> (a1, a2) 40 | whnf G |- (b [a1/x] [a2/y]) ~> nf 41 | ------------------------------- :: letpair 42 | whnf G |- let (x,y) = a in b ~> nf 43 | 44 | whnf G |- a ~> ne 45 | --------------------------------------------- :: prodcong 46 | whnf G |- let (x,y) = a in b ~> let (x,y) = ne in b 47 | 48 | 49 | defns 50 | JOp :: '' ::= 51 | 52 | defn 53 | a ~> b :: :: step :: 's_' 54 | {{ com single-step operational semantics, i. e. head reduction }} 55 | by 56 | 57 | 58 | -------------------------------------------------- :: LetPairProd 59 | let (x,y) = (a1,a2) in b ~> b [ a1 /x ] [a2 /y ] 60 | 61 | 62 | a ~> a' 63 | -------------------------------------------------- :: LetPair 64 | let (x,y) = a in b ~> let (x,y) = a' in b 65 | 66 | defns 67 | JEq :: '' ::= 68 | 69 | defn 70 | G |- A = B :: :: eq :: 'e_' 71 | {{ com Definitional equality }} 72 | by 73 | 74 | ---------------------------------------------------------- :: letpairprod 75 | G |- let (x,y) = (a1,a2) in b = b [ a1 /x ] [a2 / y] 76 | 77 | G |- A1 = A2 78 | G,x:A1 |- B1 = B2 79 | ------------------------------------ :: sigma 80 | G |- { x:A1 | B1 } = { x:A2 | B2} 81 | 82 | 83 | G |- b1 = b1' 84 | G |- b2 = b2' 85 | -------------- :: prod 86 | G |- (b1, b2) = (b1', b2') 87 | 88 | G |- a = a' 89 | G |- b = b' 90 | ----------------------------------------------- :: letpair 91 | G |- let (x,y) = a in b = let (x,y) = a' in b' 92 | 93 | defns 94 | JTyping :: '' ::= 95 | 96 | defn 97 | 98 | G |- a : A :: :: typing :: 't_' 99 | {{ com Typing }} 100 | by 101 | 102 | %% sigma types 103 | 104 | G |- A : Type 105 | G, x:A |- B : Type 106 | ------------------------------------- :: sigma 107 | G |- { x : A | B } : Type 108 | 109 | G |- a : A 110 | G |- b : B [ a / x ] 111 | ------------------------------------ :: pair 112 | G |- (a,b) : { x : A | B } 113 | 114 | 115 | G |- a : { x : A1 | A2 } 116 | G, x:A1, y:A2 |- b : B 117 | G |- B : Type 118 | ------------------------------ :: letpair_weak 119 | G |- let (x,y) = a in b : B 120 | 121 | 122 | defns 123 | JBidirectional :: '' ::= 124 | 125 | defn 126 | G |- a => A :: :: inferType :: 'i_' 127 | {{ com type synthesis (algorithmic) }} 128 | by 129 | 130 | G |- A <= Type 131 | G, x:A |- B <= Type 132 | ------------------------------------- :: sigma 133 | G |- { x : A | B } => Type 134 | 135 | defn 136 | G |- a <= B :: :: checkType :: 'c_' 137 | {{ com type checking (algorithmic) }} 138 | by 139 | 140 | 141 | G |- a <= A 142 | G |- b <= B [ a / x ] 143 | ------------------------------------ :: pair 144 | G |- (a,b) <= { x : A | B } 145 | 146 | G |- a => { x : A1 | A2 } 147 | G, x:A1, y:A2 |- b <= B 148 | ------------------------------ :: letpair_simple 149 | G |- let (x,y) = a in b <= B 150 | 151 | G |- z => { x : A1 | A2 } 152 | G, x:A1, y:A2 |- b <= B [ (x,y) / z ] 153 | -------------------------------------- :: letpair 154 | G |- let (x,y) = z in b <= B 155 | -------------------------------------------------------------------------------- /doc/template.ott: -------------------------------------------------------------------------------- 1 | % Language additions for 2 | 3 | grammar 4 | 5 | tm, a , b , A , B , u , v :: '' ::= {{ com terms and types }} 6 | 7 | 8 | defns 9 | Jwhnf :: '' ::= 10 | 11 | defn 12 | whnf G |- a = nf :: :: whnf :: 'whnf_' 13 | by 14 | 15 | defns 16 | JOp :: '' ::= 17 | 18 | defn 19 | a ~> b :: :: step :: 's_' 20 | {{ com single-step operational semantics, i. e. head reduction }} 21 | by 22 | 23 | defns 24 | JEq :: '' ::= 25 | 26 | defn 27 | G |- A = B :: :: eq :: 'e_' 28 | {{ com Definitional equality }} 29 | by 30 | 31 | defns 32 | JTyping :: '' ::= 33 | 34 | defn 35 | 36 | G |- a : A :: :: typing :: 't_' 37 | {{ com Typing }} 38 | by 39 | 40 | defns 41 | JBidirectional :: '' ::= 42 | 43 | defn 44 | G |- a => A :: :: inferType :: 'i_' 45 | {{ com type synthesis (algorithmic) }} 46 | by 47 | 48 | defn 49 | G |- a <= B :: :: checkType :: 'c_' 50 | {{ com type checking (algorithmic) }} 51 | by 52 | 53 | -------------------------------------------------------------------------------- /full/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2022, University of Pennsylvania 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the University of Pennsylvania nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL UNIVERSITY OF PENNSYLVANIA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /full/README.md: -------------------------------------------------------------------------------- 1 | pi-forall 2 | ========= 3 | 4 | A demo implementation of a simple dependently-typed language for OPLSS 5 | (Used in 2023, 2022, 2014 and 2013) 6 | 7 | The goal of this project is to bring up the design issues that occur in the 8 | implementation of the type checkers of languages like Agda, Coq, Epigram, 9 | Idris, etc. Of course, it can't cover everything, but this code is a 10 | starting point for discussion. 11 | 12 | As its main purpose is didactic, the code itself has been written for 13 | clarity, not for speed. The point of this implementation is an introduction to 14 | practical issues of language design and how specific features interact with 15 | each other. 16 | 17 | Installation 18 | ---------- 19 | 20 | Compiling pi-forall requires GHC and stack 21 | 22 | Recommended tools (see links for instructions): 23 | 24 | 1. [gchup](https://www.haskell.org/ghcup/) 25 | 26 | The gchup tool is an installer for general purpose Haskell tools, including GHC, Cabal, Stack and the Haskell language server (HLS). You'll want to install the recommended versions of all of these tools. 27 | 28 | 2. [VSCode](https://code.visualstudio.com/) and [Haskell language extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) for editing the Haskell implementation of `pi-forall`. 29 | 30 | 3. [pi-forall VS code extension](https://marketplace.visualstudio.com/items?itemName=dunhamsteve.pi4all) for syntax highlighting of `pi-forall` code in VS code. 31 | 32 | Contents 33 | -------- 34 | 35 | There are several versions of `pi-forall` in the repository. See the 36 | [documentation](https://github.com/sweirich/pi-forall/blob/2023/doc/oplss.pdf) for an extended 37 | description of what parts of the language are covered by each version. 38 | 39 | When you open the project in vscode, you should open the folder for the implementation that 40 | you want to work with (i.e. `version1`/`version2`/`full`), so that the Haskell language server 41 | can find the project metadata. 42 | 43 | Each implementation has the following structure: 44 | 45 | ``` 46 | / 47 | pi/*.pi example pi-forall files and exercises 48 | src/*.hs source code 49 | app/Main.hs entry point for command line app 50 | README.md this file 51 | LICENSE license file 52 | pi-forall.cabal project metadata 53 | stack.yaml project metadata 54 | 55 | ``` 56 | 57 | To build each version, go to that directory and type: 58 | 59 | ``` 60 | stack build 61 | ``` 62 | 63 | and to typecheck a source file: 64 | 65 | ``` 66 | stack exec -- pi-forall 67 | ``` 68 | 69 | Versioning 70 | ---------- 71 | 72 | This repository has been tested with the current ghcup recommended tool versions for June 2023, including GHC 9.2.7 and stack lts-20.24. 73 | 74 | 75 | 76 | Acknowledgement 77 | --------------- 78 | 79 | Some of this code was adapted from the 'zombie-trellys' implementation by the 80 | Trellys team. The Trellys team includes Aaron Stump, Tim Sheard, Stephanie 81 | Weirich, Garrin Kimmell, Harley D. Eades III, Peng Fu, Chris Casinghino, 82 | Vilhelm Sjöberg, Nathan Collins, and Ki Yung Ahn. 83 | 84 | This material is based upon work supported by the National Science Foundation 85 | under Grant Number 0910786. Any opinions, findings, and conclusions or 86 | recommendations expressed in this material are those of the author(s) and do 87 | not necessarily reflect the views of the National Science Foundation. 88 | -------------------------------------------------------------------------------- /full/app/Main.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | The command line interface to the pi type checker. 4 | -- Also provides functions for type checking individual terms 5 | -- and files. 6 | module Main(goFilename,go,main) where 7 | 8 | import Modules (getModules) 9 | import PrettyPrint ( render, Disp(..) ) 10 | import Environment ( emptyEnv, runTcMonad ) 11 | import TypeCheck ( tcModules, inferType ) 12 | import Parser ( parseExpr ) 13 | import Text.ParserCombinators.Parsec.Error ( errorPos, ParseError ) 14 | import Control.Monad.Except ( runExceptT ) 15 | import System.Environment(getArgs) 16 | import System.Exit (exitFailure,exitSuccess) 17 | import System.FilePath (splitFileName) 18 | 19 | exitWith :: Either a b -> (a -> IO ()) -> IO b 20 | exitWith res f = 21 | case res of 22 | Left x -> f x >> exitFailure 23 | Right y -> return y 24 | 25 | -- | Type check the given string in the empty environment 26 | go :: String -> IO () 27 | go str = do 28 | case parseExpr str of 29 | Left parseError -> putParseError parseError 30 | Right term -> do 31 | putStrLn "parsed as" 32 | putStrLn $ render $ disp term 33 | res <- runTcMonad emptyEnv (inferType term) 34 | case res of 35 | Left typeError -> putTypeError typeError 36 | Right ty -> do 37 | putStrLn "typed with type" 38 | putStrLn $ render $ disp ty 39 | 40 | -- | Display a parse error to the user 41 | putParseError :: ParseError -> IO () 42 | putParseError parseError = do 43 | putStrLn $ render $ disp $ errorPos parseError 44 | print parseError 45 | 46 | -- | Display a type error to the user 47 | putTypeError :: Disp d => d -> IO () 48 | putTypeError typeError = do 49 | putStrLn "Type Error:" 50 | putStrLn $ render $ disp typeError 51 | 52 | -- | Type check the given file 53 | goFilename :: String -> IO () 54 | goFilename pathToMainFile = do 55 | let prefixes = [currentDir, mainFilePrefix] 56 | (mainFilePrefix, name) = splitFileName pathToMainFile 57 | currentDir = "" 58 | putStrLn $ "processing " ++ name ++ "..." 59 | v <- runExceptT (getModules prefixes name) 60 | val <- v `exitWith` putParseError 61 | putStrLn "type checking..." 62 | d <- runTcMonad emptyEnv (tcModules val) 63 | defs <- d `exitWith` putTypeError 64 | putStrLn $ render $ disp (last defs) 65 | 66 | 67 | -- | 'pi ' invokes the type checker on the given 68 | -- file and either prints the types of all definitions in the module 69 | -- or prints an error message. 70 | main :: IO () 71 | main = do 72 | [pathToMainFile] <- getArgs 73 | goFilename pathToMainFile 74 | exitSuccess 75 | 76 | -------------------------------------------------------------------------------- /full/pi-forall.cabal: -------------------------------------------------------------------------------- 1 | cabal-Version: 2.2 2 | name: pi-forall 3 | version: 0.2 4 | license: MIT 5 | license-file: LICENSE 6 | copyright: (c) 2013-2023 University of Pennsylvania 7 | description: An implementation of a simple dependently typed language for OPLSS 2022 8 | author: Stephanie Weirich , based on code by Trellys Team 9 | maintainer: Stephanie Weirich 10 | build-type: Simple 11 | tested-with: GHC == 8.10.7 12 | category: Compilers/Interpreters 13 | homepage: https://github.com/sweirich/pi-forall 14 | synopsis: Demo implementation of typechecker for dependently-typed language 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/sweirich/pi-forall 19 | 20 | common shared-properties 21 | default-language: 22 | GHC2021 23 | ghc-options: 24 | -Wall -fno-warn-unused-matches -fno-warn-orphans -fno-warn-unused-top-binds -fno-warn-unused-imports -fno-warn-name-shadowing -Wno-unrecognised-pragmas 25 | default-extensions: 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DerivingStrategies 29 | 30 | build-depends: 31 | base >= 4 && < 5, 32 | parsec >= 3.1.8 && < 3.2, 33 | mtl >= 2.2.1, 34 | pretty >= 1.0.1.0, 35 | unbound-generics >= 0.4.3, 36 | transformers, 37 | array >= 0.3.0.2 && < 0.6, 38 | containers, 39 | directory, 40 | filepath, 41 | HUnit, 42 | QuickCheck 43 | if !impl(ghc >= 8.0) 44 | build-depends: semigroups 45 | 46 | 47 | library 48 | import: shared-properties 49 | hs-source-dirs: src 50 | exposed-modules: 51 | Environment 52 | Equal 53 | LayoutToken 54 | Modules 55 | Parser 56 | PrettyPrint 57 | Syntax 58 | TypeCheck 59 | Arbitrary 60 | 61 | executable pi-forall 62 | import: shared-properties 63 | build-depends: pi-forall 64 | hs-source-dirs: app 65 | main-is: Main.hs 66 | 67 | test-suite test-pi-forall 68 | import: shared-properties 69 | build-depends: pi-forall 70 | , QuickCheck >= 2.13.2 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: Main.hs 74 | -------------------------------------------------------------------------------- /full/pi/BoolLib.pi: -------------------------------------------------------------------------------- 1 | -- Standard Library of boolean functions 2 | module BoolLib where 3 | 4 | import Logic 5 | 6 | not : Bool -> Bool 7 | not = \ b . if b then False else True 8 | 9 | -- to be or not to be, that is the question 10 | not_not_equal : (b : Bool) -> (b = not b) -> Void 11 | not_not_equal = \b pf. 12 | if b then (contra pf) else (contra pf) 13 | 14 | andb : Bool -> Bool -> Bool 15 | andb = \ b1 b2. 16 | case b1 of { 17 | True -> b2; 18 | False -> False } 19 | 20 | orb : Bool -> Bool -> Bool 21 | orb = \b1 b2. 22 | case b1 of 23 | True -> True 24 | False -> b2 25 | 26 | implb : Bool -> Bool -> Bool 27 | implb = \b1 b2. if b1 then b2 else True 28 | 29 | negb : Bool -> Bool 30 | negb = \ b . if b then False else True 31 | 32 | 33 | andb_prop : (a : Bool) -> (b : Bool) -> andb a b = True -> And (a = True) (b = True) 34 | andb_prop = \a b p . 35 | if a then (if b then Conj Refl Refl 36 | else contra p) 37 | else (contra p) 38 | 39 | andb_true_intro : (b1 : Bool) -> (b2 : Bool) -> And (b1 = True) (b2 = True) -> andb b1 b2 = True 40 | andb_true_intro = \b1 b2 p . 41 | case p of 42 | Conj p1 p2 -> subst (subst Refl by p1) by p2 43 | 44 | eq_bool : Bool -> Bool -> Bool 45 | eq_bool = \ x y . if x then y else not y 46 | 47 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 48 | eq_true = \b1 b2 pf. 49 | if b1 then if b2 then Refl else contra pf 50 | else if b2 then contra pf else Refl 51 | 52 | -- A function mapping true to an inhabited type and false to an empty 53 | -- type. 54 | 55 | t : Bool -> Type 56 | t = \ b . 57 | case b of 58 | True -> Unit 59 | False -> Void 60 | 61 | is_true : Bool -> Type 62 | is_true = \b. b = True 63 | 64 | -------------------------------------------------------------------------------- /full/pi/Equal.pi: -------------------------------------------------------------------------------- 1 | module Equality where 2 | 3 | -- Defining propositional equality as an indexed datatype 4 | 5 | data Eq (A : Type) (a : A) (b : A) : Type where 6 | EqRefl of [a = b] 7 | 8 | -- The dependent elimination form "J" is derivable 9 | -- from pattern matching. 10 | j : [A : Type] -> [a1 : A] -> [a2 : A] 11 | -> (a : Eq A a1 a2) 12 | -> [B : ((x:A) -> (Eq A x a2) -> Type)] 13 | -> (b : B a2 EqRefl) 14 | -> B a1 a 15 | j = \[A] [a1] [a2] a [B] b . 16 | case a of 17 | EqRefl -> b 18 | 19 | sym : [A:Type] -> [x:A] -> [y:A] -> (Eq A x y) -> Eq A y x 20 | sym = \ [A] [x][y] pf . 21 | case pf of 22 | EqRefl -> EqRefl 23 | 24 | trans : [A:Type] -> [x:A] -> [y:A] -> [z:A] -> (Eq A x z) -> (Eq A z y) -> (Eq A x y) 25 | trans = \[A][x][y][z] pf1 pf2 . 26 | case pf2 of 27 | EqRefl -> pf1 28 | -------------------------------------------------------------------------------- /full/pi/Fin.pi: -------------------------------------------------------------------------------- 1 | -- pi-forall library for finite numbers 2 | -- The type 'Fin n' includes numbers drawn 3 | -- from the range 0 ... n - 1. 4 | -- 5 | -- Some of these are adapted from Fin.agda 6 | 7 | module Fin where 8 | 9 | import Nat 10 | import Equality 11 | import Logic 12 | 13 | -- Numbers bound within a finite range. e.g. the type "Fin 3" has 14 | -- exactly three members: 15 | -- Zero [2] 16 | -- Succ [2] (Zero [1]) 17 | -- and 18 | -- Succ [2] (Succ [1] (Zero [0])) 19 | -- 20 | 21 | data Fin (n : Nat) : Type where 22 | Zero of [m:Nat][n = Succ m] 23 | Succ of [m:Nat][n = Succ m] (Fin m) 24 | 25 | 26 | x0 : Fin 3 27 | x0 = Zero [2] 28 | 29 | x1 : Fin 3 30 | x1 = Succ [2] (Zero [1]) 31 | 32 | x2 : Fin 3 33 | x2 = Succ [2] (Succ [1] (Zero [0])) 34 | 35 | toNat : [n : Nat] -> Fin n -> Nat 36 | toNat = \ [n] fn . 37 | case fn of 38 | Zero [m] -> 0 39 | Succ [m] i -> plus 1 (toNat [m] i) 40 | 41 | raise : [m : Nat] -> (n: Nat) -> Fin m -> Fin (plus n m) 42 | raise = \ [m] n i. 43 | case n of 44 | Zero -> i 45 | Succ n0 -> Succ [plus n0 m] (raise [m] n0 i) 46 | 47 | inject_1 : [m : Nat] -> Fin m -> Fin (Succ m) 48 | inject_1 = \[m] f . Succ [m] f 49 | 50 | inject : [m:Nat] -> (n:Nat) -> Fin m -> Fin (plus m n) 51 | inject = \ [m] n fn. 52 | case fn of 53 | Zero [m0] -> Zero [plus m0 n] 54 | Succ [m0] i -> Succ [plus m0 n] (inject [m0] n i) 55 | 56 | fpred : [n : Nat] -> Fin n -> Fin n 57 | fpred = \ [n] fn . 58 | case fn of 59 | Zero [m]-> Zero [m] 60 | (Succ [m] i) -> inject_1 [m] i 61 | 62 | zero_neq_succ : [n : Nat] -> [i : Fin n] -> neg ((Zero [n] : Fin (Succ n)) = Succ [n] i) 63 | zero_neq_succ = \ [n] [i] p . contra p 64 | 65 | succ_injective : [n : Nat] -> [i : Fin n] -> [j : Fin n] -> (Succ [n] i : Fin (Succ n)) = Succ [n] j -> i = j 66 | succ_injective = \[n][i][j] p . 67 | subst Refl by p 68 | 69 | -- heterogeneous equality 70 | 71 | fin_heq : [n: Nat] -> [m:Nat] -> (Fin n) -> (Fin m) -> Bool 72 | fin_heq = \ [n] [m] fn1 fn2 . 73 | case fn1 of 74 | Zero [m1] -> 75 | case fn2 of 76 | Zero [m2] -> True 77 | Succ [m2] x -> False 78 | Succ [m1] fn1' -> 79 | case fn2 of 80 | Succ [m2] fn2' -> fin_heq [m1][m2] fn1' fn2' 81 | Zero [m2] -> False 82 | 83 | 84 | -- homogeneous equality 85 | 86 | fin_eq : [n: Nat] -> (Fin n) -> (Fin n) -> Bool 87 | fin_eq = \ [n] fn1 fn2 . 88 | case fn1 of 89 | Zero [m1] -> 90 | case fn2 of 91 | Zero [m2] -> True 92 | Succ [m2] x -> False 93 | Succ [m1] fn1' -> 94 | case fn2 of 95 | Succ [m2] fn2' -> fin_eq [m1] fn1' fn2' 96 | Zero [m2] -> False 97 | 98 | -------------------------------------------------------------------------------- /full/pi/FinHw.pi: -------------------------------------------------------------------------------- 1 | -- PI library for finite numbers: HW exercise 2 | -- 3 | -- How many Nat arguments can be declared irrelevant? 4 | -- See: Fin.pi for a solution. 5 | 6 | 7 | module Fin where 8 | 9 | import Nat 10 | 11 | data Fin (n : Nat) : Type where 12 | Zero of (m:Nat)[n = Succ m] -- modify (m:Nat) to [m:Nat] 13 | Succ of (m:Nat)[n = Succ m] (Fin m) -- modify (m:Nat) to [m:Nat] 14 | 15 | -- Modifying data declaration above will require updates to the code below. 16 | 17 | x0 : Fin 1 18 | x0 = Zero 0 19 | 20 | x1 : Fin 2 21 | x1 = Zero 1 22 | 23 | x2 : Fin 3 24 | x2 = Succ 2 (Zero 1) 25 | 26 | toNat : (n : Nat) -> Fin n -> Nat 27 | toNat = \ n fn . 28 | case fn of 29 | Zero m -> 0 30 | Succ m i -> plus 1 (toNat m i) 31 | 32 | raise : (m : Nat) -> (n: Nat) -> Fin m -> Fin (plus n m) 33 | raise = TRUSTME 34 | 35 | inject_1 : (m : Nat) -> Fin m -> Fin (Succ m) 36 | inject_1 = \m f . Succ m f 37 | 38 | inject : (m:Nat) -> (n:Nat) -> Fin m -> Fin (plus m n) 39 | inject = TRUSTME 40 | 41 | 42 | fpred : (n : Nat) -> Fin n -> Fin n 43 | fpred = \ n fn . 44 | case fn of 45 | Zero m -> Zero m 46 | (Succ m i) -> inject_1 m i 47 | 48 | -- Compare for equality 49 | 50 | fin_eq : (n: Nat) -> (Fin n) -> (Fin n) -> Bool 51 | fin_eq = \ n fn1 fn2 . 52 | case fn1 of 53 | Zero m1 -> 54 | case fn2 of 55 | Zero m2 -> True 56 | Succ m2 x -> False 57 | Succ m1 fn1' -> 58 | case fn2 of 59 | Succ m2 fn2' -> fin_eq m1 fn1' fn2' 60 | Zero m2 -> False 61 | 62 | -------------------------------------------------------------------------------- /full/pi/Fix.pi: -------------------------------------------------------------------------------- 1 | -- Can we define the Y combinator in pi-forall? 2 | -- Yes! See below. 3 | -- Note: pi-forall allows recursive definitions, 4 | -- so this is not necessary at all. 5 | 6 | module Fix where 7 | 8 | -- To type check the Y combinator, we need to have a type 9 | -- D such that D ~~ D -> D 10 | 11 | 12 | data D (A : Type) : Type where 13 | F of (_ : D A -> D A) 14 | V of (_ : A) 15 | 16 | unV : [A:Type] -> D A -> A 17 | unV = \[A] v. 18 | case v of 19 | V y -> y 20 | F f -> TRUSTME 21 | 22 | unF :[A:Type] -> D A -> D A -> D A 23 | unF = \[A] v x . 24 | case v of 25 | F f -> f x 26 | V y -> TRUSTME 27 | 28 | -- Here's the Y-combinator. To make it type 29 | -- check, we need to add the appropriate conversions 30 | -- into and out of the D type. 31 | 32 | fix : [A:Type] -> (A -> A) -> A 33 | fix = \ [A] g. 34 | let omega = 35 | ( \x. V (g (unV [A] (unF [A] x x))) 36 | : D A -> D A) in 37 | unV [A] (omega (F omega)) 38 | 39 | -- Example use case 40 | 41 | 42 | data Nat : Type where 43 | Zero 44 | Succ of ( _ : Nat) 45 | 46 | fix_add : Nat -> Nat -> Nat 47 | fix_add = fix [Nat -> Nat -> Nat] 48 | \radd. \x. \y. 49 | case x of 50 | Zero -> y 51 | Succ n -> Succ (radd n y) 52 | 53 | test : fix_add 5 2 = 7 54 | test = Refl 55 | -------------------------------------------------------------------------------- /full/pi/Hurkens.pi: -------------------------------------------------------------------------------- 1 | -- from Jonathan Chan 2 | module Hurkens where 3 | 4 | Void : Type 5 | Void = (x:Type) -> x 6 | 7 | neg : Type -> Type 8 | neg = \X. X -> Void 9 | 10 | P : Type -> Type 11 | P = \S. S -> Type 12 | 13 | U : Type 14 | U = (x : Type) -> ((P (P x)) -> x) -> P (P x) 15 | 16 | tau : (P (P U)) -> U 17 | tau = \t. \x. \f. \p. t (\s. p (f (s x f))) 18 | 19 | sigma : U -> P (P U) 20 | sigma = \s. s U (\t. tau t) 21 | 22 | Delta : P U 23 | Delta = \y. neg ((p : P U) -> sigma y p -> p (tau (sigma y))) 24 | 25 | Omega : U 26 | Omega = tau (\p. (x : U) -> sigma x p -> p x) 27 | 28 | R : (p : P U) -> ((x : U) -> sigma x p -> p x) -> p Omega 29 | R = \zero. \one. one Omega (\x. one (tau (sigma x))) 30 | 31 | M : (x : U) -> sigma x Delta -> Delta x 32 | M = \x. \two. \three. three Delta two (\p. three (\y. p (tau (sigma y)))) 33 | 34 | L : neg ((p : P U) -> ((x : U) -> sigma x p -> p x) -> p Omega) 35 | L = \zero. zero Delta M (\p. zero (\y. p (tau (sigma y)))) 36 | 37 | false : Void 38 | false = L R -------------------------------------------------------------------------------- /full/pi/Hw1.pi: -------------------------------------------------------------------------------- 1 | module Hw1 where 2 | 3 | -- HW #1: get this file to type check by adding typing rules 4 | -- for booleans and sigma types to TypeCheck.hs in 'version1' 5 | 6 | -- prelude operations on boolean values 7 | 8 | or : Bool -> Bool -> Bool 9 | or = \b1 b2. if b1 then True else b2 10 | 11 | not : Bool -> Bool 12 | not = \b . if b then False else True 13 | 14 | and : Bool -> Bool -> Bool 15 | and = \b1 b2. if b1 then b2 else False 16 | 17 | eq_bool : Bool -> Bool -> Bool 18 | eq_bool = \ b1 b2 . 19 | if b1 then b2 else (not b2) 20 | 21 | --- sigma types 22 | 23 | double : (A:Type) -> (x : A) -> { x : A | A } 24 | double = \A x. (x,x) 25 | 26 | fst : (A:Type) -> (B : A -> Type) -> { x : A | B x } -> A 27 | fst = \A B p. let (x0,y) = p in x0 28 | 29 | -------------------------------------------------------------------------------- /full/pi/Hw2.pi: -------------------------------------------------------------------------------- 1 | module Hw2 where 2 | 3 | -- First: read section 7.2 of the lecture notes about how 4 | -- propositional equality works in pi-forall. The key points are 5 | -- that `Refl` is a proof of the identity type `(a = b)` when 6 | -- a is definitionally equal to b, and that `subst` is the elimination 7 | -- form. 8 | 9 | -- For example, we can show that equality is symmetric by 10 | -- eliminating pf (of type `x = y`) when type checking 11 | -- `Refl` against type `y = x`. The `subst` adds the definition 12 | -- `x = y` to the context, so both sides of `y = x` wh normalize to y. 13 | 14 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 15 | sym = \ A x y pf . 16 | subst Refl by pf 17 | 18 | -- Homework: show that propositional equality is transitive 19 | 20 | trans : (A:Type) -> (x:A) -> (y:A) -> (z:A) -> (x = z) -> (z = y) -> (x = y) 21 | trans = \A x y z pf1 pf2 . 22 | subst pf1 by pf2 23 | 24 | -- Homework: show that it is congruent for (nondependent) application 25 | 26 | f_cong : (A:Type) -> (B : Type) -> (f : A -> B) -> (g : A -> B) 27 | -> (x:A) -> (y:A) 28 | -> (f = g) -> (x = y) -> (f x = g y) 29 | f_cong = \ A B f g x y pf1 pf2 . 30 | subst (subst Refl by pf1) by pf2 31 | 32 | -- Homework: what does congruence for dependent application look like? 33 | -- In other words, what if f and g above have a dependent type? 34 | 35 | f_cong_dep : (A:Type) -> (B : A -> Type) 36 | -> (f : (x:A) -> B x) -> (g : (x:A) -> B x) 37 | -> (x:A) -> (y:A) 38 | -> (f = g) -> (p : x = y) -> (f x = subst g y by p) 39 | f_cong_dep = \ A B f g x y pf1 pf2 . 40 | subst (subst Refl by pf1) by pf2 41 | 42 | 43 | -- properties of booleans 44 | 45 | -- an encoding of logical falsity 46 | 47 | void : Type 48 | void = (A:Type) -> A 49 | 50 | neg : Type -> Type 51 | neg = \ A . ( (A) -> void ) 52 | 53 | not : Bool -> Bool 54 | not = \ x . if x then False else True 55 | 56 | -- show that true is not false 57 | 58 | not_not_equal : (b : Bool) -> (b = not b) -> void 59 | not_not_equal = \b pf. 60 | if b then (contra pf) else (contra pf) 61 | 62 | 63 | not_false_then_true : (b : Bool) -> neg (b = False) -> b = True 64 | not_false_then_true = \b nb. 65 | if b then Refl else nb Refl (b = True) 66 | 67 | -- show that decidable equality for booleans is correct. 68 | 69 | eq_bool : Bool -> Bool -> Bool 70 | eq_bool = \x y. if x then y else not y 71 | 72 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 73 | eq_true = \b1 b2 pf. if b1 then if b2 then Refl else contra pf 74 | else if b2 then contra pf else Refl 75 | 76 | eq_false : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = False -> (b1 = b2) -> void 77 | eq_false = \ b1 b2 pf1 pf2 . 78 | if b1 then if b2 then contra pf1 else contra pf2 79 | else if b2 then contra pf2 else contra pf1 80 | 81 | false_eq_bool : (n : Bool) -> (m : Bool) -> 82 | neg (n = m) -> 83 | eq_bool n m = False 84 | false_eq_bool = \n m nnm. if n then if m then nnm Refl (eq_bool n m = False) 85 | else Refl 86 | else if m then Refl 87 | else nnm Refl (eq_bool n m = False) 88 | 89 | 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /full/pi/Lambda.pi: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | import Nat 4 | import Fin 5 | import Vec 6 | 7 | lookup : [a:Type] -> [n:Nat] -> Fin n -> Vec a n -> a 8 | lookup = \[a][n] f v. case f of 9 | Zero [m] -> case v of 10 | Cons [m'] x xs -> x 11 | Succ [m] f' -> case v of 12 | Cons [m'] x xs -> lookup [a][m] f' xs 13 | 14 | data Exp (n : Nat) : Type where 15 | Var of (Fin n) 16 | App of (Exp n) (Exp n) 17 | Lam of (Exp (Succ n)) 18 | Lit of (Nat) 19 | 20 | data Val : Type where 21 | Clos of [n:Nat] (Vec Val n) (Exp (Succ n)) 22 | VNat of (Nat) 23 | 24 | interp : [n:Nat] -> Vec Val n -> Exp n -> Val 25 | interp = \[n] rho e. 26 | case e of 27 | Var x -> lookup [Val] [n] x rho 28 | App e1 e2 -> 29 | let v1 = interp [n] rho e1 in 30 | let v2 = interp [n] rho e2 in 31 | case v1 of 32 | Clos [m] rho' body -> 33 | interp [Succ m] (Cons [m] v2 rho') body 34 | VNat i -> TRUSTME 35 | Lam e -> Clos [n] rho e 36 | Lit i -> VNat i 37 | 38 | one : Fin 2 39 | one = Succ [1] (Zero [0]) 40 | 41 | t1 : interp [0] Nil (App (Lam (Var (Zero[0]))) (Lit 3)) = VNat 3 42 | t1 = Refl 43 | 44 | -- t2 : interp [0] Nil (App (Lam (Var one)) (Lit 2)) = TRUSTME 45 | -- t2 = Refl 46 | 47 | t3 : interp [0] Nil (App (Lit 1) (Lit 2)) = TRUSTME 48 | t3 = Refl -------------------------------------------------------------------------------- /full/pi/Lambda0.pi: -------------------------------------------------------------------------------- 1 | module Lambda0 where 2 | 3 | {- 4 | A Simple example of an environment-based interpreter for a small lambda calculus. 5 | This example could easily be written in vanilla Haskell or ML. 6 | -} 7 | 8 | 9 | import Nat 10 | import List 11 | 12 | -- A small language of lambda-calculus expressions 13 | 14 | data Exp : Type where 15 | Var of (Nat) -- variables, represented with de Bruijn indices 16 | App of (Exp)(Exp) -- application 17 | Lam of (Exp) -- anonymous functions 18 | Lit of (Nat) -- natural number constants 19 | If0 of (Exp)(Exp)(Exp) -- test for zero 20 | 21 | -- example expressions 22 | -- 23 | idfun : Exp -- \ x -> x 24 | idfun = Lam (Var 0) 25 | 26 | k : Exp -- \x y -> x 27 | k = Lam (Lam (Var 1)) 28 | 29 | s : Exp -- \ x y z -> x z (y z) 30 | s = Lam (Lam (Lam (App (App (Var 2) (Var 0)) (App (Var 1) (Var 0))))) 31 | 32 | 33 | -- The result of our interpreter 34 | 35 | data Val : Type where 36 | Clos of (List Val)(Exp) -- a closure: pair of an environment and an expression w/ a free variable 37 | VNat of (Nat) -- natural number value 38 | 39 | 40 | -- List index (subscript) operator, starting from 0. 41 | 42 | nth : [a : Type] -> List a -> Nat -> a 43 | nth = \[a] l n. case l of 44 | Nil -> TRUSTME -- "index too large" 45 | Cons x xs -> case n of 46 | Zero -> x 47 | Succ m -> nth [a] xs m 48 | 49 | -- The interpreter itself 50 | 51 | interp : List Val -> Exp -> Val 52 | interp = \ rho exp . case exp of 53 | Var x -> nth [Val] rho x 54 | App e1 e2 -> 55 | let v1 = interp rho e1 in 56 | let v2 = interp rho e2 in 57 | case v1 of 58 | Clos rho' body -> 59 | interp (Cons v2 rho') body 60 | VNat i -> TRUSTME -- can't apply numbers 61 | Lam e -> Clos rho e 62 | Lit i -> VNat i 63 | If0 e1 e2 e3 -> 64 | case (interp rho e1) of 65 | VNat x -> case x of 66 | Zero -> interp rho e2 67 | (Succ y) -> interp rho e3 68 | Clos rho exp -> TRUSTME 69 | 70 | t1 : interp Nil (App (Lam (Var 0)) (Lit 3)) = VNat 3 71 | t1 = Refl 72 | 73 | t2 : interp Nil (If0 (Lit 1) (Lit 2) (Lit 3)) = VNat 3 74 | t2 = Refl 75 | 76 | -- an "unbound variable" error (i.e. scope error) 77 | 78 | e1 : interp Nil (App (Lam (Var 1)) (Lit 2)) = TRUSTME 79 | e1 = Refl 80 | 81 | -- a run-time type error 82 | 83 | e2 : interp Nil (App (Lit 1) (Lit 2)) = TRUSTME 84 | e2 = Refl 85 | -------------------------------------------------------------------------------- /full/pi/Lambda1.pi: -------------------------------------------------------------------------------- 1 | {- This version of the interpreter indexes datatype by the 2 | scoping depth of the expression. -} 3 | 4 | module Lambda where 5 | 6 | import Nat 7 | import Fin 8 | import Vec 9 | 10 | 11 | data Exp (n : Nat) : Type where 12 | Var of (Fin n) -- variables, represented with de Bruijn indices 13 | App of (Exp n) (Exp n) -- application 14 | Lam of (Exp (Succ n)) -- anonymous functions 15 | Lit of (Nat) -- natural number constants 16 | If0 of (Exp n)(Exp n)(Exp n) -- test for zero 17 | 18 | data Val : Type where 19 | Clos of [n:Nat] (Vec Val n) (Exp (Succ n)) 20 | VNat of (Nat) 21 | Wrong 22 | 23 | 24 | -- Safely access a vector using an index that is known 25 | -- to be in bounds. 26 | nth : [a:Type] -> [n:Nat] -> Vec a n -> Fin n -> a 27 | nth = \[a][n] v f. case f of 28 | Zero [m] -> case v of 29 | Cons [m'] x xs -> x 30 | Succ [m] f' -> case v of 31 | Cons [m'] x xs -> nth [a][m] xs f' 32 | 33 | 34 | interp : [n:Nat] -> Vec Val n -> Exp n -> Val 35 | interp = \[n] rho e. 36 | case e of 37 | Var x -> nth [Val] [n] rho x 38 | App e1 e2 -> 39 | let v1 = interp [n] rho e1 in 40 | let v2 = interp [n] rho e2 in 41 | case v1 of 42 | Clos [m] rho' body -> 43 | interp [Succ m] (Cons [m] v2 rho') body 44 | _ -> Wrong 45 | Lam e -> Clos [n] rho e 46 | Lit i -> VNat i 47 | If0 e1 e2 e3 -> 48 | case (interp [n] rho e1) of 49 | VNat x -> case x of 50 | Zero -> interp [n] rho e2 51 | (Succ y) -> interp [n] rho e3 52 | _ -> Wrong 53 | 54 | 55 | one : Fin 2 56 | one = Succ [1] (Zero [0]) 57 | 58 | t1 : interp [0] Nil (App (Lam (Var (Zero[0]))) (Lit 3)) = VNat 3 59 | t1 = Refl 60 | 61 | -- Scope error, doesn't type check 62 | -- t2 : interp [0] Nil (App (Lam (Var one)) (Lit 2)) = Wrong 63 | -- t2 = Refl 64 | 65 | -- object language type error, runtime error 66 | t3 : interp [0] Nil (App (Lit 1) (Lit 2)) = Wrong 67 | t3 = Refl 68 | -------------------------------------------------------------------------------- /full/pi/Lambda2.pi: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | import Nat 4 | import Fin 5 | import Vec 6 | 7 | {- This version also requires that the object language be statically typed. 8 | It eliminates all run-time errors from the expression. -} 9 | 10 | lookup : [a:Type] -> [n:Nat] -> Fin n -> Vec a n -> a 11 | lookup = \[a][n] f v. case f of 12 | Zero [m] -> case v of 13 | Cons [m'] x xs -> x 14 | Succ [m] f' -> case v of 15 | Cons [m'] x xs -> lookup [a][m] f' xs 16 | 17 | data Ty : Type where 18 | TyFun of (Ty)(Ty) 19 | TyNat 20 | 21 | data List (a : Type) : Type where 22 | Nil 23 | Cons of (a) (List a) 24 | 25 | data VarRef (n : List Ty) (t : Ty) : Type where 26 | VZ of [ts : List Ty][n = Cons t ts] 27 | VS of [ts : List Ty][u : Ty](VarRef ts t)[n = Cons u ts] 28 | 29 | -- a single variable in a context containing one variable 30 | 31 | x : VarRef (Cons TyNat Nil) TyNat 32 | x = VZ [Nil] 33 | 34 | -- two variables in a context containing two vars 35 | 36 | y1 : VarRef (Cons TyNat (Cons TyNat Nil)) TyNat 37 | y1 = VZ [Cons TyNat Nil] 38 | 39 | y2 : VarRef (Cons TyNat (Cons TyNat Nil)) TyNat 40 | y2 = VS [Cons TyNat Nil][TyNat](VZ [Nil]) 41 | 42 | 43 | data Exp (n : List Ty) (t : Ty) : Type where 44 | Var of (VarRef n t) 45 | App of [t1:Ty] (Exp n (TyFun t1 t)) (Exp n t1) 46 | Lam of [t1: Ty][t2:Ty](Exp (Cons t1 n) t2) [t = TyFun t1 t2] 47 | Lit of (Nat)[t = TyNat] 48 | If0 of (Exp n TyNat)(Exp n t)(Exp n t) 49 | 50 | data Env (val : Ty -> Type) (n : List Ty) : Type where 51 | Nil of [n = Nil] 52 | Cons of [t : Ty][ts : List Ty](val t)(Env val ts) [n = Cons t ts] 53 | 54 | data Val (t : Ty) : Type where 55 | Clos of [n:List Ty][t1:Ty][t2:Ty] 56 | (Env (\t. Val t) n) (Exp (Cons t1 n) t2)[t = TyFun t1 t2] 57 | VNat of (Nat)[t = TyNat] 58 | 59 | env : List Ty -> Type 60 | env = \u. Env (\t. Val t) u 61 | 62 | nth : [n : List Ty] -> [t:Ty] -> env n -> VarRef n t -> Val t 63 | nth = \ [n][t] e var. case var of 64 | VZ [ts] -> case e of 65 | Cons [u][ts] v vs -> v 66 | VS [ts][u] v' -> case e of 67 | Cons [u][ts] v vs -> nth [ts][t] vs v' 68 | 69 | 70 | interp : [n:List Ty] -> [t:Ty] -> env n -> Exp n t -> Val t 71 | interp = \[n][t] rho exp. 72 | case exp of 73 | Var x -> nth [n][t] rho x 74 | App [t1] e1 e2 -> 75 | let v1 = interp [n][TyFun t1 t] rho e1 in 76 | let v2 = interp [n][t1] rho e2 in 77 | case v1 of 78 | Clos [m][t1'][t2'] rho' body -> 79 | let rho'' = (Cons [t1][m] v2 rho' : env (Cons t1 m)) in 80 | interp [Cons t1 m][t2'] rho'' body 81 | 82 | Lam [t1][t2] body -> Clos [n][t1][t2] rho body 83 | Lit i -> VNat i 84 | If0 e1 e2 e3 -> case (interp [n][TyNat] rho e1) of 85 | VNat x -> case x of 86 | Zero -> interp [n][t] rho e2 87 | (Succ y) -> interp [n][t] rho e3 88 | 89 | 90 | t1 : interp [Nil][TyNat] Nil (App[TyNat] (Lam [TyNat][TyNat] (Var x)) (Lit 3)) = VNat 3 91 | t1 = Refl 92 | 93 | -- t2 : interp [Nil][TyNat] Nil (App[TyNat] (Lam[TyNat][TyNat] (Var y1)) (Lit 2)) = TRUSTME 94 | -- t2 = Refl 95 | 96 | -- t3 : interp [Nil][TyNat] Nil (App[TyNat] (Lit 1) (Lit 2)) = TRUSTME 97 | -- t3 = Refl -------------------------------------------------------------------------------- /full/pi/Lec1.pi: -------------------------------------------------------------------------------- 1 | -- Simple examples demonstrating parametric polymorphism in core language 2 | 3 | module Lec1 where 4 | 5 | id : (x:Type) -> x -> x 6 | id = \x y . y 7 | 8 | idid : ((x:Type) -> (y : x) -> x) 9 | idid = id ((x:Type) -> (y : x) -> x) id 10 | 11 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 12 | (B -> C) -> (A -> B) -> (A -> C) 13 | compose = \ A B C f g x. (f (g x)) 14 | 15 | idT : Type 16 | idT = (x:Type) -> x -> x 17 | 18 | selfapp : idT -> idT 19 | selfapp = (\x.x : (idT -> idT) -> (idT -> idT)) (\x.x) 20 | 21 | -- Church encoding: booleans 22 | 23 | true : (A:Type) -> A -> A -> A 24 | true = \A x y. x 25 | 26 | false : (A:Type) -> A -> A -> A 27 | false = \A x y. y 28 | 29 | cond : ((A:Type) -> A -> A -> A) -> (x:Type) -> x -> x -> x 30 | cond = \ b . b 31 | 32 | -- void type 33 | 34 | void : Type 35 | void = (x:Type) -> x 36 | 37 | -- inhabited by diverging term 38 | 39 | loop : (x:Type) -> x 40 | loop = \x. loop x 41 | 42 | -- unit type 43 | 44 | unit : Type 45 | unit = (x:Type) -> x -> x 46 | 47 | -- this code only type checks with a definition of type equality that 48 | -- includes beta-equivalence/definitions (i.e. >= version2) 49 | 50 | -- Church encoding of simply-typed pairs 51 | {- 52 | 53 | pair : Type -> Type -> Type 54 | pair = \p. \q. (c: Type) -> (p -> q -> c) -> c 55 | 56 | prod : (p:Type) -> (q:Type) -> p -> q -> pair p q 57 | prod = \p.\q. \x.\y. \c. \f. f x y 58 | 59 | proj1 : (p:Type) -> (q:Type) -> pair p q -> p 60 | proj1 = \p. \q. \a. a p (\x.\y.x) 61 | 62 | proj2 : (p:Type) -> (q:Type) -> pair p q -> q 63 | proj2 = \p. \q. \a. a q (\x.\y.y) 64 | 65 | swap : (p:Type) -> (q:Type) -> pair p q -> pair q p 66 | swap = \p. \q. \a. prod q p (proj2 p q a) (proj1 p q a) 67 | -} 68 | -------------------------------------------------------------------------------- /full/pi/Lec2.pi: -------------------------------------------------------------------------------- 1 | module Lec2 where 2 | 3 | 4 | -- "large eliminations" 5 | 6 | bool' : Bool -> Type 7 | bool' = \b . (B : (b : Bool) -> Type) -> B True -> B False -> B b 8 | 9 | true' : bool' True 10 | true' = \A x y . x 11 | 12 | false' : bool' False 13 | false' = \ A x y. y 14 | 15 | T : Bool -> Type 16 | T = \b. if b then Unit else Bool 17 | 18 | z1 : T True 19 | z1 = () 20 | 21 | z2 : T False 22 | z2 = True 23 | 24 | 25 | -- To get bar and barnot to work 26 | -- the typing rule for 'if' expressions must be 27 | -- context-dependent. In otherwords, it should add new 28 | -- definitions to the context in the true/false branches 29 | -- when the scrutinee is a variable 30 | -- (i.e. >= version2) 31 | 32 | 33 | not : Bool -> Bool 34 | not = \x. if x then False else True 35 | 36 | bar : (b : Bool) -> T b 37 | bar = \b. if b then () else True 38 | 39 | barnot : (b : Bool) -> T (not b) 40 | barnot = \b. if b then False else () 41 | 42 | 43 | -- projections for sigma types 44 | 45 | fst : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> A 46 | fst = \A B p. let (x,y) = p in x 47 | 48 | snd : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> B (fst A B p) 49 | snd = \A B p. let (x1,y) = p in y 50 | 51 | -- examples of propositional equality 52 | 53 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 54 | sym = \ A x y pf . 55 | subst Refl by pf 56 | 57 | -------------------------------------------------------------------------------- /full/pi/Lec3.pi: -------------------------------------------------------------------------------- 1 | module Lec3 where 2 | 3 | -- can mark some arguments as irrelevant 4 | -- irrelevant parameters can only appear in types (or as part of irrelevant arguments) 5 | 6 | id : [x:Type] -> (y : x) -> x 7 | id = \[x] y. (y : x) 8 | 9 | t0 = id [Bool] True 10 | 11 | t1 = id [Bool] (id [Bool] True) 12 | 13 | id2 : [x:Type] -> (y : x) -> x 14 | id2 = \[x] y. id [x] (y : x) 15 | 16 | -- This shouldn't type check because y is relevant 17 | -- 18 | 19 | {- 20 | id' : [x:Type] -> [y:x] -> x 21 | id' = \[x][y]. y 22 | -} 23 | 24 | {- 25 | id2' : [x:Type] -> Type 26 | id2' = \[x]. id [Type] x 27 | -} 28 | 29 | 30 | 31 | ----------------------------------------------------- 32 | -- Irrelevant arguments are ignored during type equality 33 | 34 | irrelevance : (p : [i : Bool] -> Bool) -> p [True] = p [False] 35 | irrelevance = \p . Refl 36 | 37 | 38 | 39 | 40 | 41 | ----------------------------------------------------- 42 | -- Propositional equality is relevant 43 | -- Cannot ignore/erase proofs that are used for 'subst'. 44 | -- Need a termination analysis to do this. 45 | 46 | proprel : [a : Type] -> (pf : a = Bool) -> (x : a) -> Bool 47 | proprel = \[a] pf x . 48 | subst x by pf 49 | 50 | -------------------------------------------------------------------------------- /full/pi/Lennart.pi: -------------------------------------------------------------------------------- 1 | module Lennart where 2 | 3 | -- stack exec -- pi-forall Lennart.pi 4 | -- with unbind / subst 5 | -- 7.81s user 0.52s system 97% cpu 8.568 total 6 | -- with substBind 7 | -- 3.81s user 0.28s system 94% cpu 4.321 total 8 | import Fix 9 | 10 | bool : Type 11 | bool = [C : Type] -> C -> C -> C 12 | 13 | false : bool 14 | false = \[C]. \f.\t.f 15 | true : bool 16 | true = \[C]. \f.\t.t 17 | 18 | nat : Type 19 | nat = [C : Type] -> C -> (nat -> C) -> C 20 | zero : nat 21 | zero = \[C].\z.\s.z 22 | succ : nat -> nat 23 | succ = \n.\[C].\z.\s. s n 24 | one : nat 25 | one = succ zero 26 | two : nat 27 | two = succ one 28 | three : nat 29 | three = succ two 30 | isZero : nat -> bool 31 | isZero = \n.n [bool] true (\m.false) 32 | const : [A:Type] -> A -> A -> A 33 | const = \[A].\x.\y.x 34 | prod : Type -> Type -> Type 35 | prod = \A B. [C:Type] -> (A -> B -> C) -> C 36 | pair : [A :Type] -> [B: Type] -> A -> B -> prod A B 37 | pair = \[A][B] a b. \[C] p. p a b 38 | fst : [A:Type] -> [B:Type] -> prod A B -> A 39 | fst = \[A][B] ab. ab [A] (\a.\b.a) 40 | snd : [A:Type] -> [B:Type] -> prod A B -> B 41 | snd = \[A][B] ab.ab [B] (\a.\b.b) 42 | add : nat -> nat -> nat 43 | add = fix [nat -> nat -> nat] 44 | \radd . \x.\y. x [nat] y (\ n. succ (radd n y)) 45 | mul : nat -> nat -> nat 46 | mul = fix [nat -> nat -> nat] 47 | \rmul. \x.\y. x [nat] zero (\ n. add y (rmul n y)) 48 | fac : nat -> nat 49 | fac = fix [nat -> nat] 50 | \rfac. \x. x [nat] one (\ n. mul x (rfac n)) 51 | eqnat : nat -> nat -> bool 52 | eqnat = fix [nat -> nat -> bool] 53 | \reqnat. \x. \y. 54 | x [bool] 55 | (y [bool] true (\b.false)) 56 | (\x1.y [bool] false (\y1. reqnat x1 y1)) 57 | sumto : nat -> nat 58 | sumto = fix [nat -> nat] 59 | \rsumto. \x. x [nat] zero (\n. add x (rsumto n)) 60 | n5 : nat 61 | n5 = add two three 62 | n6 : nat 63 | n6 = add three three 64 | n17 : nat 65 | n17 = add n6 (add n6 n5) 66 | n37 : nat 67 | n37 = succ (mul n6 n6) 68 | n703 : nat 69 | n703 = sumto n37 70 | n720 : nat 71 | n720 = fac n6 72 | 73 | t : (eqnat n720 (add n703 n17)) = true 74 | t = Refl -------------------------------------------------------------------------------- /full/pi/List.pi: -------------------------------------------------------------------------------- 1 | module List where 2 | 3 | import Nat 4 | 5 | data List (a : Type) : Type where 6 | Nil 7 | Cons of (a) (List a) 8 | 9 | map : [a : Type] -> [b: Type] -> (a -> b) -> List a -> List b 10 | map = \[a] [b] f xs . case xs of 11 | Nil -> Nil 12 | Cons y ys -> Cons (f y) (map [a][b] f ys) 13 | 14 | id : [a:Type] -> a -> a 15 | id = \[a] x . x 16 | 17 | 18 | f_cong2 : [a : Type]->[b : Type] -> (f : a -> b) -> (a1 : a) -> (a2 : a) -> (a1 = a2) -> f a1 = f a2 19 | f_cong2 = \[a][b] f a1 a2 pf . subst Refl by pf 20 | 21 | -- A proof about map 22 | map_id : [a:Type] -> (xs : List a) -> (map [a][a] (id[a]) xs = id [List a] xs) 23 | map_id = \[a] xs. case xs of 24 | Nil -> Refl 25 | Cons y ys -> 26 | let ih = map_id [a] ys in 27 | f_cong2 [List a][List a] (\ys. Cons y ys) (map[a][a](id[a])ys) (id [List a]ys) ih 28 | 29 | 30 | 31 | append : [a:Type] -> List a -> List a -> List a 32 | append = \[a] xs ys. case xs of 33 | Nil -> ys 34 | Cons x xs' -> Cons x (append [a] xs' ys) 35 | 36 | 37 | filter : [a:Type] -> (a -> Bool) -> List a -> List a 38 | filter = \[a] f xs . case xs of 39 | Nil -> Nil 40 | Cons y ys -> if f y then Cons y (filter [a] f ys) else (filter [a] f ys) 41 | 42 | length : [a : Type] -> List a -> Nat 43 | length = \[a] xs . case xs of 44 | Nil -> 0 45 | Cons y ys -> plus 1 (length [a] ys) 46 | 47 | head : [a : Type] -> List a -> a 48 | head = \[a] xs . case xs of 49 | Nil -> TRUSTME -- cannot remove b/c of exhaustivity check 50 | Cons y ys -> y 51 | 52 | -------------------------------------------------------------------------------- /full/pi/Logic.pi: -------------------------------------------------------------------------------- 1 | module Logic where 2 | 3 | -- products (conjunctions) 4 | --------------------------- 5 | 6 | data And (A : Type) (B : Type) : Type where 7 | Conj of (_ : A) (_ : B) 8 | 9 | proj1 : [A:Type] -> [B : Type] -> And A B -> A 10 | proj1 = \ [A] [B] p . case p of 11 | Conj x y -> x 12 | 13 | proj2 : [A:Type] -> [B : Type] -> And A B -> B 14 | proj2 = \ [A] [B] p . case p of 15 | Conj x y -> y 16 | 17 | and_comm : [A : Type] -> [B : Type] -> And A B -> And B A 18 | and_comm = \ [A][B] ab . case ab of 19 | (Conj x y) -> Conj y x 20 | 21 | and_assoc : [A : Type] -> [B : Type] -> [C : Type] -> And A (And B C) -> And (And A B) C 22 | and_assoc = \[A][B][C] abc . 23 | case abc of 24 | Conj a bc -> case bc of 25 | Conj b c -> Conj (Conj a b) c 26 | 27 | -- if and only if 28 | ----------------- 29 | 30 | iff : (A : Type) -> (B : Type) -> Type 31 | iff = \ A B . And (A -> B) (B -> A) 32 | 33 | iff_implies : [A : Type] -> [B : Type] -> iff A B -> A -> B 34 | iff_implies = \[A][B] iff. proj1 [A -> B][B -> A] iff 35 | 36 | iff_sym : [A : Type] -> [B : Type] -> iff A B -> iff B A 37 | iff_sym = \ [A][B] iff. 38 | case iff of 39 | Conj ab ba -> Conj ba ab 40 | 41 | iff_refl : [A : Type] -> iff A A 42 | iff_refl = \[A]. Conj (\x . x) (\x . x) 43 | 44 | iff_trans : [A : Type] -> [B : Type] -> [C : Type] -> (iff A B) -> (iff B C) -> (iff A C) 45 | iff_trans = \ [A] [B] [C] iff1 iff2 . 46 | case iff1 of 47 | Conj ab ba -> 48 | case iff2 of 49 | Conj bc cb -> 50 | Conj (\x. bc (ab x)) (\x. (ba (cb x))) 51 | 52 | -- Disjunction (Logical "or"), aka sums 53 | --------------------------------------- 54 | 55 | data Either (A : Type) (B : Type) : Type where 56 | Inl of (A) 57 | Inr of (B) 58 | 59 | or_commut : [A : Type] -> [B : Type] -> Either A B -> Either B A 60 | or_commut = \ [A][B] ab . case ab of 61 | Inl a -> Inr a 62 | Inr b -> Inl b 63 | 64 | or_distributes_over_and_1 : [P:Type] -> [Q:Type] -> [R:Type] -> 65 | Either P (And Q R) -> And (Either P Q) (Either P R) 66 | or_distributes_over_and_1 = \[P][Q][R] e. 67 | case e of 68 | Inl p -> Conj (Inl p) (Inl p) 69 | Inr qr -> case qr of 70 | (Conj q r) -> Conj (Inr q) (Inr r) 71 | 72 | or_assoc : [A : Type] -> [B : Type] -> [C : Type] -> Either A (Either B C) -> Either (Either A B) C 73 | or_assoc = \[A][B][C] abc . case abc of 74 | Inl a -> Inl (Inl a) 75 | Inr bc -> case bc of 76 | Inl b -> Inl (Inr b) 77 | Inr c -> Inr c 78 | 79 | -- Falsehood 80 | ------------ 81 | 82 | data Void : Type where {} -- no constructors 83 | 84 | -- aka ex_falso_quolibet 85 | false_elim : [P:Type] -> Void -> P 86 | false_elim = \ [P] v . case v of {} 87 | 88 | 89 | -- Negation 90 | ----------- 91 | 92 | neg : Type -> Type 93 | neg = \ x . (x -> Void) 94 | 95 | not_false : neg Void 96 | not_false = \x. x 97 | 98 | contradiction_implies_anything : [P:Type] -> [Q:Type] -> And P (neg P) -> Q 99 | contradiction_implies_anything = \[P][Q] and . 100 | case and of 101 | Conj p notp -> false_elim [Q] (notp p) 102 | 103 | double_neg : [P:Type] -> P -> neg (neg P) 104 | double_neg = \[P] p. 105 | \x. x p 106 | 107 | contrapositive : [P:Type] -> [Q:Type] -> (P -> Q) -> neg Q -> neg P 108 | contrapositive = \[P][Q] pq nq p. nq (pq p) 109 | 110 | not_both_true_and_false : [P:Type] -> [Q:Type] -> neg (And P (neg P)) 111 | not_both_true_and_false = \[P][Q] andpnp. 112 | case andpnp of 113 | (Conj p np) -> np p 114 | 115 | iff_neg_false : [A : Type] -> iff (neg A) (iff A Void) 116 | iff_neg_false = \ [A] . Conj (\ x . Conj x (\y. false_elim [A] y)) (proj1 [A -> Void][Void -> A]) 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /full/pi/Makefile: -------------------------------------------------------------------------------- 1 | # Main Rules 2 | # ========== 3 | # 4 | # make [all]: does a regression test, by checking that everything that 5 | # was correctly passing (failing) type checking is still 6 | # passing (failing) type checking. 7 | # 8 | # make todo: tests if known-broken things are still broken. If you 9 | # fix something in TODO_PASS (TODO_FAIL) then you should 10 | # move it to PASS (FAIL). 11 | 12 | # Use bash to run targets. 13 | SHELL=/bin/bash 14 | 15 | # PASS are tests that *should* always pass. 16 | PASS=Logic Equality Product Nat Fin Vec BoolLib Hw1 Hw2 FinHw \ 17 | Lambda Lambda0 Lambda1 Lambda2 \ 18 | Lec1 Lec2 Lec3 Lec4 \ 19 | List NatChurch Product1 Lennart Hurkens Equal Sigma 20 | 21 | # TODO_FAIL are tests that *should* fail but currently pass. 22 | TODO_FAIL= 23 | # TODO_PASS are tests that *should* pass but currently fail. 24 | TODO_PASS= 25 | # stale? 26 | UNKNOWN= 27 | # A symlink to the local pi-forall, installed by top level make. 28 | PI=pi-forall 29 | # typecheck *quietly* 30 | TYPECHECK=stack exec pi-forall 1>/dev/null # 2>&1 31 | 32 | .PHONY: pass fail todo_pass todo_fail todo 33 | 34 | all: pass fail 35 | 36 | clean: 37 | rm *.pi-elaborated 38 | 39 | pass: $(foreach p,$(PASS),$(p).pass) 40 | 41 | fail: 42 | 43 | 44 | todo_pass: $(foreach f,$(TODO_PASS),$(f).pass) 45 | todo_fail: $(foreach f,$(TODO_FAIL),$(f).fail) 46 | todo: todo_pass 47 | @echo 48 | @echo "Any names printed *without* errors should be moved from TODO_* to *" 49 | 50 | %.pass: %.pi 51 | @echo -n "$<: " 52 | @if ! $(TYPECHECK) $<; then echo -e "\033[1;31mfailed\033[0;30m (should pass)" >&2; else echo; fi 53 | 54 | %.fail: %.pi 55 | @echo -n "$<: " 56 | @if $(TYPECHECK) $<; then echo -e "\033[1;31mpassed\033[0;30m (should fail)" >&2; else echo; fi 57 | -------------------------------------------------------------------------------- /full/pi/Nat.pi: -------------------------------------------------------------------------------- 1 | -- PI library for natural numbers 2 | -- 3 | -- Some of these are adapted from Trellys examples 4 | -- 5 | -- Author: Stephanie Weirich 6 | -- 7 | 8 | module Nat where 9 | 10 | data Nat : Type where 11 | Zero 12 | Succ of (Nat) 13 | 14 | is_zero : Nat -> Bool 15 | is_zero = \ x . case x of 16 | Zero -> True 17 | Succ n' -> False 18 | 19 | pred : Nat -> Nat 20 | pred = \n . case n of 21 | Zero -> Zero 22 | Succ n' -> n' 23 | 24 | 25 | m_eq_n_Sm_eq_Sn : (m:Nat) -> (n:Nat) -> m = n -> ((Succ m : Nat) = Succ n) 26 | m_eq_n_Sm_eq_Sn = \m n pf . 27 | subst Refl by pf 28 | 29 | nat_eq : Nat -> Nat -> Bool 30 | nat_eq = \ x y . 31 | case x of 32 | Zero -> case y of 33 | Zero -> True 34 | Succ n -> False 35 | Succ m -> case y of 36 | Zero -> False 37 | Succ n -> nat_eq m n 38 | 39 | plus : Nat -> Nat -> Nat 40 | plus = \ n m . 41 | case n of 42 | Zero -> m 43 | Succ pred -> Succ (plus pred m) 44 | 45 | mult : Nat -> Nat -> Nat 46 | mult = \ n m . 47 | case n of 48 | Zero -> Zero 49 | Succ pred -> plus m (mult pred m) 50 | 51 | 52 | minus : Nat -> Nat -> Nat 53 | minus = \n m . 54 | case n of 55 | Zero -> Zero 56 | Succ pred -> case m of 57 | Zero -> n 58 | Succ mpred -> minus pred mpred 59 | 60 | ------------------------------------------------------- 61 | -- Reasoning about datatypes 62 | 63 | 64 | minus_same_zero : (n : Nat) -> (minus n n = 0) 65 | minus_same_zero = \ n . 66 | case n of 67 | Zero -> Refl 68 | Succ p -> (minus_same_zero p : minus p p = 0) 69 | 70 | lemma_minus_zero_id : (n : Nat) -> (minus n 0 = n) 71 | lemma_minus_zero_id = \n . case n of 72 | Zero -> Refl 73 | Succ n' -> Refl 74 | 75 | 76 | lemma_minus_plus_id : (m : Nat) -> (n : Nat) -> ((minus (plus m n) m) = n) 77 | lemma_minus_plus_id = \m n . 78 | case m of 79 | Zero -> lemma_minus_zero_id n 80 | Succ m' -> lemma_minus_plus_id m' n 81 | 82 | plus_associates : (i:Nat) -> (j:Nat) -> (k:Nat) -> plus (plus i j) k = plus i (plus j k) 83 | plus_associates = \ i j k . 84 | case i of 85 | -- `Refl` away `Zero`s on the left of `(+)`: (0+j)+k = j+k = 0+(j+k) 86 | Zero -> Refl 87 | -- associate `plus` in `Succ` of the inductive case: 88 | -- S ((i'+j)+k) = S (i'+(j+k)) 89 | Succ i' -> 90 | let ih = (plus_associates i' j k) in 91 | m_eq_n_Sm_eq_Sn (plus (plus i' j) k) (plus i' (plus j k)) ih 92 | 93 | -------------------------------------------------------------------------------- /full/pi/NatChurch.pi: -------------------------------------------------------------------------------- 1 | module NatChurch where 2 | 3 | -- Church encoding of natural numbers 4 | 5 | nat : Type 6 | nat = (x:Type) -> x -> (x -> x) -> x 7 | 8 | z : nat 9 | z = \x zf sf. zf 10 | 11 | s : nat -> nat 12 | s = \n. \x zf sf. sf (n x zf sf) 13 | 14 | one : nat 15 | one = s z 16 | 17 | two : nat 18 | two = s (s z) 19 | 20 | three : nat 21 | three = TRUSTME -- replace with correct definition of 3 22 | 23 | plus : nat -> nat -> nat 24 | plus = \x. \y. x nat y s 25 | 26 | test0 : plus one one = two 27 | test0 = Refl 28 | 29 | test1 : plus one two = three 30 | test1 = TRUSTME -- replace with Refl 31 | 32 | spec0 : (n : nat) -> plus z n = n 33 | spec0 = \n . Refl 34 | 35 | spec1 : (n : nat) -> (m : nat) -> plus (s n) m = s (plus n m) 36 | spec1 = \n m . Refl 37 | 38 | -- The predecessor function is *really* tricky! Don't try this 39 | -- first if you have never seen it before. 40 | 41 | pred : nat -> nat 42 | pred = TRUSTME 43 | 44 | test_pred : pred two = one 45 | test_pred = TRUSTME -- replace with Refl 46 | 47 | -- Since pi-forall allows recursive definitions, we also have Scott encodings 48 | -- of datatypes available. (See http://en.wikipedia.org/wiki/Mogensen%E2%80%93Scott_encoding. 49 | -- You can't do this in Coq or Agda because it requires an inconsistent logic). 50 | 51 | scott_nat : Type 52 | scott_nat = (x:Type) -> x -> (scott_nat -> x) -> x 53 | 54 | scott_z : scott_nat 55 | scott_z = \x z s . z 56 | 57 | scott_s : scott_nat -> scott_nat 58 | scott_s = \n . \x z s . s n 59 | 60 | scott_one : scott_nat 61 | scott_one = scott_s scott_z 62 | 63 | scott_two : scott_nat 64 | scott_two = scott_s (scott_s scott_z) 65 | 66 | scott_three : scott_nat 67 | scott_three = scott_s (scott_s (scott_s scott_z)) 68 | 69 | -- Write the predecessor function, it is much easier here 70 | 71 | scott_pred : scott_nat -> scott_nat 72 | scott_pred = TRUSTME 73 | 74 | testNC1 : scott_pred scott_two = scott_one 75 | testNC1 = TRUSTME -- replace with Refl 76 | 77 | -- Now write plus: with Scott encoded nats, note that you need to use recursion. 78 | 79 | scott_plus : scott_nat -> scott_nat -> scott_nat 80 | scott_plus = TRUSTME 81 | 82 | testNC2 : scott_plus scott_one scott_two = scott_three 83 | testNC2 = TRUSTME -- replace with Refl 84 | -------------------------------------------------------------------------------- /full/pi/Sigma.pi: -------------------------------------------------------------------------------- 1 | module Sigma where 2 | 3 | -- Defining projection terms using pattern matching 4 | 5 | fst : (A:Type) -> (B:A -> Type) -> { x : A | B x } -> A 6 | fst = \A B x . let (y,z) = x in y 7 | 8 | snd : (A:Type) -> (B:A -> Type) -> (p : { x:A | B x}) -> B (fst A B p) 9 | snd = \A B x . let (y,z) = x in z 10 | 11 | 12 | -------------------------------------------------------------------------------- /full/src/Modules.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | Tools for working with multiple source files 4 | module Modules(getModules, ModuleInfo(..)) where 5 | 6 | import Syntax 7 | import Parser(parseModuleFile, parseModuleImports) 8 | 9 | import Text.ParserCombinators.Parsec.Error ( ParseError ) 10 | 11 | import Control.Monad.Except 12 | import Control.Monad.State.Lazy 13 | import System.FilePath 14 | import System.Directory 15 | import qualified Data.Graph as Gr 16 | import Data.List(nub,(\\)) 17 | 18 | -- | getModules starts with a top-level module, and gathers all of the module's 19 | -- transitive dependency. It returns the list of parsed modules, with all 20 | -- modules appearing after its dependencies. 21 | getModules 22 | :: (Functor m, MonadError ParseError m, MonadIO m) => 23 | [FilePath] -> String -> m [Module] 24 | getModules prefixes top = do 25 | toParse <- gatherModules prefixes [ModuleImport top] 26 | flip evalStateT initialConstructorNames $ mapM reparse toParse 27 | 28 | 29 | data ModuleInfo = ModuleInfo { 30 | modInfoName :: ModuleName, 31 | modInfoFilename :: String, 32 | modInfoImports :: [ModuleImport] 33 | } 34 | 35 | -- | Build the module dependency graph. 36 | -- This only parses the imports part of each file; later we go back and parse all of it. 37 | gatherModules 38 | :: (Functor m, MonadError ParseError m, MonadIO m) => 39 | [FilePath] -> [ModuleImport] -> m [ModuleInfo] 40 | gatherModules prefixes ms = gatherModules' ms [] where 41 | gatherModules' [] accum = return $ topSort accum 42 | gatherModules' ((ModuleImport m):ms') accum = do 43 | modFileName <- getModuleFileName prefixes m 44 | imports <- moduleImports <$> parseModuleImports modFileName 45 | let accum' = ModuleInfo m modFileName imports :accum 46 | let oldMods = map (ModuleImport . modInfoName) accum' 47 | gatherModules' (nub (ms' ++ imports) \\ oldMods) accum' 48 | 49 | -- | Generate a sorted list of modules, with the postcondition that a module 50 | -- will appear _after_ any of its dependencies. 51 | topSort :: [ModuleInfo] -> [ModuleInfo] 52 | topSort ms = reverse sorted 53 | where (gr,lu) = Gr.graphFromEdges' [(m, modInfoName m, [i | ModuleImport i <- modInfoImports m]) 54 | | m <- ms] 55 | lu' v = let (m,_,_) = lu v in m 56 | sorted = [lu' v | v <- Gr.topSort gr] 57 | 58 | -- | Find the file associated with a module. 59 | getModuleFileName :: (MonadIO m) 60 | => [FilePath] -> ModuleName -> m FilePath 61 | getModuleFileName prefixes modul = do 62 | let makeFileName prefix = prefix mDotPi 63 | -- get M.pi from M or M.pi 64 | mDotPi = if takeExtension s == ".pi" 65 | then s 66 | else s <.> "pi" 67 | s = modul 68 | possibleFiles = map makeFileName prefixes 69 | files <- liftIO $ filterM doesFileExist possibleFiles 70 | if null files 71 | then error $ "Can't locate module: " ++ show modul ++ 72 | "\nTried: " ++ show possibleFiles 73 | else return $ head files 74 | 75 | -- | Fully parse a module (not just the imports). 76 | reparse :: (MonadError ParseError m, MonadIO m, MonadState ConstructorNames m) => 77 | ModuleInfo -> m Module 78 | reparse (ModuleInfo _ fileName _) = do 79 | cnames <- get 80 | modu <- parseModuleFile cnames fileName 81 | put (moduleConstructors modu) 82 | return modu 83 | 84 | -------------------------------------------------------------------------------- /full/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | 3 | # Local packages, usually specified by relative directory name 4 | packages: 5 | - '.' 6 | 7 | flags: {} 8 | 9 | extra-package-dbs: [] 10 | 11 | -------------------------------------------------------------------------------- /full/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.QuickCheck 4 | import Test.HUnit 5 | import Environment 6 | import PrettyPrint 7 | import TypeCheck 8 | import Syntax 9 | import Control.Monad.Except 10 | import Modules 11 | import Text.PrettyPrint.HughesPJ (render) 12 | import Text.ParserCombinators.Parsec.Error 13 | import Test.QuickCheck 14 | import Arbitrary 15 | 16 | main :: IO () 17 | main = do 18 | quickCheck prop_roundtrip 19 | 20 | exitWith :: Either a b -> (a -> IO b) -> IO b 21 | exitWith (Left a) f = f a 22 | exitWith (Right b) f = return b 23 | 24 | -- | Type check the given file 25 | testFile :: String -> Test 26 | testFile name = name ~: TestCase $ do 27 | v <- runExceptT (getModules ["pi"] name) 28 | val <- v `exitWith` (\b -> assertFailure $ "Parse error: " ++ render (disp b)) 29 | d <- runTcMonad emptyEnv (tcModules val) 30 | defs <- d `exitWith` (\s -> assertFailure $ "Type error:" ++ render (disp s)) 31 | putStrLn $ render $ disp (last defs) -------------------------------------------------------------------------------- /main/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2022, University of Pennsylvania 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the University of Pennsylvania nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL UNIVERSITY OF PENNSYLVANIA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /main/README.md: -------------------------------------------------------------------------------- 1 | pi-forall 2 | ========= 3 | 4 | A demo implementation of a simple dependently-typed language for OPLSS 5 | (Used in 2023, 2022, 2014 and 2013) 6 | 7 | The goal of this project is to bring up the design issues that occur in the 8 | implementation of the type checkers of languages like Agda, Coq, Epigram, 9 | Idris, etc. Of course, it can't cover everything, but this code is a 10 | starting point for discussion. 11 | 12 | As its main purpose is didactic, the code itself has been written for 13 | clarity, not for speed. The point of this implementation is an introduction to 14 | practical issues of language design and how specific features interact with 15 | each other. 16 | 17 | Installation 18 | ---------- 19 | 20 | Compiling pi-forall requires GHC and stack 21 | 22 | Recommended tools (see links for instructions): 23 | 24 | 1. [gchup](https://www.haskell.org/ghcup/) 25 | 26 | The gchup tool is an installer for general purpose Haskell tools, including GHC, Cabal, Stack and the Haskell language server (HLS). You'll want to install the recommended versions of all of these tools. 27 | 28 | 2. [VSCode](https://code.visualstudio.com/) and [Haskell language extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) for editing the Haskell implementation of `pi-forall`. 29 | 30 | 3. [pi-forall VS code extension](https://marketplace.visualstudio.com/items?itemName=dunhamsteve.pi4all) for syntax highlighting of `pi-forall` code in VS code. 31 | 32 | Contents 33 | -------- 34 | 35 | There are several versions of `pi-forall` in the repository. See the 36 | [documentation](https://github.com/sweirich/pi-forall/blob/2023/doc/oplss.pdf) for an extended 37 | description of what parts of the language are covered by each version. 38 | 39 | When you open the project in vscode, you should open the folder for the implementation that 40 | you want to work with (i.e. `version1`/`version2`/`full`), so that the Haskell language server 41 | can find the project metadata. 42 | 43 | Each implementation has the following structure: 44 | 45 | ``` 46 | / 47 | pi/*.pi example pi-forall files and exercises 48 | src/*.hs source code 49 | app/Main.hs entry point for command line app 50 | README.md this file 51 | LICENSE license file 52 | pi-forall.cabal project metadata 53 | stack.yaml project metadata 54 | 55 | ``` 56 | 57 | To build each version, go to that directory and type: 58 | 59 | ``` 60 | stack build 61 | ``` 62 | 63 | and to typecheck a source file: 64 | 65 | ``` 66 | stack exec -- pi-forall 67 | ``` 68 | 69 | Versioning 70 | ---------- 71 | 72 | This repository has been tested with the current ghcup recommended tool versions for June 2023, including GHC 9.2.7 and stack lts-20.24. 73 | 74 | 75 | 76 | Acknowledgement 77 | --------------- 78 | 79 | Some of this code was adapted from the 'zombie-trellys' implementation by the 80 | Trellys team. The Trellys team includes Aaron Stump, Tim Sheard, Stephanie 81 | Weirich, Garrin Kimmell, Harley D. Eades III, Peng Fu, Chris Casinghino, 82 | Vilhelm Sjöberg, Nathan Collins, and Ki Yung Ahn. 83 | 84 | This material is based upon work supported by the National Science Foundation 85 | under Grant Number 0910786. Any opinions, findings, and conclusions or 86 | recommendations expressed in this material are those of the author(s) and do 87 | not necessarily reflect the views of the National Science Foundation. 88 | -------------------------------------------------------------------------------- /main/app/Main.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | The command line interface to the pi type checker. 4 | -- Also provides functions for type checking individual terms 5 | -- and files. 6 | module Main(goFilename,go,main) where 7 | 8 | import Modules (getModules) 9 | import PrettyPrint ( render, Disp(..) ) 10 | import Environment ( emptyEnv, runTcMonad ) 11 | import TypeCheck ( tcModules, inferType ) 12 | import Parser ( parseExpr ) 13 | import Text.ParserCombinators.Parsec.Error ( errorPos, ParseError ) 14 | import Control.Monad.Except ( runExceptT ) 15 | import System.Environment(getArgs) 16 | import System.Exit (exitFailure,exitSuccess) 17 | import System.FilePath (splitFileName) 18 | 19 | exitWith :: Either a b -> (a -> IO ()) -> IO b 20 | exitWith res f = 21 | case res of 22 | Left x -> f x >> exitFailure 23 | Right y -> return y 24 | 25 | -- | Type check the given string in the empty environment 26 | go :: String -> IO () 27 | go str = do 28 | case parseExpr str of 29 | Left parseError -> putParseError parseError 30 | Right term -> do 31 | putStrLn "parsed as" 32 | putStrLn $ render $ disp term 33 | res <- runTcMonad emptyEnv (inferType term) 34 | case res of 35 | Left typeError -> putTypeError typeError 36 | Right ty -> do 37 | putStrLn "typed with type" 38 | putStrLn $ render $ disp ty 39 | 40 | -- | Display a parse error to the user 41 | putParseError :: ParseError -> IO () 42 | putParseError parseError = do 43 | putStrLn $ render $ disp $ errorPos parseError 44 | print parseError 45 | 46 | -- | Display a type error to the user 47 | putTypeError :: Disp d => d -> IO () 48 | putTypeError typeError = do 49 | putStrLn "Type Error:" 50 | putStrLn $ render $ disp typeError 51 | 52 | -- | Type check the given file 53 | goFilename :: String -> IO () 54 | goFilename pathToMainFile = do 55 | let prefixes = [currentDir, mainFilePrefix] 56 | (mainFilePrefix, name) = splitFileName pathToMainFile 57 | currentDir = "" 58 | putStrLn $ "processing " ++ name ++ "..." 59 | v <- runExceptT (getModules prefixes name) 60 | val <- v `exitWith` putParseError 61 | putStrLn "type checking..." 62 | d <- runTcMonad emptyEnv (tcModules val) 63 | defs <- d `exitWith` putTypeError 64 | putStrLn $ render $ disp (last defs) 65 | 66 | 67 | -- | 'pi ' invokes the type checker on the given 68 | -- file and either prints the types of all definitions in the module 69 | -- or prints an error message. 70 | main :: IO () 71 | main = do 72 | [pathToMainFile] <- getArgs 73 | goFilename pathToMainFile 74 | exitSuccess 75 | 76 | -------------------------------------------------------------------------------- /main/pi-forall.cabal: -------------------------------------------------------------------------------- 1 | cabal-Version: 2.2 2 | name: pi-forall 3 | version: 0.2 4 | license: MIT 5 | license-file: LICENSE 6 | copyright: (c) 2013-2023 University of Pennsylvania 7 | description: An implementation of a simple dependently typed language for OPLSS 2022 8 | author: Stephanie Weirich , based on code by Trellys Team 9 | maintainer: Stephanie Weirich 10 | build-type: Simple 11 | tested-with: GHC == 8.10.7 12 | category: Compilers/Interpreters 13 | homepage: https://github.com/sweirich/pi-forall 14 | synopsis: Demo implementation of typechecker for dependently-typed language 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/sweirich/pi-forall 19 | 20 | common shared-properties 21 | default-language: 22 | GHC2021 23 | ghc-options: 24 | -Wall -fno-warn-unused-matches -fno-warn-orphans -fno-warn-unused-top-binds -fno-warn-unused-imports -fno-warn-name-shadowing -Wno-unrecognised-pragmas 25 | default-extensions: 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DerivingStrategies 29 | 30 | build-depends: 31 | base >= 4 && < 5, 32 | parsec >= 3.1.8 && < 3.2, 33 | mtl >= 2.2.1, 34 | pretty >= 1.0.1.0, 35 | unbound-generics >= 0.4.3, 36 | transformers, 37 | array >= 0.3.0.2 && < 0.6, 38 | containers, 39 | directory, 40 | filepath, 41 | HUnit, 42 | QuickCheck 43 | if !impl(ghc >= 8.0) 44 | build-depends: semigroups 45 | 46 | 47 | library 48 | import: shared-properties 49 | hs-source-dirs: src 50 | exposed-modules: 51 | Environment 52 | Equal 53 | LayoutToken 54 | Modules 55 | Parser 56 | PrettyPrint 57 | Syntax 58 | TypeCheck 59 | Arbitrary 60 | 61 | executable pi-forall 62 | import: shared-properties 63 | build-depends: pi-forall 64 | hs-source-dirs: app 65 | main-is: Main.hs 66 | 67 | test-suite test-pi-forall 68 | import: shared-properties 69 | build-depends: pi-forall 70 | , QuickCheck >= 2.13.2 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: Main.hs 74 | -------------------------------------------------------------------------------- /main/pi/BoolLib.pi: -------------------------------------------------------------------------------- 1 | -- Standard Library of boolean functions 2 | module BoolLib where 3 | 4 | import Logic 5 | 6 | not : Bool -> Bool 7 | not = \ b . if b then False else True 8 | 9 | -- to be or not to be, that is the question 10 | not_not_equal : (b : Bool) -> (b = not b) -> Void 11 | not_not_equal = \b pf. 12 | if b then (contra pf) else (contra pf) 13 | 14 | andb : Bool -> Bool -> Bool 15 | andb = \ b1 b2. 16 | case b1 of { 17 | True -> b2; 18 | False -> False } 19 | 20 | orb : Bool -> Bool -> Bool 21 | orb = \b1 b2. 22 | case b1 of 23 | True -> True 24 | False -> b2 25 | 26 | implb : Bool -> Bool -> Bool 27 | implb = \b1 b2. if b1 then b2 else True 28 | 29 | negb : Bool -> Bool 30 | negb = \ b . if b then False else True 31 | 32 | 33 | andb_prop : (a : Bool) -> (b : Bool) -> andb a b = True -> And (a = True) (b = True) 34 | andb_prop = \a b p . 35 | if a then (if b then Conj Refl Refl 36 | else contra p) 37 | else (contra p) 38 | 39 | andb_true_intro : (b1 : Bool) -> (b2 : Bool) -> And (b1 = True) (b2 = True) -> andb b1 b2 = True 40 | andb_true_intro = \b1 b2 p . 41 | case p of 42 | Conj p1 p2 -> subst (subst Refl by p1) by p2 43 | 44 | eq_bool : Bool -> Bool -> Bool 45 | eq_bool = \ x y . if x then y else not y 46 | 47 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 48 | eq_true = \b1 b2 pf. 49 | if b1 then if b2 then Refl else contra pf 50 | else if b2 then contra pf else Refl 51 | 52 | -- A function mapping true to an inhabited type and false to an empty 53 | -- type. 54 | 55 | t : Bool -> Type 56 | t = \ b . 57 | case b of 58 | True -> Unit 59 | False -> Void 60 | 61 | is_true : Bool -> Type 62 | is_true = \b. b = True 63 | 64 | -------------------------------------------------------------------------------- /main/pi/Equal.pi: -------------------------------------------------------------------------------- 1 | module Equality where 2 | 3 | -- Defining propositional equality as an indexed datatype 4 | 5 | data Eq (A : Type) (a : A) (b : A) : Type where 6 | EqRefl of [a = b] 7 | 8 | -- The dependent elimination form "J" is derivable 9 | -- from pattern matching. 10 | j : [A : Type] -> [a1 : A] -> [a2 : A] 11 | -> (a : Eq A a1 a2) 12 | -> [B : ((x:A) -> (Eq A x a2) -> Type)] 13 | -> (b : B a2 EqRefl) 14 | -> B a1 a 15 | j = \[A] [a1] [a2] a [B] b . 16 | case a of 17 | EqRefl -> b 18 | 19 | sym : [A:Type] -> [x:A] -> [y:A] -> (Eq A x y) -> Eq A y x 20 | sym = \ [A] [x][y] pf . 21 | case pf of 22 | EqRefl -> EqRefl 23 | 24 | trans : [A:Type] -> [x:A] -> [y:A] -> [z:A] -> (Eq A x z) -> (Eq A z y) -> (Eq A x y) 25 | trans = \[A][x][y][z] pf1 pf2 . 26 | case pf2 of 27 | EqRefl -> pf1 28 | -------------------------------------------------------------------------------- /main/pi/Fin.pi: -------------------------------------------------------------------------------- 1 | -- pi-forall library for finite numbers 2 | -- The type 'Fin n' includes numbers drawn 3 | -- from the range 0 ... n - 1. 4 | -- 5 | -- Some of these are adapted from Fin.agda 6 | 7 | module Fin where 8 | 9 | import Nat 10 | import Equality 11 | import Logic 12 | 13 | -- Numbers bound within a finite range. e.g. the type "Fin 3" has 14 | -- exactly three members: 15 | -- Zero [2] 16 | -- Succ [2] (Zero [1]) 17 | -- and 18 | -- Succ [2] (Succ [1] (Zero [0])) 19 | -- 20 | 21 | data Fin (n : Nat) : Type where 22 | Zero of [m:Nat][n = Succ m] 23 | Succ of [m:Nat][n = Succ m] (Fin m) 24 | 25 | 26 | x0 : Fin 3 27 | x0 = Zero [2] 28 | 29 | x1 : Fin 3 30 | x1 = Succ [2] (Zero [1]) 31 | 32 | x2 : Fin 3 33 | x2 = Succ [2] (Succ [1] (Zero [0])) 34 | 35 | toNat : [n : Nat] -> Fin n -> Nat 36 | toNat = \ [n] fn . 37 | case fn of 38 | Zero [m] -> 0 39 | Succ [m] i -> plus 1 (toNat [m] i) 40 | 41 | raise : [m : Nat] -> (n: Nat) -> Fin m -> Fin (plus n m) 42 | raise = \ [m] n i. 43 | case n of 44 | Zero -> i 45 | Succ n0 -> Succ [plus n0 m] (raise [m] n0 i) 46 | 47 | inject_1 : [m : Nat] -> Fin m -> Fin (Succ m) 48 | inject_1 = \[m] f . Succ [m] f 49 | 50 | inject : [m:Nat] -> (n:Nat) -> Fin m -> Fin (plus m n) 51 | inject = \ [m] n fn. 52 | case fn of 53 | Zero [m0] -> Zero [plus m0 n] 54 | Succ [m0] i -> Succ [plus m0 n] (inject [m0] n i) 55 | 56 | fpred : [n : Nat] -> Fin n -> Fin n 57 | fpred = \ [n] fn . 58 | case fn of 59 | Zero [m]-> Zero [m] 60 | (Succ [m] i) -> inject_1 [m] i 61 | 62 | zero_neq_succ : [n : Nat] -> [i : Fin n] -> neg ((Zero [n] : Fin (Succ n)) = Succ [n] i) 63 | zero_neq_succ = \ [n] [i] p . contra p 64 | 65 | succ_injective : [n : Nat] -> [i : Fin n] -> [j : Fin n] -> (Succ [n] i : Fin (Succ n)) = Succ [n] j -> i = j 66 | succ_injective = \[n][i][j] p . 67 | subst Refl by p 68 | 69 | -- heterogeneous equality 70 | 71 | fin_heq : [n: Nat] -> [m:Nat] -> (Fin n) -> (Fin m) -> Bool 72 | fin_heq = \ [n] [m] fn1 fn2 . 73 | case fn1 of 74 | Zero [m1] -> 75 | case fn2 of 76 | Zero [m2] -> True 77 | Succ [m2] x -> False 78 | Succ [m1] fn1' -> 79 | case fn2 of 80 | Succ [m2] fn2' -> fin_heq [m1][m2] fn1' fn2' 81 | Zero [m2] -> False 82 | 83 | 84 | -- homogeneous equality 85 | 86 | fin_eq : [n: Nat] -> (Fin n) -> (Fin n) -> Bool 87 | fin_eq = \ [n] fn1 fn2 . 88 | case fn1 of 89 | Zero [m1] -> 90 | case fn2 of 91 | Zero [m2] -> True 92 | Succ [m2] x -> False 93 | Succ [m1] fn1' -> 94 | case fn2 of 95 | Succ [m2] fn2' -> fin_eq [m1] fn1' fn2' 96 | Zero [m2] -> False 97 | 98 | -------------------------------------------------------------------------------- /main/pi/FinHw.pi: -------------------------------------------------------------------------------- 1 | -- PI library for finite numbers: HW exercise 2 | -- 3 | -- How many Nat arguments can be declared irrelevant? 4 | -- See: Fin.pi for a solution. 5 | 6 | 7 | module Fin where 8 | 9 | import Nat 10 | 11 | data Fin (n : Nat) : Type where 12 | Zero of (m:Nat)[n = Succ m] -- modify (m:Nat) to [m:Nat] 13 | Succ of (m:Nat)[n = Succ m] (Fin m) -- modify (m:Nat) to [m:Nat] 14 | 15 | -- Modifying data declaration above will require updates to the code below. 16 | 17 | x0 : Fin 1 18 | x0 = Zero 0 19 | 20 | x1 : Fin 2 21 | x1 = Zero 1 22 | 23 | x2 : Fin 3 24 | x2 = Succ 2 (Zero 1) 25 | 26 | toNat : (n : Nat) -> Fin n -> Nat 27 | toNat = \ n fn . 28 | case fn of 29 | Zero m -> 0 30 | Succ m i -> plus 1 (toNat m i) 31 | 32 | raise : (m : Nat) -> (n: Nat) -> Fin m -> Fin (plus n m) 33 | raise = TRUSTME 34 | 35 | inject_1 : (m : Nat) -> Fin m -> Fin (Succ m) 36 | inject_1 = \m f . Succ m f 37 | 38 | inject : (m:Nat) -> (n:Nat) -> Fin m -> Fin (plus m n) 39 | inject = TRUSTME 40 | 41 | 42 | fpred : (n : Nat) -> Fin n -> Fin n 43 | fpred = \ n fn . 44 | case fn of 45 | Zero m -> Zero m 46 | (Succ m i) -> inject_1 m i 47 | 48 | -- Compare for equality 49 | 50 | fin_eq : (n: Nat) -> (Fin n) -> (Fin n) -> Bool 51 | fin_eq = \ n fn1 fn2 . 52 | case fn1 of 53 | Zero m1 -> 54 | case fn2 of 55 | Zero m2 -> True 56 | Succ m2 x -> False 57 | Succ m1 fn1' -> 58 | case fn2 of 59 | Succ m2 fn2' -> fin_eq m1 fn1' fn2' 60 | Zero m2 -> False 61 | 62 | -------------------------------------------------------------------------------- /main/pi/Fix.pi: -------------------------------------------------------------------------------- 1 | -- Can we define the Y combinator in pi-forall? 2 | -- Yes! See below. 3 | -- Note: pi-forall allows recursive definitions, 4 | -- so this is not necessary at all. 5 | 6 | module Fix where 7 | 8 | -- To type check the Y combinator, we need to have a type 9 | -- D such that D ~~ D -> D 10 | 11 | 12 | data D (A : Type) : Type where 13 | F of (_ : D A -> D A) 14 | V of (_ : A) 15 | 16 | unV : [A:Type] -> D A -> A 17 | unV = \[A] v. 18 | case v of 19 | V y -> y 20 | F f -> TRUSTME 21 | 22 | unF :[A:Type] -> D A -> D A -> D A 23 | unF = \[A] v x . 24 | case v of 25 | F f -> f x 26 | V y -> TRUSTME 27 | 28 | -- Here's the Y-combinator. To make it type 29 | -- check, we need to add the appropriate conversions 30 | -- into and out of the D type. 31 | 32 | fix : [A:Type] -> (A -> A) -> A 33 | fix = \ [A] g. 34 | let omega = 35 | ( \x. V (g (unV [A] (unF [A] x x))) 36 | : D A -> D A) in 37 | unV [A] (omega (F omega)) 38 | 39 | -- Example use case 40 | 41 | 42 | data Nat : Type where 43 | Zero 44 | Succ of ( _ : Nat) 45 | 46 | fix_add : Nat -> Nat -> Nat 47 | fix_add = fix [Nat -> Nat -> Nat] 48 | \radd. \x. \y. 49 | case x of 50 | Zero -> y 51 | Succ n -> Succ (radd n y) 52 | 53 | test : fix_add 5 2 = 7 54 | test = Refl 55 | -------------------------------------------------------------------------------- /main/pi/Hurkens.pi: -------------------------------------------------------------------------------- 1 | -- from Jonathan Chan 2 | module Hurkens where 3 | 4 | Void : Type 5 | Void = (x:Type) -> x 6 | 7 | neg : Type -> Type 8 | neg = \X. X -> Void 9 | 10 | P : Type -> Type 11 | P = \S. S -> Type 12 | 13 | U : Type 14 | U = (x : Type) -> ((P (P x)) -> x) -> P (P x) 15 | 16 | tau : (P (P U)) -> U 17 | tau = \t. \x. \f. \p. t (\s. p (f (s x f))) 18 | 19 | sigma : U -> P (P U) 20 | sigma = \s. s U (\t. tau t) 21 | 22 | Delta : P U 23 | Delta = \y. neg ((p : P U) -> sigma y p -> p (tau (sigma y))) 24 | 25 | Omega : U 26 | Omega = tau (\p. (x : U) -> sigma x p -> p x) 27 | 28 | R : (p : P U) -> ((x : U) -> sigma x p -> p x) -> p Omega 29 | R = \zero. \one. one Omega (\x. one (tau (sigma x))) 30 | 31 | M : (x : U) -> sigma x Delta -> Delta x 32 | M = \x. \two. \three. three Delta two (\p. three (\y. p (tau (sigma y)))) 33 | 34 | L : neg ((p : P U) -> ((x : U) -> sigma x p -> p x) -> p Omega) 35 | L = \zero. zero Delta M (\p. zero (\y. p (tau (sigma y)))) 36 | 37 | false : Void 38 | false = L R -------------------------------------------------------------------------------- /main/pi/Hw1.pi: -------------------------------------------------------------------------------- 1 | module Hw1 where 2 | 3 | -- HW #1: get this file to type check by adding typing rules 4 | -- for booleans and sigma types to TypeCheck.hs in 'version1' 5 | 6 | -- prelude operations on boolean values 7 | 8 | or : Bool -> Bool -> Bool 9 | or = \b1 b2. if b1 then True else b2 10 | 11 | not : Bool -> Bool 12 | not = \b . if b then False else True 13 | 14 | and : Bool -> Bool -> Bool 15 | and = \b1 b2. if b1 then b2 else False 16 | 17 | eq_bool : Bool -> Bool -> Bool 18 | eq_bool = \ b1 b2 . 19 | if b1 then b2 else (not b2) 20 | 21 | --- sigma types 22 | 23 | double : (A:Type) -> (x : A) -> { x : A | A } 24 | double = \A x. (x,x) 25 | 26 | fst : (A:Type) -> (B : A -> Type) -> { x : A | B x } -> A 27 | fst = \A B p. let (x0,y) = p in x0 28 | 29 | -------------------------------------------------------------------------------- /main/pi/Hw2.pi: -------------------------------------------------------------------------------- 1 | module Hw2 where 2 | 3 | -- First: read section 7.2 of the lecture notes about how 4 | -- propositional equality works in pi-forall. The key points are 5 | -- that `Refl` is a proof of the identity type `(a = b)` when 6 | -- a is definitionally equal to b, and that `subst` is the elimination 7 | -- form. 8 | 9 | -- For example, we can show that equality is symmetric by 10 | -- eliminating pf (of type `x = y`) when type checking 11 | -- `Refl` against type `y = x`. The `subst` adds the definition 12 | -- `x = y` to the context, so both sides of `y = x` wh normalize to y. 13 | 14 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 15 | sym = \ A x y pf . 16 | subst Refl by pf 17 | 18 | -- Homework: show that propositional equality is transitive 19 | 20 | trans : (A:Type) -> (x:A) -> (y:A) -> (z:A) -> (x = z) -> (z = y) -> (x = y) 21 | trans = {- SOLN DATA -} \A x y z pf1 pf2 . 22 | subst pf1 by pf2 {- STUBWITH TRUSTME -} 23 | 24 | -- Homework: show that it is congruent for (nondependent) application 25 | 26 | f_cong : (A:Type) -> (B : Type) -> (f : A -> B) -> (g : A -> B) 27 | -> (x:A) -> (y:A) 28 | -> (f = g) -> (x = y) -> (f x = g y) 29 | f_cong = {- SOLN DATA -} \ A B f g x y pf1 pf2 . 30 | subst (subst Refl by pf1) by pf2 {- STUBWITH TRUSTME -} 31 | 32 | -- Homework: what does congruence for dependent application look like? 33 | -- In other words, what if f and g above have a dependent type? 34 | 35 | {- SOLN DATA -} 36 | f_cong_dep : (A:Type) -> (B : A -> Type) 37 | -> (f : (x:A) -> B x) -> (g : (x:A) -> B x) 38 | -> (x:A) -> (y:A) 39 | -> (f = g) -> (p : x = y) -> (f x = subst g y by p) 40 | f_cong_dep = \ A B f g x y pf1 pf2 . 41 | subst (subst Refl by pf1) by pf2 {- STUBWITH -} 42 | 43 | 44 | -- properties of booleans 45 | 46 | -- an encoding of logical falsity 47 | 48 | void : Type 49 | void = (A:Type) -> A 50 | 51 | neg : Type -> Type 52 | neg = \ A . ( (A) -> void ) 53 | 54 | not : Bool -> Bool 55 | not = \ x . if x then False else True 56 | 57 | -- show that true is not false 58 | 59 | not_not_equal : (b : Bool) -> (b = not b) -> void 60 | not_not_equal = {- SOLN DATA -} \b pf. 61 | if b then (contra pf) else (contra pf) {- STUBWITH TRUSTME -} 62 | 63 | 64 | not_false_then_true : (b : Bool) -> neg (b = False) -> b = True 65 | not_false_then_true = {- SOLN DATA -} \b nb. 66 | if b then Refl else nb Refl (b = True) {- STUBWITH TRUSTME -} 67 | 68 | -- show that decidable equality for booleans is correct. 69 | 70 | eq_bool : Bool -> Bool -> Bool 71 | eq_bool = \x y. if x then y else not y 72 | 73 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 74 | eq_true = \b1 b2 pf. {- SOLN DATA -} 75 | if b1 then if b2 then Refl else contra pf 76 | else if b2 then contra pf else Refl {- STUBWITH TRUSTME -} 77 | 78 | eq_false : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = False -> (b1 = b2) -> void 79 | eq_false = {- SOLN DATA -} \ b1 b2 pf1 pf2 . 80 | if b1 then if b2 then contra pf1 else contra pf2 81 | else if b2 then contra pf2 else contra pf1 {- STUBWITH TRUSTME -} 82 | 83 | false_eq_bool : (n : Bool) -> (m : Bool) -> 84 | neg (n = m) -> 85 | eq_bool n m = False 86 | false_eq_bool = \n m nnm. {- SOLN DATA -} 87 | if n then if m then nnm Refl (eq_bool n m = False) 88 | else Refl 89 | else if m then Refl 90 | else nnm Refl (eq_bool n m = False) {- STUBWITH TRUSTME -} 91 | 92 | 93 | 94 | 95 | 96 | -------------------------------------------------------------------------------- /main/pi/Lambda.pi: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | import Nat 4 | import Fin 5 | import Vec 6 | 7 | lookup : [a:Type] -> [n:Nat] -> Fin n -> Vec a n -> a 8 | lookup = \[a][n] f v. case f of 9 | Zero [m] -> case v of 10 | Cons [m'] x xs -> x 11 | Succ [m] f' -> case v of 12 | Cons [m'] x xs -> lookup [a][m] f' xs 13 | 14 | data Exp (n : Nat) : Type where 15 | Var of (Fin n) 16 | App of (Exp n) (Exp n) 17 | Lam of (Exp (Succ n)) 18 | Lit of (Nat) 19 | 20 | data Val : Type where 21 | Clos of [n:Nat] (Vec Val n) (Exp (Succ n)) 22 | VNat of (Nat) 23 | 24 | interp : [n:Nat] -> Vec Val n -> Exp n -> Val 25 | interp = \[n] rho e. 26 | case e of 27 | Var x -> lookup [Val] [n] x rho 28 | App e1 e2 -> 29 | let v1 = interp [n] rho e1 in 30 | let v2 = interp [n] rho e2 in 31 | case v1 of 32 | Clos [m] rho' body -> 33 | interp [Succ m] (Cons [m] v2 rho') body 34 | VNat i -> TRUSTME 35 | Lam e -> Clos [n] rho e 36 | Lit i -> VNat i 37 | 38 | one : Fin 2 39 | one = Succ [1] (Zero [0]) 40 | 41 | t1 : interp [0] Nil (App (Lam (Var (Zero[0]))) (Lit 3)) = VNat 3 42 | t1 = Refl 43 | 44 | -- t2 : interp [0] Nil (App (Lam (Var one)) (Lit 2)) = TRUSTME 45 | -- t2 = Refl 46 | 47 | t3 : interp [0] Nil (App (Lit 1) (Lit 2)) = TRUSTME 48 | t3 = Refl -------------------------------------------------------------------------------- /main/pi/Lambda0.pi: -------------------------------------------------------------------------------- 1 | module Lambda0 where 2 | 3 | {- 4 | A Simple example of an environment-based interpreter for a small lambda calculus. 5 | This example could easily be written in vanilla Haskell or ML. 6 | -} 7 | 8 | 9 | import Nat 10 | import List 11 | 12 | -- A small language of lambda-calculus expressions 13 | 14 | data Exp : Type where 15 | Var of (Nat) -- variables, represented with de Bruijn indices 16 | App of (Exp)(Exp) -- application 17 | Lam of (Exp) -- anonymous functions 18 | Lit of (Nat) -- natural number constants 19 | If0 of (Exp)(Exp)(Exp) -- test for zero 20 | 21 | -- example expressions 22 | -- 23 | idfun : Exp -- \ x -> x 24 | idfun = Lam (Var 0) 25 | 26 | k : Exp -- \x y -> x 27 | k = Lam (Lam (Var 1)) 28 | 29 | s : Exp -- \ x y z -> x z (y z) 30 | s = Lam (Lam (Lam (App (App (Var 2) (Var 0)) (App (Var 1) (Var 0))))) 31 | 32 | 33 | -- The result of our interpreter 34 | 35 | data Val : Type where 36 | Clos of (List Val)(Exp) -- a closure: pair of an environment and an expression w/ a free variable 37 | VNat of (Nat) -- natural number value 38 | 39 | 40 | -- List index (subscript) operator, starting from 0. 41 | 42 | nth : [a : Type] -> List a -> Nat -> a 43 | nth = \[a] l n. case l of 44 | Nil -> TRUSTME -- "index too large" 45 | Cons x xs -> case n of 46 | Zero -> x 47 | Succ m -> nth [a] xs m 48 | 49 | -- The interpreter itself 50 | 51 | interp : List Val -> Exp -> Val 52 | interp = \ rho exp . case exp of 53 | Var x -> nth [Val] rho x 54 | App e1 e2 -> 55 | let v1 = interp rho e1 in 56 | let v2 = interp rho e2 in 57 | case v1 of 58 | Clos rho' body -> 59 | interp (Cons v2 rho') body 60 | VNat i -> TRUSTME -- can't apply numbers 61 | Lam e -> Clos rho e 62 | Lit i -> VNat i 63 | If0 e1 e2 e3 -> 64 | case (interp rho e1) of 65 | VNat x -> case x of 66 | Zero -> interp rho e2 67 | (Succ y) -> interp rho e3 68 | Clos rho exp -> TRUSTME 69 | 70 | t1 : interp Nil (App (Lam (Var 0)) (Lit 3)) = VNat 3 71 | t1 = Refl 72 | 73 | t2 : interp Nil (If0 (Lit 1) (Lit 2) (Lit 3)) = VNat 3 74 | t2 = Refl 75 | 76 | -- an "unbound variable" error (i.e. scope error) 77 | 78 | e1 : interp Nil (App (Lam (Var 1)) (Lit 2)) = TRUSTME 79 | e1 = Refl 80 | 81 | -- a run-time type error 82 | 83 | e2 : interp Nil (App (Lit 1) (Lit 2)) = TRUSTME 84 | e2 = Refl 85 | -------------------------------------------------------------------------------- /main/pi/Lambda1.pi: -------------------------------------------------------------------------------- 1 | {- This version of the interpreter indexes datatype by the 2 | scoping depth of the expression. -} 3 | 4 | module Lambda where 5 | 6 | import Nat 7 | import Fin 8 | import Vec 9 | 10 | 11 | data Exp (n : Nat) : Type where 12 | Var of (Fin n) -- variables, represented with de Bruijn indices 13 | App of (Exp n) (Exp n) -- application 14 | Lam of (Exp (Succ n)) -- anonymous functions 15 | Lit of (Nat) -- natural number constants 16 | If0 of (Exp n)(Exp n)(Exp n) -- test for zero 17 | 18 | data Val : Type where 19 | Clos of [n:Nat] (Vec Val n) (Exp (Succ n)) 20 | VNat of (Nat) 21 | Wrong 22 | 23 | 24 | -- Safely access a vector using an index that is known 25 | -- to be in bounds. 26 | nth : [a:Type] -> [n:Nat] -> Vec a n -> Fin n -> a 27 | nth = \[a][n] v f. case f of 28 | Zero [m] -> case v of 29 | Cons [m'] x xs -> x 30 | Succ [m] f' -> case v of 31 | Cons [m'] x xs -> nth [a][m] xs f' 32 | 33 | 34 | interp : [n:Nat] -> Vec Val n -> Exp n -> Val 35 | interp = \[n] rho e. 36 | case e of 37 | Var x -> nth [Val] [n] rho x 38 | App e1 e2 -> 39 | let v1 = interp [n] rho e1 in 40 | let v2 = interp [n] rho e2 in 41 | case v1 of 42 | Clos [m] rho' body -> 43 | interp [Succ m] (Cons [m] v2 rho') body 44 | _ -> Wrong 45 | Lam e -> Clos [n] rho e 46 | Lit i -> VNat i 47 | If0 e1 e2 e3 -> 48 | case (interp [n] rho e1) of 49 | VNat x -> case x of 50 | Zero -> interp [n] rho e2 51 | (Succ y) -> interp [n] rho e3 52 | _ -> Wrong 53 | 54 | 55 | one : Fin 2 56 | one = Succ [1] (Zero [0]) 57 | 58 | t1 : interp [0] Nil (App (Lam (Var (Zero[0]))) (Lit 3)) = VNat 3 59 | t1 = Refl 60 | 61 | -- Scope error, doesn't type check 62 | -- t2 : interp [0] Nil (App (Lam (Var one)) (Lit 2)) = Wrong 63 | -- t2 = Refl 64 | 65 | -- object language type error, runtime error 66 | t3 : interp [0] Nil (App (Lit 1) (Lit 2)) = Wrong 67 | t3 = Refl 68 | -------------------------------------------------------------------------------- /main/pi/Lambda2.pi: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | import Nat 4 | import Fin 5 | import Vec 6 | 7 | {- This version also requires that the object language be statically typed. 8 | It eliminates all run-time errors from the expression. -} 9 | 10 | lookup : [a:Type] -> [n:Nat] -> Fin n -> Vec a n -> a 11 | lookup = \[a][n] f v. case f of 12 | Zero [m] -> case v of 13 | Cons [m'] x xs -> x 14 | Succ [m] f' -> case v of 15 | Cons [m'] x xs -> lookup [a][m] f' xs 16 | 17 | data Ty : Type where 18 | TyFun of (Ty)(Ty) 19 | TyNat 20 | 21 | data List (a : Type) : Type where 22 | Nil 23 | Cons of (a) (List a) 24 | 25 | data VarRef (n : List Ty) (t : Ty) : Type where 26 | VZ of [ts : List Ty][n = Cons t ts] 27 | VS of [ts : List Ty][u : Ty](VarRef ts t)[n = Cons u ts] 28 | 29 | -- a single variable in a context containing one variable 30 | 31 | x : VarRef (Cons TyNat Nil) TyNat 32 | x = VZ [Nil] 33 | 34 | -- two variables in a context containing two vars 35 | 36 | y1 : VarRef (Cons TyNat (Cons TyNat Nil)) TyNat 37 | y1 = VZ [Cons TyNat Nil] 38 | 39 | y2 : VarRef (Cons TyNat (Cons TyNat Nil)) TyNat 40 | y2 = VS [Cons TyNat Nil][TyNat](VZ [Nil]) 41 | 42 | 43 | data Exp (n : List Ty) (t : Ty) : Type where 44 | Var of (VarRef n t) 45 | App of [t1:Ty] (Exp n (TyFun t1 t)) (Exp n t1) 46 | Lam of [t1: Ty][t2:Ty](Exp (Cons t1 n) t2) [t = TyFun t1 t2] 47 | Lit of (Nat)[t = TyNat] 48 | If0 of (Exp n TyNat)(Exp n t)(Exp n t) 49 | 50 | data Env (val : Ty -> Type) (n : List Ty) : Type where 51 | Nil of [n = Nil] 52 | Cons of [t : Ty][ts : List Ty](val t)(Env val ts) [n = Cons t ts] 53 | 54 | data Val (t : Ty) : Type where 55 | Clos of [n:List Ty][t1:Ty][t2:Ty] 56 | (Env (\t. Val t) n) (Exp (Cons t1 n) t2)[t = TyFun t1 t2] 57 | VNat of (Nat)[t = TyNat] 58 | 59 | env : List Ty -> Type 60 | env = \u. Env (\t. Val t) u 61 | 62 | nth : [n : List Ty] -> [t:Ty] -> env n -> VarRef n t -> Val t 63 | nth = \ [n][t] e var. case var of 64 | VZ [ts] -> case e of 65 | Cons [u][ts] v vs -> v 66 | VS [ts][u] v' -> case e of 67 | Cons [u][ts] v vs -> nth [ts][t] vs v' 68 | 69 | 70 | interp : [n:List Ty] -> [t:Ty] -> env n -> Exp n t -> Val t 71 | interp = \[n][t] rho exp. 72 | case exp of 73 | Var x -> nth [n][t] rho x 74 | App [t1] e1 e2 -> 75 | let v1 = interp [n][TyFun t1 t] rho e1 in 76 | let v2 = interp [n][t1] rho e2 in 77 | case v1 of 78 | Clos [m][t1'][t2'] rho' body -> 79 | let rho'' = (Cons [t1][m] v2 rho' : env (Cons t1 m)) in 80 | interp [Cons t1 m][t2'] rho'' body 81 | 82 | Lam [t1][t2] body -> Clos [n][t1][t2] rho body 83 | Lit i -> VNat i 84 | If0 e1 e2 e3 -> case (interp [n][TyNat] rho e1) of 85 | VNat x -> case x of 86 | Zero -> interp [n][t] rho e2 87 | (Succ y) -> interp [n][t] rho e3 88 | 89 | 90 | t1 : interp [Nil][TyNat] Nil (App[TyNat] (Lam [TyNat][TyNat] (Var x)) (Lit 3)) = VNat 3 91 | t1 = Refl 92 | 93 | -- t2 : interp [Nil][TyNat] Nil (App[TyNat] (Lam[TyNat][TyNat] (Var y1)) (Lit 2)) = TRUSTME 94 | -- t2 = Refl 95 | 96 | -- t3 : interp [Nil][TyNat] Nil (App[TyNat] (Lit 1) (Lit 2)) = TRUSTME 97 | -- t3 = Refl -------------------------------------------------------------------------------- /main/pi/Lec1.pi: -------------------------------------------------------------------------------- 1 | -- Simple examples demonstrating parametric polymorphism in core language 2 | 3 | module Lec1 where 4 | 5 | id : (x:Type) -> x -> x 6 | id = \x y . y 7 | 8 | idid : ((x:Type) -> (y : x) -> x) 9 | idid = id ((x:Type) -> (y : x) -> x) id 10 | 11 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 12 | (B -> C) -> (A -> B) -> (A -> C) 13 | compose = \ A B C f g x. (f (g x)) 14 | 15 | idT : Type 16 | idT = (x:Type) -> x -> x 17 | 18 | selfapp : idT -> idT 19 | selfapp = (\x.x : (idT -> idT) -> (idT -> idT)) (\x.x) 20 | 21 | -- Church encoding: booleans 22 | 23 | true : (A:Type) -> A -> A -> A 24 | true = \A x y. x 25 | 26 | false : (A:Type) -> A -> A -> A 27 | false = \A x y. y 28 | 29 | cond : ((A:Type) -> A -> A -> A) -> (x:Type) -> x -> x -> x 30 | cond = \ b . b 31 | 32 | -- void type 33 | 34 | void : Type 35 | void = (x:Type) -> x 36 | 37 | -- inhabited by diverging term 38 | 39 | loop : (x:Type) -> x 40 | loop = \x. loop x 41 | 42 | -- unit type 43 | 44 | unit : Type 45 | unit = (x:Type) -> x -> x 46 | 47 | -- this code only type checks with a definition of type equality that 48 | -- includes beta-equivalence/definitions (i.e. >= version2) 49 | 50 | -- Church encoding of simply-typed pairs 51 | {- 52 | 53 | pair : Type -> Type -> Type 54 | pair = \p. \q. (c: Type) -> (p -> q -> c) -> c 55 | 56 | prod : (p:Type) -> (q:Type) -> p -> q -> pair p q 57 | prod = \p.\q. \x.\y. \c. \f. f x y 58 | 59 | proj1 : (p:Type) -> (q:Type) -> pair p q -> p 60 | proj1 = \p. \q. \a. a p (\x.\y.x) 61 | 62 | proj2 : (p:Type) -> (q:Type) -> pair p q -> q 63 | proj2 = \p. \q. \a. a q (\x.\y.y) 64 | 65 | swap : (p:Type) -> (q:Type) -> pair p q -> pair q p 66 | swap = \p. \q. \a. prod q p (proj2 p q a) (proj1 p q a) 67 | -} 68 | -------------------------------------------------------------------------------- /main/pi/Lec2.pi: -------------------------------------------------------------------------------- 1 | module Lec2 where 2 | 3 | 4 | -- "large eliminations" 5 | 6 | bool' : Bool -> Type 7 | bool' = \b . (B : (b : Bool) -> Type) -> B True -> B False -> B b 8 | 9 | true' : bool' True 10 | true' = \A x y . x 11 | 12 | false' : bool' False 13 | false' = \ A x y. y 14 | 15 | T : Bool -> Type 16 | T = \b. if b then Unit else Bool 17 | 18 | z1 : T True 19 | z1 = () 20 | 21 | z2 : T False 22 | z2 = True 23 | 24 | 25 | -- To get bar and barnot to work 26 | -- the typing rule for 'if' expressions must be 27 | -- context-dependent. In otherwords, it should add new 28 | -- definitions to the context in the true/false branches 29 | -- when the scrutinee is a variable 30 | -- (i.e. >= version2) 31 | 32 | 33 | not : Bool -> Bool 34 | not = \x. if x then False else True 35 | 36 | bar : (b : Bool) -> T b 37 | bar = \b. if b then () else True 38 | 39 | barnot : (b : Bool) -> T (not b) 40 | barnot = \b. if b then False else () 41 | 42 | 43 | -- projections for sigma types 44 | 45 | fst : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> A 46 | fst = \A B p. let (x,y) = p in x 47 | 48 | snd : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> B (fst A B p) 49 | snd = \A B p. let (x1,y) = p in y 50 | 51 | -- examples of propositional equality 52 | 53 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 54 | sym = \ A x y pf . 55 | subst Refl by pf 56 | 57 | -------------------------------------------------------------------------------- /main/pi/Lec3.pi: -------------------------------------------------------------------------------- 1 | module Lec3 where 2 | 3 | -- can mark some arguments as irrelevant 4 | -- irrelevant parameters can only appear in types (or as part of irrelevant arguments) 5 | 6 | id : [x:Type] -> (y : x) -> x 7 | id = \[x] y. (y : x) 8 | 9 | t0 = id [Bool] True 10 | 11 | t1 = id [Bool] (id [Bool] True) 12 | 13 | id2 : [x:Type] -> (y : x) -> x 14 | id2 = \[x] y. id [x] (y : x) 15 | 16 | -- This shouldn't type check because y is relevant 17 | -- 18 | 19 | {- 20 | id' : [x:Type] -> [y:x] -> x 21 | id' = \[x][y]. y 22 | -} 23 | 24 | {- 25 | id2' : [x:Type] -> Type 26 | id2' = \[x]. id [Type] x 27 | -} 28 | 29 | 30 | 31 | ----------------------------------------------------- 32 | -- Irrelevant arguments are ignored during type equality 33 | 34 | irrelevance : (p : [i : Bool] -> Bool) -> p [True] = p [False] 35 | irrelevance = \p . Refl 36 | 37 | 38 | 39 | 40 | 41 | ----------------------------------------------------- 42 | -- Propositional equality is relevant 43 | -- Cannot ignore/erase proofs that are used for 'subst'. 44 | -- Need a termination analysis to do this. 45 | 46 | proprel : [a : Type] -> (pf : a = Bool) -> (x : a) -> Bool 47 | proprel = \[a] pf x . 48 | subst x by pf 49 | 50 | -------------------------------------------------------------------------------- /main/pi/Lennart.pi: -------------------------------------------------------------------------------- 1 | module Lennart where 2 | 3 | -- stack exec -- pi-forall Lennart.pi 4 | -- with unbind / subst 5 | -- 7.81s user 0.52s system 97% cpu 8.568 total 6 | -- with substBind 7 | -- 3.81s user 0.28s system 94% cpu 4.321 total 8 | import Fix 9 | 10 | bool : Type 11 | bool = [C : Type] -> C -> C -> C 12 | 13 | false : bool 14 | false = \[C]. \f.\t.f 15 | true : bool 16 | true = \[C]. \f.\t.t 17 | 18 | nat : Type 19 | nat = [C : Type] -> C -> (nat -> C) -> C 20 | zero : nat 21 | zero = \[C].\z.\s.z 22 | succ : nat -> nat 23 | succ = \n.\[C].\z.\s. s n 24 | one : nat 25 | one = succ zero 26 | two : nat 27 | two = succ one 28 | three : nat 29 | three = succ two 30 | isZero : nat -> bool 31 | isZero = \n.n [bool] true (\m.false) 32 | const : [A:Type] -> A -> A -> A 33 | const = \[A].\x.\y.x 34 | prod : Type -> Type -> Type 35 | prod = \A B. [C:Type] -> (A -> B -> C) -> C 36 | pair : [A :Type] -> [B: Type] -> A -> B -> prod A B 37 | pair = \[A][B] a b. \[C] p. p a b 38 | fst : [A:Type] -> [B:Type] -> prod A B -> A 39 | fst = \[A][B] ab. ab [A] (\a.\b.a) 40 | snd : [A:Type] -> [B:Type] -> prod A B -> B 41 | snd = \[A][B] ab.ab [B] (\a.\b.b) 42 | add : nat -> nat -> nat 43 | add = fix [nat -> nat -> nat] 44 | \radd . \x.\y. x [nat] y (\ n. succ (radd n y)) 45 | mul : nat -> nat -> nat 46 | mul = fix [nat -> nat -> nat] 47 | \rmul. \x.\y. x [nat] zero (\ n. add y (rmul n y)) 48 | fac : nat -> nat 49 | fac = fix [nat -> nat] 50 | \rfac. \x. x [nat] one (\ n. mul x (rfac n)) 51 | eqnat : nat -> nat -> bool 52 | eqnat = fix [nat -> nat -> bool] 53 | \reqnat. \x. \y. 54 | x [bool] 55 | (y [bool] true (\b.false)) 56 | (\x1.y [bool] false (\y1. reqnat x1 y1)) 57 | sumto : nat -> nat 58 | sumto = fix [nat -> nat] 59 | \rsumto. \x. x [nat] zero (\n. add x (rsumto n)) 60 | n5 : nat 61 | n5 = add two three 62 | n6 : nat 63 | n6 = add three three 64 | n17 : nat 65 | n17 = add n6 (add n6 n5) 66 | n37 : nat 67 | n37 = succ (mul n6 n6) 68 | n703 : nat 69 | n703 = sumto n37 70 | n720 : nat 71 | n720 = fac n6 72 | 73 | t : (eqnat n720 (add n703 n17)) = true 74 | t = Refl -------------------------------------------------------------------------------- /main/pi/List.pi: -------------------------------------------------------------------------------- 1 | module List where 2 | 3 | import Nat 4 | 5 | data List (a : Type) : Type where 6 | Nil 7 | Cons of (a) (List a) 8 | 9 | map : [a : Type] -> [b: Type] -> (a -> b) -> List a -> List b 10 | map = \[a] [b] f xs . case xs of 11 | Nil -> Nil 12 | Cons y ys -> Cons (f y) (map [a][b] f ys) 13 | 14 | id : [a:Type] -> a -> a 15 | id = \[a] x . x 16 | 17 | 18 | f_cong2 : [a : Type]->[b : Type] -> (f : a -> b) -> (a1 : a) -> (a2 : a) -> (a1 = a2) -> f a1 = f a2 19 | f_cong2 = \[a][b] f a1 a2 pf . subst Refl by pf 20 | 21 | -- A proof about map 22 | map_id : [a:Type] -> (xs : List a) -> (map [a][a] (id[a]) xs = id [List a] xs) 23 | map_id = \[a] xs. case xs of 24 | Nil -> Refl 25 | Cons y ys -> 26 | let ih = map_id [a] ys in 27 | f_cong2 [List a][List a] (\ys. Cons y ys) (map[a][a](id[a])ys) (id [List a]ys) ih 28 | 29 | 30 | 31 | append : [a:Type] -> List a -> List a -> List a 32 | append = \[a] xs ys. case xs of 33 | Nil -> ys 34 | Cons x xs' -> Cons x (append [a] xs' ys) 35 | 36 | 37 | filter : [a:Type] -> (a -> Bool) -> List a -> List a 38 | filter = \[a] f xs . case xs of 39 | Nil -> Nil 40 | Cons y ys -> if f y then Cons y (filter [a] f ys) else (filter [a] f ys) 41 | 42 | length : [a : Type] -> List a -> Nat 43 | length = \[a] xs . case xs of 44 | Nil -> 0 45 | Cons y ys -> plus 1 (length [a] ys) 46 | 47 | head : [a : Type] -> List a -> a 48 | head = \[a] xs . case xs of 49 | Nil -> TRUSTME -- cannot remove b/c of exhaustivity check 50 | Cons y ys -> y 51 | 52 | -------------------------------------------------------------------------------- /main/pi/Logic.pi: -------------------------------------------------------------------------------- 1 | module Logic where 2 | 3 | -- products (conjunctions) 4 | --------------------------- 5 | 6 | data And (A : Type) (B : Type) : Type where 7 | Conj of (_ : A) (_ : B) 8 | 9 | proj1 : [A:Type] -> [B : Type] -> And A B -> A 10 | proj1 = \ [A] [B] p . case p of 11 | Conj x y -> x 12 | 13 | proj2 : [A:Type] -> [B : Type] -> And A B -> B 14 | proj2 = \ [A] [B] p . case p of 15 | Conj x y -> y 16 | 17 | and_comm : [A : Type] -> [B : Type] -> And A B -> And B A 18 | and_comm = \ [A][B] ab . case ab of 19 | (Conj x y) -> Conj y x 20 | 21 | and_assoc : [A : Type] -> [B : Type] -> [C : Type] -> And A (And B C) -> And (And A B) C 22 | and_assoc = \[A][B][C] abc . 23 | case abc of 24 | Conj a bc -> case bc of 25 | Conj b c -> Conj (Conj a b) c 26 | 27 | -- if and only if 28 | ----------------- 29 | 30 | iff : (A : Type) -> (B : Type) -> Type 31 | iff = \ A B . And (A -> B) (B -> A) 32 | 33 | iff_implies : [A : Type] -> [B : Type] -> iff A B -> A -> B 34 | iff_implies = \[A][B] iff. proj1 [A -> B][B -> A] iff 35 | 36 | iff_sym : [A : Type] -> [B : Type] -> iff A B -> iff B A 37 | iff_sym = \ [A][B] iff. 38 | case iff of 39 | Conj ab ba -> Conj ba ab 40 | 41 | iff_refl : [A : Type] -> iff A A 42 | iff_refl = \[A]. Conj (\x . x) (\x . x) 43 | 44 | iff_trans : [A : Type] -> [B : Type] -> [C : Type] -> (iff A B) -> (iff B C) -> (iff A C) 45 | iff_trans = \ [A] [B] [C] iff1 iff2 . 46 | case iff1 of 47 | Conj ab ba -> 48 | case iff2 of 49 | Conj bc cb -> 50 | Conj (\x. bc (ab x)) (\x. (ba (cb x))) 51 | 52 | -- Disjunction (Logical "or"), aka sums 53 | --------------------------------------- 54 | 55 | data Either (A : Type) (B : Type) : Type where 56 | Inl of (A) 57 | Inr of (B) 58 | 59 | or_commut : [A : Type] -> [B : Type] -> Either A B -> Either B A 60 | or_commut = \ [A][B] ab . case ab of 61 | Inl a -> Inr a 62 | Inr b -> Inl b 63 | 64 | or_distributes_over_and_1 : [P:Type] -> [Q:Type] -> [R:Type] -> 65 | Either P (And Q R) -> And (Either P Q) (Either P R) 66 | or_distributes_over_and_1 = \[P][Q][R] e. 67 | case e of 68 | Inl p -> Conj (Inl p) (Inl p) 69 | Inr qr -> case qr of 70 | (Conj q r) -> Conj (Inr q) (Inr r) 71 | 72 | or_assoc : [A : Type] -> [B : Type] -> [C : Type] -> Either A (Either B C) -> Either (Either A B) C 73 | or_assoc = \[A][B][C] abc . case abc of 74 | Inl a -> Inl (Inl a) 75 | Inr bc -> case bc of 76 | Inl b -> Inl (Inr b) 77 | Inr c -> Inr c 78 | 79 | -- Falsehood 80 | ------------ 81 | 82 | data Void : Type where {} -- no constructors 83 | 84 | -- aka ex_falso_quolibet 85 | false_elim : [P:Type] -> Void -> P 86 | false_elim = \ [P] v . case v of {} 87 | 88 | 89 | -- Negation 90 | ----------- 91 | 92 | neg : Type -> Type 93 | neg = \ x . (x -> Void) 94 | 95 | not_false : neg Void 96 | not_false = \x. x 97 | 98 | contradiction_implies_anything : [P:Type] -> [Q:Type] -> And P (neg P) -> Q 99 | contradiction_implies_anything = \[P][Q] and . 100 | case and of 101 | Conj p notp -> false_elim [Q] (notp p) 102 | 103 | double_neg : [P:Type] -> P -> neg (neg P) 104 | double_neg = \[P] p. 105 | \x. x p 106 | 107 | contrapositive : [P:Type] -> [Q:Type] -> (P -> Q) -> neg Q -> neg P 108 | contrapositive = \[P][Q] pq nq p. nq (pq p) 109 | 110 | not_both_true_and_false : [P:Type] -> [Q:Type] -> neg (And P (neg P)) 111 | not_both_true_and_false = \[P][Q] andpnp. 112 | case andpnp of 113 | (Conj p np) -> np p 114 | 115 | iff_neg_false : [A : Type] -> iff (neg A) (iff A Void) 116 | iff_neg_false = \ [A] . Conj (\ x . Conj x (\y. false_elim [A] y)) (proj1 [A -> Void][Void -> A]) 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /main/pi/Makefile: -------------------------------------------------------------------------------- 1 | # Main Rules 2 | # ========== 3 | # 4 | # make [all]: does a regression test, by checking that everything that 5 | # was correctly passing (failing) type checking is still 6 | # passing (failing) type checking. 7 | # 8 | # make todo: tests if known-broken things are still broken. If you 9 | # fix something in TODO_PASS (TODO_FAIL) then you should 10 | # move it to PASS (FAIL). 11 | 12 | # Use bash to run targets. 13 | SHELL=/bin/bash 14 | 15 | # PASS are tests that *should* always pass. 16 | PASS=Logic Equality Product Nat Fin Vec BoolLib Hw1 Hw2 FinHw \ 17 | Lambda Lambda0 Lambda1 Lambda2 \ 18 | Lec1 Lec2 Lec3 Lec4 \ 19 | List NatChurch Product1 Lennart Hurkens Equal Sigma 20 | 21 | # TODO_FAIL are tests that *should* fail but currently pass. 22 | TODO_FAIL= 23 | # TODO_PASS are tests that *should* pass but currently fail. 24 | TODO_PASS= 25 | # stale? 26 | UNKNOWN= 27 | # A symlink to the local pi-forall, installed by top level make. 28 | PI=pi-forall 29 | # typecheck *quietly* 30 | TYPECHECK=stack exec pi-forall 1>/dev/null # 2>&1 31 | 32 | .PHONY: pass fail todo_pass todo_fail todo 33 | 34 | all: pass fail 35 | 36 | clean: 37 | rm *.pi-elaborated 38 | 39 | pass: $(foreach p,$(PASS),$(p).pass) 40 | 41 | fail: 42 | 43 | 44 | todo_pass: $(foreach f,$(TODO_PASS),$(f).pass) 45 | todo_fail: $(foreach f,$(TODO_FAIL),$(f).fail) 46 | todo: todo_pass 47 | @echo 48 | @echo "Any names printed *without* errors should be moved from TODO_* to *" 49 | 50 | %.pass: %.pi 51 | @echo -n "$<: " 52 | @if ! $(TYPECHECK) $<; then echo -e "\033[1;31mfailed\033[0;30m (should pass)" >&2; else echo; fi 53 | 54 | %.fail: %.pi 55 | @echo -n "$<: " 56 | @if $(TYPECHECK) $<; then echo -e "\033[1;31mpassed\033[0;30m (should fail)" >&2; else echo; fi 57 | -------------------------------------------------------------------------------- /main/pi/Maybe.pi: -------------------------------------------------------------------------------- 1 | module Maybe where 2 | 3 | data Maybe (A : Type) : Type where 4 | Just of (A) 5 | Nothing 6 | 7 | fmap : [A : Type] -> [B : Type] -> (A -> B) -> Maybe A -> Maybe B 8 | fmap = \ [A] [B] f m . 9 | case m of 10 | Nothing -> Nothing 11 | (Just a) -> Just (f a) 12 | 13 | zap : [A : Type] -> [B : Type] -> Maybe (A -> B) -> Maybe A -> Maybe B 14 | zap = \ [A] [B] mf ma . 15 | case mf of 16 | Just f -> case ma of 17 | Just a -> Just (f a) 18 | Nothing -> Nothing 19 | Nothing -> Nothing 20 | 21 | join : [A : Type] -> Maybe (Maybe A) -> Maybe A 22 | join = \ [A] mma . 23 | case mma of 24 | Just ma -> case ma of 25 | (Just a) -> Just a 26 | Nothing -> Nothing 27 | Nothing -> Nothing 28 | 29 | bind : [A : Type] -> [B: Type] -> Maybe A -> (A -> Maybe B) -> Maybe B 30 | bind = \ [A] [B] m k . 31 | case m of 32 | Just a -> k a 33 | Nothing -> Nothing 34 | -------------------------------------------------------------------------------- /main/pi/Nat.pi: -------------------------------------------------------------------------------- 1 | -- PI library for natural numbers 2 | -- 3 | -- Some of these are adapted from Trellys examples 4 | -- 5 | -- Author: Stephanie Weirich 6 | -- 7 | 8 | module Nat where 9 | 10 | data Nat : Type where 11 | Zero 12 | Succ of (Nat) 13 | 14 | is_zero : Nat -> Bool 15 | is_zero = \ x . case x of 16 | Zero -> True 17 | Succ n' -> False 18 | 19 | pred : Nat -> Nat 20 | pred = \n . case n of 21 | Zero -> Zero 22 | Succ n' -> n' 23 | 24 | 25 | m_eq_n_Sm_eq_Sn : (m:Nat) -> (n:Nat) -> m = n -> ((Succ m : Nat) = Succ n) 26 | m_eq_n_Sm_eq_Sn = {- SOLN EP -} \m n pf . 27 | subst Refl by pf {- STUBWITH TRUSTME -} 28 | 29 | nat_eq : Nat -> Nat -> Bool 30 | nat_eq = \ x y . 31 | case x of 32 | Zero -> case y of 33 | Zero -> True 34 | Succ n -> False 35 | Succ m -> case y of 36 | Zero -> False 37 | Succ n -> nat_eq m n 38 | 39 | plus : Nat -> Nat -> Nat 40 | plus = \ n m . 41 | case n of 42 | Zero -> m 43 | Succ pred -> Succ (plus pred m) 44 | 45 | mult : Nat -> Nat -> Nat 46 | mult = \ n m . 47 | case n of 48 | Zero -> Zero 49 | Succ pred -> plus m (mult pred m) 50 | 51 | 52 | minus : Nat -> Nat -> Nat 53 | minus = \n m . 54 | case n of 55 | Zero -> Zero 56 | Succ pred -> case m of 57 | Zero -> n 58 | Succ mpred -> minus pred mpred 59 | 60 | ------------------------------------------------------- 61 | -- Reasoning about datatypes 62 | 63 | 64 | minus_same_zero : (n : Nat) -> (minus n n = 0) 65 | minus_same_zero = \ n . 66 | case n of 67 | Zero -> Refl 68 | Succ p -> (minus_same_zero p : minus p p = 0) 69 | 70 | lemma_minus_zero_id : (n : Nat) -> (minus n 0 = n) 71 | lemma_minus_zero_id = {- SOLN EP -} 72 | \n . case n of 73 | Zero -> Refl 74 | Succ n' -> Refl {- STUBWITH TRUSTME -} 75 | 76 | 77 | lemma_minus_plus_id : (m : Nat) -> (n : Nat) -> ((minus (plus m n) m) = n) 78 | lemma_minus_plus_id = \m n . 79 | case m of 80 | Zero -> lemma_minus_zero_id n 81 | Succ m' -> lemma_minus_plus_id m' n 82 | 83 | plus_associates : (i:Nat) -> (j:Nat) -> (k:Nat) -> plus (plus i j) k = plus i (plus j k) 84 | plus_associates = \ i j k . 85 | case i of 86 | -- `Refl` away `Zero`s on the left of `(+)`: (0+j)+k = j+k = 0+(j+k) 87 | Zero -> Refl 88 | -- associate `plus` in `Succ` of the inductive case: 89 | -- S ((i'+j)+k) = S (i'+(j+k)) 90 | Succ i' -> 91 | let ih = (plus_associates i' j k) in 92 | m_eq_n_Sm_eq_Sn (plus (plus i' j) k) (plus i' (plus j k)) ih 93 | 94 | -------------------------------------------------------------------------------- /main/pi/NatChurch.pi: -------------------------------------------------------------------------------- 1 | module NatChurch where 2 | 3 | -- Church encoding of natural numbers 4 | 5 | nat : Type 6 | nat = (x:Type) -> x -> (x -> x) -> x 7 | 8 | z : nat 9 | z = \x zf sf. zf 10 | 11 | s : nat -> nat 12 | s = \n. \x zf sf. sf (n x zf sf) 13 | 14 | one : nat 15 | one = s z 16 | 17 | two : nat 18 | two = s (s z) 19 | 20 | three : nat 21 | three = TRUSTME -- replace with correct definition of 3 22 | 23 | plus : nat -> nat -> nat 24 | plus = \x. \y. x nat y s 25 | 26 | test0 : plus one one = two 27 | test0 = Refl 28 | 29 | test1 : plus one two = three 30 | test1 = TRUSTME -- replace with Refl 31 | 32 | spec0 : (n : nat) -> plus z n = n 33 | spec0 = \n . Refl 34 | 35 | spec1 : (n : nat) -> (m : nat) -> plus (s n) m = s (plus n m) 36 | spec1 = \n m . Refl 37 | 38 | -- The predecessor function is *really* tricky! Don't try this 39 | -- first if you have never seen it before. 40 | 41 | pred : nat -> nat 42 | pred = TRUSTME 43 | 44 | test_pred : pred two = one 45 | test_pred = TRUSTME -- replace with Refl 46 | 47 | -- Since pi-forall allows recursive definitions, we also have Scott encodings 48 | -- of datatypes available. (See http://en.wikipedia.org/wiki/Mogensen%E2%80%93Scott_encoding. 49 | -- You can't do this in Coq or Agda because it requires an inconsistent logic). 50 | 51 | scott_nat : Type 52 | scott_nat = (x:Type) -> x -> (scott_nat -> x) -> x 53 | 54 | scott_z : scott_nat 55 | scott_z = \x z s . z 56 | 57 | scott_s : scott_nat -> scott_nat 58 | scott_s = \n . \x z s . s n 59 | 60 | scott_one : scott_nat 61 | scott_one = scott_s scott_z 62 | 63 | scott_two : scott_nat 64 | scott_two = scott_s (scott_s scott_z) 65 | 66 | scott_three : scott_nat 67 | scott_three = scott_s (scott_s (scott_s scott_z)) 68 | 69 | -- Write the predecessor function, it is much easier here 70 | 71 | scott_pred : scott_nat -> scott_nat 72 | scott_pred = TRUSTME 73 | 74 | testNC1 : scott_pred scott_two = scott_one 75 | testNC1 = TRUSTME -- replace with Refl 76 | 77 | -- Now write plus: with Scott encoded nats, note that you need to use recursion. 78 | 79 | scott_plus : scott_nat -> scott_nat -> scott_nat 80 | scott_plus = TRUSTME 81 | 82 | testNC2 : scott_plus scott_one scott_two = scott_three 83 | testNC2 = TRUSTME -- replace with Refl 84 | -------------------------------------------------------------------------------- /main/pi/Prelude.pi: -------------------------------------------------------------------------------- 1 | -- Standard library for pi-forall 2 | -- includes all definitions 3 | 4 | module Prelude where 5 | 6 | import BoolLib 7 | 8 | id : (x:Type) -> x -> x 9 | id = \x y . y 10 | 11 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 12 | (B -> C) -> (A -> B) -> (A -> C) 13 | compose = \ A B C f g x. (f (g x)) 14 | 15 | -- some Church encodings, need impredicativity to make them 16 | -- more reasonable 17 | 18 | bool : Type 1 19 | bool = (A:Type) -> A -> A -> A 20 | 21 | true : bool 22 | true = \A x y. x 23 | 24 | false : bool 25 | false = \A x y. y 26 | 27 | bool' : bool -> Type 1 28 | bool' = \b . (B : (b : bool) -> Type) -> B true -> B false -> B b 29 | 30 | true' : bool' true 31 | true' = \A x y . x 32 | 33 | false' : bool' false 34 | false' = \ A x y. y 35 | 36 | 37 | nat : Type 1 38 | nat = (x:Type) -> x -> (x -> x) -> x 39 | 40 | zero : nat 41 | zero = \x z s. z 42 | 43 | succ : nat -> nat 44 | succ = \n x z s. s (n x z s) 45 | 46 | equal : (x:Type) -> (y:Type) -> Type 1 47 | equal = \x y. (f : Type -> Type) -> f x -> f y 48 | 49 | reflexivity : (x:Type) -> equal x x 50 | reflexivity = \x f z . z 51 | 52 | -- homework add booleans? sigma types? 53 | 54 | 55 | x = True 56 | 57 | 58 | data List (a : Type) : Type where 59 | Nil 60 | Cons of (x:a) (y:List a) 61 | 62 | y : List Bool 63 | y = Cons True (Cons False Nil) 64 | 65 | z : Bool 66 | z = if True then False else True 67 | 68 | 69 | not : Bool -> Bool 70 | not = \b . if b then False else True 71 | 72 | T : Bool -> Type 73 | T = \b. if b then One else One 74 | 75 | bar : (b : Bool) -> (T b : Type) 76 | bar = \b .if b then tt else tt 77 | 78 | snot : (b : Bool) -> (T (not b) : Type) 79 | snot = \b. if b then tt else tt 80 | 81 | good : not True = False 82 | good = Refl 83 | 84 | data Nat : Type where 85 | zero 86 | succ of ( x : Nat ) 87 | 88 | data Vec (a:Type) (i : Nat) : Type where 89 | Nil of (i = zero) 90 | Cons of (j : Nat) (i = succ j) (a) (Vec a j) 91 | 92 | head : (a:Type) -> (i : Nat) -> Vec a (succ i) -> a 93 | head = \ a i v. case v of 94 | Nil p -> contra p 95 | Cons j p hd tl -> hd 96 | 97 | -------------------------------------------------------------------------------- /main/pi/Sigma.pi: -------------------------------------------------------------------------------- 1 | module Sigma where 2 | 3 | -- Defining projection terms using pattern matching 4 | 5 | fst : (A:Type) -> (B:A -> Type) -> { x : A | B x } -> A 6 | fst = \A B x . let (y,z) = x in y 7 | 8 | snd : (A:Type) -> (B:A -> Type) -> (p : { x:A | B x}) -> B (fst A B p) 9 | snd = \A B x . let (y,z) = x in z 10 | 11 | 12 | -------------------------------------------------------------------------------- /main/src/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer ( 2 | identifier, reserved, operator, reservedOp, charLiteral, stringLiteral, 3 | natural, integer, float, naturalOrFloat, decimal, hexadecimal, octal, 4 | symbol, lexeme, whiteSpace, parens, braces, angles, brackets, semi, 5 | comma, colon, dot, semiSep, semiSep1, commaSep, commaSep1, allOf 6 | ) where 7 | 8 | import Text.Parsec 9 | import qualified Text.Parsec.Token as P 10 | import Text.Parsec.Language (haskellStyle) 11 | 12 | lexer = P.makeTokenParser haskellStyle 13 | 14 | identifier = P.identifier lexer 15 | reserved = P.reserved lexer 16 | operator = P.operator lexer 17 | reservedOp = P.reservedOp lexer 18 | charLiteral = P.charLiteral lexer 19 | stringLiteral = P.stringLiteral lexer 20 | natural = P.natural lexer 21 | integer = P.integer lexer 22 | float = P.float lexer 23 | naturalOrFloat = P.naturalOrFloat lexer 24 | decimal = P.decimal lexer 25 | hexadecimal = P.hexadecimal lexer 26 | octal = P.octal lexer 27 | symbol = P.symbol lexer 28 | lexeme = P.lexeme lexer 29 | whiteSpace = P.whiteSpace lexer 30 | parens = P.parens lexer 31 | braces = P.braces lexer 32 | angles = P.angles lexer 33 | brackets = P.brackets lexer 34 | semi = P.semi lexer 35 | comma = P.comma lexer 36 | colon = P.colon lexer 37 | dot = P.dot lexer 38 | semiSep = P.semiSep lexer 39 | semiSep1 = P.semiSep1 lexer 40 | commaSep = P.commaSep lexer 41 | commaSep1 = P.commaSep1 lexer 42 | 43 | 44 | allOf p = do 45 | P.whiteSpace lexer 46 | r <- p 47 | eof 48 | return r -------------------------------------------------------------------------------- /main/src/Modules.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | Tools for working with multiple source files 4 | module Modules(getModules, ModuleInfo(..)) where 5 | 6 | import Syntax 7 | import Parser(parseModuleFile, parseModuleImports) 8 | 9 | import Text.ParserCombinators.Parsec.Error ( ParseError ) 10 | 11 | import Control.Monad.Except 12 | {- SOLN DATA -} 13 | import Control.Monad.State.Lazy{- STUBWITH -} 14 | import System.FilePath 15 | import System.Directory 16 | import qualified Data.Graph as Gr 17 | import Data.List(nub,(\\)) 18 | 19 | -- | getModules starts with a top-level module, and gathers all of the module's 20 | -- transitive dependency. It returns the list of parsed modules, with all 21 | -- modules appearing after its dependencies. 22 | getModules 23 | :: (Functor m, MonadError ParseError m, MonadIO m) => 24 | [FilePath] -> String -> m [Module] 25 | getModules prefixes top = do 26 | toParse <- gatherModules prefixes [ModuleImport top] 27 | {- SOLN DATA -} 28 | flip evalStateT initialConstructorNames $ mapM reparse toParse 29 | {- STUBWITH mapM reparse toParse -} 30 | 31 | data ModuleInfo = ModuleInfo { 32 | modInfoName :: ModuleName, 33 | modInfoFilename :: String, 34 | modInfoImports :: [ModuleImport] 35 | } 36 | 37 | -- | Build the module dependency graph. 38 | -- This only parses the imports part of each file; later we go back and parse all of it. 39 | gatherModules 40 | :: (Functor m, MonadError ParseError m, MonadIO m) => 41 | [FilePath] -> [ModuleImport] -> m [ModuleInfo] 42 | gatherModules prefixes ms = gatherModules' ms [] where 43 | gatherModules' [] accum = return $ topSort accum 44 | gatherModules' ((ModuleImport m):ms') accum = do 45 | modFileName <- getModuleFileName prefixes m 46 | imports <- moduleImports <$> parseModuleImports modFileName 47 | let accum' = ModuleInfo m modFileName imports :accum 48 | let oldMods = map (ModuleImport . modInfoName) accum' 49 | gatherModules' (nub (ms' ++ imports) \\ oldMods) accum' 50 | 51 | -- | Generate a sorted list of modules, with the postcondition that a module 52 | -- will appear _after_ any of its dependencies. 53 | topSort :: [ModuleInfo] -> [ModuleInfo] 54 | topSort ms = reverse sorted 55 | where (gr,lu) = Gr.graphFromEdges' [(m, modInfoName m, [i | ModuleImport i <- modInfoImports m]) 56 | | m <- ms] 57 | lu' v = let (m,_,_) = lu v in m 58 | sorted = [lu' v | v <- Gr.topSort gr] 59 | 60 | -- | Find the file associated with a module. 61 | getModuleFileName :: (MonadIO m) 62 | => [FilePath] -> ModuleName -> m FilePath 63 | getModuleFileName prefixes modul = do 64 | let makeFileName prefix = prefix mDotPi 65 | -- get M.pi from M or M.pi 66 | mDotPi = if takeExtension s == ".pi" 67 | then s 68 | else s <.> "pi" 69 | s = modul 70 | possibleFiles = map makeFileName prefixes 71 | files <- liftIO $ filterM doesFileExist possibleFiles 72 | if null files 73 | then error $ "Can't locate module: " ++ show modul ++ 74 | "\nTried: " ++ show possibleFiles 75 | else return $ head files 76 | 77 | -- | Fully parse a module (not just the imports). 78 | {- SOLN DATA -} 79 | reparse :: (MonadError ParseError m, MonadIO m, MonadState ConstructorNames m) => 80 | ModuleInfo -> m Module 81 | reparse (ModuleInfo _ fileName _) = do 82 | cnames <- get 83 | modu <- parseModuleFile cnames fileName 84 | put (moduleConstructors modu) 85 | return modu 86 | {- STUBWITH 87 | reparse :: (MonadError ParseError m, MonadIO m) => 88 | ModuleInfo -> m Module 89 | reparse (ModuleInfo _ fileName _) = parseModuleFile fileName 90 | -} 91 | -------------------------------------------------------------------------------- /main/src/TODO: -------------------------------------------------------------------------------- 1 | UPDATES = Summer 2023 2 | * update to latest tool stack 3 | * GHC2021 4 | * remove ViewPatterns 5 | 6 | DONE = Summer 2022 7 | * revise irrelevance 8 | * switch to unbound-generics 9 | * update unbound-generics 10 | * remove TemplateHaskell and pick a minimum GHC version 11 | 12 | 13 | DONE - Summer 2014 14 | * Switch to cayenne style, remove "inductive" types 15 | * fix type abbreviations issue with replib (i.e. String vs TConName and DConName) 16 | * figure out indexed types 17 | * remove epsilon (if possible) 18 | * mutual blocks in definitions 19 | 20 | DONE 21 | * Type : Type 22 | * recursive definitions in context 23 | * removed Axiom 24 | * Axiom K / UIP examples 25 | 26 | ================================================================ 27 | EXERCISE IDEAS 28 | * write an infinite loop 29 | * write a loop that unfolds during type checking 30 | * write a term that should type check, but restricted unfolding prevents it 31 | 32 | ================================================================ 33 | DONE - Summer 2013 34 | * Ind based on constrained types 35 | * More principled annotations 36 | * pat2term needs a type annotation 37 | * type check pattern matching? 38 | * Remove extra variable binding in let 39 | * Irr arguments 40 | - is conv erased in Coq? Agda? 41 | * Add preamble/credits to each file 42 | * Add cabal file 43 | * Many more test cases and DEBUGGING! 44 | * check for exhaustiveness of case analysis (mostly!) 45 | 46 | TODO 47 | * Make the pretty-printer use precedence levels (and omit 'freshening' of vars) 48 | * Comment/beautify source files 49 | 50 | WON'T DO 51 | * wildcard names 52 | * Unification for type args - NO 53 | * OTT file for language specification (both elaboration and type checking) 54 | 55 | EXERCISE IDEAS 56 | * add irrelevant arguments to data structures? 57 | * remove positivity check, implement infinite loop? 58 | * remove levels, implement infinite loop? 59 | * unsoundness when escape check is removed from pattern matching ? 60 | * add booleans? 61 | * add sigma types? -------------------------------------------------------------------------------- /main/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | 3 | # Local packages, usually specified by relative directory name 4 | packages: 5 | - '.' 6 | 7 | flags: {} 8 | 9 | extra-package-dbs: [] 10 | 11 | -------------------------------------------------------------------------------- /main/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.QuickCheck 4 | import Test.HUnit 5 | import Environment 6 | import PrettyPrint 7 | import TypeCheck 8 | import Syntax 9 | import Control.Monad.Except 10 | import Modules 11 | import Text.PrettyPrint.HughesPJ (render) 12 | import Text.ParserCombinators.Parsec.Error 13 | import Test.QuickCheck 14 | import Arbitrary 15 | 16 | main :: IO () 17 | main = do 18 | quickCheck prop_roundtrip 19 | 20 | exitWith :: Either a b -> (a -> IO b) -> IO b 21 | exitWith (Left a) f = f a 22 | exitWith (Right b) f = return b 23 | 24 | -- | Type check the given file 25 | testFile :: String -> Test 26 | testFile name = name ~: TestCase $ do 27 | v <- runExceptT (getModules ["pi"] name) 28 | val <- v `exitWith` (\b -> assertFailure $ "Parse error: " ++ render (disp b)) 29 | d <- runTcMonad emptyEnv (tcModules val) 30 | defs <- d `exitWith` (\s -> assertFailure $ "Type error:" ++ render (disp s)) 31 | putStrLn $ render $ disp (last defs) -------------------------------------------------------------------------------- /old/compose15.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/pi-forall/75feff0f86f10d02c9e69999f0a112d0d289c948/old/compose15.pdf -------------------------------------------------------------------------------- /old/compose15.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sweirich/pi-forall/75feff0f86f10d02c9e69999f0a112d0d289c948/old/compose15.pptx -------------------------------------------------------------------------------- /version1/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2022, University of Pennsylvania 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the University of Pennsylvania nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL UNIVERSITY OF PENNSYLVANIA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /version1/README.md: -------------------------------------------------------------------------------- 1 | pi-forall 2 | ========= 3 | 4 | A demo implementation of a simple dependently-typed language for OPLSS 5 | (Used in 2023, 2022, 2014 and 2013) 6 | 7 | The goal of this project is to bring up the design issues that occur in the 8 | implementation of the type checkers of languages like Agda, Coq, Epigram, 9 | Idris, etc. Of course, it can't cover everything, but this code is a 10 | starting point for discussion. 11 | 12 | As its main purpose is didactic, the code itself has been written for 13 | clarity, not for speed. The point of this implementation is an introduction to 14 | practical issues of language design and how specific features interact with 15 | each other. 16 | 17 | Installation 18 | ---------- 19 | 20 | Compiling pi-forall requires GHC and stack 21 | 22 | Recommended tools (see links for instructions): 23 | 24 | 1. [gchup](https://www.haskell.org/ghcup/) 25 | 26 | The gchup tool is an installer for general purpose Haskell tools, including GHC, Cabal, Stack and the Haskell language server (HLS). You'll want to install the recommended versions of all of these tools. 27 | 28 | 2. [VSCode](https://code.visualstudio.com/) and [Haskell language extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) for editing the Haskell implementation of `pi-forall`. 29 | 30 | 3. [pi-forall VS code extension](https://marketplace.visualstudio.com/items?itemName=dunhamsteve.pi4all) for syntax highlighting of `pi-forall` code in VS code. 31 | 32 | Contents 33 | -------- 34 | 35 | There are several versions of `pi-forall` in the repository. See the 36 | [documentation](https://github.com/sweirich/pi-forall/blob/2023/doc/oplss.pdf) for an extended 37 | description of what parts of the language are covered by each version. 38 | 39 | When you open the project in vscode, you should open the folder for the implementation that 40 | you want to work with (i.e. `version1`/`version2`/`full`), so that the Haskell language server 41 | can find the project metadata. 42 | 43 | Each implementation has the following structure: 44 | 45 | ``` 46 | / 47 | pi/*.pi example pi-forall files and exercises 48 | src/*.hs source code 49 | app/Main.hs entry point for command line app 50 | README.md this file 51 | LICENSE license file 52 | pi-forall.cabal project metadata 53 | stack.yaml project metadata 54 | 55 | ``` 56 | 57 | To build each version, go to that directory and type: 58 | 59 | ``` 60 | stack build 61 | ``` 62 | 63 | and to typecheck a source file: 64 | 65 | ``` 66 | stack exec -- pi-forall 67 | ``` 68 | 69 | Versioning 70 | ---------- 71 | 72 | This repository has been tested with the current ghcup recommended tool versions for June 2023, including GHC 9.2.7 and stack lts-20.24. 73 | 74 | 75 | 76 | Acknowledgement 77 | --------------- 78 | 79 | Some of this code was adapted from the 'zombie-trellys' implementation by the 80 | Trellys team. The Trellys team includes Aaron Stump, Tim Sheard, Stephanie 81 | Weirich, Garrin Kimmell, Harley D. Eades III, Peng Fu, Chris Casinghino, 82 | Vilhelm Sjöberg, Nathan Collins, and Ki Yung Ahn. 83 | 84 | This material is based upon work supported by the National Science Foundation 85 | under Grant Number 0910786. Any opinions, findings, and conclusions or 86 | recommendations expressed in this material are those of the author(s) and do 87 | not necessarily reflect the views of the National Science Foundation. 88 | -------------------------------------------------------------------------------- /version1/app/Main.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | The command line interface to the pi type checker. 4 | -- Also provides functions for type checking individual terms 5 | -- and files. 6 | module Main (goFilename, go, main) where 7 | 8 | import Control.Monad.Except (runExceptT) 9 | import Environment (emptyEnv, runTcMonad) 10 | import Modules (getModules) 11 | import Parser (parseExpr) 12 | import PrettyPrint (Disp (..), render) 13 | import System.Environment (getArgs) 14 | import System.Exit (exitFailure, exitSuccess) 15 | import System.FilePath (splitFileName) 16 | import Text.ParserCombinators.Parsec.Error (ParseError, errorPos) 17 | import TypeCheck (inferType, tcModules) 18 | 19 | exitWith :: Either a b -> (a -> IO ()) -> IO b 20 | exitWith res f = 21 | case res of 22 | Left x -> f x >> exitFailure 23 | Right y -> return y 24 | 25 | -- | Type check the given string in the empty environment 26 | go :: String -> IO () 27 | go str = do 28 | case parseExpr str of 29 | Left parseError -> putParseError parseError 30 | Right term -> do 31 | putStrLn "parsed as" 32 | putStrLn $ render $ disp term 33 | res <- runTcMonad emptyEnv (inferType term) 34 | case res of 35 | Left typeError -> putTypeError typeError 36 | Right ty -> do 37 | putStrLn "typed with type" 38 | putStrLn $ render $ disp ty 39 | 40 | -- | Display a parse error to the user 41 | putParseError :: ParseError -> IO () 42 | putParseError parseError = do 43 | putStrLn $ render $ disp $ errorPos parseError 44 | print parseError 45 | 46 | -- | Display a type error to the user 47 | putTypeError :: Disp d => d -> IO () 48 | putTypeError typeError = do 49 | putStrLn "Type Error:" 50 | putStrLn $ render $ disp typeError 51 | 52 | -- | Type check the given file 53 | goFilename :: String -> IO () 54 | goFilename pathToMainFile = do 55 | let prefixes = [currentDir, mainFilePrefix] 56 | (mainFilePrefix, name) = splitFileName pathToMainFile 57 | currentDir = "" 58 | putStrLn $ "processing " ++ name ++ "..." 59 | v <- runExceptT (getModules prefixes name) 60 | val <- v `exitWith` putParseError 61 | putStrLn "type checking..." 62 | d <- runTcMonad emptyEnv (tcModules val) 63 | defs <- d `exitWith` putTypeError 64 | putStrLn $ render $ disp (last defs) 65 | 66 | -- | 'pi ' invokes the type checker on the given 67 | -- file and either prints the types of all definitions in the module 68 | -- or prints an error message. 69 | main :: IO () 70 | main = do 71 | [pathToMainFile] <- getArgs 72 | goFilename pathToMainFile 73 | exitSuccess 74 | -------------------------------------------------------------------------------- /version1/pi-forall.cabal: -------------------------------------------------------------------------------- 1 | cabal-Version: 2.2 2 | name: pi-forall 3 | version: 0.2 4 | license: MIT 5 | license-file: LICENSE 6 | copyright: (c) 2013-2023 University of Pennsylvania 7 | description: An implementation of a simple dependently typed language for OPLSS 2022 8 | author: Stephanie Weirich , based on code by Trellys Team 9 | maintainer: Stephanie Weirich 10 | build-type: Simple 11 | tested-with: GHC == 8.10.7 12 | category: Compilers/Interpreters 13 | homepage: https://github.com/sweirich/pi-forall 14 | synopsis: Demo implementation of typechecker for dependently-typed language 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/sweirich/pi-forall 19 | 20 | common shared-properties 21 | default-language: 22 | GHC2021 23 | ghc-options: 24 | -Wall -fno-warn-unused-matches -fno-warn-orphans -fno-warn-unused-top-binds -fno-warn-unused-imports -fno-warn-name-shadowing -Wno-unrecognised-pragmas 25 | default-extensions: 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DerivingStrategies 29 | 30 | build-depends: 31 | base >= 4 && < 5, 32 | parsec >= 3.1.8 && < 3.2, 33 | mtl >= 2.2.1, 34 | pretty >= 1.0.1.0, 35 | unbound-generics >= 0.4.3, 36 | transformers, 37 | array >= 0.3.0.2 && < 0.6, 38 | containers, 39 | directory, 40 | filepath, 41 | HUnit, 42 | QuickCheck 43 | if !impl(ghc >= 8.0) 44 | build-depends: semigroups 45 | 46 | 47 | library 48 | import: shared-properties 49 | hs-source-dirs: src 50 | exposed-modules: 51 | Environment 52 | Equal 53 | LayoutToken 54 | Modules 55 | Parser 56 | PrettyPrint 57 | Syntax 58 | TypeCheck 59 | Arbitrary 60 | 61 | executable pi-forall 62 | import: shared-properties 63 | build-depends: pi-forall 64 | hs-source-dirs: app 65 | main-is: Main.hs 66 | 67 | test-suite test-pi-forall 68 | import: shared-properties 69 | build-depends: pi-forall 70 | , QuickCheck >= 2.13.2 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: Main.hs 74 | -------------------------------------------------------------------------------- /version1/pi/Hw1.pi: -------------------------------------------------------------------------------- 1 | module Hw1 where 2 | 3 | -- HW #1: get this file to type check by adding typing rules 4 | -- for booleans and sigma types to TypeCheck.hs in 'version1' 5 | 6 | -- prelude operations on boolean values 7 | 8 | or : Bool -> Bool -> Bool 9 | or = \b1 b2. if b1 then True else b2 10 | 11 | not : Bool -> Bool 12 | not = \b . if b then False else True 13 | 14 | and : Bool -> Bool -> Bool 15 | and = \b1 b2. if b1 then b2 else False 16 | 17 | eq_bool : Bool -> Bool -> Bool 18 | eq_bool = \ b1 b2 . 19 | if b1 then b2 else (not b2) 20 | 21 | --- sigma types 22 | 23 | double : (A:Type) -> (x : A) -> { x : A | A } 24 | double = \A x. (x,x) 25 | 26 | fst : (A:Type) -> (B : A -> Type) -> { x : A | B x } -> A 27 | fst = \A B p. let (x0,y) = p in x0 28 | 29 | -------------------------------------------------------------------------------- /version1/pi/Lec1.pi: -------------------------------------------------------------------------------- 1 | -- Simple examples demonstrating parametric polymorphism in core language 2 | 3 | module Lec1 where 4 | 5 | id : (x:Type) -> x -> x 6 | id = \x y . y 7 | 8 | idid : ((x:Type) -> (y : x) -> x) 9 | idid = id ((x:Type) -> (y : x) -> x) id 10 | 11 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 12 | (B -> C) -> (A -> B) -> (A -> C) 13 | compose = \ A B C f g x. (f (g x)) 14 | 15 | idT : Type 16 | idT = (x:Type) -> x -> x 17 | 18 | selfapp : idT -> idT 19 | selfapp = (\x.x : (idT -> idT) -> (idT -> idT)) (\x.x) 20 | 21 | -- Church encoding: booleans 22 | 23 | true : (A:Type) -> A -> A -> A 24 | true = \A x y. x 25 | 26 | false : (A:Type) -> A -> A -> A 27 | false = \A x y. y 28 | 29 | cond : ((A:Type) -> A -> A -> A) -> (x:Type) -> x -> x -> x 30 | cond = \ b . b 31 | 32 | -- void type 33 | 34 | void : Type 35 | void = (x:Type) -> x 36 | 37 | -- inhabited by diverging term 38 | 39 | loop : (x:Type) -> x 40 | loop = \x. loop x 41 | 42 | -- unit type 43 | 44 | unit : Type 45 | unit = (x:Type) -> x -> x 46 | 47 | -- this code only type checks with a definition of type equality that 48 | -- includes beta-equivalence/definitions (i.e. >= version2) 49 | 50 | -- Church encoding of simply-typed pairs 51 | 52 | 53 | pair : Type -> Type -> Type 54 | pair = \p. \q. (c: Type) -> (p -> q -> c) -> c 55 | 56 | prod : (p:Type) -> (q:Type) -> p -> q -> 57 | ((\p. \q. (c: Type) -> (p -> q -> c) -> c): Type -> Type -> Type) p q 58 | prod = \p.\q. \x.\y. \c. \f. f x y 59 | 60 | proj1 : (p:Type) -> (q:Type) -> pair p q -> p 61 | proj1 = \p. \q. \a. a p (\x.\y.x) 62 | 63 | proj2 : (p:Type) -> (q:Type) -> pair p q -> q 64 | proj2 = \p. \q. \a. a q (\x.\y.y) 65 | 66 | swap : (p:Type) -> (q:Type) -> pair p q -> pair q p 67 | swap = \p. \q. \a. prod q p (proj2 p q a) (proj1 p q a) 68 | 69 | -------------------------------------------------------------------------------- /version1/src/Modules.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | Tools for working with multiple source files 4 | module Modules (getModules, ModuleInfo (..)) where 5 | 6 | import Control.Monad.Except 7 | import Data.Graph qualified as Gr 8 | import Data.List (nub, (\\)) 9 | import Parser (parseModuleFile, parseModuleImports) 10 | import Syntax 11 | import System.Directory 12 | import System.FilePath 13 | import Text.ParserCombinators.Parsec.Error (ParseError) 14 | 15 | -- | getModules starts with a top-level module, and gathers all of the module's 16 | -- transitive dependency. It returns the list of parsed modules, with all 17 | -- modules appearing after its dependencies. 18 | getModules :: 19 | (Functor m, MonadError ParseError m, MonadIO m) => 20 | [FilePath] -> 21 | String -> 22 | m [Module] 23 | getModules prefixes top = do 24 | toParse <- gatherModules prefixes [ModuleImport top] 25 | mapM reparse toParse 26 | 27 | data ModuleInfo = ModuleInfo 28 | { modInfoName :: ModuleName, 29 | modInfoFilename :: String, 30 | modInfoImports :: [ModuleImport] 31 | } 32 | 33 | -- | Build the module dependency graph. 34 | -- This only parses the imports part of each file; later we go back and parse all of it. 35 | gatherModules :: 36 | (Functor m, MonadError ParseError m, MonadIO m) => 37 | [FilePath] -> 38 | [ModuleImport] -> 39 | m [ModuleInfo] 40 | gatherModules prefixes ms = gatherModules' ms [] 41 | where 42 | gatherModules' [] accum = return $ topSort accum 43 | gatherModules' ((ModuleImport m) : ms') accum = do 44 | modFileName <- getModuleFileName prefixes m 45 | imports <- moduleImports <$> parseModuleImports modFileName 46 | let accum' = ModuleInfo m modFileName imports : accum 47 | let oldMods = map (ModuleImport . modInfoName) accum' 48 | gatherModules' (nub (ms' ++ imports) \\ oldMods) accum' 49 | 50 | -- | Generate a sorted list of modules, with the postcondition that a module 51 | -- will appear _after_ any of its dependencies. 52 | topSort :: [ModuleInfo] -> [ModuleInfo] 53 | topSort ms = reverse sorted 54 | where 55 | (gr, lu) = 56 | Gr.graphFromEdges' 57 | [ (m, modInfoName m, [i | ModuleImport i <- modInfoImports m]) 58 | | m <- ms 59 | ] 60 | lu' v = let (m, _, _) = lu v in m 61 | sorted = [lu' v | v <- Gr.topSort gr] 62 | 63 | -- | Find the file associated with a module. 64 | getModuleFileName :: 65 | (MonadIO m) => 66 | [FilePath] -> 67 | ModuleName -> 68 | m FilePath 69 | getModuleFileName prefixes modul = do 70 | let makeFileName prefix = prefix mDotPi 71 | -- get M.pi from M or M.pi 72 | mDotPi = 73 | if takeExtension s == ".pi" 74 | then s 75 | else s <.> "pi" 76 | s = modul 77 | possibleFiles = map makeFileName prefixes 78 | files <- liftIO $ filterM doesFileExist possibleFiles 79 | if null files 80 | then 81 | error $ 82 | "Can't locate module: " ++ show modul 83 | ++ "\nTried: " 84 | ++ show possibleFiles 85 | else return $ head files 86 | 87 | -- | Fully parse a module (not just the imports). 88 | reparse :: 89 | (MonadError ParseError m, MonadIO m) => 90 | ModuleInfo -> 91 | m Module 92 | reparse (ModuleInfo _ fileName _) = parseModuleFile fileName 93 | -------------------------------------------------------------------------------- /version1/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | 3 | # Local packages, usually specified by relative directory name 4 | packages: 5 | - '.' 6 | 7 | flags: {} 8 | 9 | extra-package-dbs: [] 10 | 11 | -------------------------------------------------------------------------------- /version1/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Arbitrary 4 | import Control.Monad.Except 5 | import Environment 6 | import Modules 7 | import PrettyPrint 8 | import Syntax 9 | import Test.HUnit 10 | import Test.QuickCheck 11 | import Text.ParserCombinators.Parsec.Error 12 | import Text.PrettyPrint.HughesPJ (render) 13 | import TypeCheck 14 | 15 | main :: IO () 16 | main = do 17 | quickCheck prop_roundtrip 18 | 19 | exitWith :: Either a b -> (a -> IO b) -> IO b 20 | exitWith (Left a) f = f a 21 | exitWith (Right b) f = return b 22 | 23 | -- | Type check the given file 24 | testFile :: String -> Test 25 | testFile name = name ~: TestCase $ do 26 | v <- runExceptT (getModules ["pi"] name) 27 | val <- v `exitWith` (\b -> assertFailure $ "Parse error: " ++ render (disp b)) 28 | d <- runTcMonad emptyEnv (tcModules val) 29 | defs <- d `exitWith` (\s -> assertFailure $ "Type error:" ++ render (disp s)) 30 | putStrLn $ render $ disp (last defs) 31 | -------------------------------------------------------------------------------- /version2/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2022, University of Pennsylvania 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the University of Pennsylvania nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL UNIVERSITY OF PENNSYLVANIA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /version2/README.md: -------------------------------------------------------------------------------- 1 | pi-forall 2 | ========= 3 | 4 | A demo implementation of a simple dependently-typed language for OPLSS 5 | (Used in 2023, 2022, 2014 and 2013) 6 | 7 | The goal of this project is to bring up the design issues that occur in the 8 | implementation of the type checkers of languages like Agda, Coq, Epigram, 9 | Idris, etc. Of course, it can't cover everything, but this code is a 10 | starting point for discussion. 11 | 12 | As its main purpose is didactic, the code itself has been written for 13 | clarity, not for speed. The point of this implementation is an introduction to 14 | practical issues of language design and how specific features interact with 15 | each other. 16 | 17 | Installation 18 | ---------- 19 | 20 | Compiling pi-forall requires GHC and stack 21 | 22 | Recommended tools (see links for instructions): 23 | 24 | 1. [gchup](https://www.haskell.org/ghcup/) 25 | 26 | The gchup tool is an installer for general purpose Haskell tools, including GHC, Cabal, Stack and the Haskell language server (HLS). You'll want to install the recommended versions of all of these tools. 27 | 28 | 2. [VSCode](https://code.visualstudio.com/) and [Haskell language extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) for editing the Haskell implementation of `pi-forall`. 29 | 30 | 3. [pi-forall VS code extension](https://marketplace.visualstudio.com/items?itemName=dunhamsteve.pi4all) for syntax highlighting of `pi-forall` code in VS code. 31 | 32 | Contents 33 | -------- 34 | 35 | There are several versions of `pi-forall` in the repository. See the 36 | [documentation](https://github.com/sweirich/pi-forall/blob/2023/doc/oplss.pdf) for an extended 37 | description of what parts of the language are covered by each version. 38 | 39 | When you open the project in vscode, you should open the folder for the implementation that 40 | you want to work with (i.e. `version1`/`version2`/`full`), so that the Haskell language server 41 | can find the project metadata. 42 | 43 | Each implementation has the following structure: 44 | 45 | ``` 46 | / 47 | pi/*.pi example pi-forall files and exercises 48 | src/*.hs source code 49 | app/Main.hs entry point for command line app 50 | README.md this file 51 | LICENSE license file 52 | pi-forall.cabal project metadata 53 | stack.yaml project metadata 54 | 55 | ``` 56 | 57 | To build each version, go to that directory and type: 58 | 59 | ``` 60 | stack build 61 | ``` 62 | 63 | and to typecheck a source file: 64 | 65 | ``` 66 | stack exec -- pi-forall 67 | ``` 68 | 69 | Versioning 70 | ---------- 71 | 72 | This repository has been tested with the current ghcup recommended tool versions for June 2023, including GHC 9.2.7 and stack lts-20.24. 73 | 74 | 75 | 76 | Acknowledgement 77 | --------------- 78 | 79 | Some of this code was adapted from the 'zombie-trellys' implementation by the 80 | Trellys team. The Trellys team includes Aaron Stump, Tim Sheard, Stephanie 81 | Weirich, Garrin Kimmell, Harley D. Eades III, Peng Fu, Chris Casinghino, 82 | Vilhelm Sjöberg, Nathan Collins, and Ki Yung Ahn. 83 | 84 | This material is based upon work supported by the National Science Foundation 85 | under Grant Number 0910786. Any opinions, findings, and conclusions or 86 | recommendations expressed in this material are those of the author(s) and do 87 | not necessarily reflect the views of the National Science Foundation. 88 | -------------------------------------------------------------------------------- /version2/app/Main.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | The command line interface to the pi type checker. 4 | -- Also provides functions for type checking individual terms 5 | -- and files. 6 | module Main(goFilename,go,main) where 7 | 8 | import Modules (getModules) 9 | import PrettyPrint ( render, Disp(..) ) 10 | import Environment ( emptyEnv, runTcMonad ) 11 | import TypeCheck ( tcModules, inferType ) 12 | import Parser ( parseExpr ) 13 | import Text.ParserCombinators.Parsec.Error ( errorPos, ParseError ) 14 | import Control.Monad.Except ( runExceptT ) 15 | import System.Environment(getArgs) 16 | import System.Exit (exitFailure,exitSuccess) 17 | import System.FilePath (splitFileName) 18 | 19 | exitWith :: Either a b -> (a -> IO ()) -> IO b 20 | exitWith res f = 21 | case res of 22 | Left x -> f x >> exitFailure 23 | Right y -> return y 24 | 25 | -- | Type check the given string in the empty environment 26 | go :: String -> IO () 27 | go str = do 28 | case parseExpr str of 29 | Left parseError -> putParseError parseError 30 | Right term -> do 31 | putStrLn "parsed as" 32 | putStrLn $ render $ disp term 33 | res <- runTcMonad emptyEnv (inferType term) 34 | case res of 35 | Left typeError -> putTypeError typeError 36 | Right ty -> do 37 | putStrLn "typed with type" 38 | putStrLn $ render $ disp ty 39 | 40 | -- | Display a parse error to the user 41 | putParseError :: ParseError -> IO () 42 | putParseError parseError = do 43 | putStrLn $ render $ disp $ errorPos parseError 44 | print parseError 45 | 46 | -- | Display a type error to the user 47 | putTypeError :: Disp d => d -> IO () 48 | putTypeError typeError = do 49 | putStrLn "Type Error:" 50 | putStrLn $ render $ disp typeError 51 | 52 | -- | Type check the given file 53 | goFilename :: String -> IO () 54 | goFilename pathToMainFile = do 55 | let prefixes = [currentDir, mainFilePrefix] 56 | (mainFilePrefix, name) = splitFileName pathToMainFile 57 | currentDir = "" 58 | putStrLn $ "processing " ++ name ++ "..." 59 | v <- runExceptT (getModules prefixes name) 60 | val <- v `exitWith` putParseError 61 | putStrLn "type checking..." 62 | d <- runTcMonad emptyEnv (tcModules val) 63 | defs <- d `exitWith` putTypeError 64 | putStrLn $ render $ disp (last defs) 65 | 66 | 67 | -- | 'pi ' invokes the type checker on the given 68 | -- file and either prints the types of all definitions in the module 69 | -- or prints an error message. 70 | main :: IO () 71 | main = do 72 | [pathToMainFile] <- getArgs 73 | goFilename pathToMainFile 74 | exitSuccess 75 | 76 | -------------------------------------------------------------------------------- /version2/pi-forall.cabal: -------------------------------------------------------------------------------- 1 | cabal-Version: 2.2 2 | name: pi-forall 3 | version: 0.2 4 | license: MIT 5 | license-file: LICENSE 6 | copyright: (c) 2013-2023 University of Pennsylvania 7 | description: An implementation of a simple dependently typed language for OPLSS 2022 8 | author: Stephanie Weirich , based on code by Trellys Team 9 | maintainer: Stephanie Weirich 10 | build-type: Simple 11 | tested-with: GHC == 8.10.7 12 | category: Compilers/Interpreters 13 | homepage: https://github.com/sweirich/pi-forall 14 | synopsis: Demo implementation of typechecker for dependently-typed language 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/sweirich/pi-forall 19 | 20 | common shared-properties 21 | default-language: 22 | GHC2021 23 | ghc-options: 24 | -Wall -fno-warn-unused-matches -fno-warn-orphans -fno-warn-unused-top-binds -fno-warn-unused-imports -fno-warn-name-shadowing -Wno-unrecognised-pragmas 25 | default-extensions: 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DerivingStrategies 29 | 30 | build-depends: 31 | base >= 4 && < 5, 32 | parsec >= 3.1.8 && < 3.2, 33 | mtl >= 2.2.1, 34 | pretty >= 1.0.1.0, 35 | unbound-generics >= 0.4.3, 36 | transformers, 37 | array >= 0.3.0.2 && < 0.6, 38 | containers, 39 | directory, 40 | filepath, 41 | HUnit, 42 | QuickCheck 43 | if !impl(ghc >= 8.0) 44 | build-depends: semigroups 45 | 46 | 47 | library 48 | import: shared-properties 49 | hs-source-dirs: src 50 | exposed-modules: 51 | Environment 52 | Equal 53 | LayoutToken 54 | Modules 55 | Parser 56 | PrettyPrint 57 | Syntax 58 | TypeCheck 59 | Arbitrary 60 | 61 | executable pi-forall 62 | import: shared-properties 63 | build-depends: pi-forall 64 | hs-source-dirs: app 65 | main-is: Main.hs 66 | 67 | test-suite test-pi-forall 68 | import: shared-properties 69 | build-depends: pi-forall 70 | , QuickCheck >= 2.13.2 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: Main.hs 74 | -------------------------------------------------------------------------------- /version2/pi/Hw1.pi: -------------------------------------------------------------------------------- 1 | module Hw1 where 2 | 3 | -- HW #1: get this file to type check by adding typing rules 4 | -- for booleans and sigma types to TypeCheck.hs in 'version1' 5 | 6 | -- prelude operations on boolean values 7 | 8 | or : Bool -> Bool -> Bool 9 | or = \b1 b2. if b1 then True else b2 10 | 11 | not : Bool -> Bool 12 | not = \b . if b then False else True 13 | 14 | and : Bool -> Bool -> Bool 15 | and = \b1 b2. if b1 then b2 else False 16 | 17 | eq_bool : Bool -> Bool -> Bool 18 | eq_bool = \ b1 b2 . 19 | if b1 then b2 else (not b2) 20 | 21 | --- sigma types 22 | 23 | double : (A:Type) -> (x : A) -> { x : A | A } 24 | double = \A x. (x,x) 25 | 26 | fst : (A:Type) -> (B : A -> Type) -> { x : A | B x } -> A 27 | fst = \A B p. let (x0,y) = p in x0 28 | 29 | -------------------------------------------------------------------------------- /version2/pi/Hw2.pi: -------------------------------------------------------------------------------- 1 | module Hw2 where 2 | 3 | -- First: read section 7.2 of the lecture notes about how 4 | -- propositional equality works in pi-forall. The key points are 5 | -- that `Refl` is a proof of the identity type `(a = b)` when 6 | -- a is definitionally equal to b, and that `subst` is the elimination 7 | -- form. 8 | 9 | -- For example, we can show that equality is symmetric by 10 | -- eliminating pf (of type `x = y`) when type checking 11 | -- `Refl` against type `y = x`. The `subst` adds the definition 12 | -- `x = y` to the context, so both sides of `y = x` wh normalize to y. 13 | 14 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 15 | sym = \ A x y pf . 16 | subst Refl by pf 17 | 18 | -- Homework: show that propositional equality is transitive 19 | 20 | trans : (A:Type) -> (x:A) -> (y:A) -> (z:A) -> (x = z) -> (z = y) -> (x = y) 21 | trans = TRUSTME 22 | 23 | -- Homework: show that it is congruent for (nondependent) application 24 | 25 | f_cong : (A:Type) -> (B : Type) -> (f : A -> B) -> (g : A -> B) 26 | -> (x:A) -> (y:A) 27 | -> (f = g) -> (x = y) -> (f x = g y) 28 | f_cong = TRUSTME 29 | 30 | -- Homework: what does congruence for dependent application look like? 31 | -- In other words, what if f and g above have a dependent type? 32 | 33 | 34 | 35 | 36 | -- properties of booleans 37 | 38 | -- an encoding of logical falsity 39 | 40 | void : Type 41 | void = (A:Type) -> A 42 | 43 | neg : Type -> Type 44 | neg = \ A . ( (A) -> void ) 45 | 46 | not : Bool -> Bool 47 | not = \ x . if x then False else True 48 | 49 | -- show that true is not false 50 | 51 | not_not_equal : (b : Bool) -> (b = not b) -> void 52 | not_not_equal = TRUSTME 53 | 54 | 55 | not_false_then_true : (b : Bool) -> neg (b = False) -> b = True 56 | not_false_then_true = TRUSTME 57 | 58 | -- show that decidable equality for booleans is correct. 59 | 60 | eq_bool : Bool -> Bool -> Bool 61 | eq_bool = \x y. if x then y else not y 62 | 63 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 64 | eq_true = \b1 b2 pf. TRUSTME 65 | 66 | eq_false : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = False -> (b1 = b2) -> void 67 | eq_false = TRUSTME 68 | 69 | false_eq_bool : (n : Bool) -> (m : Bool) -> 70 | neg (n = m) -> 71 | eq_bool n m = False 72 | false_eq_bool = \n m nnm. TRUSTME 73 | 74 | 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /version2/pi/Lec1.pi: -------------------------------------------------------------------------------- 1 | -- Simple examples demonstrating parametric polymorphism in core language 2 | 3 | module Lec1 where 4 | 5 | id : (x:Type) -> x -> x 6 | id = \x y . y 7 | 8 | idid : ((x:Type) -> (y : x) -> x) 9 | idid = id ((x:Type) -> (y : x) -> x) id 10 | 11 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 12 | (B -> C) -> (A -> B) -> (A -> C) 13 | compose = \ A B C f g x. (f (g x)) 14 | 15 | idT : Type 16 | idT = (x:Type) -> x -> x 17 | 18 | selfapp : idT -> idT 19 | selfapp = (\x.x : (idT -> idT) -> (idT -> idT)) (\x.x) 20 | 21 | -- Church encoding: booleans 22 | 23 | true : (A:Type) -> A -> A -> A 24 | true = \A x y. x 25 | 26 | false : (A:Type) -> A -> A -> A 27 | false = \A x y. y 28 | 29 | cond : ((A:Type) -> A -> A -> A) -> (x:Type) -> x -> x -> x 30 | cond = \ b . b 31 | 32 | -- void type 33 | 34 | void : Type 35 | void = (x:Type) -> x 36 | 37 | -- inhabited by diverging term 38 | 39 | loop : (x:Type) -> x 40 | loop = \x. loop x 41 | 42 | -- unit type 43 | 44 | unit : Type 45 | unit = (x:Type) -> x -> x 46 | 47 | -- this code only type checks with a definition of type equality that 48 | -- includes beta-equivalence/definitions (i.e. >= version2) 49 | 50 | -- Church encoding of simply-typed pairs 51 | {- 52 | 53 | pair : Type -> Type -> Type 54 | pair = \p. \q. (c: Type) -> (p -> q -> c) -> c 55 | 56 | prod : (p:Type) -> (q:Type) -> p -> q -> pair p q 57 | prod = \p.\q. \x.\y. \c. \f. f x y 58 | 59 | proj1 : (p:Type) -> (q:Type) -> pair p q -> p 60 | proj1 = \p. \q. \a. a p (\x.\y.x) 61 | 62 | proj2 : (p:Type) -> (q:Type) -> pair p q -> q 63 | proj2 = \p. \q. \a. a q (\x.\y.y) 64 | 65 | swap : (p:Type) -> (q:Type) -> pair p q -> pair q p 66 | swap = \p. \q. \a. prod q p (proj2 p q a) (proj1 p q a) 67 | -} 68 | -------------------------------------------------------------------------------- /version2/pi/Lec2.pi: -------------------------------------------------------------------------------- 1 | module Lec2 where 2 | 3 | 4 | -- "large eliminations" 5 | 6 | bool' : Bool -> Type 7 | bool' = \b . (B : (b : Bool) -> Type) -> B True -> B False -> B b 8 | 9 | true' : bool' True 10 | true' = \A x y . x 11 | 12 | false' : bool' False 13 | false' = \ A x y. y 14 | 15 | T : Bool -> Type 16 | T = \b. if b then Unit else Bool 17 | 18 | z1 : T True 19 | z1 = () 20 | 21 | z2 : T False 22 | z2 = True 23 | 24 | 25 | -- To get bar and barnot to work 26 | -- the typing rule for 'if' expressions must be 27 | -- context-dependent. In otherwords, it should add new 28 | -- definitions to the context in the true/false branches 29 | -- when the scrutinee is a variable 30 | -- (i.e. >= version2) 31 | 32 | 33 | not : Bool -> Bool 34 | not = \x. if x then False else True 35 | 36 | bar : (b : Bool) -> T b 37 | bar = \b. if b then () else True 38 | 39 | barnot : (b : Bool) -> T (not b) 40 | barnot = \b. if b then False else () 41 | 42 | 43 | -- projections for sigma types 44 | 45 | fst : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> A 46 | fst = \A B p. let (x,y) = p in x 47 | 48 | snd : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> B (fst A B p) 49 | snd = \A B p. let (x1,y) = p in y 50 | 51 | -- examples of propositional equality 52 | 53 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 54 | sym = \ A x y pf . 55 | subst Refl by pf 56 | 57 | -------------------------------------------------------------------------------- /version2/pi/NatChurch.pi: -------------------------------------------------------------------------------- 1 | module NatChurch where 2 | 3 | -- Church encoding of natural numbers 4 | 5 | nat : Type 6 | nat = (x:Type) -> x -> (x -> x) -> x 7 | 8 | z : nat 9 | z = \x zf sf. zf 10 | 11 | s : nat -> nat 12 | s = \n. \x zf sf. sf (n x zf sf) 13 | 14 | one : nat 15 | one = s z 16 | 17 | two : nat 18 | two = s (s z) 19 | 20 | three : nat 21 | three = TRUSTME -- replace with correct definition of 3 22 | 23 | plus : nat -> nat -> nat 24 | plus = \x. \y. x nat y s 25 | 26 | test0 : plus one one = two 27 | test0 = Refl 28 | 29 | test1 : plus one two = three 30 | test1 = TRUSTME -- replace with Refl 31 | 32 | spec0 : (n : nat) -> plus z n = n 33 | spec0 = \n . Refl 34 | 35 | spec1 : (n : nat) -> (m : nat) -> plus (s n) m = s (plus n m) 36 | spec1 = \n m . Refl 37 | 38 | -- The predecessor function is *really* tricky! Don't try this 39 | -- first if you have never seen it before. 40 | 41 | pred : nat -> nat 42 | pred = TRUSTME 43 | 44 | test_pred : pred two = one 45 | test_pred = TRUSTME -- replace with Refl 46 | 47 | -- Since pi-forall allows recursive definitions, we also have Scott encodings 48 | -- of datatypes available. (See http://en.wikipedia.org/wiki/Mogensen%E2%80%93Scott_encoding. 49 | -- You can't do this in Coq or Agda because it requires an inconsistent logic). 50 | 51 | scott_nat : Type 52 | scott_nat = (x:Type) -> x -> (scott_nat -> x) -> x 53 | 54 | scott_z : scott_nat 55 | scott_z = \x z s . z 56 | 57 | scott_s : scott_nat -> scott_nat 58 | scott_s = \n . \x z s . s n 59 | 60 | scott_one : scott_nat 61 | scott_one = scott_s scott_z 62 | 63 | scott_two : scott_nat 64 | scott_two = scott_s (scott_s scott_z) 65 | 66 | scott_three : scott_nat 67 | scott_three = scott_s (scott_s (scott_s scott_z)) 68 | 69 | -- Write the predecessor function, it is much easier here 70 | 71 | scott_pred : scott_nat -> scott_nat 72 | scott_pred = TRUSTME 73 | 74 | testNC1 : scott_pred scott_two = scott_one 75 | testNC1 = TRUSTME -- replace with Refl 76 | 77 | -- Now write plus: with Scott encoded nats, note that you need to use recursion. 78 | 79 | scott_plus : scott_nat -> scott_nat -> scott_nat 80 | scott_plus = TRUSTME 81 | 82 | testNC2 : scott_plus scott_one scott_two = scott_three 83 | testNC2 = TRUSTME -- replace with Refl 84 | -------------------------------------------------------------------------------- /version2/pi/Sigma.pi: -------------------------------------------------------------------------------- 1 | module Sigma where 2 | 3 | -- Defining projection terms using pattern matching 4 | 5 | fst : (A:Type) -> (B:A -> Type) -> { x : A | B x } -> A 6 | fst = \A B x . let (y,z) = x in y 7 | 8 | snd : (A:Type) -> (B:A -> Type) -> (p : { x:A | B x}) -> B (fst A B p) 9 | snd = \A B x . let (y,z) = x in z 10 | 11 | 12 | -------------------------------------------------------------------------------- /version2/src/Modules.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | Tools for working with multiple source files 4 | module Modules(getModules, ModuleInfo(..)) where 5 | 6 | import Syntax 7 | import Parser(parseModuleFile, parseModuleImports) 8 | 9 | import Text.ParserCombinators.Parsec.Error ( ParseError ) 10 | 11 | import Control.Monad.Except 12 | 13 | import System.FilePath 14 | import System.Directory 15 | import qualified Data.Graph as Gr 16 | import Data.List(nub,(\\)) 17 | 18 | -- | getModules starts with a top-level module, and gathers all of the module's 19 | -- transitive dependency. It returns the list of parsed modules, with all 20 | -- modules appearing after its dependencies. 21 | getModules 22 | :: (Functor m, MonadError ParseError m, MonadIO m) => 23 | [FilePath] -> String -> m [Module] 24 | getModules prefixes top = do 25 | toParse <- gatherModules prefixes [ModuleImport top] 26 | mapM reparse toParse 27 | 28 | data ModuleInfo = ModuleInfo { 29 | modInfoName :: ModuleName, 30 | modInfoFilename :: String, 31 | modInfoImports :: [ModuleImport] 32 | } 33 | 34 | -- | Build the module dependency graph. 35 | -- This only parses the imports part of each file; later we go back and parse all of it. 36 | gatherModules 37 | :: (Functor m, MonadError ParseError m, MonadIO m) => 38 | [FilePath] -> [ModuleImport] -> m [ModuleInfo] 39 | gatherModules prefixes ms = gatherModules' ms [] where 40 | gatherModules' [] accum = return $ topSort accum 41 | gatherModules' ((ModuleImport m):ms') accum = do 42 | modFileName <- getModuleFileName prefixes m 43 | imports <- moduleImports <$> parseModuleImports modFileName 44 | let accum' = ModuleInfo m modFileName imports :accum 45 | let oldMods = map (ModuleImport . modInfoName) accum' 46 | gatherModules' (nub (ms' ++ imports) \\ oldMods) accum' 47 | 48 | -- | Generate a sorted list of modules, with the postcondition that a module 49 | -- will appear _after_ any of its dependencies. 50 | topSort :: [ModuleInfo] -> [ModuleInfo] 51 | topSort ms = reverse sorted 52 | where (gr,lu) = Gr.graphFromEdges' [(m, modInfoName m, [i | ModuleImport i <- modInfoImports m]) 53 | | m <- ms] 54 | lu' v = let (m,_,_) = lu v in m 55 | sorted = [lu' v | v <- Gr.topSort gr] 56 | 57 | -- | Find the file associated with a module. 58 | getModuleFileName :: (MonadIO m) 59 | => [FilePath] -> ModuleName -> m FilePath 60 | getModuleFileName prefixes modul = do 61 | let makeFileName prefix = prefix mDotPi 62 | -- get M.pi from M or M.pi 63 | mDotPi = if takeExtension s == ".pi" 64 | then s 65 | else s <.> "pi" 66 | s = modul 67 | possibleFiles = map makeFileName prefixes 68 | files <- liftIO $ filterM doesFileExist possibleFiles 69 | if null files 70 | then error $ "Can't locate module: " ++ show modul ++ 71 | "\nTried: " ++ show possibleFiles 72 | else return $ head files 73 | 74 | -- | Fully parse a module (not just the imports). 75 | reparse :: (MonadError ParseError m, MonadIO m) => 76 | ModuleInfo -> m Module 77 | reparse (ModuleInfo _ fileName _) = parseModuleFile fileName 78 | -------------------------------------------------------------------------------- /version2/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | 3 | # Local packages, usually specified by relative directory name 4 | packages: 5 | - '.' 6 | 7 | flags: {} 8 | 9 | extra-package-dbs: [] 10 | 11 | -------------------------------------------------------------------------------- /version2/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.QuickCheck 4 | import Test.HUnit 5 | import Environment 6 | import PrettyPrint 7 | import TypeCheck 8 | import Syntax 9 | import Control.Monad.Except 10 | import Modules 11 | import Text.PrettyPrint.HughesPJ (render) 12 | import Text.ParserCombinators.Parsec.Error 13 | import Test.QuickCheck 14 | import Arbitrary 15 | 16 | main :: IO () 17 | main = do 18 | quickCheck prop_roundtrip 19 | 20 | exitWith :: Either a b -> (a -> IO b) -> IO b 21 | exitWith (Left a) f = f a 22 | exitWith (Right b) f = return b 23 | 24 | -- | Type check the given file 25 | testFile :: String -> Test 26 | testFile name = name ~: TestCase $ do 27 | v <- runExceptT (getModules ["pi"] name) 28 | val <- v `exitWith` (\b -> assertFailure $ "Parse error: " ++ render (disp b)) 29 | d <- runTcMonad emptyEnv (tcModules val) 30 | defs <- d `exitWith` (\s -> assertFailure $ "Type error:" ++ render (disp s)) 31 | putStrLn $ render $ disp (last defs) -------------------------------------------------------------------------------- /version3/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2022, University of Pennsylvania 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the University of Pennsylvania nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL UNIVERSITY OF PENNSYLVANIA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /version3/README.md: -------------------------------------------------------------------------------- 1 | pi-forall 2 | ========= 3 | 4 | A demo implementation of a simple dependently-typed language for OPLSS 5 | (Used in 2023, 2022, 2014 and 2013) 6 | 7 | The goal of this project is to bring up the design issues that occur in the 8 | implementation of the type checkers of languages like Agda, Coq, Epigram, 9 | Idris, etc. Of course, it can't cover everything, but this code is a 10 | starting point for discussion. 11 | 12 | As its main purpose is didactic, the code itself has been written for 13 | clarity, not for speed. The point of this implementation is an introduction to 14 | practical issues of language design and how specific features interact with 15 | each other. 16 | 17 | Installation 18 | ---------- 19 | 20 | Compiling pi-forall requires GHC and stack 21 | 22 | Recommended tools (see links for instructions): 23 | 24 | 1. [gchup](https://www.haskell.org/ghcup/) 25 | 26 | The gchup tool is an installer for general purpose Haskell tools, including GHC, Cabal, Stack and the Haskell language server (HLS). You'll want to install the recommended versions of all of these tools. 27 | 28 | 2. [VSCode](https://code.visualstudio.com/) and [Haskell language extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) for editing the Haskell implementation of `pi-forall`. 29 | 30 | 3. [pi-forall VS code extension](https://marketplace.visualstudio.com/items?itemName=dunhamsteve.pi4all) for syntax highlighting of `pi-forall` code in VS code. 31 | 32 | Contents 33 | -------- 34 | 35 | There are several versions of `pi-forall` in the repository. See the 36 | [documentation](https://github.com/sweirich/pi-forall/blob/2023/doc/oplss.pdf) for an extended 37 | description of what parts of the language are covered by each version. 38 | 39 | When you open the project in vscode, you should open the folder for the implementation that 40 | you want to work with (i.e. `version1`/`version2`/`full`), so that the Haskell language server 41 | can find the project metadata. 42 | 43 | Each implementation has the following structure: 44 | 45 | ``` 46 | / 47 | pi/*.pi example pi-forall files and exercises 48 | src/*.hs source code 49 | app/Main.hs entry point for command line app 50 | README.md this file 51 | LICENSE license file 52 | pi-forall.cabal project metadata 53 | stack.yaml project metadata 54 | 55 | ``` 56 | 57 | To build each version, go to that directory and type: 58 | 59 | ``` 60 | stack build 61 | ``` 62 | 63 | and to typecheck a source file: 64 | 65 | ``` 66 | stack exec -- pi-forall 67 | ``` 68 | 69 | Versioning 70 | ---------- 71 | 72 | This repository has been tested with the current ghcup recommended tool versions for June 2023, including GHC 9.2.7 and stack lts-20.24. 73 | 74 | 75 | 76 | Acknowledgement 77 | --------------- 78 | 79 | Some of this code was adapted from the 'zombie-trellys' implementation by the 80 | Trellys team. The Trellys team includes Aaron Stump, Tim Sheard, Stephanie 81 | Weirich, Garrin Kimmell, Harley D. Eades III, Peng Fu, Chris Casinghino, 82 | Vilhelm Sjöberg, Nathan Collins, and Ki Yung Ahn. 83 | 84 | This material is based upon work supported by the National Science Foundation 85 | under Grant Number 0910786. Any opinions, findings, and conclusions or 86 | recommendations expressed in this material are those of the author(s) and do 87 | not necessarily reflect the views of the National Science Foundation. 88 | -------------------------------------------------------------------------------- /version3/app/Main.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | The command line interface to the pi type checker. 4 | -- Also provides functions for type checking individual terms 5 | -- and files. 6 | module Main(goFilename,go,main) where 7 | 8 | import Modules (getModules) 9 | import PrettyPrint ( render, Disp(..) ) 10 | import Environment ( emptyEnv, runTcMonad ) 11 | import TypeCheck ( tcModules, inferType ) 12 | import Parser ( parseExpr ) 13 | import Text.ParserCombinators.Parsec.Error ( errorPos, ParseError ) 14 | import Control.Monad.Except ( runExceptT ) 15 | import System.Environment(getArgs) 16 | import System.Exit (exitFailure,exitSuccess) 17 | import System.FilePath (splitFileName) 18 | 19 | exitWith :: Either a b -> (a -> IO ()) -> IO b 20 | exitWith res f = 21 | case res of 22 | Left x -> f x >> exitFailure 23 | Right y -> return y 24 | 25 | -- | Type check the given string in the empty environment 26 | go :: String -> IO () 27 | go str = do 28 | case parseExpr str of 29 | Left parseError -> putParseError parseError 30 | Right term -> do 31 | putStrLn "parsed as" 32 | putStrLn $ render $ disp term 33 | res <- runTcMonad emptyEnv (inferType term) 34 | case res of 35 | Left typeError -> putTypeError typeError 36 | Right ty -> do 37 | putStrLn "typed with type" 38 | putStrLn $ render $ disp ty 39 | 40 | -- | Display a parse error to the user 41 | putParseError :: ParseError -> IO () 42 | putParseError parseError = do 43 | putStrLn $ render $ disp $ errorPos parseError 44 | print parseError 45 | 46 | -- | Display a type error to the user 47 | putTypeError :: Disp d => d -> IO () 48 | putTypeError typeError = do 49 | putStrLn "Type Error:" 50 | putStrLn $ render $ disp typeError 51 | 52 | -- | Type check the given file 53 | goFilename :: String -> IO () 54 | goFilename pathToMainFile = do 55 | let prefixes = [currentDir, mainFilePrefix] 56 | (mainFilePrefix, name) = splitFileName pathToMainFile 57 | currentDir = "" 58 | putStrLn $ "processing " ++ name ++ "..." 59 | v <- runExceptT (getModules prefixes name) 60 | val <- v `exitWith` putParseError 61 | putStrLn "type checking..." 62 | d <- runTcMonad emptyEnv (tcModules val) 63 | defs <- d `exitWith` putTypeError 64 | putStrLn $ render $ disp (last defs) 65 | 66 | 67 | -- | 'pi ' invokes the type checker on the given 68 | -- file and either prints the types of all definitions in the module 69 | -- or prints an error message. 70 | main :: IO () 71 | main = do 72 | [pathToMainFile] <- getArgs 73 | goFilename pathToMainFile 74 | exitSuccess 75 | 76 | -------------------------------------------------------------------------------- /version3/pi-forall.cabal: -------------------------------------------------------------------------------- 1 | cabal-Version: 2.2 2 | name: pi-forall 3 | version: 0.2 4 | license: MIT 5 | license-file: LICENSE 6 | copyright: (c) 2013-2023 University of Pennsylvania 7 | description: An implementation of a simple dependently typed language for OPLSS 2022 8 | author: Stephanie Weirich , based on code by Trellys Team 9 | maintainer: Stephanie Weirich 10 | build-type: Simple 11 | tested-with: GHC == 8.10.7 12 | category: Compilers/Interpreters 13 | homepage: https://github.com/sweirich/pi-forall 14 | synopsis: Demo implementation of typechecker for dependently-typed language 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/sweirich/pi-forall 19 | 20 | common shared-properties 21 | default-language: 22 | GHC2021 23 | ghc-options: 24 | -Wall -fno-warn-unused-matches -fno-warn-orphans -fno-warn-unused-top-binds -fno-warn-unused-imports -fno-warn-name-shadowing -Wno-unrecognised-pragmas 25 | default-extensions: 26 | DefaultSignatures 27 | DeriveAnyClass 28 | DerivingStrategies 29 | 30 | build-depends: 31 | base >= 4 && < 5, 32 | parsec >= 3.1.8 && < 3.2, 33 | mtl >= 2.2.1, 34 | pretty >= 1.0.1.0, 35 | unbound-generics >= 0.4.3, 36 | transformers, 37 | array >= 0.3.0.2 && < 0.6, 38 | containers, 39 | directory, 40 | filepath, 41 | HUnit, 42 | QuickCheck 43 | if !impl(ghc >= 8.0) 44 | build-depends: semigroups 45 | 46 | 47 | library 48 | import: shared-properties 49 | hs-source-dirs: src 50 | exposed-modules: 51 | Environment 52 | Equal 53 | LayoutToken 54 | Modules 55 | Parser 56 | PrettyPrint 57 | Syntax 58 | TypeCheck 59 | Arbitrary 60 | 61 | executable pi-forall 62 | import: shared-properties 63 | build-depends: pi-forall 64 | hs-source-dirs: app 65 | main-is: Main.hs 66 | 67 | test-suite test-pi-forall 68 | import: shared-properties 69 | build-depends: pi-forall 70 | , QuickCheck >= 2.13.2 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: Main.hs 74 | -------------------------------------------------------------------------------- /version3/pi/Hw1.pi: -------------------------------------------------------------------------------- 1 | module Hw1 where 2 | 3 | -- HW #1: get this file to type check by adding typing rules 4 | -- for booleans and sigma types to TypeCheck.hs in 'version1' 5 | 6 | -- prelude operations on boolean values 7 | 8 | or : Bool -> Bool -> Bool 9 | or = \b1 b2. if b1 then True else b2 10 | 11 | not : Bool -> Bool 12 | not = \b . if b then False else True 13 | 14 | and : Bool -> Bool -> Bool 15 | and = \b1 b2. if b1 then b2 else False 16 | 17 | eq_bool : Bool -> Bool -> Bool 18 | eq_bool = \ b1 b2 . 19 | if b1 then b2 else (not b2) 20 | 21 | --- sigma types 22 | 23 | double : (A:Type) -> (x : A) -> { x : A | A } 24 | double = \A x. (x,x) 25 | 26 | fst : (A:Type) -> (B : A -> Type) -> { x : A | B x } -> A 27 | fst = \A B p. let (x0,y) = p in x0 28 | 29 | -------------------------------------------------------------------------------- /version3/pi/Hw2.pi: -------------------------------------------------------------------------------- 1 | module Hw2 where 2 | 3 | -- First: read section 7.2 of the lecture notes about how 4 | -- propositional equality works in pi-forall. The key points are 5 | -- that `Refl` is a proof of the identity type `(a = b)` when 6 | -- a is definitionally equal to b, and that `subst` is the elimination 7 | -- form. 8 | 9 | -- For example, we can show that equality is symmetric by 10 | -- eliminating pf (of type `x = y`) when type checking 11 | -- `Refl` against type `y = x`. The `subst` adds the definition 12 | -- `x = y` to the context, so both sides of `y = x` wh normalize to y. 13 | 14 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 15 | sym = \ A x y pf . 16 | subst Refl by pf 17 | 18 | -- Homework: show that propositional equality is transitive 19 | 20 | trans : (A:Type) -> (x:A) -> (y:A) -> (z:A) -> (x = z) -> (z = y) -> (x = y) 21 | trans = TRUSTME 22 | 23 | -- Homework: show that it is congruent for (nondependent) application 24 | 25 | f_cong : (A:Type) -> (B : Type) -> (f : A -> B) -> (g : A -> B) 26 | -> (x:A) -> (y:A) 27 | -> (f = g) -> (x = y) -> (f x = g y) 28 | f_cong = TRUSTME 29 | 30 | -- Homework: what does congruence for dependent application look like? 31 | -- In other words, what if f and g above have a dependent type? 32 | 33 | 34 | 35 | 36 | -- properties of booleans 37 | 38 | -- an encoding of logical falsity 39 | 40 | void : Type 41 | void = (A:Type) -> A 42 | 43 | neg : Type -> Type 44 | neg = \ A . ( (A) -> void ) 45 | 46 | not : Bool -> Bool 47 | not = \ x . if x then False else True 48 | 49 | -- show that true is not false 50 | 51 | not_not_equal : (b : Bool) -> (b = not b) -> void 52 | not_not_equal = TRUSTME 53 | 54 | 55 | not_false_then_true : (b : Bool) -> neg (b = False) -> b = True 56 | not_false_then_true = TRUSTME 57 | 58 | -- show that decidable equality for booleans is correct. 59 | 60 | eq_bool : Bool -> Bool -> Bool 61 | eq_bool = \x y. if x then y else not y 62 | 63 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 64 | eq_true = \b1 b2 pf. TRUSTME 65 | 66 | eq_false : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = False -> (b1 = b2) -> void 67 | eq_false = TRUSTME 68 | 69 | false_eq_bool : (n : Bool) -> (m : Bool) -> 70 | neg (n = m) -> 71 | eq_bool n m = False 72 | false_eq_bool = \n m nnm. TRUSTME 73 | 74 | 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /version3/pi/Lec1.pi: -------------------------------------------------------------------------------- 1 | -- Simple examples demonstrating parametric polymorphism in core language 2 | 3 | module Lec1 where 4 | 5 | id : (x:Type) -> x -> x 6 | id = \x y . y 7 | 8 | idid : ((x:Type) -> (y : x) -> x) 9 | idid = id ((x:Type) -> (y : x) -> x) id 10 | 11 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 12 | (B -> C) -> (A -> B) -> (A -> C) 13 | compose = \ A B C f g x. (f (g x)) 14 | 15 | idT : Type 16 | idT = (x:Type) -> x -> x 17 | 18 | selfapp : idT -> idT 19 | selfapp = (\x.x : (idT -> idT) -> (idT -> idT)) (\x.x) 20 | 21 | -- Church encoding: booleans 22 | 23 | true : (A:Type) -> A -> A -> A 24 | true = \A x y. x 25 | 26 | false : (A:Type) -> A -> A -> A 27 | false = \A x y. y 28 | 29 | cond : ((A:Type) -> A -> A -> A) -> (x:Type) -> x -> x -> x 30 | cond = \ b . b 31 | 32 | -- void type 33 | 34 | void : Type 35 | void = (x:Type) -> x 36 | 37 | -- inhabited by diverging term 38 | 39 | loop : (x:Type) -> x 40 | loop = \x. loop x 41 | 42 | -- unit type 43 | 44 | unit : Type 45 | unit = (x:Type) -> x -> x 46 | 47 | -- this code only type checks with a definition of type equality that 48 | -- includes beta-equivalence/definitions (i.e. >= version2) 49 | 50 | -- Church encoding of simply-typed pairs 51 | {- 52 | 53 | pair : Type -> Type -> Type 54 | pair = \p. \q. (c: Type) -> (p -> q -> c) -> c 55 | 56 | prod : (p:Type) -> (q:Type) -> p -> q -> pair p q 57 | prod = \p.\q. \x.\y. \c. \f. f x y 58 | 59 | proj1 : (p:Type) -> (q:Type) -> pair p q -> p 60 | proj1 = \p. \q. \a. a p (\x.\y.x) 61 | 62 | proj2 : (p:Type) -> (q:Type) -> pair p q -> q 63 | proj2 = \p. \q. \a. a q (\x.\y.y) 64 | 65 | swap : (p:Type) -> (q:Type) -> pair p q -> pair q p 66 | swap = \p. \q. \a. prod q p (proj2 p q a) (proj1 p q a) 67 | -} 68 | -------------------------------------------------------------------------------- /version3/pi/Lec2.pi: -------------------------------------------------------------------------------- 1 | module Lec2 where 2 | 3 | 4 | -- "large eliminations" 5 | 6 | bool' : Bool -> Type 7 | bool' = \b . (B : (b : Bool) -> Type) -> B True -> B False -> B b 8 | 9 | true' : bool' True 10 | true' = \A x y . x 11 | 12 | false' : bool' False 13 | false' = \ A x y. y 14 | 15 | T : Bool -> Type 16 | T = \b. if b then Unit else Bool 17 | 18 | z1 : T True 19 | z1 = () 20 | 21 | z2 : T False 22 | z2 = True 23 | 24 | 25 | -- To get bar and barnot to work 26 | -- the typing rule for 'if' expressions must be 27 | -- context-dependent. In otherwords, it should add new 28 | -- definitions to the context in the true/false branches 29 | -- when the scrutinee is a variable 30 | -- (i.e. >= version2) 31 | 32 | 33 | not : Bool -> Bool 34 | not = \x. if x then False else True 35 | 36 | bar : (b : Bool) -> T b 37 | bar = \b. if b then () else True 38 | 39 | barnot : (b : Bool) -> T (not b) 40 | barnot = \b. if b then False else () 41 | 42 | 43 | -- projections for sigma types 44 | 45 | fst : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> A 46 | fst = \A B p. let (x,y) = p in x 47 | 48 | snd : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> B (fst A B p) 49 | snd = \A B p. let (x1,y) = p in y 50 | 51 | -- examples of propositional equality 52 | 53 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 54 | sym = \ A x y pf . 55 | subst Refl by pf 56 | 57 | -------------------------------------------------------------------------------- /version3/pi/Lec3.pi: -------------------------------------------------------------------------------- 1 | module Lec3 where 2 | 3 | -- can mark some arguments as irrelevant 4 | -- irrelevant parameters can only appear in types (or as part of irrelevant arguments) 5 | 6 | id : [x:Type] -> (y : x) -> x 7 | id = \[x] y. (y : x) 8 | 9 | t0 = id [Bool] True 10 | 11 | t1 = id [Bool] (id [Bool] True) 12 | 13 | id2 : [x:Type] -> (y : x) -> x 14 | id2 = \[x] y. id [x] (y : x) 15 | 16 | -- This shouldn't type check because y is relevant 17 | -- 18 | 19 | {- 20 | id' : [x:Type] -> [y:x] -> x 21 | id' = \[x][y]. y 22 | -} 23 | 24 | {- 25 | id2' : [x:Type] -> Type 26 | id2' = \[x]. id [Type] x 27 | -} 28 | 29 | 30 | 31 | ----------------------------------------------------- 32 | -- Irrelevant arguments are ignored during type equality 33 | 34 | irrelevance : (p : [i : Bool] -> Bool) -> p [True] = p [False] 35 | irrelevance = \p . Refl 36 | 37 | 38 | 39 | 40 | 41 | ----------------------------------------------------- 42 | -- Propositional equality is relevant 43 | -- Cannot ignore/erase proofs that are used for 'subst'. 44 | -- Need a termination analysis to do this. 45 | 46 | proprel : [a : Type] -> (pf : a = Bool) -> (x : a) -> Bool 47 | proprel = \[a] pf x . 48 | subst x by pf 49 | 50 | -------------------------------------------------------------------------------- /version3/pi/NatChurch.pi: -------------------------------------------------------------------------------- 1 | module NatChurch where 2 | 3 | -- Church encoding of natural numbers 4 | 5 | nat : Type 6 | nat = (x:Type) -> x -> (x -> x) -> x 7 | 8 | z : nat 9 | z = \x zf sf. zf 10 | 11 | s : nat -> nat 12 | s = \n. \x zf sf. sf (n x zf sf) 13 | 14 | one : nat 15 | one = s z 16 | 17 | two : nat 18 | two = s (s z) 19 | 20 | three : nat 21 | three = TRUSTME -- replace with correct definition of 3 22 | 23 | plus : nat -> nat -> nat 24 | plus = \x. \y. x nat y s 25 | 26 | test0 : plus one one = two 27 | test0 = Refl 28 | 29 | test1 : plus one two = three 30 | test1 = TRUSTME -- replace with Refl 31 | 32 | spec0 : (n : nat) -> plus z n = n 33 | spec0 = \n . Refl 34 | 35 | spec1 : (n : nat) -> (m : nat) -> plus (s n) m = s (plus n m) 36 | spec1 = \n m . Refl 37 | 38 | -- The predecessor function is *really* tricky! Don't try this 39 | -- first if you have never seen it before. 40 | 41 | pred : nat -> nat 42 | pred = TRUSTME 43 | 44 | test_pred : pred two = one 45 | test_pred = TRUSTME -- replace with Refl 46 | 47 | -- Since pi-forall allows recursive definitions, we also have Scott encodings 48 | -- of datatypes available. (See http://en.wikipedia.org/wiki/Mogensen%E2%80%93Scott_encoding. 49 | -- You can't do this in Coq or Agda because it requires an inconsistent logic). 50 | 51 | scott_nat : Type 52 | scott_nat = (x:Type) -> x -> (scott_nat -> x) -> x 53 | 54 | scott_z : scott_nat 55 | scott_z = \x z s . z 56 | 57 | scott_s : scott_nat -> scott_nat 58 | scott_s = \n . \x z s . s n 59 | 60 | scott_one : scott_nat 61 | scott_one = scott_s scott_z 62 | 63 | scott_two : scott_nat 64 | scott_two = scott_s (scott_s scott_z) 65 | 66 | scott_three : scott_nat 67 | scott_three = scott_s (scott_s (scott_s scott_z)) 68 | 69 | -- Write the predecessor function, it is much easier here 70 | 71 | scott_pred : scott_nat -> scott_nat 72 | scott_pred = TRUSTME 73 | 74 | testNC1 : scott_pred scott_two = scott_one 75 | testNC1 = TRUSTME -- replace with Refl 76 | 77 | -- Now write plus: with Scott encoded nats, note that you need to use recursion. 78 | 79 | scott_plus : scott_nat -> scott_nat -> scott_nat 80 | scott_plus = TRUSTME 81 | 82 | testNC2 : scott_plus scott_one scott_two = scott_three 83 | testNC2 = TRUSTME -- replace with Refl 84 | -------------------------------------------------------------------------------- /version3/pi/Sigma.pi: -------------------------------------------------------------------------------- 1 | module Sigma where 2 | 3 | -- Defining projection terms using pattern matching 4 | 5 | fst : (A:Type) -> (B:A -> Type) -> { x : A | B x } -> A 6 | fst = \A B x . let (y,z) = x in y 7 | 8 | snd : (A:Type) -> (B:A -> Type) -> (p : { x:A | B x}) -> B (fst A B p) 9 | snd = \A B x . let (y,z) = x in z 10 | 11 | 12 | -------------------------------------------------------------------------------- /version3/src/Main.hs: -------------------------------------------------------------------------------- 1 | {- PiForall language, OPLSS -} 2 | 3 | -- | The command line interface to the pi type checker. 4 | -- Also provides functions for type checking individual terms 5 | -- and files. 6 | module Main(goFilename,go,main) where 7 | 8 | import Modules (getModules) 9 | import PrettyPrint 10 | import Environment 11 | import TypeCheck 12 | import Parser 13 | 14 | import Text.PrettyPrint.HughesPJ (render) 15 | import Text.ParserCombinators.Parsec.Error 16 | 17 | import Control.Monad.Except 18 | 19 | import System.Environment(getArgs) 20 | import System.Exit (exitFailure,exitSuccess) 21 | import System.FilePath (splitFileName) 22 | 23 | exitWith :: Either a b -> (a -> IO ()) -> IO b 24 | exitWith res f = 25 | case res of 26 | Left x -> f x >> exitFailure 27 | Right y -> return y 28 | 29 | -- | Type check the given string in the empty environment 30 | go :: String -> IO () 31 | go str = do 32 | case parseExpr str of 33 | Left parseError -> putParseError parseError 34 | Right term -> do 35 | putStrLn "parsed as" 36 | putStrLn $ render $ disp term 37 | res <- runTcMonad emptyEnv (inferType term) 38 | case res of 39 | Left typeError -> putTypeError typeError 40 | Right ty -> do 41 | putStrLn "typed with type" 42 | putStrLn $ render $ disp ty 43 | 44 | -- | Display a parse error to the user 45 | putParseError :: ParseError -> IO () 46 | putParseError parseError = do 47 | putStrLn $ render $ disp $ errorPos parseError 48 | putStrLn $ show parseError 49 | 50 | -- | Display a type error to the user 51 | putTypeError :: Disp d => d -> IO () 52 | putTypeError typeError = do 53 | putStrLn "Type Error:" 54 | putStrLn $ render $ disp typeError 55 | 56 | -- | Type check the given file 57 | goFilename :: String -> IO () 58 | goFilename pathToMainFile = do 59 | let prefixes = currentDir : mainFilePrefix : [] 60 | (mainFilePrefix, name) = splitFileName pathToMainFile 61 | currentDir = "" 62 | putStrLn $ "processing " ++ name ++ "..." 63 | v <- runExceptT (getModules prefixes name) 64 | val <- v `exitWith` putParseError 65 | putStrLn "type checking..." 66 | d <- runTcMonad emptyEnv (tcModules val) 67 | defs <- d `exitWith` putTypeError 68 | putStrLn $ render $ disp (last defs) 69 | 70 | 71 | 72 | 73 | 74 | 75 | -- | 'pi ' invokes the type checker on the given 76 | -- file and either prints the types of all definitions in the module 77 | -- or prints an error message. 78 | main :: IO () 79 | main = do 80 | [pathToMainFile] <- getArgs 81 | goFilename pathToMainFile 82 | exitSuccess 83 | 84 | -------------------------------------------------------------------------------- /version3/src/Modules.hs: -------------------------------------------------------------------------------- 1 | {- pi-forall language -} 2 | 3 | -- | Tools for working with multiple source files 4 | module Modules(getModules, ModuleInfo(..)) where 5 | 6 | import Syntax 7 | import Parser(parseModuleFile, parseModuleImports) 8 | 9 | import Text.ParserCombinators.Parsec.Error ( ParseError ) 10 | 11 | import Control.Monad.Except 12 | 13 | import System.FilePath 14 | import System.Directory 15 | import qualified Data.Graph as Gr 16 | import Data.List(nub,(\\)) 17 | 18 | -- | getModules starts with a top-level module, and gathers all of the module's 19 | -- transitive dependency. It returns the list of parsed modules, with all 20 | -- modules appearing after its dependencies. 21 | getModules 22 | :: (Functor m, MonadError ParseError m, MonadIO m) => 23 | [FilePath] -> String -> m [Module] 24 | getModules prefixes top = do 25 | toParse <- gatherModules prefixes [ModuleImport top] 26 | mapM reparse toParse 27 | 28 | data ModuleInfo = ModuleInfo { 29 | modInfoName :: ModuleName, 30 | modInfoFilename :: String, 31 | modInfoImports :: [ModuleImport] 32 | } 33 | 34 | -- | Build the module dependency graph. 35 | -- This only parses the imports part of each file; later we go back and parse all of it. 36 | gatherModules 37 | :: (Functor m, MonadError ParseError m, MonadIO m) => 38 | [FilePath] -> [ModuleImport] -> m [ModuleInfo] 39 | gatherModules prefixes ms = gatherModules' ms [] where 40 | gatherModules' [] accum = return $ topSort accum 41 | gatherModules' ((ModuleImport m):ms') accum = do 42 | modFileName <- getModuleFileName prefixes m 43 | imports <- moduleImports <$> parseModuleImports modFileName 44 | let accum' = ModuleInfo m modFileName imports :accum 45 | let oldMods = map (ModuleImport . modInfoName) accum' 46 | gatherModules' (nub (ms' ++ imports) \\ oldMods) accum' 47 | 48 | -- | Generate a sorted list of modules, with the postcondition that a module 49 | -- will appear _after_ any of its dependencies. 50 | topSort :: [ModuleInfo] -> [ModuleInfo] 51 | topSort ms = reverse sorted 52 | where (gr,lu) = Gr.graphFromEdges' [(m, modInfoName m, [i | ModuleImport i <- modInfoImports m]) 53 | | m <- ms] 54 | lu' v = let (m,_,_) = lu v in m 55 | sorted = [lu' v | v <- Gr.topSort gr] 56 | 57 | -- | Find the file associated with a module. 58 | getModuleFileName :: (MonadIO m) 59 | => [FilePath] -> ModuleName -> m FilePath 60 | getModuleFileName prefixes modul = do 61 | let makeFileName prefix = prefix mDotPi 62 | -- get M.pi from M or M.pi 63 | mDotPi = if takeExtension s == ".pi" 64 | then s 65 | else s <.> "pi" 66 | s = modul 67 | possibleFiles = map makeFileName prefixes 68 | files <- liftIO $ filterM doesFileExist possibleFiles 69 | if null files 70 | then error $ "Can't locate module: " ++ show modul ++ 71 | "\nTried: " ++ show possibleFiles 72 | else return $ head files 73 | 74 | -- | Fully parse a module (not just the imports). 75 | reparse :: (MonadError ParseError m, MonadIO m) => 76 | ModuleInfo -> m Module 77 | reparse (ModuleInfo _ fileName _) = parseModuleFile fileName 78 | -------------------------------------------------------------------------------- /version3/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | 3 | # Local packages, usually specified by relative directory name 4 | packages: 5 | - '.' 6 | 7 | flags: {} 8 | 9 | extra-package-dbs: [] 10 | 11 | -------------------------------------------------------------------------------- /version3/test/Hw1.pi: -------------------------------------------------------------------------------- 1 | module Hw1 where 2 | 3 | -- HW #1: get this file to type check by adding typing rules 4 | -- for booleans and let expressions to TypeCheck.hs and Equal.hs 5 | 6 | z0 : Bool 7 | z0 = if True then False else True 8 | 9 | -- prelude operations on boolean values 10 | 11 | or : Bool -> Bool -> Bool 12 | or = \b1 b2. if b1 then True else b2 13 | 14 | not : Bool -> Bool 15 | not = \b . if b then False else True 16 | 17 | and : Bool -> Bool -> Bool 18 | and = \b1 b2. if b1 then b2 else False 19 | 20 | eq_bool : Bool -> Bool -> Bool 21 | eq_bool = \ b1 b2 . 22 | if b1 then b2 else (not b2) 23 | 24 | -- sigma types 25 | 26 | double : (A:Type) -> (x : A) -> { x : A | A } 27 | double = \A x. (x,x) 28 | 29 | fst : (A:Type) -> (B : A -> Type) -> { x : A | B x } -> A 30 | fst = \A B p. let (x0,y) = p in x0 31 | 32 | -------------------------------------------------------------------------------- /version3/test/Hw2.pi: -------------------------------------------------------------------------------- 1 | module Hw2 where 2 | 3 | -- show that propositional equality is transitive 4 | 5 | trans : (A:Type) -> (x:A) -> (y:A) -> (z:A) -> (x = z) -> (z = y) -> (x = y) 6 | trans = TRUSTME 7 | 8 | 9 | -- properties of booleans 10 | 11 | -- an encoding of logical falsity 12 | void : Type 13 | void = (A:Type) -> A 14 | 15 | neg : Type -> Type 16 | neg = \ A . ( (A) -> void ) 17 | 18 | not : Bool -> Bool 19 | not = \ x . if x then False else True 20 | 21 | -- to be or not to be, that is the question 22 | 23 | not_not_equal : (b : Bool) -> (b = not b) -> void 24 | not_not_equal = TRUSTME 25 | 26 | 27 | not_false_then_true : (b : Bool) -> neg (b = False) -> b = True 28 | not_false_then_true = TRUSTME 29 | 30 | -- showing that decidable equality is correct. 31 | 32 | eq_bool : Bool -> Bool -> Bool 33 | eq_bool = \x y. if x then y else not y 34 | 35 | eq_true : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = True -> (b1 = b2) 36 | eq_true = \b1 b2 pf. TRUSTME 37 | 38 | eq_false : (b1 : Bool) -> (b2 : Bool) -> eq_bool b1 b2 = False -> (b1 = b2) -> void 39 | eq_false = TRUSTME 40 | 41 | false_eq_bool : (n : Bool) -> (m : Bool) -> 42 | neg (n = m) -> 43 | eq_bool n m = False 44 | false_eq_bool = \n m nnm. TRUSTME 45 | 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /version3/test/Lec1.pi: -------------------------------------------------------------------------------- 1 | module Lec1 where 2 | 3 | id : (x:Type) -> x -> x 4 | id = \x y . y 5 | 6 | idid : ((x:Type) -> (y : x) -> x) 7 | idid = id ((x:Type) -> (y : x) -> x) id 8 | 9 | compose : (A : Type) -> (B : Type) -> (C:Type) -> 10 | (B -> C) -> (A -> B) -> (A -> C) 11 | compose = \ A B C f g x. (f (g x)) 12 | 13 | -- some Church encodings: booleans 14 | 15 | bool : Type 16 | bool = (A:Type) -> A -> A -> A 17 | 18 | true : bool 19 | true = \A x y. x 20 | 21 | false : bool 22 | false = \A x y. y 23 | 24 | cond : bool -> (x:Type) -> x -> x -> x 25 | cond = \ b . b 26 | 27 | void : Type 28 | void = (x:Type) -> x 29 | 30 | unit : Type 31 | unit = (x:Type) -> x -> x 32 | 33 | -- need definitional equality for this one 34 | 35 | bool' : bool -> Type 36 | bool' = \b . (B : (b : bool) -> Type) -> (B true) -> B false -> B b 37 | 38 | true' : bool' true 39 | true' = \A x y . x 40 | 41 | false' : bool' false 42 | false' = \ A x y. y 43 | 44 | -------------------------------------------------------------------------------- /version3/test/Lec2.pi: -------------------------------------------------------------------------------- 1 | module Lec2 where 2 | 3 | -- this code only type checks with a definition of type equality that 4 | -- includes beta-equivalence 5 | 6 | bool' : Bool -> Type 7 | bool' = \b . (B : (b : Bool) -> Type) -> B True -> B False -> B b 8 | 9 | true' : bool' True 10 | true' = \A x y . x 11 | 12 | false' : bool' False 13 | false' = \ A x y. y 14 | 15 | T : Bool -> Type 16 | T = \b. if b then Unit else Bool 17 | 18 | z1 : T True 19 | z1 = () 20 | 21 | z2 : T False 22 | z2 = True 23 | 24 | 25 | -- To get bar and barnot to work 26 | -- the typing rule for 'if' expressions must be 27 | -- context-dependent. In otherwords, it should add new 28 | -- definitions to the context in the true/false branches 29 | -- when the scrutinee is a variable 30 | 31 | not : Bool -> Bool 32 | not = \x. if x then False else True 33 | 34 | bar : (b : Bool) -> T b 35 | bar = \b. if b then () else True 36 | 37 | barnot : (b : Bool) -> T (not b) 38 | barnot = \b. if b then False else () 39 | 40 | -- projections for sigma types 41 | 42 | fst : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> A 43 | fst = \A B p. let (x,y) = p in x 44 | 45 | snd : (A:Type) -> (B : A -> Type) -> (p : { x2 : A | B x2 }) -> B (fst A B p) 46 | snd = \A B p. let (x1,y) = p in y 47 | 48 | -- examples of propositional equality 49 | 50 | sym : (A:Type) -> (x:A) -> (y:A) -> (x = y) -> y = x 51 | sym = \ A x y pf . 52 | subst refl by pf 53 | 54 | -------------------------------------------------------------------------------- /version3/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.QuickCheck 4 | import Test.HUnit 5 | import Environment 6 | import PrettyPrint 7 | import TypeCheck 8 | import Syntax 9 | import Control.Monad.Except 10 | import Modules 11 | import Text.PrettyPrint.HughesPJ (render) 12 | import Text.ParserCombinators.Parsec.Error 13 | import Test.QuickCheck 14 | import Arbitrary 15 | 16 | main :: IO () 17 | main = do 18 | quickCheck prop_roundtrip 19 | 20 | exitWith :: Either a b -> (a -> IO b) -> IO b 21 | exitWith (Left a) f = f a 22 | exitWith (Right b) f = return b 23 | 24 | -- | Type check the given file 25 | testFile :: String -> Test 26 | testFile name = name ~: TestCase $ do 27 | v <- runExceptT (getModules ["pi"] name) 28 | val <- v `exitWith` (\b -> assertFailure $ "Parse error: " ++ render (disp b)) 29 | d <- runTcMonad emptyEnv (tcModules val) 30 | defs <- d `exitWith` (\s -> assertFailure $ "Type error:" ++ render (disp s)) 31 | putStrLn $ render $ disp (last defs) -------------------------------------------------------------------------------- /version3/test/NatChurch.pi: -------------------------------------------------------------------------------- 1 | module NatChurch where 2 | 3 | -- Church encoding of natural numbers 4 | 5 | nat : Type 6 | nat = (x:Type) -> x -> (x -> x) -> x 7 | 8 | z : nat 9 | z = \x zf sf. zf 10 | 11 | s : nat -> nat 12 | s = \n. \x zf sf. sf (n x zf sf) 13 | 14 | one : nat 15 | one = s z 16 | 17 | two : nat 18 | two = s (s z) 19 | 20 | plus : nat -> nat -> nat 21 | plus = \x. \y. x nat y s 22 | 23 | test0 : plus one one = two 24 | test0 = refl 25 | 26 | spec0 : (n : nat) -> plus z n = n 27 | spec0 = \n . refl 28 | 29 | spec1 : (n : nat) -> (m : nat) -> plus (s n) m = s (plus n m) 30 | spec1 = \n m . refl 31 | 32 | -- this one is *really* tricky! 33 | 34 | pred : nat -> nat 35 | pred = TRUSTME 36 | 37 | test_pred : pred two = one 38 | test_pred = TRUSTME -- replace with refl 39 | 40 | -- Since pi-forall allows recursive definitions, we also have Scott encodings 41 | -- of datatypes available. (See http://en.wikipedia.org/wiki/Mogensen%E2%80%93Scott_encoding. 42 | -- You can't do this in Coq or Agda because it requires an inconsistent logic). 43 | 44 | scott_nat : Type 45 | scott_nat = (x:Type) -> x -> (scott_nat -> x) -> x 46 | 47 | scott_z : scott_nat 48 | scott_z = \x z s . z 49 | 50 | scott_s : scott_nat -> scott_nat 51 | scott_s = \n . \x z s . s n 52 | 53 | scott_one : scott_nat 54 | scott_one = scott_s scott_z 55 | 56 | scott_two : scott_nat 57 | scott_two = scott_s (scott_s scott_z) 58 | 59 | scott_three : scott_nat 60 | scott_three = scott_s (scott_s (scott_s scott_z)) 61 | 62 | -- Write the predecessor function, it is much easier here 63 | 64 | scott_pred : scott_nat -> scott_nat 65 | scott_pred = TRUSTME 66 | 67 | test1 : scott_pred scott_two = scott_one 68 | test1 = TRUSTME -- replace with refl 69 | 70 | -- Now write plus: with Scott encoded nats, note that you need to use recursion. 71 | 72 | scott_plus : scott_nat -> scott_nat -> scott_nat 73 | scott_plus = TRUSTME 74 | 75 | test2 : scott_plus scott_one scott_two = scott_three 76 | test2 = TRUSTME -- replace with refl --------------------------------------------------------------------------------