├── .gitignore ├── .travis.yml ├── COPYING ├── README.md ├── alpha.rkt ├── basics.rkt ├── fresh.rkt ├── gui ├── main.rkt ├── pie-lexer.rkt ├── pie-styles.rkt └── print-gui.rkt ├── info.rkt ├── interactive-editing.rkt ├── locations.rkt ├── main.rkt ├── normalize.rkt ├── parser.rkt ├── pie-err.rkt ├── pie-info.rkt ├── pie.scrbl ├── pretty.rkt ├── rep.rkt ├── resugar.rkt ├── serialization.rkt ├── show-goal.rkt ├── slideshow.rkt ├── test-todo-output.rkt ├── tests.rkt ├── todo-test.pie ├── tooltip.rkt └── typechecker.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *.css 2 | *.js 3 | *~ 4 | *# 5 | 6 | compiled 7 | /doc 8 | 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Based from: https://github.com/greghendershott/travis-racket 4 | 5 | # Optional: Remove to use Travis CI's older infrastructure. 6 | sudo: false 7 | 8 | env: 9 | global: 10 | # Supply a global RACKET_DIR environment variable. This is where 11 | # Racket will be installed. A good idea is to use ~/racket because 12 | # that doesn't require sudo to install and is therefore compatible 13 | # with Travis CI's newer container infrastructure. 14 | - RACKET_DIR=~/racket 15 | matrix: 16 | # Supply at least one RACKET_VERSION environment variable. This is 17 | # used by the install-racket.sh script (run at before_install, 18 | # below) to select the version of Racket to download and install. 19 | # 20 | # Supply more than one RACKET_VERSION (as in the example below) to 21 | # create a Travis-CI build matrix to test against multiple Racket 22 | # versions. 23 | - RACKET_VERSION=6.5 24 | - RACKET_VERSION=6.6 25 | - RACKET_VERSION=6.7 26 | - RACKET_VERSION=6.8 27 | - RACKET_VERSION=6.9 28 | - RACKET_VERSION=6.10 29 | - RACKET_VERSION=6.11 30 | - RACKET_VERSION=6.12 31 | - RACKET_VERSION=7.0 32 | - RACKET_VERSION=7.1 33 | - RACKET_VERSION=HEAD 34 | 35 | matrix: 36 | allow_failures: 37 | env: RACKET_VERSION=HEAD 38 | fast_finish: true 39 | 40 | before_install: 41 | - git clone https://github.com/greghendershott/travis-racket.git 42 | - cat travis-racket/install-racket.sh | bash # pipe to bash not sh! 43 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 44 | 45 | install: 46 | - raco pkg install --deps search-auto cover 47 | - raco pkg install --auto --name pie --link $TRAVIS_BUILD_DIR 48 | 49 | before_script: 50 | # Set up an X server, so GTK doesn't fail to initialize for GUI tests 51 | - "export DISPLAY=:99.0" 52 | - "sh -e /etc/init.d/xvfb start" 53 | - sleep 3 # give xvfb some time to start 54 | 55 | # Here supply steps such as raco make, raco test, etc. Note that you 56 | # need to supply /usr/racket/bin/ -- it's not in PATH. You can run 57 | # `raco pkg install --deps search-auto pie` to install any required 58 | # packages without it getting stuck on a confirmation prompt. 59 | script: 60 | - raco test -ep pie 61 | 62 | after_success: 63 | - raco setup --check-deps pie 64 | - raco pkg install --deps search-auto cover-coveralls 65 | - raco pkg install --deps search-auto 66 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage -p pie 67 | 68 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pie: A Little Language with Dependent Types 2 | 3 | This is Pie, the companion language for _The Little Typer_ by Daniel P. Friedman and David Thrane Christiansen. 4 | 5 | ## How to Use Pie 6 | 7 | Pie is a [Racket](http://racket-lang.org) language, requiring Racket version 6.5 or newer. After installation, Racket will interpret any file beginning with `#lang pie` as a Pie program. 8 | 9 | ### TODO items 10 | 11 | If you can't figure out what to write at some point in a Pie program, it's OK to leave behind a space to be filled out later. This corresponds to the empty boxes in _The Little Typer_. These TODOs are written `TODO` in Pie. 12 | 13 | ### DrRacket Integration 14 | 15 | Pie provides additional information to DrRacket, including tooltips and other metadata. Point the mouse at a pair of parentheses, a name, or a Pie constructor or type constructor to see information about the expression. 16 | 17 | Additionally, Pie supports the [DrRacket TODO list](https://github.com/david-christiansen/todo-list) for incomplete programs. 18 | 19 | ### Command-Line REPL 20 | 21 | If you prefer an editor other than DrRacket, it may be convenient to start a Pie REPL on a command line. To do so, use the command `racket -l pie -i` to start Racket with the `pie` language in interactive mode. 22 | 23 | 24 | ## Installation Instructions 25 | Pie is available on the Racket package server. If you don't plan to make your own changes to Pie, then it is easiest to install it from there. 26 | 27 | ### From DrRacket 28 | 29 | Click the "File" menu, and then select "Install Package...". Type `pie` in the box, and click the "Install" button. 30 | 31 | ### From a Command Line 32 | 33 | Run the following command: 34 | `raco pkg install pie` 35 | 36 | ## Updates 37 | 38 | Because it exists to support a book, the Pie language is finished and will not change. However, this _implementation_ of Pie might someday acquire additional features, or it might require updates to keep up with new computers. In that case, update it as you would any Racket package. 39 | 40 | ### Updating in DrRacket 41 | 42 | Click the "File" menu, and then select "Install Package...". Type `pie` in the box, and click the "Update" button. 43 | 44 | ### Updating from a Command Line 45 | 46 | The command `raco pkg update pie` updates Pie. 47 | -------------------------------------------------------------------------------- /alpha.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (require "basics.rkt") 4 | 5 | (provide α-equiv?) 6 | 7 | ;; Public interface 8 | 9 | (: α-equiv? (-> Core Core Boolean)) 10 | (define (α-equiv? e1 e2) 11 | (α-equiv-aux 0 '() '() e1 e2)) 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | ;; Helpers 16 | 17 | (define-type Bindings (Listof (Pair Symbol Natural))) 18 | 19 | (: bind (-> Bindings Symbol Natural Bindings)) 20 | (define (bind b x lvl) 21 | (cons (cons x lvl) 22 | b)) 23 | 24 | (: α-equiv-aux (-> Natural Bindings Bindings Core Core Boolean)) 25 | (define (α-equiv-aux lvl b1 b2 e1 e2) 26 | (match* (e1 e2) 27 | [(x y) 28 | #:when (and (symbol? x) (symbol? y)) 29 | (cond 30 | [(and (var-name? x) (var-name? y)) 31 | (let ([x-binding (assv x b1)] 32 | [y-binding (assv y b2)]) 33 | (match* (x-binding y-binding) 34 | ;; Both bound 35 | [((cons _ lvl-x) (cons _ lvl-y)) 36 | (= lvl-x lvl-y)] 37 | ;; Both free 38 | [(#f #f) (eqv? x y)] 39 | ;; One bound, one free 40 | [(_ _) #f]))] 41 | ;; Constructor equality (e.g. zero ≡ zero) 42 | [(and (not (var-name? x)) (not (var-name? y))) 43 | (eqv? x y)] 44 | ;; one constructor, one var (e.g. zero /≡ x) 45 | [else #f])] 46 | ;; Atoms must be the same atom 47 | [(`(quote ,a) `(quote ,b)) 48 | (eqv? a b)] 49 | [(`(Π ((,x ,A1)) ,B1) `(Π ((,y ,A2)) ,B2)) 50 | (and (α-equiv-aux lvl b1 b2 A1 A2) 51 | (α-equiv-aux (add1 lvl) 52 | (bind b1 x lvl) 53 | (bind b2 y lvl) 54 | B1 55 | B2))] 56 | [(`(Σ ((,x ,A1)) ,D1) `(Σ ((,y ,A2)) ,D2)) 57 | (and (α-equiv-aux lvl b1 b2 A1 A2) 58 | (α-equiv-aux (add1 lvl) 59 | (bind b1 x lvl) 60 | (bind b2 y lvl) 61 | D1 62 | D2))] 63 | [(`(λ (,x) ,body1) `(λ (,y) ,body2)) 64 | (α-equiv-aux (add1 lvl) 65 | (bind b1 x lvl) 66 | (bind b2 y lvl) 67 | body1 68 | body2)] 69 | ;; η for Absurd relies on read-back inserting an annotation 70 | [(`(the Absurd ,_) `(the Absurd ,_)) #t] 71 | ;; Non-binding keywords 72 | [((cons kw1 args1) 73 | (cons kw2 args2)) 74 | #:when (and (symbol? kw1) (symbol? kw2) 75 | (not (or (eqv? kw1 'λ) (eqv? kw1 'Π) (eqv? kw1 'Σ) (eqv? kw1 'TODO))) 76 | (not (or (eqv? kw2 'λ) (eqv? kw2 'Π) (eqv? kw2 'Σ) (eqv? kw2 'TODO))) 77 | (not (var-name? kw1)) (not (var-name? kw2))) 78 | (and (eqv? kw1 kw2) 79 | (α-equiv-aux* lvl b1 b2 args1 args2))] 80 | ;; Holes from the same location are equal 81 | [(`(TODO ,loc1 ,t1) `(TODO ,loc2 ,t2)) 82 | (and (equal? loc1 loc2) 83 | (α-equiv-aux lvl b1 b2 t1 t2))] 84 | ;; Function application 85 | [(`(,f ,arg1) `(,g ,arg2)) 86 | (and (α-equiv-aux lvl b1 b2 f g) 87 | (α-equiv-aux lvl b1 b2 arg1 arg2))] 88 | [(_ _) #f])) 89 | 90 | 91 | (: α-equiv-aux* (-> Natural Bindings Bindings (Listof Core) (Listof Core) Boolean)) 92 | (define (α-equiv-aux* lvl b1 b2 args1 args2) 93 | (cond 94 | [(and (pair? args1) (pair? args2)) 95 | (and (α-equiv-aux lvl b1 b2 (car args1) (car args2)) 96 | (α-equiv-aux* lvl b1 b2 (cdr args1) (cdr args2)))] 97 | [(and (null? args1) (null? args2)) #t] 98 | [else #f])) 99 | 100 | (module+ test 101 | (require typed/rackunit) 102 | (check-true (α-equiv? '(λ (x) x) '(λ (x) x))) 103 | (check-true (α-equiv? '(λ (x) x) '(λ (y) y))) 104 | (check-true (α-equiv? '(λ (x) (λ (y) x)) '(λ (x) (λ (y) x)))) 105 | (check-true (α-equiv? '(λ (x) (λ (y) x)) '(λ (y) (λ (z) y)))) 106 | (check-false (α-equiv? '(λ (x) (λ (y) x)) '(λ (y) (λ (z) z)))) 107 | (check-false (α-equiv? '(λ (x) (λ (y) x)) '(λ (y) (λ (x) x)))) 108 | (check-false (α-equiv? '(λ (x) x) '(λ (y) x))) 109 | 110 | (check-true (α-equiv? 'x 'x)) 111 | (check-false (α-equiv? 'x 'y)) 112 | 113 | (check-true (α-equiv? '(f x) '(f x))) 114 | (check-false (α-equiv? '(f x) '(g x))) 115 | (check-true (α-equiv? '(λ (f) (f x)) '(λ (g) (g x)))) 116 | 117 | (check-true (α-equiv? 'zero 'zero)) 118 | (check-true (α-equiv? '(add1 zero) '(add1 zero))) 119 | 120 | (check-true (α-equiv? ''rugbrød ''rugbrød)) 121 | (check-false (α-equiv? ''rugbrød ''rundstykker)) 122 | 123 | (check-true (α-equiv? '(Σ ((half Nat)) (= Nat n (double half))) 124 | '(Σ ((blurgh Nat)) (= Nat n (double blurgh))))) 125 | (check-false (α-equiv? '(Σ ((half Nat)) (= Nat n (double half))) 126 | '(Σ ((half Nat)) (= Nat n (twice half))))) 127 | 128 | (check-true (α-equiv? '(the Absurd x) '(the Absurd x))) 129 | (check-true (α-equiv? '(the Absurd x) '(the Absurd y))) 130 | (check-true (α-equiv? '(the Absurd x) '(the Absurd (find-the-proof x)))) 131 | 132 | (define here (location->srcloc (syntax->location #'here))) 133 | (define there (location->srcloc (syntax->location #'there))) 134 | (check-true (α-equiv? `(TODO ,here Nat) `(TODO ,here Nat))) 135 | (check-false (α-equiv? `(TODO ,here Nat) `(TODO ,there Nat))) 136 | 137 | (check-false (α-equiv? 'zero 'naught)) 138 | 139 | (check-true (α-equiv? '(Π ((n Nat)) (= Nat n n)) '(Π ((m Nat)) (= Nat m m)))) 140 | (check-false (α-equiv? '(Π ((n Nat)) (= Nat n n)) '(Π ((m Nat)) (= Nat n n)))) 141 | (check-false (α-equiv? '(Π ((n Nat)) (= Nat n n)) '(Σ ((m Nat)) (= Nat m m)))) 142 | ) 143 | -------------------------------------------------------------------------------- /basics.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;;; basics.rkt 4 | ;;; 5 | ;;; This file contains preliminary definitions that are needed in 6 | ;;; the rest of the system, including datatypes for ASTs, values, 7 | ;;; contexts, states, etc. 8 | 9 | (require (for-syntax racket/base syntax/parse) racket/match 10 | "fresh.rkt") 11 | (provide (all-defined-out) 12 | (for-syntax (all-defined-out)) 13 | Precise-Loc 14 | location? 15 | syntax->location 16 | location->srcloc 17 | Srcloc) 18 | 19 | 20 | ;;; Source locations 21 | 22 | (define-type Srcloc (List String Integer Integer Integer Integer)) 23 | 24 | (require/typed "locations.rkt" 25 | [#:opaque Precise-Loc location?] 26 | [location-for-info? (-> Precise-Loc Boolean)] 27 | [syntax->location (-> Syntax Precise-Loc)] 28 | [location->srcloc (-> Precise-Loc Srcloc)] 29 | [not-for-info (-> Precise-Loc Precise-Loc)]) 30 | 31 | 32 | ;;; Note that Loc is used for the equality of TODO that comes out of read-back, so 33 | ;;; it should not be a trivial value. 34 | (define-type Loc Precise-Loc) 35 | 36 | 37 | ;;; Keywords 38 | 39 | (define-type Pie-Keyword 40 | (U 'U 41 | 'Nat 'zero 'add1 'which-Nat 'iter-Nat 'rec-Nat 'ind-Nat 42 | '-> '→ 'Π 'λ 'Pi '∏ 'lambda 43 | 'quote 'Atom 44 | 'car 'cdr 'cons 'Σ 'Sigma 'Pair 45 | 'Trivial 'sole 46 | 'List ':: 'nil 'rec-List 'ind-List 47 | 'Absurd 'ind-Absurd 48 | '= 'same 'replace 'trans 'cong 'symm 'ind-= 49 | 'Vec 'vecnil 'vec:: 'head 'tail 'ind-Vec 50 | 'Either 'left 'right 'ind-Either 51 | 'TODO 'the)) 52 | 53 | 54 | ;;; Abstract syntax of high-level programs 55 | 56 | ;; @ associates a source location with a Pie expression or 57 | ;; declaration. This allows the implementation to report give precise, 58 | ;; helpful feedback. 59 | (struct @ ([loc : Loc] 60 | [stx : Src-Stx]) 61 | #:transparent 62 | #:type-name Src) 63 | 64 | (: src-loc (-> Src Loc)) 65 | (define src-loc @-loc) 66 | 67 | (: src-stx (-> Src Src-Stx)) 68 | (define src-stx @-stx) 69 | 70 | (: src? (-> Any Boolean : Src)) 71 | (define src? @?) 72 | 73 | (struct binder ([loc : Loc] [var : Symbol]) #:transparent #:type-name Binding-Site) 74 | 75 | (define-type Typed-Binder 76 | (List Binding-Site Src)) 77 | 78 | 79 | ;;; Pie expressions consist of a source location attached by @ to an 80 | ;;; S-expression that follows the structure defined in The Little 81 | ;;; Typer. Each sub-expression also has a source location, so they are 82 | ;;; Src rather than Src-Stx. 83 | (define-type Src-Stx 84 | (U (List 'the Src Src) 85 | 'U 86 | 'Nat 87 | 'zero 88 | Symbol 89 | 'Atom 90 | (List 'quote Symbol) 91 | (List 'add1 Src) 92 | (List 'which-Nat Src Src Src) 93 | (List 'iter-Nat Src Src Src) 94 | (List 'rec-Nat Src Src Src) 95 | (List 'ind-Nat Src Src Src Src) 96 | (List* '-> Src Src (Listof Src)) 97 | (List 'Π (List* Typed-Binder (Listof Typed-Binder)) Src) 98 | (List 'λ (List* Binding-Site (Listof Binding-Site)) Src) 99 | (List 'Σ (List* Typed-Binder (Listof Typed-Binder)) Src) 100 | (List 'Pair Src Src) 101 | (List 'cons Src Src) 102 | (List 'car Src) 103 | (List 'cdr Src) 104 | 'Trivial 105 | 'sole 106 | 'nil 107 | Natural 108 | (List ':: Src Src) 109 | (List 'List Src) 110 | (List 'rec-List Src Src Src) 111 | (List 'ind-List Src Src Src Src) 112 | 'Absurd 113 | (List 'ind-Absurd Src Src) 114 | (List '= Src Src Src) 115 | (List 'same Src) 116 | (List 'replace Src Src Src) 117 | (List 'trans Src Src) 118 | (List 'cong Src Src) 119 | (List 'symm Src) 120 | (List 'ind-= Src Src Src) 121 | (List 'Vec Src Src) 122 | 'vecnil 123 | (List 'vec:: Src Src) 124 | (List 'head Src) 125 | (List 'tail Src) 126 | (List 'ind-Vec Src Src Src Src Src) 127 | (List 'Either Src Src) 128 | (List 'left Src) 129 | (List 'right Src) 130 | (List 'ind-Either Src Src Src Src) 131 | 'TODO 132 | (List* Src Src (Listof Src)))) 133 | 134 | ;; Core Pie expressions are the result of type checking (elaborating) 135 | ;; an expression written in Pie. They do not have source positions, 136 | ;; because they by definition are not written by a user of the 137 | ;; implementation. 138 | (define-type Core 139 | (U (List 'the Core Core) 140 | 'U 141 | 'Nat 142 | 'zero 143 | Symbol 144 | (List 'add1 Core) 145 | (List 'which-Nat Core (List 'the Core Core) Core) 146 | (List 'iter-Nat Core (List 'the Core Core) Core) 147 | (List 'rec-Nat Core (List 'the Core Core) Core) 148 | (List 'ind-Nat Core Core Core Core) 149 | (List 'Π (List (List Symbol Core)) Core) 150 | (List 'λ (List Symbol) Core) 151 | 'Atom 152 | (List 'quote Symbol) 153 | (List 'Σ (List (List Symbol Core)) Core) 154 | (List 'cons Core Core) 155 | (List 'car Core) 156 | (List 'cdr Core) 157 | (List ':: Core Core) 158 | 'nil 159 | (List 'List Core) 160 | (List 'rec-List Core (List 'the Core Core) Core) 161 | (List 'ind-List Core Core Core Core) 162 | 'Absurd 163 | (List 'ind-Absurd Core Core) 164 | (List '= Core Core Core) 165 | (List 'same Core) 166 | (List 'replace Core Core Core) 167 | (List 'trans Core Core) 168 | (List 'cong Core Core Core) ;; Extra expr is type found through synth 169 | (List 'symm Core) 170 | (List 'ind-= Core Core Core) 171 | (List 'Vec Core Core) 172 | (List 'vec:: Core Core) 173 | 'vecnil 174 | (List 'head Core) 175 | (List 'tail Core) 176 | (List 'ind-Vec Core Core Core Core Core) 177 | (List 'Either Core Core) 178 | (List 'left Core) 179 | (List 'right Core) 180 | (List 'ind-Either Core Core Core Core) 181 | (List 'TODO Srcloc Core) 182 | (List Core Core))) 183 | 184 | 185 | ;;; Values 186 | 187 | ;; In order to type check Pie, it is necessary to find the normal 188 | ;; forms of expressions and compare them with each other. The normal 189 | ;; form of an expression is determined by its type - types that have 190 | ;; η-rules (such as Π, Σ, Trivial, and Absurd) impose requirements on 191 | ;; the normal form. For instance, every normal function has λ at the 192 | ;; top, and every normal pair has cons at the top. 193 | 194 | ;; Finding normal forms has two steps: first, programs are evaluated, 195 | ;; much as they are with the Scheme interpreter at the end of The 196 | ;; Little Schemer. Then, these values are "read back" into the syntax 197 | ;; of their normal forms. This happens in normalize.rkt. This file 198 | ;; defines the values that expressions can have. Structures or symbols 199 | ;; that represent values are written in ALL-CAPS. 200 | 201 | ;; Laziness is implemented by allowing values to be a closure that 202 | ;; does not bind a variable. It is described in normalize.rkt (search 203 | ;; for "Call-by-need"). 204 | (struct DELAY-CLOS ([env : Env] [expr : Core]) #:transparent) 205 | (struct DELAY ([val : (Boxof (U DELAY-CLOS Value))]) #:transparent) 206 | 207 | (struct QUOTE ([name : Symbol]) #:transparent) 208 | (struct ADD1 ([smaller : Value]) #:transparent) 209 | (struct PI ([arg-name : Symbol] 210 | [arg-type : Value] 211 | [result-type : Closure]) 212 | #:transparent) 213 | (struct LAM ([arg-name : Symbol] [body : Closure]) #:transparent) 214 | (struct SIGMA ([car-name : Symbol] 215 | [car-type : Value] 216 | [cdr-type : Closure]) 217 | #:transparent) 218 | (struct CONS ([car : Value] [cdr : Value]) #:transparent) 219 | (struct LIST:: ([head : Value] [tail : Value]) #:transparent) 220 | (struct LIST ([entry-type : Value]) #:transparent) 221 | (struct EQUAL ([type : Value] [from : Value] [to : Value]) 222 | #:transparent) 223 | (struct SAME ([value : Value]) #:transparent) 224 | (struct VEC ([entry-type : Value] [length : Value]) #:transparent) 225 | (struct VEC:: ([head : Value] [tail : Value]) #:transparent) 226 | (struct EITHER ([left-type : Value] [right-type : Value]) #:transparent) 227 | (struct LEFT ([value : Value]) #:transparent) 228 | (struct RIGHT ([value : Value]) #:transparent) 229 | (struct NEU ([type : Value] [neutral : Neutral]) #:transparent) 230 | (define-type Value 231 | (U 'UNIVERSE 232 | 'NAT 'ZERO ADD1 233 | QUOTE 'ATOM 234 | PI LAM 235 | SIGMA CONS 236 | 'TRIVIAL 'SOLE 237 | LIST LIST:: 'NIL 238 | 'ABSURD 239 | EQUAL SAME 240 | VEC 'VECNIL VEC:: 241 | EITHER LEFT RIGHT 242 | NEU 243 | DELAY)) 244 | 245 | 246 | ;; Neutral expressions are represented by structs that ensure that no 247 | ;; non-neutral expressions can be represented. 248 | 249 | (struct N-var ([name : Symbol]) #:transparent) 250 | (struct N-TODO ([where : Srcloc] [type : Value]) #:transparent) 251 | (struct N-which-Nat ([target : Neutral] [base : Norm] [step : Norm]) #:transparent) 252 | (struct N-iter-Nat ([target : Neutral] [base : Norm] [step : Norm]) #:transparent) 253 | (struct N-rec-Nat ([target : Neutral] [base : Norm] [step : Norm]) #:transparent) 254 | (struct N-ind-Nat ([target : Neutral] 255 | [motive : Norm] 256 | [base : Norm] 257 | [step : Norm]) 258 | #:transparent) 259 | (struct N-car ([target : Neutral]) #:transparent) 260 | (struct N-cdr ([target : Neutral]) #:transparent) 261 | (struct N-rec-List ([target : Neutral] [base : Norm] [step : Norm]) #:transparent) 262 | (struct N-ind-List ([target : Neutral] 263 | [motive : Norm] 264 | [base : Norm] 265 | [step : Norm]) 266 | #:transparent) 267 | (struct N-ind-Absurd ([target : Neutral] [motive : Norm]) #:transparent) 268 | (struct N-replace ([target : Neutral] [motive : Norm] [base : Norm]) #:transparent) 269 | (struct N-trans1 ([target1 : Neutral] [target2 : Norm]) #:transparent) 270 | (struct N-trans2 ([target1 : Norm] [target2 : Neutral]) #:transparent) 271 | (struct N-trans12 ([target1 : Neutral] [target2 : Neutral]) #:transparent) 272 | ;; function contains enough to get back res type, so only two fields here 273 | (struct N-cong ([target : Neutral] [function : Norm]) #:transparent) 274 | (struct N-symm ([target : Neutral]) #:transparent) 275 | (struct N-ind-= ([target : Neutral] [motive : Norm] [base : Norm]) #:transparent) 276 | (struct N-head ([target : Neutral]) #:transparent) 277 | (struct N-tail ([target : Neutral]) #:transparent) 278 | (struct N-ind-Vec1 ([target1 : Neutral] 279 | [target2 : Norm] 280 | [motive : Norm] 281 | [base : Norm] 282 | [step : Norm]) 283 | #:transparent) 284 | (struct N-ind-Vec2 ([target1 : Norm] 285 | [target2 : Neutral] 286 | [motive : Norm] 287 | [base : Norm] 288 | [step : Norm]) 289 | #:transparent) 290 | (struct N-ind-Vec12 ([target1 : Neutral] 291 | [target2 : Neutral] 292 | [motive : Norm] 293 | [base : Norm] 294 | [step : Norm]) 295 | #:transparent) 296 | (struct N-ind-Either ([target : Neutral] 297 | [motive : Norm] 298 | [base-left : Norm] 299 | [base-right : Norm]) 300 | #:transparent) 301 | (struct N-ap ([rator : Neutral] [rand : Norm]) #:transparent) 302 | 303 | (define-type Neutral 304 | (U N-var N-TODO 305 | N-which-Nat N-iter-Nat N-rec-Nat N-ind-Nat 306 | N-car N-cdr 307 | N-rec-List N-ind-List 308 | N-ind-Absurd 309 | N-replace N-trans1 N-trans2 N-trans12 N-cong N-symm N-ind-= 310 | N-head N-tail N-ind-Vec1 N-ind-Vec2 N-ind-Vec12 311 | N-ind-Either 312 | N-ap)) 313 | 314 | (define-predicate Neutral? Neutral) 315 | 316 | ;; Normal forms consist of syntax that is produced by read-back, 317 | ;; following the type. This structure contains a type value and a 318 | ;; value described by the type, so that read-back can later be applied 319 | ;; to it. 320 | (struct THE ([type : Value] [value : Value]) #:transparent #:type-name Norm) 321 | 322 | (define-predicate Norm? Norm) 323 | 324 | 325 | ;;; Error handling 326 | 327 | ;; Messages to be shown to the user contain a mix of text (represented 328 | ;; as strings) and expressions (represented as Core Pie expressions). 329 | (define-type Message 330 | (Listof (U String Core))) 331 | 332 | ;; The result of an operation that can fail, such as type checking, is 333 | ;; represented using either the stop or the go structures. 334 | (define-type (Perhaps α) 335 | (U (go α) stop)) 336 | 337 | ;; A successful result 338 | (struct (α) go ([result : α]) #:transparent) 339 | 340 | ;; An error message 341 | (struct stop ([where : Loc] [message : Message]) #:transparent) 342 | 343 | ;; go-on is very much like let*. The difference is that if any of the 344 | ;; values bound to variables in it are stop, then the entire 345 | ;; expression becomes that first stop. Otherwise, the variables are 346 | ;; bound to the contents of each go. 347 | (define-syntax (go-on stx) 348 | (syntax-parse stx 349 | [(go-on () e) (syntax/loc stx e)] 350 | [(go-on ((p0 b0) (p b) ...) e) 351 | (syntax/loc stx 352 | (match b0 353 | [(go p0) (go-on ((p b) ...) e)] 354 | [(stop where msg) (stop where msg)]))])) 355 | 356 | 357 | ;;; Recognizing variable names 358 | 359 | ;; This macro causes a name to be defined both for Racket macros and 360 | ;; for use in ordinary Racket programs. In Racket, these are 361 | ;; separated. 362 | ;; 363 | ;; Variable name recognition is needed in Racket macros in order to 364 | ;; parse Pie into the Src type, and it is needed in ordinary programs 365 | ;; in order to implement the type checker. 366 | (define-syntax-rule (define-here-and-for-syntax what impl) 367 | (begin (define what impl) 368 | (begin-for-syntax (define what impl)))) 369 | 370 | ;; The type of var-name? guarantees that the implementation will 371 | ;; always accept symbols that are not Pie keywords, and never accept 372 | ;; those that are. 373 | (: var-name? (-> Symbol Boolean : 374 | #:+ (! Pie-Keyword) 375 | #:- Pie-Keyword)) 376 | (define-here-and-for-syntax (var-name? x) 377 | (not (or (eqv? x 'U) (eqv? x 'Nat) (eqv? x 'zero) 378 | (eqv? x 'add1) (eqv? x 'which-Nat) (eqv? x 'ind-Nat) 379 | (eqv? x 'rec-Nat) (eqv? x 'iter-Nat) 380 | (eqv? x '->) (eqv? x '→) (eqv? x 'Π) (eqv? x 'Pi) (eqv? x '∏) (eqv? x 'λ) (eqv? x 'lambda) 381 | (eqv? x 'quote) (eqv? x 'Atom) (eqv? x 'Σ) (eqv? x 'Sigma) (eqv? x 'Pair) 382 | (eqv? x 'cons) (eqv? x 'car) (eqv? x 'cdr) 383 | (eqv? x 'Trivial) (eqv? x 'sole) 384 | (eqv? x '::) (eqv? x 'nil) (eqv? x 'List) 385 | (eqv? x 'rec-List) (eqv? x 'ind-List) 386 | (eqv? x 'Absurd) (eqv? x 'ind-Absurd) 387 | (eqv? x '=) (eqv? x 'same) (eqv? x 'replace) 388 | (eqv? x 'symm) (eqv? x 'trans) (eqv? x 'cong) (eqv? x 'ind-=) 389 | (eqv? x 'Vec) (eqv? x 'vec::) (eqv? x 'vecnil) 390 | (eqv? x 'head) (eqv? x 'tail) (eqv? x 'ind-Vec) 391 | (eqv? x 'Either) (eqv? x 'left) (eqv? x 'right) 392 | (eqv? x 'ind-Either) (eqv? x 'the) 393 | (eqv? x 'TODO)))) 394 | 395 | 396 | 397 | 398 | ;;; Contexts 399 | 400 | ;; A context maps free variable names to binders. 401 | (define-type Ctx 402 | (Listof (Pair Symbol Binder))) 403 | 404 | 405 | ;; There are three kinds of binders: a free binder represents a free 406 | ;; variable, that was bound in some larger context by λ, Π, or Σ. A 407 | ;; def binder represents a name bound by define. A claim binder 408 | ;; doesn't actually bind a name; however, it reserves the name for 409 | ;; later definition with define and records the type that will be 410 | ;; used. 411 | (define-type Binder (U Def Free Claim)) 412 | (define-type Claim claim) 413 | (struct claim ([type : Value]) #:transparent) 414 | (struct def ([type : Value] [value : Value]) #:transparent #:type-name Def) 415 | (struct free ([type : Value]) #:transparent #:type-name Free) 416 | 417 | 418 | ;; To find the type of a variable in a context, find the closest 419 | ;; non-claim binder and extract its type. 420 | (: var-type (-> Ctx Loc Symbol (Perhaps Value))) 421 | (define (var-type Γ where x) 422 | (match Γ 423 | ['() (stop where `("Unknown variable" ,x))] 424 | [(cons (cons y (claim tv)) Γ-next) 425 | (var-type Γ-next where x)] 426 | [(cons (cons y b) Γ-next) 427 | (if (eqv? x y) 428 | (go (binder-type b)) 429 | (var-type Γ-next where x))])) 430 | 431 | (: binder-type (-> Binder Value)) 432 | (define (binder-type b) 433 | (match b 434 | [(claim tv) tv] 435 | [(def tv v) tv] 436 | [(free tv) tv])) 437 | 438 | ;; The starting context is empty. 439 | (: init-ctx Ctx) 440 | (define init-ctx '()) 441 | 442 | (: bind-free (-> Ctx Symbol Value Ctx)) 443 | (define (bind-free Γ x tv) 444 | (if (assv x Γ) 445 | (error 'bind-free "~a is already bound in ~a" x Γ) 446 | (cons (cons x (free tv)) Γ))) 447 | 448 | (: bind-val (-> Ctx Symbol Value Value Ctx)) 449 | (define (bind-val Γ x tv v) 450 | (cons (cons x (def tv v)) Γ)) 451 | 452 | 453 | ;; For informationa bout serializable contexts, see the comments in 454 | ;; normalize.rkt. 455 | (define-type Serializable-Ctx 456 | (Listof (List Symbol (U (List 'free Core) 457 | (List 'def Core Core) 458 | (List 'claim Core))))) 459 | 460 | (define-predicate serializable-ctx? Serializable-Ctx) 461 | 462 | 463 | 464 | 465 | ;;; Run-time environments 466 | 467 | ;; A run-time environment associates a value with each variable. 468 | (define-type Env 469 | (Listof (Pair Symbol Value))) 470 | 471 | ;; When type checking Pie, it is sometimes necessary to find the 472 | ;; normal form of an expression that has free variables. These free 473 | ;; variables are described in the type checking context. The value 474 | ;; associated with each free variable should be itself - a neutral 475 | ;; expression. ctx->env converts a context into an environment by 476 | ;; assigning a neutral expression to each variable. 477 | (: ctx->env (-> Ctx Env)) 478 | (define (ctx->env Γ) 479 | (match Γ 480 | [(cons (cons x (def tv v)) Γ-next) 481 | (cons (cons x v) 482 | (ctx->env Γ-next))] 483 | [(cons (cons x (free tv)) Γ-next) 484 | (cons (cons x (NEU tv (N-var x))) 485 | (ctx->env Γ-next))] 486 | [(cons (cons x (claim tv)) Γ-next) 487 | (ctx->env Γ-next)] 488 | ['() '()])) 489 | 490 | ;; Extend an environment with a value for a new variable. 491 | (: extend-env (-> Env Symbol Value Env)) 492 | (define (extend-env ρ x v) (cons (cons x v) ρ)) 493 | 494 | ;; To find the value of a variable in an environment, look it up in 495 | ;; the usual Lisp way using assv. 496 | (: var-val (-> Env Symbol Value)) 497 | (define (var-val ρ x) 498 | (match (assv x ρ) 499 | [(cons y v) v] 500 | [#f (error (format "Variable ~a not in\n\tρ: ~a\n" x ρ))])) 501 | 502 | 503 | 504 | ;;; Closures 505 | 506 | ;; There are two kinds of closures: first-order closures and 507 | ;; higher-order closures. They are used for different purposes in 508 | ;; Pie. It would be possible to have only one representation, but they 509 | ;; are good for different things, so both are included. See 510 | ;; val-of-closure in normalize.rkt for how to find the value of a 511 | ;; closure, given the value for its free variable. 512 | (define-type Closure (U FO-CLOS HO-CLOS)) 513 | 514 | ;; First-order closures, which are a pair of an environment an an 515 | ;; expression whose free variables are given values by the 516 | ;; environment, are used for most closures in Pie. They are easier to 517 | ;; debug, because their contents are visible rather than being part of 518 | ;; a compiled Racket function. On the other hand, they are more 519 | ;; difficult to construct out of values, because it would be necessary 520 | ;; to first read the values back into Core Pie syntax. 521 | (struct FO-CLOS ([env : Env] [var : Symbol] [expr : Core]) #:transparent) 522 | 523 | ;; Higher-order closures re-used Racket's built-in notion of 524 | ;; closure. They are more convenient when constructing closures from 525 | ;; existing values, which happens both during type checking, where 526 | ;; these values are used for things like the type of a step, and 527 | ;; during evaluation, where they are used as type annotations on THE 528 | ;; and NEU. 529 | (struct HO-CLOS ([proc : (-> Value Value)]) #:transparent) 530 | 531 | 532 | ;;; Finding fresh names 533 | 534 | ;; Find a fresh name, using none of those described in a context. 535 | ;; 536 | ;; This is the implementation of the Γ ⊢ fresh ↝ x form of 537 | ;; judgment. Unlike the rules in the appendix to The Little Typer, 538 | ;; this implementation also accepts a name suggestion so that the code 539 | ;; produced by elaboration has names that are as similar as possible 540 | ;; to those written by the user. 541 | (: fresh (-> Ctx Symbol Symbol)) 542 | (define (fresh Γ x) 543 | (freshen (names-only Γ) x)) 544 | 545 | ;; Find a fresh name, using none of those described in a context nor 546 | ;; occurring in an expression. This is used when constructing a fresh 547 | ;; binding to avoid capturing a free variable that would otherwise be 548 | ;; an error because it points at the context. 549 | (: fresh-binder (-> Ctx Src Symbol Symbol)) 550 | (define (fresh-binder Γ expr x) 551 | (freshen (append (names-only Γ) (occurring-names expr)) x)) 552 | 553 | 554 | ;; Find the names that are described in a context, so they can be 555 | ;; avoided. 556 | (: names-only (-> Ctx (Listof Symbol))) 557 | (define (names-only Γ) 558 | (cond 559 | [(null? Γ) '()] 560 | [else (cons (car (car Γ)) (names-only (cdr Γ)))])) 561 | 562 | ;; Find all the names that occur in an expression. For correctness, we 563 | ;; need only find the free identifiers, but finding the bound 564 | ;; identifiers as well means that the bindings introduced by 565 | ;; desugaring expressions are more different from the program as 566 | ;; written, which can help readability of internals. 567 | (: occurring-names (-> Src (Listof Symbol))) 568 | (define (occurring-names expr) 569 | (match (src-stx expr) 570 | [`(the ,t ,e) 571 | (append (occurring-names t) (occurring-names e))] 572 | [`(quote ,x) 573 | '()] 574 | [`(add1 ,n) 575 | (occurring-names n)] 576 | [`(which-Nat ,tgt ,base ,step) 577 | (append (occurring-names tgt) (occurring-names base) (occurring-names step))] 578 | [`(iter-Nat ,tgt ,base ,step) 579 | (append (occurring-names tgt) (occurring-names base) (occurring-names step))] 580 | [`(rec-Nat ,tgt ,base ,step) 581 | (append (occurring-names tgt) (occurring-names base) (occurring-names step))] 582 | [`(ind-Nat ,tgt ,mot ,base ,step) 583 | (append (occurring-names tgt) (occurring-names mot) (occurring-names base) (occurring-names step))] 584 | [(cons '-> (cons t0 ts)) 585 | (append (occurring-names t0) (apply append (map occurring-names ts)))] 586 | [`(Π ,bindings ,t) 587 | (append (apply append (map occurring-binder-names bindings)) (occurring-names t))] 588 | [`(λ ,bindings ,t) 589 | (append (map binder-var bindings) (occurring-names t))] 590 | [`(Σ ,bindings ,t) 591 | (append (apply append (map occurring-binder-names bindings)) (occurring-names t))] 592 | [`(Pair ,A ,D) 593 | (append (occurring-names A) (occurring-names D))] 594 | [`(cons ,A ,D) 595 | (append (occurring-names A) (occurring-names D))] 596 | [`(car ,p) 597 | (occurring-names p)] 598 | [`(cdr ,p) 599 | (occurring-names p)] 600 | [`(:: ,A ,D) 601 | (append (occurring-names A) (occurring-names D))] 602 | [`(List ,E) 603 | (occurring-names E)] 604 | [`(rec-List ,tgt ,base ,step) 605 | (append (occurring-names tgt) (occurring-names base) (occurring-names step))] 606 | [`(ind-List ,tgt ,mot ,base ,step) 607 | (append (occurring-names tgt) (occurring-names mot) (occurring-names base) (occurring-names step))] 608 | [`(ind-Absurd ,tgt ,mot) 609 | (append (occurring-names tgt) (occurring-names mot))] 610 | [`(= ,A ,from ,to) 611 | (append (occurring-names A) (occurring-names from) (occurring-names to))] 612 | [`(same ,e) 613 | (occurring-names e)] 614 | [`(replace ,tgt ,mot ,base) 615 | (append (occurring-names tgt) (occurring-names mot) (occurring-names base))] 616 | [`(trans ,tgt1 ,tgt2) 617 | (append (occurring-names tgt1) (occurring-names tgt2))] 618 | [`(cong ,tgt ,f) 619 | (append (occurring-names tgt) (occurring-names f))] 620 | [`(symm ,tgt) 621 | (occurring-names tgt)] 622 | [`(ind-= ,tgt ,mot ,base) 623 | (append (occurring-names tgt) (occurring-names mot) (occurring-names base))] 624 | [`(Vec ,E ,len) 625 | (append (occurring-names E) (occurring-names len))] 626 | [`(vec:: ,hd ,tl) 627 | (append (occurring-names hd) (occurring-names tl))] 628 | [`(head ,tgt) 629 | (occurring-names tgt)] 630 | [`(tail ,tgt) 631 | (occurring-names tgt)] 632 | [`(ind-Vec ,len ,tgt ,mot ,base ,step) 633 | (append (occurring-names len) (occurring-names tgt) 634 | (occurring-names mot) 635 | (occurring-names base) (occurring-names step))] 636 | [`(Either ,A ,B) 637 | (append (occurring-names A) (occurring-names B))] 638 | [`(left ,e) 639 | (occurring-names e)] 640 | [`(right ,e) 641 | (occurring-names e)] 642 | [`(ind-Either ,tgt ,mot ,l ,r) 643 | (append (occurring-names tgt) (occurring-names mot) (occurring-names l) (occurring-names r))] 644 | [(cons (? src? f) (cons arg0 args)) 645 | (append (occurring-names f) (occurring-names arg0) (apply append (map occurring-names args)))] 646 | [x 647 | (if (and (symbol? x) (var-name? x)) 648 | (list x) 649 | '())])) 650 | 651 | (: occurring-binder-names (-> Typed-Binder (Listof Symbol))) 652 | (define (occurring-binder-names b) 653 | (match b 654 | [(list (binder where x) t) 655 | (cons x (occurring-names t))])) 656 | 657 | 658 | ;; Local Variables: 659 | ;; eval: (put 'Π 'racket-indent-function 1) 660 | ;; eval: (put 'Σ 'racket-indent-function 1) 661 | ;; eval: (put 'go-on 'racket-indent-function 1) 662 | ;; eval: (setq whitespace-line-column 70) 663 | ;; End: 664 | 665 | 666 | -------------------------------------------------------------------------------- /fresh.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (require racket/string) 4 | (provide freshen) 5 | 6 | (: freshen (-> (Listof Symbol) Symbol Symbol)) 7 | (define (freshen used x) 8 | (if (memv x used) 9 | (let ([split (split-name x)]) 10 | (freshen-aux used split)) 11 | x)) 12 | 13 | (: freshen-aux (-> (Listof Symbol) (Pair String Number) Symbol)) 14 | (define (freshen-aux used split) 15 | (let ([joined (unsplit-name split)]) 16 | (if (memv joined used) 17 | (freshen-aux used (next-split-name split)) 18 | joined))) 19 | 20 | (: next-split-name (-> (Pair String Number) (Pair String Number))) 21 | (define (next-split-name split) 22 | (cons (car split) (add1 (cdr split)))) 23 | 24 | (: unsplit-name (-> (Pair String Number) Symbol)) 25 | (define (unsplit-name split) 26 | (string->symbol 27 | (string-append (car split) (number->subscript-string (cdr split))))) 28 | 29 | (: string-replace* (-> String (Listof (Pair String String)) String)) 30 | (define (string-replace* str replacements) 31 | (cond 32 | [(null? replacements) str] 33 | [else 34 | (let ([from (car (car replacements))] 35 | [to (cdr (car replacements))]) 36 | (string-replace* (string-replace str from to) 37 | (cdr replacements)))])) 38 | 39 | (: subscript-replacements (Listof (Pair String String))) 40 | (define subscript-replacements 41 | '(("0" . "₀") 42 | ("1" . "₁") 43 | ("2" . "₂") 44 | ("3" . "₃") 45 | ("4" . "₄") 46 | ("5" . "₅") 47 | ("6" . "₆") 48 | ("7" . "₇") 49 | ("8" . "₈") 50 | ("9" . "₉"))) 51 | 52 | (: non-subscripts (Listof (Pair String String))) 53 | (define non-subscripts 54 | '(("₀" . "0") 55 | ("₁" . "1") 56 | ("₂" . "2") 57 | ("₃" . "3") 58 | ("₄" . "4") 59 | ("₅" . "5") 60 | ("₆" . "6") 61 | ("₇" . "7") 62 | ("₈" . "8") 63 | ("₉" . "9"))) 64 | 65 | 66 | (: subscript-digit? (-> Char Boolean)) 67 | (define (subscript-digit? c) 68 | (if (assoc (string c) non-subscripts) 69 | #t 70 | #f)) 71 | 72 | (: subscript->number (-> String Number)) 73 | (define (subscript->number str) 74 | (safe-string->number (string-replace* str non-subscripts))) 75 | 76 | (: number->subscript-string (-> Number String)) 77 | (define (number->subscript-string n) 78 | (string-replace* (number->string n) subscript-replacements)) 79 | 80 | (: split-name (-> Symbol (Pair String Number))) 81 | (define (split-name name) 82 | (let ([str (symbol->string name)]) 83 | (split-name-aux str (sub1 (string-length str))))) 84 | 85 | (: split-name-aux (-> String Integer (Pair String Number))) 86 | (define (split-name-aux str i) 87 | (cond 88 | [(zero? i) 89 | (cond 90 | [(subscript-digit? (string-ref str i)) 91 | (cons "x" (subscript->number str))] 92 | [else (cons (string (string-ref str i)) 93 | (subscript->number (substring str i (string-length str))))])] 94 | [(subscript-digit? (string-ref str i)) 95 | (split-name-aux str (sub1 i))] 96 | [else (cons 97 | (substring str 0 (add1 i)) 98 | (subscript->number (substring str i (string-length str))))])) 99 | 100 | (: safe-string->number (-> String Number)) 101 | (define (safe-string->number str) 102 | (let ([num (string->number str)]) 103 | (if (eqv? num #f) 104 | 1 105 | num))) 106 | 107 | (module+ test 108 | (require typed/rackunit) 109 | (check-eqv? (freshen '(x) 'x) 110 | 'x₁) 111 | (check-eqv? (freshen '(x x₁ x₂) 'x) 112 | 'x₃) 113 | (check-eqv? (freshen '(x x1 x2) 'y) 114 | 'y) 115 | (check-eqv? (freshen '(r2d r2d₀ r2d₁) 'r2d) 116 | 'r2d₂) 117 | (check-eqv? (freshen '() 'A) 118 | 'A) 119 | (check-eqv? (freshen '(x₁) 'x₁) 'x₂) 120 | (check-eqv? (freshen '() 'x₁) 'x₁) 121 | (check-eqv? (freshen '() (string->symbol "₉₉")) 122 | (string->symbol "₉₉")) 123 | (check-eqv? (freshen (list (string->symbol "₉₉")) (string->symbol "₉₉")) 124 | 'x₉₉) 125 | (check-eqv? (freshen (list (string->symbol "₉₉") 'x₉₉) (string->symbol "₉₉")) 126 | 'x₁₀₀)) 127 | -------------------------------------------------------------------------------- /gui/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax syntax/parse)) 4 | 5 | (require (except-in "../basics.rkt" go-on)) 6 | (require (except-in "../typechecker.rkt" rename)) 7 | (require "../parser.rkt") 8 | (require "../rep.rkt") 9 | (require (only-in "../locations.rkt" location->syntax)) 10 | (require (except-in racket/gui yield module)) 11 | (require (prefix-in gui: racket/gui)) 12 | (require framework) 13 | (require (prefix-in : parser-tools/lex-sre)) 14 | (require syntax-color/racket-lexer) 15 | (require syntax/srcloc) 16 | (require racket/generator) 17 | (require "pie-lexer.rkt") 18 | (require "pie-styles.rkt") 19 | (require "print-gui.rkt") 20 | (require data/interval-map) 21 | (require pict) 22 | 23 | (provide pie-slide-orientation-horizontal? pie-text%) 24 | 25 | (current-pie-gui-font-size 40) 26 | 27 | (define (token-sym->style s) 28 | (symbol->string s)) 29 | 30 | 31 | (define-syntax (go-on stx) 32 | (syntax-parse stx 33 | [(go-on () e) (syntax/loc stx e)] 34 | [(go-on ((p0 b0) (p b) ...) e) 35 | (syntax/loc stx 36 | (match b0 37 | [(go p0) (go-on ((p b) ...) e)] 38 | [(stop where msg) (stop where msg)]))])) 39 | 40 | (define pie-text% 41 | (class (pie-styles-mixin color:text%) 42 | (init-field feedback pie-context) 43 | (init [initial-contents ""]) 44 | (super-new) 45 | 46 | (define (hl-err loc) 47 | (when (location? loc) 48 | (queue-callback 49 | (thunk 50 | (define loc-stx (location->syntax loc)) 51 | (send this clear-err) 52 | (send this highlight-range 53 | (sub1 (source-location-position loc-stx)) 54 | (sub1 (+ (source-location-position loc-stx) 55 | (source-location-span loc-stx))) 56 | "darkorange" 57 | #f 58 | 'high 59 | #:key 'pie-error))))) 60 | 61 | (define/public (clear-err) 62 | (send this unhighlight-ranges/key 'pie-error)) 63 | 64 | (define/public (type-check) 65 | (define txt 66 | (send this get-text)) 67 | (set-box! contains-sheds? #f) 68 | (define contents 69 | (with-handlers ([exn:fail? 70 | (lambda (e) 71 | (send this unhighlight-ranges/key 'type-info) 72 | (send this unhighlight-ranges/key 'TODO) 73 | (send feedback set-error e) 74 | (send feedback set-status 'bad) 75 | (when (exn:srclocs? e) 76 | (define wheres 77 | ((exn:srclocs-accessor e) e)) 78 | (when (pair? wheres) 79 | (hl-err (car wheres)))) 80 | #f)]) 81 | (with-input-from-string txt 82 | (lambda () 83 | (port-count-lines! (current-input-port)) 84 | (for/list ([form (in-generator 85 | (let loop () 86 | (define form 87 | (read-syntax 'pie-editor)) 88 | (unless (or (exn:fail? form) 89 | (eof-object? form)) 90 | (yield form) 91 | (loop))))]) 92 | (parse-pie-decl form)))))) 93 | (when contents 94 | (queue-callback 95 | (thunk 96 | (send feedback reset) 97 | (send feedback set-status 'unknown) 98 | (send this clear-err) 99 | (define res (box (go (void)))) 100 | (set-box! res 101 | (let loop ([Γ pie-context] 102 | [forms contents]) 103 | (if (null? forms) 104 | (go Γ) 105 | (match (car forms) 106 | [`(expression ,e) 107 | (go-on ((out (norm Γ e))) 108 | (begin (send feedback pprint-pie out) 109 | (loop Γ (cdr forms))))] 110 | [`(claim ,name ,name-loc ,ty) 111 | (hook name-loc 'definition) 112 | (go-on ((new-Γ (add-claim Γ name name-loc ty))) 113 | (loop new-Γ (cdr forms)))] 114 | [`(definition ,name ,name-loc ,e) 115 | (hook name-loc 'definition) 116 | (go-on ((new-Γ (add-def Γ name name-loc e))) 117 | (loop new-Γ (cdr forms)))] 118 | [`(check-same ,loc ,type ,e1 ,e2) 119 | (go-on ((_ (check-same Γ loc type e1 e2))) 120 | (loop Γ (cdr forms)))] 121 | [x (displayln `("Didn't match" ,x)) (error 'todo "~a" x)])))) 122 | (match (unbox res) 123 | [(stop where msg) 124 | (hl-err where) 125 | (send feedback set-status 'bad) 126 | (send feedback pprint-message msg)] 127 | [(go Γ) 128 | (send feedback set-status 129 | (cond 130 | [(unbox contains-sheds?) 131 | 'incomplete] 132 | [(let loop ([ctx Γ]) 133 | (match ctx 134 | ['() #f] 135 | [(cons (cons x (claim _)) _) #t] 136 | [(cons (cons x _) more-ctx) (loop more-ctx)])) 137 | 'incomplete] 138 | [else 'ok]))]) 139 | (prepare-type-info))))) 140 | 141 | (define (on-change) 142 | (queue-callback 143 | (thunk 144 | (define end (send this get-start-position)) 145 | (let loop ([pos (sub1 end)]) 146 | (define (done from) 147 | (case (send this get-text from end) 148 | [("Pi") 149 | (send this insert "Π" from end)] 150 | [("Sigma") 151 | (send this insert "Σ" from end)] 152 | [("lambda") 153 | (send this insert "λ" from end)] 154 | [else (void)]) 155 | (void)) 156 | (when (negative? pos) 157 | (done 0)) 158 | (let* ((str (send this get-text (max pos 0) end))) 159 | (when (> (string-length str) 0) 160 | (let ((ch (string-ref str 0))) 161 | (cond 162 | [(or (char-whitespace? ch) 163 | (memv ch '(#\( #\) #\[ #\]))) 164 | (done (add1 pos))] 165 | [(>= pos 0) (loop (sub1 pos))] 166 | [else (void)]))))) 167 | (send this type-check)) 168 | #f)) 169 | 170 | 171 | (define/augment (after-delete start len) 172 | (on-change)) 173 | 174 | (define/augment (after-insert start len) 175 | (on-change)) 176 | 177 | (define/public (show-info start end what) 178 | (send this unhighlight-ranges/key 'type-info) 179 | (send this highlight-range start end "lightgray" #f 'high #:key 'type-info) 180 | (match what 181 | [`(has-type ,t) 182 | (send feedback reset) 183 | (send feedback pprint-message `("Has type" ,t))] 184 | [`(binding-site ,t) 185 | (send feedback reset) 186 | (send feedback pprint-message `("Variable binding with type" ,t))] 187 | [`(is-type ,t) 188 | (send feedback reset) 189 | (send feedback pprint-message '("A type"))] 190 | [`(TODO ,Γ ,t) 191 | (send feedback reset) 192 | (send feedback pprint-message `("Will have type" ,t))] 193 | [_ (void)])) 194 | 195 | (define contains-sheds? (box #f)) 196 | 197 | (define/augment (after-set-position) 198 | (define info 199 | (interval-map-ref type-info (send this get-start-position) #f)) 200 | (when info 201 | (show-info (car info) (cadr info) (caddr info)))) 202 | 203 | (define type-info (make-interval-map)) 204 | (define type-info-input (box (list))) 205 | 206 | (define (prepare-type-info) 207 | (define the-info (sort (unbox type-info-input) 208 | (lambda (l1 l2) 209 | (< (- (cadr l2) (car l2)) 210 | (- (cadr l1) (car l1)))))) 211 | (set-box! type-info-input (list)) 212 | (set! type-info (make-interval-map)) 213 | (for ([info (in-list the-info)]) 214 | (interval-map-set! type-info (car info) (cadr info) info))) 215 | 216 | (define (hook loc what) 217 | (define loc-stx (location->syntax loc)) 218 | (define start (sub1 (source-location-position loc-stx))) 219 | (define end (sub1 (+ (source-location-position loc-stx) 220 | (source-location-span loc-stx)))) 221 | (match what 222 | ['definition 223 | (send this change-style (send this definition-name-delta) start end)] 224 | [`(binding-site ,e) 225 | (set-box! type-info-input 226 | (cons (list start end `(binding-site ,e)) 227 | (unbox type-info-input)))] 228 | [`(is-type ,e) 229 | (set-box! type-info-input 230 | (cons (list start end `(is-type ,e)) 231 | (unbox type-info-input)))] 232 | [`(has-type ,t) 233 | (set-box! type-info-input 234 | (cons (list start end `(has-type ,t)) 235 | (unbox type-info-input)))] 236 | [`(TODO ,Γ ,t) 237 | (send this highlight-range start end "gold" #f 'low #:key 'TODO) 238 | (set-box! contains-sheds? #t) 239 | (set-box! type-info-input 240 | (cons (list start end `(TODO ,Γ ,t)) 241 | (unbox type-info-input)))] 242 | [_ (void)]) 243 | (void)) 244 | 245 | (pie-info-hook hook) 246 | 247 | (queue-callback 248 | (thunk 249 | (send this start-colorer 250 | token-sym->style 251 | pie-lexer 252 | (list (list (string->symbol "(") (string->symbol ")")))) 253 | (send this begin-edit-sequence) 254 | (send this insert initial-contents) 255 | (gui:yield) 256 | (send this type-check) 257 | (send this end-edit-sequence) 258 | (send this scroll-to-position 0))))) 259 | 260 | 261 | (define pie-slide-orientation-horizontal? 262 | (make-parameter #f)) 263 | 264 | #; 265 | (define (pie-on-frame f 266 | #:initial-contents [contents ""] 267 | #:font-size [font-size #f] 268 | #:pie-state [pie-state init-st]) 269 | (define panel (new panel:vertical-dragable% [parent f])) 270 | (send panel set-orientation (pie-slide-orientation-horizontal?)) 271 | (parameterize ([current-pie-gui-font-size (or font-size 40)]) 272 | (define fb (new pie-feedback%)) 273 | (define ed (new pie-text% 274 | [feedback fb] 275 | [pie-state pie-state] 276 | [initial-contents contents])) 277 | 278 | (define c (new editor-canvas% [parent panel] [editor ed] [style '(hide-hscroll auto-vscroll no-border)])) 279 | (define fbc (new editor-canvas% [parent panel] [editor fb] [style '(hide-hscroll auto-vscroll no-border)])) 280 | 281 | (send panel set-percentages '(2/3 1/3)) 282 | 283 | (for ([ed (list fb ed)]) 284 | (define keymap (send ed get-keymap)) 285 | (add-editor-keymap-functions keymap) 286 | (add-text-keymap-functions keymap))) 287 | 288 | void) 289 | 290 | (define frame:pie-text<%> 291 | (interface (frame:text<%>))) 292 | 293 | 294 | (define frame:pie-feedback<%> 295 | (interface (frame:basic<%>) 296 | [get-pie-feedback (->m (is-a?/c pie-feedback%))])) 297 | 298 | (define frame:pie-feedback-mixin 299 | (mixin (frame:basic<%>) (frame:pie-feedback<%>) 300 | (super-new) 301 | (inherit get-area-container) 302 | (define feedback (new pie-feedback%)) 303 | (define/public (get-pie-feedback) 304 | feedback))) 305 | 306 | 307 | (define frame:pie-text-mixin 308 | (mixin (frame:editor<%> frame:pie-feedback<%>) (frame:pie-text<%>) 309 | (define f this) 310 | (define the-editor-class 311 | (class (editor:backup-autosave-mixin (editor:info-mixin pie-text%)) 312 | (super-new [feedback (send f get-pie-feedback)] 313 | [pie-context init-ctx]))) 314 | (super-new [editor% the-editor-class]) 315 | (define/override (get-editor<%>) 316 | (class->interface pie-text%)))) 317 | 318 | (define pie-frame% 319 | (class 320 | (frame:text-info-mixin 321 | (frame:info-mixin 322 | (frame:searchable-text-mixin 323 | (frame:pie-text-mixin 324 | (frame:editor-mixin 325 | (frame:searchable-mixin 326 | (frame:standard-menus-mixin 327 | (frame:pie-feedback-mixin 328 | (frame:size-pref-mixin 329 | (frame:basic-mixin frame%)))))))))) 330 | (super-new 331 | [size-preferences-key 'pie:size-prefs] 332 | [position-preferences-key 'pie:position-prefs]) 333 | (define/override (edit-menu:between-redo-and-cut menu) 334 | (define increase 335 | (new menu-item% 336 | [label "Increase font size"] 337 | [parent menu] 338 | [callback 339 | (lambda (menu event) 340 | (current-pie-gui-font-size 341 | (add1 (current-pie-gui-font-size))) 342 | (send (send this get-editor) change-style 343 | (make-object style-delta% 'change-bigger 1)))])) 344 | (define decrease 345 | (new menu-item% 346 | [label "Decrease font size"] 347 | [parent menu] 348 | [callback 349 | (lambda (menu event) 350 | (current-pie-gui-font-size 351 | (sub1 (current-pie-gui-font-size))) 352 | (send (send this get-editor) change-style 353 | (make-object style-delta% 'change-smaller 1)))])) 354 | (void)) 355 | (define/override (help-menu:about-callback item evt) 356 | (message-box 357 | "About Pie" 358 | "Welcome to Pie, a little dependently typed language." 359 | this 360 | '(ok no-icon))) 361 | (define/override (get-area-container%) 362 | panel:horizontal-dragable%) 363 | (define vertical? (get-preference 'pie:editor-vertical?)) 364 | (send (send this get-area-container) 365 | set-orientation (not vertical?)) 366 | (define feedback-canvas 367 | (new editor-canvas% 368 | [parent (send this get-area-container)] 369 | [editor (send this get-pie-feedback)])))) 370 | 371 | (define (interactive-pie) 372 | (define icon-size 128) 373 | (define icon 374 | (pict->bitmap (scale-to-fit (text "(Π)" null 128) icon-size icon-size))) 375 | (frame:current-icon icon) 376 | (application:current-app-name "Pie") 377 | (frame:setup-size-pref 'pie:size-prefs 600 500 378 | #:position-preferences 'pie:position-prefs) 379 | (current-pie-gui-font-size 16) 380 | 381 | (define (new-window filename) 382 | (define f (new pie-frame% 383 | [filename filename])) 384 | 385 | (frame:remove-empty-menus f) 386 | (frame:reorder-menus f) 387 | (send f show #t) 388 | f) 389 | (handler:current-create-new-window new-window) 390 | (new-window #f)) 391 | 392 | (module+ main (interactive-pie)) 393 | -------------------------------------------------------------------------------- /gui/pie-lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require parser-tools/lex 4 | racket/contract 5 | (prefix-in : parser-tools/lex-sre)) 6 | 7 | (provide 8 | pie-lexer 9 | pie-lexer/status 10 | pie-nobar-lexer/status) 11 | 12 | (define-lex-abbrevs 13 | 14 | ;; For case insensitivity 15 | [a (char-set "aA")] 16 | [b (char-set "bB")] 17 | [c (char-set "cC")] 18 | [d (char-set "dD")] 19 | [e (char-set "eE")] 20 | [f (char-set "fF")] 21 | [g (char-set "gG")] 22 | [h (char-set "hH")] 23 | [i (char-set "iI")] 24 | [j (char-set "jJ")] 25 | [k (char-set "kK")] 26 | [l (char-set "lL")] 27 | [m (char-set "mM")] 28 | [n (char-set "nN")] 29 | [o (char-set "oO")] 30 | [p (char-set "pP")] 31 | [q (char-set "qQ")] 32 | [r (char-set "rR")] 33 | [s (char-set "sS")] 34 | [t (char-set "tT")] 35 | [u (char-set "uU")] 36 | [v (char-set "vV")] 37 | [w (char-set "wW")] 38 | [x (char-set "xX")] 39 | [y (char-set "yY")] 40 | [z (char-set "zZ")] 41 | 42 | [digit (:/ "0" "9")] 43 | [digit2 (:/ "0" "1")] 44 | [digit8 (:/ "0" "7")] 45 | [digit10 digit] 46 | [digit16 (:/ "af" "AF" "09")] 47 | 48 | [langchar (:or (:/ "az" "AZ" "09") "+" "-" "_")] 49 | 50 | [pie-whitespace whitespace] 51 | 52 | [line-comment (:: ";" (:* (:~ #\newline)))] 53 | 54 | 55 | ;; What about char->integer constraint? 56 | [unicode (:or (:: "u" (:** 1 4 digit16)) 57 | (:: "U" (:** 1 6 digit16)))] 58 | 59 | [character (:or (:: "#\\" any-char) 60 | (:: "#\\" character-name) 61 | (:: "#\\" (:/ "0" "3") digit8 digit8) 62 | (:: "#\\" unicode))] 63 | 64 | [character-name (:or (:: s p a c e) 65 | (:: n e w l i n e) 66 | (:: n u l) 67 | (:: n u l l) 68 | (:: b a c k s p a c e) 69 | (:: t a b) 70 | (:: l i n e f e e d) 71 | (:: v t a b) 72 | (:: p a g e) 73 | (:: r e t u r n) 74 | (:: r u b o u t))] 75 | 76 | [bad-char (:or "#\\" 77 | (:: "#\\" (:>= 2 alphabetic)) 78 | (:: "#\\" (:/ "0" "3") digit8))] 79 | 80 | ;; What about byte string regexp strings 81 | [str (:or (:: (:? (:or "#px" "#rx")) "\"" (:* string-element (:: "\\" unicode)) "\"") 82 | byte-str)] 83 | [byte-str (:: (:? (:or "#px" "#rx")) "#\"" (:* byte-string-element) "\"")] 84 | [string-element (:or (:~ "\"" "\\") 85 | string-escape)] 86 | [byte-string-element (:or (:- (:/ "\x00" "\xFF") "\"" "\\") 87 | string-escape)] 88 | [string-escape (:or "\\\"" 89 | "\\\\" 90 | "\\a" 91 | "\\b" 92 | "\\t" 93 | "\\n" 94 | "\\v" 95 | "\\f" 96 | "\\r" 97 | "\\e" 98 | "\\'" 99 | (:: "\\" (:** 1 3 digit8)) 100 | (:: "\\x" (:** 1 2 digit16)) 101 | (:: "\\" #\newline))] 102 | 103 | [bad-str (:: (:? (:or "#px" "#rx")) (:? "#") "\"" 104 | (:* (:~ "\"" "\\") 105 | (:: "\\" any-char)) 106 | (:? "\\" "\""))] 107 | 108 | 109 | [special-numbers (:or (:: n a n ".0") (:: i n f ".0") 110 | (:: n a n ".f") (:: i n f ".f"))] 111 | [special-extflonums (:or (:: n a n ".t") (:: i n f ".t"))] 112 | [exponent-marker (:or e s f d l)] 113 | [exponent-marker16 (:or s l)] 114 | [sign (char-set "+-")] 115 | [exactness (:or "#i" "#e" "#I" "#E")] 116 | [radix2 (:or "#b" "#B")] 117 | [radix8 (:or "#o" "#O")] 118 | [radix10 (:or "#d" "#D")] 119 | [radix16 (:or "#x" "#X")] 120 | 121 | [script (:: "#!" (:or #\space #\/) (:* (:~ #\newline) (:: #\\ #\newline)))] 122 | 123 | [identifier-delims (:or (char-set "\",'`()[]{};") pie-whitespace)] 124 | [identifier-chars (:~ identifier-delims "\\" "|")] 125 | [identifier-escapes (:or (:: "\\" any-char) 126 | (:: "|" (:* (:~ "|")) "|"))] 127 | [identifier-start (:or identifier-escapes 128 | (:~ identifier-delims "\\" "|" "#") 129 | "#%")] 130 | [identifier (:: identifier-start 131 | (:* identifier-escapes identifier-chars))] 132 | 133 | [nobar-identifier-escapes (:: "\\" any-char)] 134 | [nobar-identifier-start (:or nobar-identifier-escapes 135 | (:~ identifier-delims "\\" "|" "#") 136 | "#%")] 137 | [nobar-identifier (:: nobar-identifier-start 138 | (:* nobar-identifier-escapes identifier-chars))] 139 | 140 | [bad-id-start (:or identifier-escapes 141 | (:~ identifier-delims "\\" "|"))] 142 | [bad-id-escapes (:or identifier-escapes 143 | (:: "|" (:* (:~ "|"))))] 144 | [bad-id (:or (:: bad-id-start 145 | (:* identifier-escapes identifier-chars) 146 | (:? "\\" bad-id-escapes)) 147 | "\\" 148 | bad-id-escapes)] 149 | 150 | 151 | [nobar-bad-id-escapes nobar-identifier-escapes] 152 | [nobar-bad-id (:or (:: bad-id-start 153 | (:* nobar-identifier-escapes identifier-chars) 154 | (:? "\\" nobar-bad-id-escapes)) 155 | "\\" 156 | nobar-bad-id-escapes)] 157 | 158 | [keyword (:: "#:" (:* identifier-escapes identifier-chars))] 159 | [nobar-keyword (:: "#:" (:* nobar-identifier-escapes identifier-chars))] 160 | 161 | [reader-command (:or (:: "#" c s) (:: "#" c i))] 162 | [sharing (:or (:: "#" (make-uinteger digit10) "=") 163 | (:: "#" (make-uinteger digit10) "#"))] 164 | 165 | [list-prefix (:or "" "#hash" "#hasheq" "#hasheqv" "#s" (:: "#" (:* digit10)))]) 166 | 167 | (define-lex-trans make-num 168 | (syntax-rules () 169 | ((_ digit radix exponent-marker) 170 | (:: (make-prefix radix) (make-complex digit exponent-marker))))) 171 | 172 | (define-lex-trans make-prefix 173 | (syntax-rules () 174 | ((_ radix) (:or (:: radix (:? exactness)) 175 | (:: (:? exactness) radix))))) 176 | 177 | (define-lex-trans make-complex 178 | (syntax-rules () 179 | ((_ digit exponent-marker) 180 | (:or (make-real digit exponent-marker) 181 | (:: (make-real digit exponent-marker) "@" (make-real digit exponent-marker)) 182 | (:: (make-real digit exponent-marker) "+" (:or special-numbers (make-ureal digit exponent-marker)) i) 183 | (:: (make-real digit exponent-marker) "-" (:or special-numbers (make-ureal digit exponent-marker)) i) 184 | (:: (make-real digit exponent-marker) "+" i) 185 | (:: (make-real digit exponent-marker) "-" i) 186 | (:: "+" (:or special-numbers (make-ureal digit exponent-marker)) i) 187 | (:: "-" (:or special-numbers (make-ureal digit exponent-marker)) i) 188 | (:: "+" i) 189 | (:: "-" i))))) 190 | 191 | (define-lex-trans make-ureal 192 | (syntax-rules () 193 | ((_ digit exponent-marker) 194 | (make-ureal* digit exponent-marker make-suffix)))) 195 | 196 | (define-lex-trans make-ureal* 197 | (syntax-rules () 198 | ((_ digit exponent-marker make-suffix) 199 | (:or (make-uinteger digit) 200 | (:: (make-uinteger digit) "/" (make-uinteger digit) (make-suffix digit exponent-marker)) 201 | (make-decimal digit exponent-marker make-suffix))))) 202 | 203 | (define-lex-trans make-real 204 | (syntax-rules () 205 | ((_ digit exponent-marker) 206 | (make-real* digit exponent-marker make-suffix special-numbers)))) 207 | 208 | (define-lex-trans make-real* 209 | (syntax-rules () 210 | ((_ digit exponent-marker make-suffix special-numbers) 211 | (:or (:: (:? sign) (make-ureal* digit exponent-marker make-suffix)) 212 | (:: (char-set "+-") special-numbers))))) 213 | 214 | (define-lex-trans make-uinteger 215 | (syntax-rules () 216 | ((_ digit) (:: (:+ digit) (:* "#"))))) 217 | 218 | (define-lex-trans make-decimal 219 | (syntax-rules () 220 | ((_ digit exponent-marker make-suffix) 221 | (:or (:: (make-uinteger digit) (make-suffix digit exponent-marker)) 222 | (:: "." (:+ digit) (:* "#") (make-suffix digit exponent-marker)) 223 | (:: (:+ digit) "." (:* digit) (:* "#") (make-suffix digit exponent-marker)) 224 | (:: (:+ digit) (:+ "#") "." (:* "#") (make-suffix digit exponent-marker)))))) 225 | 226 | (define-lex-trans make-suffix 227 | (syntax-rules () 228 | ((_ digit exponent-marker) (:or "" (:: exponent-marker (:? sign) (:+ digit)))))) 229 | 230 | (define-lex-trans make-extflonum-suffix 231 | (syntax-rules () 232 | ((_ digit exponent-marker) (:: exponent-marker (:? sign) (:+ digit))))) 233 | 234 | (define-lex-trans make-extflonum 235 | (syntax-rules () 236 | ((_ digit radix) 237 | (:: radix (make-real* digit (:or "t" "T") make-extflonum-suffix special-extflonums))))) 238 | 239 | (define (ret lexeme type paren start-pos end-pos status) 240 | (values lexeme type paren (position-offset start-pos) (position-offset end-pos) status)) 241 | 242 | 243 | (define get-next-comment 244 | (lexer 245 | ["#|" (values 1 end-pos)] 246 | ["|#" (values -1 end-pos)] 247 | [(:or "#" "|" (:* (:~ "|" "#"))) 248 | (get-next-comment input-port)] 249 | [(eof) (values 'eof end-pos)] 250 | [(special) 251 | (get-next-comment input-port)] 252 | [(special-comment) 253 | (get-next-comment input-port)])) 254 | 255 | (define (read-nested-comment num-opens start-pos input) 256 | (let-values (((diff end) (get-next-comment input))) 257 | (cond 258 | ((eq? 'eof diff) (ret "" 'error #f start-pos end 'continue)) 259 | (else 260 | (let ((next-num-opens (+ diff num-opens))) 261 | (cond 262 | ((= 0 next-num-opens) (ret "" 'comment #f start-pos end 'continue)) 263 | (else (read-nested-comment next-num-opens start-pos input)))))))) 264 | 265 | (define (get-offset i) 266 | (let-values (((x y offset) (port-next-location i))) 267 | offset)) 268 | 269 | (define (escape-regexp s) 270 | (apply string-append 271 | (map (lambda (c) 272 | (if (memq c '(#\( #\) #\* #\+ #\? #\[ #\] #\. #\^ #\\ #\|)) 273 | (string #\\ c) 274 | (string c))) 275 | (string->list s)))) 276 | 277 | (define (special-read-line i) 278 | (let ((next (peek-char-or-special i))) 279 | (cond 280 | ((or (eq? next #\newline) (not (char? next))) 281 | null) 282 | (else 283 | (read-char i) 284 | (cons next (special-read-line i)))))) 285 | 286 | (define (read-line/skip-over-specials i) 287 | (let loop () 288 | (let ((next (peek-char-or-special i))) 289 | (cond 290 | ((or (eq? next #\newline) (eof-object? next)) 291 | null) 292 | (else 293 | (read-char-or-special i) 294 | (if (char? next) 295 | (cons next (loop)) 296 | (loop))))))) 297 | 298 | (define (get-here-string start-pos i) 299 | (let* ((ender (list->string (special-read-line i))) 300 | (next-char (peek-char-or-special i))) 301 | (cond 302 | ((or (equal? ender "") (not (eq? #\newline next-char))) 303 | (values (string-append "#<<" ender) 'error #f start-pos (get-offset i) 'datum)) 304 | (else 305 | (read-char i) 306 | (let loop ((acc (list (string-append "#<<" ender "\n")))) 307 | (let* ((next-line (list->string (special-read-line i))) 308 | (next-char (peek-char-or-special i))) 309 | (cond 310 | ((not (or (char? next-char) (eof-object? next-char))) ;; a special 311 | (values (apply string-append (reverse (cons next-line acc))) 312 | 'error #f start-pos (get-offset i) 313 | 'datum)) 314 | ((equal? next-line ender) ;; end of string 315 | (values (apply string-append (reverse (cons next-line acc))) 316 | 'string #f start-pos (get-offset i) 317 | 'datum)) 318 | ((eof-object? next-char) 319 | (values (apply string-append (reverse (cons next-line acc))) 320 | 'error #f start-pos (get-offset i) 321 | 'datum)) 322 | (else 323 | (read-char i) 324 | (loop (cons (string-append next-line "\n") acc)))))))))) 325 | 326 | (define (pie-lexer in) 327 | (let-values ([(lexeme type paren start end adj) (pie-lexer/status in)]) 328 | (values lexeme type paren start end))) 329 | 330 | (define-syntax-rule (lexer/status identifier keyword bad-id) 331 | (lexer 332 | [(:+ pie-whitespace) 333 | (ret lexeme 'white-space #f start-pos end-pos 'continue)] 334 | [(:: (:or "#true" "#false" "#t" "#f" "#T" "#F") 335 | (:* (:~ identifier-delims))) 336 | (ret lexeme 337 | (if (member lexeme '("#true" "#false" "#t" "#f" "#T" "#F")) 338 | 'constant 339 | 'error) 340 | #f start-pos end-pos 'datum)] 341 | [(:or character 342 | (make-num digit2 radix2 exponent-marker) 343 | (make-num digit8 radix8 exponent-marker) 344 | (make-num digit10 (:? radix10) exponent-marker) 345 | (make-num digit16 radix16 exponent-marker16) 346 | (make-extflonum digit2 radix2) 347 | (make-extflonum digit8 radix8) 348 | (make-extflonum digit10 (:? radix10)) 349 | (make-extflonum digit16 radix16)) 350 | (ret lexeme 'constant #f start-pos end-pos 'datum)] 351 | [keyword (ret lexeme 'hash-colon-keyword #f start-pos end-pos 'datum)] 352 | [str (ret lexeme 'string #f start-pos end-pos 'datum)] 353 | [";" 354 | (values (apply string (read-line/skip-over-specials input-port)) 'comment #f 355 | (position-offset start-pos) 356 | (get-offset input-port) 357 | 'continue)] 358 | #; 359 | [line-comment 360 | (ret lexeme 'comment #f start-pos end-pos)] 361 | ["#;" 362 | (ret lexeme 'sexp-comment #f start-pos end-pos 'continue)] 363 | ["#|" (read-nested-comment 1 start-pos input-port)] 364 | [script 365 | (ret lexeme 'comment #f start-pos end-pos 'continue)] 366 | [(:: list-prefix "(") 367 | (ret lexeme 'parenthesis '|(| start-pos end-pos 'open)] 368 | [(:: list-prefix "[") 369 | (ret lexeme 'parenthesis '|[| start-pos end-pos 'open)] 370 | [(:: list-prefix "{") 371 | (ret lexeme 'parenthesis '|{| start-pos end-pos 'open)] 372 | [(:or ")" "]" "}") 373 | (ret lexeme 'parenthesis (string->symbol lexeme) start-pos end-pos 'close)] 374 | [(:: "'" identifier) 375 | (ret lexeme 'data-ctor #f start-pos end-pos 'continue)] 376 | [(:or "'" "`" "#'" "#`" "#&") 377 | (ret lexeme 'constant #f start-pos end-pos 'continue)] 378 | [(:or sharing reader-command "." "," ",@" "#," "#,@") 379 | (ret lexeme 'other #f start-pos end-pos 'continue)] 380 | 381 | [(:: (:or "#lang " "#!") 382 | (:or langchar 383 | (:: langchar (:* (:or langchar "/")) langchar))) 384 | (ret lexeme 'other #f start-pos end-pos 'continue)] 385 | [(:: (:or "#lang " "#!") (:* (:& any-char (complement whitespace)))) 386 | (ret lexeme 'error #f start-pos end-pos 'continue)] 387 | 388 | [identifier 389 | (let ((category 390 | (case lexeme 391 | [("claim" 392 | "check-same" 393 | "TODO" 394 | "define" "which-Nat" "iter-Nat" "rec-Nat" "ind-Nat" 395 | "ind-Either" "head" "tail" "ind-Vec" "ind-Absurd" "the" 396 | "car" "cdr" "cong" "trans" "symm" "replace") 397 | 'keyword] 398 | [("U" 399 | "Π" "Pi" "∏" "->" "→" 400 | "Σ" "Sigma" "Pair" 401 | "Either" 402 | "Atom" 403 | "Nat" 404 | "Vec" "List" 405 | "Trivial" 406 | "Absurd" 407 | "=") 408 | 'type-ctor] 409 | [("lambda" "λ" "cons" "left" "right" "sole" "zero" "add1" "same" 410 | "::" "vec::" "vecnil" "nil") 411 | 'data-ctor] 412 | [else 'symbol]))) 413 | (ret lexeme category #f start-pos end-pos 'datum))] 414 | ["#<<" 415 | (get-here-string (position-offset start-pos) input-port)] 416 | [(special) 417 | (cond 418 | [(or (number? lexeme) (boolean? lexeme)) 419 | (ret lexeme 'constant #f start-pos end-pos 'datum)] 420 | [(string? lexeme) 421 | (ret lexeme 'string #f start-pos end-pos 'datum)] 422 | [(keyword? lexeme) 423 | (ret lexeme 'hash-colon-keyword #f start-pos end-pos 'datum)] 424 | [else 425 | (ret "" 'no-color #f start-pos end-pos 'datum)])] 426 | [(special-comment) 427 | (ret "" 'comment #f start-pos end-pos 'continue)] 428 | [(eof) (values lexeme 'eof #f #f #f #f)] 429 | [(:or bad-char bad-str 430 | (:& bad-id 431 | (complement (:: (:or (:: "#" (:or f t)) reader-command sharing "#<<" "#\\" "#|" "#;" "#&" script) 432 | any-string)))) 433 | (ret lexeme 'error #f start-pos end-pos 'bad)] 434 | [any-char (extend-error lexeme start-pos end-pos input-port)])) 435 | 436 | (define pie-lexer/status (lexer/status identifier keyword bad-id)) 437 | (define pie-nobar-lexer/status (lexer/status nobar-identifier nobar-keyword nobar-bad-id)) 438 | 439 | (define (extend-error lexeme start end in) 440 | (define next (peek-char-or-special in)) 441 | (if (or (char-whitespace? next) 442 | (memq next 443 | `(special 444 | #\" #\, #\' #\` #\( #\) #\[ #\] #\{ #\} #\; 445 | ,eof))) 446 | (ret lexeme 'error #f start end 'bad) 447 | (let-values (((rest end-pos) (get-chunk in))) 448 | (ret (string-append lexeme rest) 'error #f start end-pos 'bad)))) 449 | 450 | (define get-chunk 451 | (lexer 452 | [(:+ (:~ identifier-delims)) (values lexeme end-pos)])) 453 | -------------------------------------------------------------------------------- /gui/pie-styles.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui) 3 | (require framework) 4 | 5 | (provide (all-defined-out)) 6 | 7 | (define current-pie-gui-font-size 8 | (make-parameter 40)) 9 | 10 | (define (exact n) 11 | (inexact->exact (round n))) 12 | 13 | (define pie-styles<%> 14 | (interface (editor<%>) 15 | [text-style (->m (is-a?/c style<%>))] 16 | [keyword-style (->m (is-a?/c style<%>))] 17 | [parenthesis-style (->m (is-a?/c style<%>))] 18 | [data-constructor-style (->m (is-a?/c style<%>))] 19 | [type-constructor-style (->m (is-a?/c style<%>))] 20 | [definition-name-style (->m (is-a?/c style<%>))] 21 | [definition-name-delta (->m (is-a?/c style-delta%))] 22 | [var-style (->m (is-a?/c style<%>))] 23 | [change-font-size (->m exact-integer? void?)])) 24 | 25 | (define pie-styles-mixin 26 | (mixin (color:text<%>) (pie-styles<%>) 27 | (super-new) 28 | (define sans-face "CMU Bright") 29 | (define serif-face "Latin Modern Roman") 30 | 31 | (define style-list (send this get-style-list)) 32 | (define basic (send style-list basic-style)) 33 | (define basic-delta 34 | (make-object style-delta% 35 | 'change-size (exact (current-pie-gui-font-size)))) 36 | (send basic-delta set-face sans-face) 37 | (send basic-delta set-size-in-pixels-on #t) 38 | (define new-basic (send style-list find-or-create-style basic basic-delta)) 39 | (send style-list replace-named-style "Basic" new-basic) 40 | (send style-list replace-named-style "Standard" new-basic) 41 | 42 | (define var-delta (make-object style-delta%)) 43 | (send var-delta set-face sans-face) 44 | (send var-delta set-style-on 'italic) 45 | (send var-delta set-size-in-pixels-on #t) 46 | (define the-var-style 47 | (send style-list find-or-create-style new-basic var-delta)) 48 | 49 | (define/public (var-style) the-var-style) 50 | 51 | (define text-delta 52 | (make-object style-delta%)) 53 | (send text-delta set-face serif-face) 54 | (send text-delta set-size-in-pixels-on #t) 55 | (define book-style 56 | (send style-list find-or-create-style new-basic 57 | text-delta)) 58 | (send style-list new-named-style "book-text" book-style) 59 | (define/public (text-style) book-style) 60 | 61 | (define parenthesis-delta 62 | (make-object style-delta%)) 63 | (send parenthesis-delta set-face sans-face) 64 | (send parenthesis-delta set-weight-on 'bold) 65 | (send parenthesis-delta set-delta-foreground "DimGray") 66 | (send parenthesis-delta set-size-in-pixels-on #t) 67 | (define paren-style 68 | (send style-list find-or-create-style new-basic 69 | parenthesis-delta)) 70 | (send style-list new-named-style "parenthesis" paren-style) 71 | 72 | (define/public (parenthesis-style) paren-style) 73 | 74 | (define type-ctor-delta 75 | (make-object style-delta%)) 76 | (send type-ctor-delta set-face sans-face) 77 | (send type-ctor-delta set-size-in-pixels-on #t) 78 | (define type-ctor-style 79 | (send style-list find-or-create-style new-basic 80 | type-ctor-delta)) 81 | (send style-list new-named-style "type-ctor" type-ctor-style) 82 | 83 | (define/public (type-constructor-style) type-ctor-style) 84 | 85 | (define definition-delta 86 | (make-object style-delta%)) 87 | (define/public (definition-name-delta) definition-delta) 88 | (send definition-delta set-face sans-face) 89 | (send definition-delta set-weight-on 'bold) 90 | (send definition-delta set-style-on 'italic) 91 | (send definition-delta set-size-in-pixels-on #t) 92 | (define definition-style 93 | (send style-list find-or-create-style new-basic 94 | definition-delta)) 95 | (send style-list new-named-style "definition" definition-style) 96 | 97 | (define/public (definition-name-style) definition-style) 98 | 99 | (define data-ctor-delta 100 | (make-object style-delta%)) 101 | (send data-ctor-delta set-face sans-face) 102 | (send data-ctor-delta set-size-in-pixels-on #t) 103 | (define data-ctor-style 104 | (send style-list find-or-create-style new-basic 105 | data-ctor-delta)) 106 | (send style-list new-named-style "data-ctor" data-ctor-style) 107 | (send style-list new-named-style "constant" data-ctor-style) 108 | (define/public (data-constructor-style) data-ctor-style) 109 | 110 | (define keyword-delta 111 | (make-object style-delta%)) 112 | (send keyword-delta set-face sans-face) 113 | (send keyword-delta set-weight-on 'bold) 114 | (send keyword-delta set-size-in-pixels-on #t) 115 | (define pie-keyword-style 116 | (send style-list find-or-create-style new-basic 117 | keyword-delta)) 118 | (send style-list new-named-style "keyword" pie-keyword-style) 119 | (define/public (keyword-style) pie-keyword-style) 120 | 121 | (define/public (change-font-size amount) 122 | (define style-list (send this get-style-list)) 123 | (define basic (send style-list basic-style)) 124 | (define δ 125 | (cond 126 | [(> amount 0) 127 | (make-object style-delta% 'change-bigger amount)] 128 | [(< amount 0) 129 | (make-object style-delta% 'change-smaller (- amount))] 130 | [else 131 | (make-object style-delta%)])) 132 | (send basic set-delta δ) 133 | (void)))) 134 | -------------------------------------------------------------------------------- /gui/print-gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/function racket/list racket/match) 4 | (require "pie-styles.rkt" "../basics.rkt" "../resugar.rkt") 5 | (require racket/gui framework) 6 | (require pict) 7 | 8 | (provide pie-feedback%) 9 | 10 | (define indentation (make-parameter 0)) 11 | 12 | (define-syntax indented 13 | (syntax-rules () 14 | [(_ i e ...) 15 | (parameterize ([indentation (+ i (indentation))]) 16 | (begin e ...))])) 17 | 18 | (define pie-feedback% 19 | (class (pie-styles-mixin color:text%) 20 | (super-new [auto-wrap #t]) 21 | 22 | (init-field [status 'unknown]) 23 | 24 | (define ok (colorize (text "✔" "DejaVu Sans Mono" (current-pie-gui-font-size)) "darkgreen")) 25 | (define incomplete 26 | (let* ([mark (colorize (text "?" (cons 'bold "DejaVu Sans Mono") (current-pie-gui-font-size)) "white")] 27 | [size (max (pict-width mark) (pict-height mark))]) 28 | (cc-superimpose 29 | (filled-rounded-rectangle size size #:color "gold" #:draw-border? #f) 30 | mark))) 31 | (define bad (colorize (text "✖" "DejaVu Sans Mono" (current-pie-gui-font-size)) "red")) 32 | (define/public (set-status s) 33 | (set! status s) 34 | (send this invalidate-bitmap-cache) 35 | (define c (send this get-canvas)) 36 | (when c (send c refresh))) 37 | (define (status-pict) 38 | (match status 39 | ['ok ok] 40 | ['incomplete incomplete] 41 | ['bad bad] 42 | [_ (blank)])) 43 | 44 | (define/override (on-paint before? dc left top right bottom dx dy draw-caret) 45 | (super on-paint before? dc left top right bottom dx dy draw-caret) 46 | (define pict (status-pict)) 47 | (define c (send this get-canvas)) 48 | (when c 49 | (define w (send c get-width)) 50 | (draw-pict pict dc (- w (pict-width pict) 25 (send c horizontal-inset)) (+ 5 (send c vertical-inset))))) 51 | 52 | (define-syntax unlocked 53 | (syntax-rules () 54 | [(_ e ...) 55 | (let ((locked? (send this is-locked?))) 56 | (dynamic-wind 57 | (thunk (when locked? (send this lock #f))) 58 | (thunk e ...) 59 | (thunk (when locked? (send this lock #t)))))])) 60 | 61 | (define/public (set-error e) 62 | (unlocked 63 | (send this reset) 64 | (send this change-style (send this text-style)) 65 | (send this insert (exn-message e) 0 (send this last-position))) 66 | (send this scroll-to-position 0)) 67 | 68 | (define/public (reset) 69 | (unlocked 70 | (send this insert "" 0 (send this last-position)) 71 | (send this change-style (send this text-style)))) 72 | 73 | (define/public (spaces n) 74 | (send this change-style (send this text-style)) 75 | (send this insert (build-string n (lambda (i) #\space)))) 76 | 77 | (define/public (space) (spaces 1)) 78 | 79 | (define/public (indent) 80 | (spaces (indentation))) 81 | 82 | (define/public (start-line) 83 | (indent)) 84 | 85 | (define/public (terpri) 86 | (send this change-style (send this text-style)) 87 | (send this insert "\n") 88 | (start-line)) 89 | 90 | (define (l) 91 | (send this change-style (send this parenthesis-style)) 92 | (send this insert "(") 93 | (send this change-style (send this text-style))) 94 | 95 | (define (r) 96 | (send this change-style (send this parenthesis-style)) 97 | (send this insert ")") 98 | (send this change-style (send this text-style))) 99 | 100 | (define-syntax parens 101 | (syntax-rules () 102 | ((_ e ...) 103 | (begin (l) 104 | (indented 1 e ...) 105 | (r))))) 106 | 107 | (define-syntax η 108 | (syntax-rules () 109 | [(η x) (lambda () (x))])) 110 | 111 | (define (top-binder? sym) 112 | (and (symbol? sym) 113 | (or (eqv? sym 'Pi) 114 | (eqv? sym 'Π) 115 | (eqv? sym 'Sigma) 116 | (eqv? sym 'Σ)))) 117 | (define (ind? sym) 118 | (and (symbol? sym) 119 | (let ([str (symbol->string sym)]) 120 | (and (>= (string-length str) 4) 121 | (string=? (substring str 0 4) "ind-"))))) 122 | 123 | (define (sep s op args) 124 | (match args 125 | ['() (void)] 126 | [(list b) (op b)] 127 | [(cons b bs) (op b) (s) (sep s op bs)])) 128 | 129 | 130 | (define (vsep op args) 131 | (sep (η terpri) op args)) 132 | (define (hsep op args) 133 | (sep (η space) op args)) 134 | 135 | (define (annots bindings) 136 | (define (print-binding b) 137 | (match b 138 | [(list x ty) 139 | (parens 140 | (print-var x) 141 | (space) 142 | (indented (+ (string-length (symbol->string x)) 2) 143 | (print-pie ty)))])) 144 | (vsep print-binding bindings)) 145 | 146 | (define (atomic? x) 147 | (match x 148 | [(? symbol?) #t] 149 | [(? number?) #t] 150 | [(list 'quote _) #t] 151 | [_ #f])) 152 | 153 | (define/public (print-tycon c) 154 | (send this change-style (send this type-constructor-style)) 155 | (send this insert (symbol->string c)) 156 | (send this change-style (send this text-style))) 157 | 158 | (define/public (print-con c) 159 | (send this change-style (send this data-constructor-style)) 160 | (send this insert (symbol->string c)) 161 | (send this change-style (send this text-style))) 162 | 163 | (define/public (print-atom c) 164 | (send this change-style (send this data-constructor-style)) 165 | (send this insert "'") 166 | (send this insert (symbol->string c)) 167 | (send this change-style (send this text-style))) 168 | 169 | (define/public (print-lit x) 170 | (send this change-style (send this data-constructor-style)) 171 | (send this insert (format "~a" x)) 172 | (send this change-style (send this text-style))) 173 | 174 | (define/public (print-elim c) 175 | (send this change-style (send this keyword-style)) 176 | (send this insert (symbol->string c)) 177 | (send this change-style (send this text-style))) 178 | 179 | (define/public (print-var c) 180 | (send this change-style (send this var-style)) 181 | (send this insert (symbol->string c)) 182 | (send this change-style (send this text-style))) 183 | 184 | (define (elim? x) 185 | (if (memv x '(which-Nat ind-Nat iter-Nat rec-Nat ind-Vec head tail car cdr ind-Absurd the)) 186 | #t 187 | #f)) 188 | 189 | (define (tycon? x) 190 | (if (memv x '(U Π Pi Σ Sigma Nat Atom Absurd Trivial Pair -> Vec List Either)) 191 | #t 192 | #f)) 193 | 194 | (define (con? x) 195 | (if (memv x '(cons λ lambda add1 zero :: vec:: nil vecnil sole left right)) 196 | #t 197 | #f)) 198 | 199 | (define (print-pie expr) 200 | ;; Always display something, even if the print code is borked 201 | (with-handlers ([exn:fail? (lambda (e) 202 | (displayln (exn-message e)) 203 | (send this insert (format "~a" expr)))]) 204 | (match expr 205 | [(list (and b (or 'Π 'Σ)) 206 | bindings 207 | body) 208 | (parens (print-tycon b) 209 | (spaces 1) 210 | (indented (add1 (string-length (symbol->string b))) 211 | (parens (annots bindings))) 212 | (terpri) 213 | (print-pie body))] 214 | [(list (or 'lambda 'λ) (list-rest args) body) 215 | (parens 216 | (print-con 'λ) (space) (parens (hsep (lambda (x) (print-var x)) args)) 217 | (indented 1 (terpri) (print-pie body)))] 218 | [(cons '-> (app reverse (cons ret (app reverse args)))) 219 | (parens (print-tycon '->) 220 | (if (andmap atomic? args) 221 | (begin (space) 222 | (hsep print-pie args)) 223 | (indented 3 224 | (space) 225 | (vsep (lambda (x) (print-pie x)) 226 | args))) 227 | (indented 1 (terpri) (print-pie ret)) )] 228 | [(list 'quote x) (print-atom x)] 229 | [(list 'TODO loc ty) (print-elim 'TODO)] 230 | [(cons (? elim? e) args) 231 | (parens 232 | (print-elim e) 233 | (space) 234 | (match args 235 | [(list) (void)] 236 | [(cons target others) 237 | (indented (+ (string-length (symbol->string e)) 1) 238 | (print-pie target)) 239 | (when (pair? others) 240 | (indented 2 241 | (terpri) 242 | (vsep (lambda (x) (print-pie x)) others)))]))] 243 | [(cons (? con? c) args) 244 | (parens (print-con c) 245 | (space) 246 | (match args 247 | [(list) (void)] 248 | [(list (? atomic? arg)) 249 | (print-pie arg)] 250 | [(list arg) 251 | (indented 2 252 | (terpri) 253 | (print-pie arg))] 254 | [(cons fst others) 255 | (indented (+ (string-length (symbol->string c)) 1) 256 | (print-pie fst)) 257 | (indented 2 258 | (terpri) 259 | (vsep (lambda (x) (print-pie x)) others))]))] 260 | [(list-rest (? symbol? op) (? atomic? arg) args) 261 | #:when (and (< (length args) 20) 262 | (andmap atomic? args)) 263 | (parens 264 | (hsep (lambda (x) 265 | (print-pie x)) 266 | (cons op (cons arg args))))] 267 | [(list-rest (? symbol? op) arg args) 268 | (parens (print-pie op) (space) 269 | (indented (add1 (string-length (symbol->string op))) 270 | (print-pie arg)) 271 | (indented 1 272 | (when (pair? args) 273 | (terpri) 274 | (vsep (lambda (x) (print-pie x)) 275 | args))))] 276 | [(list-rest op args) 277 | (parens (print-pie op) 278 | (indented 1 279 | (terpri) 280 | (vsep (lambda (x) (print-pie x)) 281 | args)))] 282 | [(? con? c) 283 | (print-con c)] 284 | [(? tycon? t) 285 | (print-tycon t)] 286 | [(? symbol? x) 287 | (print-var x)] 288 | [(? number? n) 289 | (print-lit n)] 290 | [other (send this insert (format "OOPS[~a]" other))]))) 291 | 292 | (define/public (pprint-pie expr (description "")) 293 | (unlocked 294 | (start-line) 295 | (indented (string-length description) 296 | (when (not (string=? description "")) 297 | (send this change-style (send this text-style)) 298 | (send this insert description)) 299 | (print-pie (resugar expr)))) 300 | (send this scroll-to-position 0)) 301 | 302 | (define/public (pprint-message msg) 303 | (unlocked 304 | (start-line) 305 | (for ([part msg]) 306 | (cond [(string? part) 307 | (send this change-style (send this text-style)) 308 | (send this insert part)] 309 | [else (indented 2 (terpri) (print-pie (resugar part))) (terpri)]))) 310 | (send this scroll-to-position 0)) 311 | 312 | (send this lock #t))) 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "pie") 3 | (define version "0.01") 4 | (define deps '(("base" #:version "6.5") 5 | "data-lib" "gui-lib" "slideshow-lib" "pict-lib" 6 | "typed-racket-lib" "typed-racket-more" 7 | "parser-tools-lib" "syntax-color-lib" 8 | "rackunit-lib")) 9 | (define pkg-desc "A little dependently typed language to be used with The Little Typer") 10 | 11 | (define build-deps '("todo-list" "scribble-lib" "racket-doc" "sandbox-lib" 12 | "rackunit-lib")) 13 | (define scribblings '(("pie.scrbl" () (language) "pie"))) 14 | -------------------------------------------------------------------------------- /interactive-editing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match racket/format) 3 | (provide auto more-auto) 4 | 5 | (define (auto type) 6 | (~a (auto-aux 1 type))) 7 | 8 | (define (more-auto type) 9 | (~a (auto-aux 50 type))) 10 | 11 | (define (auto-aux depth type) 12 | (if (zero? depth) 13 | 'TODO 14 | (match type 15 | [`(Π ((,x ,A)) ,B) 16 | `(λ (,x) ,(auto-aux (sub1 depth) B))] 17 | [`(Σ ((,x ,A)) ,D) 18 | `(cons ,(auto-aux (sub1 depth) A) 19 | ,(auto-aux (sub1 depth) D))] 20 | ['Trivial 'sole] 21 | [`(Vec ,E zero) 'vecnil] 22 | [`(Vec ,E (add1 ,len)) 23 | `(vec:: ,(auto-aux (sub1 depth) E) 24 | ,(auto-aux (sub1 depth) `(Vec ,E ,len)))] 25 | [else 'TODO]))) 26 | -------------------------------------------------------------------------------- /locations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide location? 3 | syntax->location 4 | (rename-out [location-syntax location->syntax]) 5 | location->srcloc 6 | location-for-info? 7 | not-for-info) 8 | 9 | (struct location (syntax for-info?)) 10 | 11 | (define (syntax->location stx) 12 | (location stx #t)) 13 | 14 | (define (not-for-info loc) 15 | (location (location-syntax loc) #f)) 16 | 17 | (define (location->srcloc loc) 18 | (define stx (location-syntax loc)) 19 | (list (format "~a" (syntax-source stx)) 20 | (syntax-line stx) 21 | (syntax-column stx) 22 | (syntax-position stx) 23 | (syntax-span stx))) 24 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base racket/match racket/string racket/format) 4 | (for-syntax (for-syntax racket/base)) 5 | (for-syntax syntax/srcloc)) 6 | (require (for-syntax "parser.rkt")) 7 | (require (for-syntax (except-in "basics.rkt" var-name? go-on))) 8 | (require (for-syntax "rep.rkt" "typechecker.rkt" (only-in "normalize.rkt" read-back-ctx))) 9 | (require "basics.rkt" "rep.rkt" "parser.rkt" (only-in "normalize.rkt" val-of-ctx)) 10 | (require (for-syntax syntax/parse) 11 | (for-syntax (for-syntax syntax/parse))) 12 | (require "serialization.rkt") 13 | (require (for-syntax "serialization.rkt")) 14 | (require "pie-err.rkt" (for-syntax "pie-err.rkt")) 15 | (require "resugar.rkt" (for-syntax "resugar.rkt")) 16 | (require "pretty.rkt" (for-syntax "pretty.rkt")) 17 | (require (for-syntax "show-goal.rkt")) 18 | (require racket/port (for-syntax racket/port)) 19 | (require (prefix-in kw: "pie-info.rkt") 20 | (for-syntax (prefix-in kw: "pie-info.rkt"))) 21 | 22 | (require (rename-in typed/racket [#%module-begin mod])) 23 | 24 | (provide (rename-out [pie-module-begin #%module-begin] 25 | [pie-top-interaction #%top-interaction] 26 | [pie-top #%top] 27 | [pie-datum #%datum]) 28 | (for-syntax (rename-out [pie-top #%top] 29 | [pie-datum #%datum])) 30 | the-pie-ctx 31 | list 32 | match norm 33 | (rename-out [kw:U U] 34 | [kw:Nat Nat] [kw:zero zero] [kw:add1 add1] [kw:which-Nat which-Nat] [kw:iter-Nat iter-Nat] [kw:rec-Nat rec-Nat] [kw:ind-Nat ind-Nat] 35 | [kw:-> ->] [kw:→ →] [kw:Π Π] [kw:λ λ] [kw:Pi Pi] [kw:∏ ∏] [kw:lambda lambda] 36 | [kw:quote quote] [kw:Atom Atom] 37 | [kw:car car] [kw:cdr cdr] [kw:cons cons] [kw:Σ Σ] [kw:Sigma Sigma] [kw:Pair Pair] 38 | [kw:Trivial Trivial] [kw:sole sole] 39 | [kw:List List] [kw::: ::] [kw:nil nil] [kw:rec-List rec-List] [kw:ind-List ind-List] 40 | [kw:Absurd Absurd] [kw:ind-Absurd ind-Absurd] 41 | [kw:= =] [kw:same same] [kw:replace replace] [kw:trans trans] [kw:cong cong] [kw:symm symm] 42 | [kw:Vec Vec] [kw:vecnil vecnil] [kw:vec:: vec::] [kw:head head] [kw:tail tail] [kw:ind-Vec ind-Vec] 43 | [kw:Either Either] [kw:left left] [kw:right right] [kw:ind-Either ind-Either] 44 | [kw:TODO TODO] [kw:the the] 45 | [kw:claim claim] [kw:define define] [kw:check-same check-same]) 46 | (all-from-out "pie-info.rkt") 47 | (for-syntax (all-from-out "pie-info.rkt"))) 48 | 49 | (begin-for-syntax 50 | (define-syntax (go-on stx) 51 | (syntax-parse stx 52 | [(go-on () e) (syntax/loc stx e)] 53 | [(go-on ((p0 b0) (p b) ...) e) 54 | (syntax/loc stx 55 | (match b0 56 | [(go p0) (go-on ((p b) ...) e)] 57 | [(stop where msg) (stop where msg)]))]))) 58 | 59 | (begin-for-syntax 60 | (require "tooltip.rkt" (only-in "locations.rkt" location->syntax)) 61 | (define holes (box '())) 62 | (define (a-or-an t) 63 | (match t 64 | [`(,c . ,_) 65 | (case c 66 | [(-> → Either = add1 iter-Nat ind-Nat ind-List ind-Absurd ind-Vec ind-Either) 67 | "an"] 68 | [else "a"])] 69 | ['Atom "an"] 70 | [_ "a"])) 71 | (define (hook loc what) 72 | (when (and (not (eqv? loc #f))) 73 | (define loc-stx (location->syntax loc)) 74 | (define start (sub1 (source-location-position loc-stx))) 75 | (define end (sub1 (+ (source-location-position loc-stx) 76 | (source-location-span loc-stx)))) 77 | (define loc-stx-str 78 | (let ([src (syntax->datum loc-stx)]) 79 | (let ([test-str (format "~a" src)]) 80 | (if (> (string-length test-str) 40) 81 | (match src 82 | [(cons op args) (format "(~a ...)" op)] 83 | [_ (string-append (substring test-str 0 37) "...")]) 84 | test-str)))) 85 | (match what 86 | ['definition 87 | (void)] 88 | [`(binding-site ,t) 89 | (attach-tooltip #'a-stx loc-stx (format "Variable with type:\n~a" 90 | (with-output-to-string 91 | (lambda () 92 | (pprint-pie (resugar t))))))] 93 | [`(is-type ,e) 94 | (attach-tooltip #'a-stx loc-stx "A type")] 95 | [`(has-type ,t) 96 | (let ([sugary (resugar t)]) 97 | (attach-tooltip #'a-stx loc-stx (format "~a\nis ~a:\n~a" 98 | loc-stx-str 99 | (a-or-an sugary) 100 | (with-output-to-string 101 | (lambda () 102 | (pprint-pie sugary))))))] 103 | [`(TODO ,Γ ,t) 104 | (let ([sugary (resugar t)]) 105 | (attach-tooltip #'a-stx loc-stx (format "Will be ~a:\n~a" 106 | (a-or-an sugary) 107 | (with-output-to-string 108 | (lambda () 109 | (pprint-pie sugary)))))) 110 | (set-box! holes (cons (list loc-stx Γ t) (unbox holes)))] 111 | [_ (void)]) 112 | (void))) 113 | (pie-info-hook hook)) 114 | 115 | (begin-for-syntax 116 | (struct todo-item (full summary) #:prefab) 117 | (struct command (name module-path function arguments) #:prefab)) 118 | 119 | (define-syntax (pie-module-begin stx) 120 | (syntax-parse stx 121 | [(_ form ...) 122 | (define Γ 123 | (with-handlers ([exn:fail:pie? 124 | ;; If there's an error, log all the tooltips we've 125 | ;; generated so far so the user gets some feedback. 126 | (λ (e) (log-all-tooltips!) (raise e))]) 127 | (let loop ([forms (syntax->list #'(form ...))] 128 | [Γ init-ctx]) 129 | (cond 130 | [(null? forms) 131 | Γ] 132 | [else 133 | (match (parse-pie-decl (car forms)) 134 | [`(claim ,f ,f-loc ,ty) 135 | (match (add-claim Γ f f-loc ty) 136 | [(go new-Γ) 137 | (loop (cdr forms) new-Γ)] 138 | [(stop where why) 139 | (raise-pie-error where why)])] 140 | [`(definition ,f ,f-loc ,e) 141 | (match (add-def Γ f f-loc e) 142 | [(go new-Γ) 143 | (loop (cdr forms) new-Γ)] 144 | [(stop where why) 145 | (raise-pie-error where why)])] 146 | [`(check-same ,loc ,ty ,e1 ,e2) 147 | (match (check-same Γ loc ty e1 e2) 148 | [(go _) 149 | (loop (cdr forms) Γ)] 150 | [(stop where why) 151 | (raise-pie-error where why)])] 152 | [`(expression ,e) 153 | (match (norm Γ e) 154 | [(go out) 155 | (begin (pprint-pie (resugar out)) 156 | (printf "\n") 157 | (loop (cdr forms) Γ))] 158 | [(stop where why) 159 | (raise-pie-error where why)])])])))) 160 | (log-all-tooltips!) 161 | (define ctx-string (dump (read-back-ctx Γ))) 162 | (with-syntax ([ctx-string ctx-string] 163 | [(hole ...) 164 | (for/list ([info (reverse (unbox holes))]) 165 | (match-define (list loc Γ t) 166 | info) 167 | (match-define (list hole-summary hole-details) 168 | (goal->strings loc Γ t)) 169 | 170 | (define hole-output-str 171 | (string-append 172 | (source-location->prefix loc) 173 | ;; Check whether there are free local variables 174 | (if (ormap (lambda (H) 175 | (match H 176 | [(list _ (list 'free _)) #t] 177 | [_ #f])) 178 | Γ) 179 | ;; If there are free vars, print the 180 | ;; version with the horizontal line 181 | (string-append "TODO:\n" 182 | hole-details) 183 | ;; If no free vars, show only the goal type. 184 | (string-append "TODO: " 185 | (if (string-contains? hole-summary "\n") 186 | (string-append "\n" 187 | (indent-string 1 hole-summary)) 188 | hole-summary))) 189 | "\n")) 190 | (syntax-property 191 | (syntax-property 192 | (quasisyntax/loc loc (displayln #,hole-output-str)) 193 | 'todo 194 | (todo-item 195 | hole-details 196 | hole-summary)) 197 | 'editing-command 198 | (list (command "Auto" 'pie/interactive-editing 'auto (list t)) 199 | (command "More Auto" 'pie/interactive-editing 'more-auto (list t)))))]) 200 | 201 | (syntax/loc stx 202 | (#%module-begin 203 | (pie-decl->binders form) ... 204 | (set-box! the-pie-ctx (val-of-ctx (restore ctx-string))) 205 | (void (list hole ...)))))])) 206 | 207 | 208 | (define-syntax (pie-top stx) 209 | (syntax-parse stx 210 | [(_ . x) #''x])) 211 | 212 | (begin-for-syntax 213 | (define-syntax pie-top 214 | (syntax-rules () 215 | [(_ . x) 'x]))) 216 | 217 | 218 | (define-syntax (pie-datum stx) 219 | (syntax-parse stx 220 | [(_ . x) #''x])) 221 | 222 | (begin-for-syntax 223 | (define-syntax pie-datum 224 | (syntax-rules () 225 | [(_ . x) 'x]))) 226 | 227 | (define the-pie-ctx (box init-ctx)) 228 | 229 | (define-syntax (pie-top-interaction stx) 230 | (syntax-parse stx 231 | [(_ . e) 232 | (syntax/loc stx 233 | (match (parse-pie-decl #'e) 234 | [`(expression ,expr) 235 | (define Γ (unbox the-pie-ctx)) 236 | (define n (norm Γ expr)) 237 | (match n 238 | [(go out) 239 | (pprint-pie (resugar out))] 240 | [(stop where what) 241 | (raise-pie-error where what)])] 242 | [`(check-same ,loc ,ty ,e1 ,e2) 243 | (match (check-same (unbox the-pie-ctx) loc ty e1 e2) 244 | [(go _) 245 | (void)] 246 | [(stop where why) 247 | (raise-pie-error where why)])] 248 | [_ (raise-syntax-error #f "The Pie REPL does not support adding new definitions. Please load a file containing Pie code." #'e)]))])) 249 | 250 | (module reader syntax/module-reader 251 | pie 252 | #:info (lambda (k v default-filter) 253 | (case k 254 | [(drracket:default-filters) 255 | '(("Pie Sources" "*.pie"))] 256 | [(drracket:default-extension) 257 | "pie"] 258 | [(drracket:opt-out-toolbar-buttons) 259 | '(debug-tool)] 260 | [(drracket:indentation) 261 | (lambda (txt pos) 262 | (and-let* ([line (send txt position-paragraph pos)] 263 | [line-start (send txt paragraph-start-position line)] 264 | [sexp-start (send txt find-up-sexp line-start)] 265 | [buffer-end-pos (send txt last-position)] 266 | [op-end (send txt get-forward-sexp (add1 sexp-start))] 267 | [op-start (send txt get-backward-sexp op-end)] 268 | [indent-basis 269 | (- op-start 270 | (send txt paragraph-start-position 271 | (send txt position-paragraph op-start)))] 272 | [default-indent (+ 1 indent-basis)] 273 | [op (string->symbol (send txt get-text op-start op-end #t))]) 274 | (define in-Pi-or-Sigma? 275 | (and-let* ([grandparent-sexp-start (send txt find-up-sexp sexp-start)] 276 | [grand-op-end (send txt get-forward-sexp (add1 grandparent-sexp-start))] 277 | [grand-op-start (send txt get-backward-sexp grand-op-end)] 278 | [grand-op (send txt get-text grand-op-start grand-op-end)]) 279 | (if (member grand-op '("Pi" "Π" "∏" "Sigma" "Σ")) 280 | #t 281 | #f))) 282 | (define real-op 283 | (match op 284 | ['lambda 'λ] 285 | ['Pi 'Π] 286 | ['∏ 'Π] 287 | ['Sigma 'Σ] 288 | ['-> '→] 289 | [other other])) 290 | 291 | (match real-op 292 | [(or 'which-Nat 'iter-Nat 'rec-Nat 'ind-Nat 293 | 'car 'cdr 'rec-List 'ind-List 'ind-Absurd 294 | 'replace 'cong 'trans 'symm 'head 'tail 'ind-Vec 295 | 'ind-Either) 296 | (define target-count 297 | (match real-op 298 | [(or 'trans 'ind-Vec) 2] 299 | [_ 1])) 300 | ;; find if last 301 | (let ([targets-end 302 | (let loop ([i target-count] 303 | [pos (add1 sexp-start)]) 304 | (if (> i 0) 305 | (loop (sub1 i) 306 | (send txt get-forward-sexp pos)) 307 | pos))]) 308 | (and targets-end 309 | (let ([first-line-sexp-end (send txt get-forward-sexp pos)]) 310 | (if (or (not first-line-sexp-end) 311 | (>= first-line-sexp-end targets-end)) 312 | (+ 1 indent-basis) 313 | (+ 4 indent-basis)))))] 314 | [other 315 | #:when (or (eqv? op '->) (eqv? op '→)) 316 | (and-let* ([sexp-end (send txt get-forward-sexp sexp-start)] 317 | [last-arg-start (send txt get-backward-sexp (sub1 sexp-end))] 318 | [first-arg-start (send txt get-backward-sexp 319 | (send txt get-forward-sexp op-end))] 320 | [last-arg-end (send txt get-forward-sexp last-arg-start)] 321 | [first-line-sexp-end (send txt get-forward-sexp pos)] 322 | [->-indent-basis 323 | (- first-arg-start 324 | (send txt paragraph-start-position 325 | (send txt position-paragraph first-arg-start)))]) 326 | (if (>= first-line-sexp-end last-arg-end) 327 | (+ 1 indent-basis) 328 | (+ ->-indent-basis)))] 329 | [_ 330 | #:when in-Pi-or-Sigma? 331 | ;; Use normal Racket sexp indenting 332 | #f] 333 | [_ default-indent])))] 334 | [(color-lexer) 335 | (lambda (in) 336 | (define-values (tok pie-style paren start end) (pie-lexer in)) 337 | (values tok 338 | (case pie-style 339 | [(type-ctor data-ctor) 'constant] 340 | [else pie-style]) 341 | paren 342 | start 343 | end))] 344 | [else (default-filter k v)])) 345 | (require "gui/pie-lexer.rkt") 346 | (require racket/class racket/match) 347 | (require (for-syntax racket/base syntax/parse)) 348 | (define-syntax (and-let* stx) 349 | (syntax-parse stx 350 | [(_ () e ...) #'(let () e ...)] 351 | [(_ ((x:id e1) (y:id e2) ...) e ...) 352 | #'(let ((x e1)) 353 | (and x (and-let* ((y e2) ...) e ...)))])) 354 | ) 355 | 356 | -------------------------------------------------------------------------------- /normalize.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | ;;; normalize.rkt 4 | ;;; 5 | ;;; This file implements normalization by evaluation. 6 | 7 | (require "basics.rkt") 8 | (require (for-syntax racket/base syntax/parse)) 9 | (require/typed "locations.rkt" (location->srcloc (-> Loc Srcloc))) 10 | (provide (all-defined-out)) 11 | 12 | 13 | ;;; Call-by-need evaluation 14 | 15 | ;; Pie is a total language, which means that every program will 16 | ;; eventually terminate. Because the steps taken during evaluation are 17 | ;; completely deterministic, and because Pie is total, it is 18 | ;; acceptable to choose any order of evaluation. 19 | 20 | ;; On the other hand, many useful Pie programs will take many more 21 | ;; evaluation steps to complete when using strict evaluation. For 22 | ;; instance, consider zerop from chapter 3 of The Little Typer. zerop 23 | ;; returns 'nil when its argument's value has add1 at the top, or 't 24 | ;; if it is zero. If (zerop (double 10000)) is evaluated strictly, the 25 | ;; evaluator will first need to find out that (double 10000) is 20000, 26 | ;; requiring 10000 steps. On the other hand, if it is evaluated 27 | ;; lazily, then it will need only one step to discover that the value 28 | ;; has add1 at the top. 29 | 30 | ;; Pie uses call-by-need evaluation. This means that if two different 31 | ;; expressions make use of some expression, such as a definition, then 32 | ;; evaluation steps will be shared between them and will not need to 33 | ;; be repeated. 34 | 35 | ;; Call-by-need evaluation is achieved by introducing a new value that 36 | ;; represents evaluation that has not yet been performed, but should 37 | ;; instead be performed on demand. That value, which doesn't represent 38 | ;; any value in the Pie sense of the word, is called DELAY and is 39 | ;; defined in basics.rkt. When DELAY represents work that has not yet 40 | ;; been done, it is filled with a special kind of closure called 41 | ;; DELAY-CLOS that pairs an expression with its environment. 42 | 43 | ;; Not every DELAY represents evaluation that has not yet been 44 | ;; performed. Some represent evaluation that was already demanded by 45 | ;; some other operator. The work is shared by updating the contents of 46 | ;; DELAY with an actual value. 47 | 48 | ;; later is used to delay evaluation by constructing a DELAY value 49 | ;; that contains a DELAY-CLOS closure. 50 | (: later (-> Env Core Value)) 51 | (define (later ρ expr) 52 | (DELAY (box (DELAY-CLOS ρ expr)))) 53 | 54 | ;; undelay is used to find the value that is contained in a 55 | ;; DELAY-CLOS closure by invoking the evaluator. 56 | (: undelay (-> DELAY-CLOS Value)) 57 | (define (undelay c) 58 | (match c 59 | [(DELAY-CLOS ρ expr) 60 | (now (val-of ρ expr))])) 61 | 62 | ;; now demands the _actual_ value represented by a DELAY. If the value 63 | ;; is a DELAY-CLOS, then it is computed using undelay. If it is 64 | ;; anything else, then it has already been computed, so it is 65 | ;; returned. 66 | ;; 67 | ;; now should be used any time that a value is inspected to see what 68 | ;; form it has, because those situations require that the delayed 69 | ;; evaluation steps be carried out. 70 | (: now (-> Value Value)) 71 | (define (now v) 72 | (match v 73 | [(DELAY (and b (box v))) 74 | (if (DELAY-CLOS? v) 75 | (let ((the-value (undelay v))) 76 | (set-box! b the-value) 77 | the-value) 78 | v)] 79 | [other other])) 80 | 81 | ;; !! is a version of now that works in a pattern. This is convenient 82 | ;; because it is sometimes necessary to inspect part of a value that 83 | ;; is not at the top - for instance, when checking vecnil, it is 84 | ;; important that the length in the Vec type's value be precisely 85 | ;; zero. 86 | (define-match-expander !! 87 | (lambda (pat-stx) 88 | (syntax-parse pat-stx 89 | [(!! p) 90 | (syntax/loc pat-stx 91 | (app now p))]))) 92 | 93 | 94 | 95 | ;;; Helper for constructing nested Π types 96 | 97 | (define-syntax (Π-type stx) 98 | (syntax-parse stx 99 | [(_ () ret) (syntax/loc stx ret)] 100 | [(_ ((x:id arg-t) b ...) ret) 101 | (syntax/loc stx 102 | (PI 'x arg-t (HO-CLOS (λ (x) (Π-type (b ...) ret)))))])) 103 | 104 | 105 | ;;; The evaluator 106 | 107 | ;; Functions whose names begin with "do-" are helpers that implement 108 | ;; the corresponding eliminator. 109 | 110 | (: do-ap (-> Value Value Value)) 111 | (define (do-ap rator-v rand-v) 112 | (match (now rator-v) 113 | [(LAM x c) 114 | (val-of-closure c rand-v)] 115 | [(NEU (!! (PI x A c)) 116 | ne) 117 | (NEU (val-of-closure c rand-v) 118 | (N-ap ne (THE A rand-v)))])) 119 | 120 | (: do-which-Nat (-> Value Value Value Value Value)) 121 | (define (do-which-Nat tgt-v b-tv b-v s-v) 122 | (match (now tgt-v) 123 | ['ZERO b-v] 124 | [(ADD1 n-1v) 125 | (do-ap s-v n-1v)] 126 | [(NEU (!! 'NAT) ne) 127 | (NEU b-tv 128 | (N-which-Nat ne 129 | (THE b-tv b-v) 130 | (THE (Π-type ((n 'NAT)) b-tv) 131 | s-v)))])) 132 | 133 | (: do-iter-Nat (-> Value Value Value Value Value)) 134 | (define (do-iter-Nat tgt-v b-tv b-v s-v) 135 | (match (now tgt-v) 136 | ['ZERO b-v] 137 | [(ADD1 n-1v) 138 | (do-ap s-v (do-iter-Nat n-1v b-tv b-v s-v))] 139 | [(NEU (!! 'NAT) ne) 140 | (NEU b-tv 141 | (N-iter-Nat ne 142 | (THE b-tv b-v) 143 | (THE (Π-type ((n b-tv)) b-tv) 144 | s-v)))])) 145 | 146 | (: do-rec-Nat (-> Value Value Value Value Value)) 147 | (define (do-rec-Nat tgt-v b-tv b-v s-v) 148 | (match (now tgt-v) 149 | ['ZERO b-v] 150 | [(ADD1 n-1v) 151 | (do-ap 152 | (do-ap s-v n-1v) 153 | (do-rec-Nat n-1v b-tv b-v s-v))] 154 | [(NEU (!! 'NAT) ne) 155 | (NEU b-tv 156 | (N-rec-Nat ne 157 | (THE b-tv b-v) 158 | (THE (Π-type ((n-1 'NAT) 159 | (ih b-tv)) 160 | b-tv) 161 | s-v)))])) 162 | 163 | 164 | (: do-ind-Nat (-> Value Value Value Value Value)) 165 | (define (do-ind-Nat tgt-v mot-v b-v s-v) 166 | (match (now tgt-v) 167 | ['ZERO b-v] 168 | [(ADD1 n-1v) 169 | (do-ap (do-ap s-v n-1v) 170 | (do-ind-Nat n-1v mot-v b-v s-v))] 171 | [(NEU (!! 'NAT) ne) 172 | (NEU (do-ap mot-v tgt-v) 173 | (N-ind-Nat 174 | ne 175 | (THE (Π-type ((x 'NAT)) 'UNIVERSE) 176 | mot-v) 177 | (THE (do-ap mot-v 'ZERO) b-v) 178 | (THE (Π-type ((n-1 'NAT) 179 | (ih (do-ap mot-v n-1))) 180 | (do-ap mot-v (ADD1 n-1))) 181 | s-v)))])) 182 | 183 | (: do-car (-> Value Value)) 184 | (define (do-car p-v) 185 | (match (now p-v) 186 | [(CONS a d) a] 187 | [(NEU (!! (SIGMA x A c)) ne) 188 | (NEU A (N-car ne))])) 189 | 190 | (: do-cdr (-> Value Value)) 191 | (define (do-cdr p-v) 192 | (match (now p-v) 193 | [(CONS a d) 194 | d] 195 | [(NEU (!! (SIGMA x A c)) ne) 196 | (NEU (val-of-closure c (do-car p-v)) 197 | (N-cdr ne))])) 198 | 199 | (: do-ind-List (-> Value Value Value Value Value)) 200 | (define (do-ind-List tgt-v mot-v b-v s-v) 201 | (match (now tgt-v) 202 | ['NIL b-v] 203 | [(LIST:: h t) 204 | (do-ap 205 | (do-ap (do-ap s-v h) t) 206 | (do-ind-List t mot-v b-v s-v))] 207 | [(NEU (!! (LIST E)) ne) 208 | (let ([mot-tv (Π-type ((xs (LIST E))) 'UNIVERSE)]) 209 | (NEU (do-ap mot-v tgt-v) 210 | (N-ind-List 211 | ne 212 | (THE mot-tv mot-v) 213 | (THE (do-ap mot-v 'NIL) b-v) 214 | (THE (Π-type ((h E) 215 | (t (LIST E)) 216 | (ih (do-ap mot-v t))) 217 | (do-ap mot-v (LIST:: h t))) 218 | s-v))))])) 219 | 220 | (: do-rec-List (-> Value Value Value Value Value)) 221 | (define (do-rec-List tgt-v b-tv b-v s-v) 222 | (match (now tgt-v) 223 | ['NIL b-v] 224 | [(LIST:: h t) 225 | (do-ap (do-ap (do-ap s-v h) t) 226 | (do-rec-List t b-tv b-v s-v))] 227 | [(NEU (!! (LIST E)) ne) 228 | (NEU b-tv 229 | (N-rec-List 230 | ne 231 | (THE b-tv b-v) 232 | (THE (Π-type ((h E) 233 | (t (LIST E)) 234 | (ih b-tv)) 235 | b-tv) 236 | s-v)))])) 237 | 238 | (: do-ind-Absurd (-> Value Value Value)) 239 | (define (do-ind-Absurd tgt-v mot-v) 240 | (match (now tgt-v) 241 | [(NEU (!! ABSURD) ne) 242 | (NEU mot-v 243 | (N-ind-Absurd ne (THE 'UNIVERSE mot-v)))])) 244 | 245 | (: do-replace (-> Value Value Value Value)) 246 | (define (do-replace tgt-v mot-v b-v) 247 | (match (now tgt-v) 248 | [(SAME v) 249 | b-v] 250 | [(NEU (!! (EQUAL A-v from-v to-v)) 251 | ne) 252 | (NEU (do-ap mot-v to-v) 253 | (N-replace ne 254 | (THE (Π-type ((x A-v)) 'UNIVERSE) 255 | mot-v) 256 | (THE (do-ap mot-v from-v) 257 | b-v)))])) 258 | 259 | (: do-trans (-> Value Value Value)) 260 | (define (do-trans tgt-1v tgt-2v) 261 | (match* ((now tgt-1v) (now tgt-2v)) 262 | [((SAME v) (SAME _)) 263 | (SAME v)] 264 | [((SAME from-v) (NEU (!! (EQUAL A-v _ to-v)) ne2)) 265 | (NEU (EQUAL A-v from-v to-v) 266 | (N-trans2 (THE (EQUAL A-v from-v from-v) (SAME from-v)) 267 | ne2))] 268 | [((NEU (!! (EQUAL A-v from-v _)) ne1) (SAME to-v)) 269 | (NEU (EQUAL A-v from-v to-v) 270 | (N-trans1 ne1 (THE (EQUAL A-v to-v to-v) (SAME to-v))))] 271 | [((NEU (!! (EQUAL A-v from-v _)) ne1) (NEU (!! (EQUAL _ _ to-v)) ne2)) 272 | (NEU (EQUAL A-v from-v to-v) 273 | (N-trans12 ne1 ne2))])) 274 | 275 | (: do-cong (-> Value Value Value Value)) 276 | (define (do-cong tgt-v B-v fun-v) 277 | (match (now tgt-v) 278 | [(SAME v) 279 | (SAME (do-ap fun-v v))] 280 | [(NEU (!! (EQUAL A-v from-v to-v)) ne) 281 | (NEU (EQUAL B-v (do-ap fun-v from-v) (do-ap fun-v to-v)) 282 | (N-cong ne (THE (Π-type ((x A-v)) B-v) fun-v)))])) 283 | 284 | (: do-symm (-> Value Value)) 285 | (define (do-symm tgt-v) 286 | (match (now tgt-v) 287 | [(SAME v) (SAME v)] 288 | [(NEU (!! (EQUAL A-v from-v to-v)) 289 | ne) 290 | (NEU (EQUAL A-v to-v from-v) 291 | (N-symm ne))])) 292 | 293 | (: do-ind-= (-> Value Value Value Value)) 294 | (define (do-ind-= tgt-v motive-v base-v) 295 | (match (now tgt-v) 296 | [(SAME v) base-v] 297 | [(NEU (!! (EQUAL A from to)) ne) 298 | (NEU (do-ap (do-ap motive-v to) tgt-v) 299 | (N-ind-= ne 300 | (THE (Π-type ((to A) 301 | (p (EQUAL A from to))) 302 | 'UNIVERSE) 303 | motive-v) 304 | (THE (do-ap (do-ap motive-v from) 305 | (SAME from)) 306 | base-v)))])) 307 | 308 | (: do-head (-> Value Value)) 309 | (define (do-head tgt-v) 310 | (match (now tgt-v) 311 | [(VEC:: hv tv) hv] 312 | [(NEU (!! (VEC Ev (!! (ADD1 len-1v)))) 313 | ne) 314 | (NEU Ev (N-head ne))])) 315 | 316 | (: do-tail (-> Value Value)) 317 | (define (do-tail tgt-v) 318 | (match (now tgt-v) 319 | [(VEC:: hv tv) tv] 320 | [(NEU (!! (VEC Ev (!! (ADD1 len-1v)))) ne) 321 | (NEU (VEC Ev len-1v) (N-tail ne))])) 322 | 323 | (: ind-Vec-step-type (-> Value Value Value)) 324 | (define (ind-Vec-step-type Ev mot-v) 325 | (Π-type ((k 'NAT) 326 | (e Ev) 327 | (es (VEC Ev k)) 328 | (ih (do-ap (do-ap mot-v k) es))) 329 | (do-ap (do-ap mot-v (ADD1 k)) (VEC:: e es)))) 330 | 331 | (: do-ind-Vec (-> Value Value Value Value Value Value)) 332 | (define (do-ind-Vec len-v vec-v mot-v b-v s-v) 333 | (match* ((now len-v) (now vec-v)) 334 | [('ZERO 'VECNIL) b-v] 335 | [((ADD1 len-1-v) (VEC:: h t)) 336 | (do-ap (do-ap (do-ap (do-ap s-v len-1-v) h) (do-tail vec-v)) 337 | (do-ind-Vec len-1-v t mot-v b-v s-v))] 338 | [((NEU (!! 'NAT) len) (NEU (!! (VEC Ev _)) ne)) 339 | (NEU (do-ap (do-ap mot-v len-v) vec-v) 340 | (N-ind-Vec12 len 341 | ne 342 | (THE (Π-type ((k 'NAT) 343 | (es (VEC Ev k))) 344 | 'UNIVERSE) 345 | mot-v) 346 | (THE (do-ap (do-ap mot-v 'ZERO) 'VECNIL) b-v) 347 | (THE (ind-Vec-step-type Ev mot-v) 348 | s-v)))] 349 | [(len-v (NEU (!! (VEC Ev _)) ne)) 350 | (NEU (do-ap (do-ap mot-v len-v) vec-v) 351 | (N-ind-Vec2 (THE 'NAT len-v) 352 | ne 353 | (THE (Π-type ((k 'NAT) 354 | (es (VEC Ev k))) 355 | 'UNIVERSE) 356 | mot-v) 357 | (THE (do-ap (do-ap mot-v 'ZERO) 'VECNIL) 358 | b-v) 359 | (THE (ind-Vec-step-type Ev mot-v) s-v)))])) 360 | 361 | (: do-ind-Either (-> Value Value Value Value Value)) 362 | (define (do-ind-Either tgt mot l r) 363 | (match (now tgt) 364 | [(LEFT x) 365 | (do-ap l x)] 366 | [(RIGHT x) 367 | (do-ap r x)] 368 | [(NEU (!! (EITHER Lv Rv)) ne) 369 | (let ([mot-tv (Π-type ((x (EITHER Lv Rv))) 'UNIVERSE)]) 370 | (NEU (do-ap mot tgt) 371 | (N-ind-Either ne 372 | (THE mot-tv mot) 373 | (THE (Π-type ((x Lv)) 374 | (do-ap mot (LEFT x))) 375 | l) 376 | (THE (Π-type ((x Rv)) 377 | (do-ap mot (RIGHT x))) 378 | r))))])) 379 | 380 | ;; The main evaluator is val-of. Instead of calling itself 381 | ;; recursively, it uses later to delay the evaluation of expressions 382 | ;; other than the outermost constructor or type constructor. 383 | 384 | (: val-of (-> Env Core Value)) 385 | (define (val-of ρ e) 386 | (match e 387 | [`(the ,t ,expr) (val-of ρ expr)] 388 | ['U 'UNIVERSE] 389 | ['Nat 'NAT] 390 | ['zero 'ZERO] 391 | [`(add1 ,n) (ADD1 (later ρ n))] 392 | [`(Π ((,x ,A)) ,B) 393 | (let ([A-v (later ρ A)]) 394 | (PI x A-v (FO-CLOS ρ x B)))] 395 | [`(λ (,x) ,b) 396 | (LAM x (FO-CLOS ρ x b))] 397 | [`(which-Nat ,tgt (the ,b-t ,b) ,s) 398 | (do-which-Nat (later ρ tgt) 399 | (later ρ b-t) 400 | (later ρ b) 401 | (later ρ s))] 402 | [`(iter-Nat ,tgt (the ,b-t ,b) ,s) 403 | (do-iter-Nat (later ρ tgt) 404 | (later ρ b-t) 405 | (later ρ b) 406 | (later ρ s))] 407 | [`(rec-Nat ,tgt (the ,b-t ,b) ,s) 408 | (do-rec-Nat (later ρ tgt) 409 | (later ρ b-t) 410 | (later ρ b) 411 | (later ρ s))] 412 | [`(ind-Nat ,tgt ,mot ,b ,s) 413 | (do-ind-Nat (later ρ tgt) 414 | (later ρ mot) 415 | (later ρ b) 416 | (later ρ s))] 417 | ['Atom 'ATOM] 418 | [`(Σ ((,x ,A)) ,D) 419 | (let ([A-v (later ρ A)]) 420 | (SIGMA x A-v (FO-CLOS ρ x D)))] 421 | [`(cons ,a ,d) (CONS (later ρ a) (later ρ d))] 422 | [`(car ,p) (do-car (later ρ p))] 423 | [`(cdr ,p) (do-cdr (later ρ p))] 424 | [`(quote ,a) #:when (symbol? a) (QUOTE a)] 425 | ['Trivial 'TRIVIAL] 426 | ['sole 'SOLE] 427 | ['nil 'NIL] 428 | [`(:: ,h ,t) (LIST:: (later ρ h) (later ρ t))] 429 | [`(List ,E) (LIST (later ρ E))] 430 | [`(ind-List ,tgt ,mot ,b ,s) 431 | (do-ind-List (later ρ tgt) 432 | (later ρ mot) 433 | (later ρ b) 434 | (later ρ s))] 435 | [`(rec-List ,tgt (the ,b-t ,b) ,s) 436 | (do-rec-List (later ρ tgt) 437 | (later ρ b-t) 438 | (later ρ b) 439 | (later ρ s))] 440 | [`Absurd 'ABSURD] 441 | [`(ind-Absurd ,tgt ,mot) 442 | (do-ind-Absurd (later ρ tgt) (later ρ mot))] 443 | [`(= ,A ,from ,to) 444 | (EQUAL (later ρ A) (later ρ from) (later ρ to))] 445 | [`(same ,e) 446 | (SAME (later ρ e))] 447 | [`(replace ,tgt ,mot ,b) 448 | (do-replace (later ρ tgt) (later ρ mot) (later ρ b))] 449 | [`(trans ,p1 ,p2) 450 | (do-trans (later ρ p1) (later ρ p2))] 451 | [`(cong ,p1 ,p2 ,p3) 452 | (do-cong (later ρ p1) (later ρ p2) (later ρ p3))] 453 | [`(symm ,p) 454 | (do-symm (later ρ p))] 455 | [`(ind-= ,tgt ,mot ,b) 456 | (do-ind-= (later ρ tgt) (later ρ mot) (later ρ b))] 457 | [`(Vec ,E ,len) 458 | (VEC (later ρ E) (later ρ len))] 459 | ['vecnil 'VECNIL] 460 | [`(vec:: ,h ,t) (VEC:: (later ρ h) (later ρ t))] 461 | [`(head ,es) (do-head (later ρ es))] 462 | [`(tail ,es) (do-tail (later ρ es))] 463 | [`(ind-Vec ,len ,es ,mot ,b ,s) 464 | (do-ind-Vec (later ρ len) 465 | (later ρ es) 466 | (later ρ mot) 467 | (later ρ b) 468 | (later ρ s))] 469 | [`(Either ,L ,R) (EITHER (later ρ L) (later ρ R))] 470 | [`(left ,l) (LEFT (later ρ l))] 471 | [`(right ,r) (RIGHT (later ρ r))] 472 | [`(ind-Either ,tgt ,mot ,l ,r) 473 | (do-ind-Either (later ρ tgt) 474 | (later ρ mot) 475 | (later ρ l) 476 | (later ρ r))] 477 | [`(,rator ,rand) 478 | (do-ap (later ρ rator) (later ρ rand))] 479 | [`(TODO ,where ,type) 480 | (NEU (later ρ type) (N-TODO where (later ρ type)))] 481 | [x 482 | (if (and (symbol? x) (var-name? x)) 483 | (var-val ρ x) 484 | (error (format "No evaluator for ~a" x)))])) 485 | 486 | 487 | ;;; Context serialization and deserialization 488 | 489 | ;; In order to support both type checking and a REPL, Pie needs to be 490 | ;; able to serialize contexts (which contain Pie values) into pure 491 | ;; S-expressions (which are simple data that can be saved to disk or 492 | ;; to a network). 493 | ;; 494 | ;; One disadvantage of the current approach is that laziness is 495 | ;; lost. In other words, every value in the context is strictly 496 | ;; evaluated as part of serializing it, which might make that process 497 | ;; slow if there are values that take a long time to compute. 498 | 499 | (: read-back-ctx (-> Ctx Serializable-Ctx)) 500 | (define (read-back-ctx Γ) 501 | (match Γ 502 | ['() 503 | '()] 504 | [(cons (cons x (free t)) Γ-next) 505 | (cons (list x (list 'free (read-back-type Γ-next t))) 506 | (read-back-ctx Γ-next))] 507 | [(cons (cons x (def t v)) Γ-next) 508 | (cons (list x (list 'def (read-back-type Γ-next t) (read-back Γ-next t v))) 509 | (read-back-ctx Γ-next))] 510 | [(cons (cons x (claim t)) Γ-next) 511 | (cons (list x (list 'claim (read-back-type Γ-next t))) 512 | (read-back-ctx Γ-next))])) 513 | 514 | (: val-of-ctx (-> Serializable-Ctx Ctx)) 515 | (define (val-of-ctx ctx-list) 516 | (match ctx-list 517 | ['() '()] 518 | [(cons (list x b) ctx-tail) 519 | (let ([Γ (val-of-ctx ctx-tail)]) 520 | (cons (cons x 521 | (match b 522 | [(list 'free t) (free (val-in-ctx Γ t))] 523 | [(list 'def t e) (def (val-in-ctx Γ t) (val-in-ctx Γ e))] 524 | [(list 'claim t) (claim (val-in-ctx Γ t))])) 525 | Γ))])) 526 | 527 | ;;; Normalization 528 | 529 | ;; Convert the value of a type back into the Core Pie syntax that 530 | ;; represents it. These read-back types are checked for sameness using 531 | ;; α-equiv?. 532 | (: read-back-type (-> Ctx Value Core)) 533 | (define (read-back-type Γ tv) 534 | (match (now tv) 535 | ['UNIVERSE 'U] 536 | ['NAT 'Nat] 537 | [(PI x A c) 538 | (let ((A-e (read-back-type Γ A)) 539 | (x^ (fresh Γ x))) 540 | `(Π ((,x^ ,A-e)) 541 | ,(let ((Γ/x^ (bind-free Γ x^ A))) 542 | (read-back-type Γ/x^ (val-of-closure c (NEU A (N-var x^)))))))] 543 | ['ATOM 'Atom] 544 | [(SIGMA x A c) 545 | (let ((A-e (read-back-type Γ A)) 546 | (x^ (fresh Γ x))) 547 | `(Σ ((,x^ ,A-e)) 548 | ,(let ((Γ/x^ (bind-free Γ x^ A))) 549 | (read-back-type Γ/x^ (val-of-closure c (NEU A (N-var x^)))))))] 550 | ['TRIVIAL 'Trivial] 551 | [(LIST E) `(List ,(read-back-type Γ E))] 552 | ['ABSURD 'Absurd] 553 | [(EQUAL Av fromv tov) 554 | `(= ,(read-back-type Γ Av) 555 | ,(read-back Γ Av fromv) 556 | ,(read-back Γ Av tov))] 557 | [(VEC Ev lenv) 558 | `(Vec ,(read-back-type Γ Ev) ,(read-back Γ 'NAT lenv))] 559 | [(EITHER Lv Rv) 560 | `(Either ,(read-back-type Γ Lv) ,(read-back-type Γ Rv))] 561 | [(NEU UNIVERSE ne) 562 | (read-back-neutral Γ ne)])) 563 | 564 | ;; Read back the Core Pie expression that represents a value. This 565 | ;; process is determined by the type, which is what allows η-expansion 566 | ;; to occur. 567 | (: read-back (-> Ctx Value Value Core)) 568 | (define (read-back Γ tv v) 569 | (match* ((now tv) (now v)) 570 | [('UNIVERSE v) (read-back-type Γ v)] 571 | [('NAT 'ZERO) 'zero] 572 | [('NAT (ADD1 n-1)) 573 | `(add1 ,(read-back Γ 'NAT n-1))] 574 | [((PI x A c) f) 575 | (let ((y (match f 576 | [(LAM y _) y] 577 | [_ x]))) 578 | (let ((x^ (fresh Γ y))) 579 | `(λ (,x^) 580 | ,(read-back 581 | (bind-free Γ x^ A) 582 | (val-of-closure c (NEU A (N-var x^))) 583 | (do-ap f (NEU A (N-var x^)))))))] 584 | [((SIGMA x A c) p-v) 585 | (let ((the-car (do-car p-v))) 586 | `(cons ,(read-back Γ A the-car) 587 | ,(read-back Γ 588 | (val-of-closure c the-car) 589 | (do-cdr p-v))))] 590 | [('ATOM (QUOTE a)) 591 | `(quote ,a)] 592 | [('TRIVIAL _) 'sole] ;; η-expansion 593 | [((LIST E) 'NIL) 'nil] 594 | [((LIST E) (LIST:: h t)) 595 | `(:: ,(read-back Γ E h) ,(read-back Γ (LIST E) t))] 596 | [('ABSURD (NEU _ ne)) 597 | ;; This type annotation is half of the η law. See the 598 | ;; implementation of α-equiv? for the other half. 599 | `(the Absurd ,(read-back-neutral Γ ne))] 600 | [((EQUAL Av _ _) (SAME v)) 601 | `(same ,(read-back Γ Av v))] 602 | [((VEC Ev (!! 'ZERO)) _) 'vecnil] 603 | [((VEC Ev (!! (ADD1 len-1v))) (VEC:: h t)) 604 | `(vec:: ,(read-back Γ Ev h) 605 | ,(read-back Γ (VEC Ev len-1v) t))] 606 | [((EITHER Lv Rv) (LEFT lv)) 607 | `(left ,(read-back Γ Lv lv))] 608 | [((EITHER Lv Rv) (RIGHT rv)) 609 | `(right ,(read-back Γ Rv rv))] 610 | [(_ (NEU _ ne)) 611 | (read-back-neutral Γ ne)])) 612 | 613 | ;; Read back a neutral expression. This process is not determined by 614 | ;; the type, because type-driven reading back has already occurred by 615 | ;; the time that read-back calls read-back-neutral. 616 | (: read-back-neutral (-> Ctx Neutral Core)) 617 | (define (read-back-neutral Γ ne) 618 | (match ne 619 | [(N-which-Nat tgt (THE b-tv b-v) (THE s-tv s-v)) 620 | `(which-Nat ,(read-back-neutral Γ tgt) 621 | (the ,(read-back-type Γ b-tv) 622 | ,(read-back Γ b-tv b-v)) 623 | ,(read-back Γ s-tv s-v))] 624 | [(N-iter-Nat tgt (THE b-tv b-v) (THE s-tv s-v)) 625 | `(iter-Nat ,(read-back-neutral Γ tgt) 626 | (the ,(read-back-type Γ b-tv) 627 | ,(read-back Γ b-tv b-v)) 628 | ,(read-back Γ s-tv s-v))] 629 | [(N-rec-Nat tgt (THE b-tv b-v) (THE s-tv s-v)) 630 | `(rec-Nat ,(read-back-neutral Γ tgt) 631 | (the ,(read-back-type Γ b-tv) 632 | ,(read-back Γ b-tv b-v)) 633 | ,(read-back Γ s-tv s-v))] 634 | [(N-ind-Nat tgt 635 | (THE mot-tv mot-v) 636 | (THE b-tv b-v) 637 | (THE s-tv s-v)) 638 | `(ind-Nat ,(read-back-neutral Γ tgt) 639 | ,(read-back Γ mot-tv mot-v) 640 | ,(read-back Γ b-tv b-v) 641 | ,(read-back Γ s-tv s-v))] 642 | [(N-car tgt) 643 | (ann `(car ,(read-back-neutral Γ tgt)) Core)] 644 | [(N-cdr tgt) 645 | (ann `(cdr ,(read-back-neutral Γ tgt)) Core)] 646 | [(N-ind-List tgt (THE mot-t mot) (THE b-t b) (THE s-t s)) 647 | `(ind-List ,(read-back-neutral Γ tgt) 648 | ,(read-back Γ mot-t mot) 649 | ,(read-back Γ b-t b) 650 | ,(read-back Γ s-t s))] 651 | [(N-rec-List tgt (THE b-t b) (THE s-t s)) 652 | `(rec-List ,(read-back-neutral Γ tgt) 653 | (the ,(read-back-type Γ b-t) 654 | ,(read-back Γ b-t b)) 655 | ,(read-back Γ s-t s))] 656 | [(N-ind-Absurd tgt (THE tv ttv)) 657 | ;; Here's some Absurd η. The rest is in α-equiv?. 658 | `(ind-Absurd (the Absurd ,(read-back-neutral Γ tgt)) 659 | ,(read-back Γ tv ttv))] 660 | [(N-replace tgt (THE mot-tv mot-v) (THE b-tv b-v)) 661 | `(replace ,(read-back-neutral Γ tgt) 662 | ,(read-back Γ mot-tv mot-v) 663 | ,(read-back Γ b-tv b-v))] 664 | [(N-trans12 p1 p2) 665 | `(trans ,(read-back-neutral Γ p1) ,(read-back-neutral Γ p2))] 666 | [(N-trans1 ne (THE t v)) 667 | `(trans ,(read-back-neutral Γ ne) ,(read-back Γ t v))] 668 | [(N-trans2 (THE t v) ne) 669 | `(trans ,(read-back Γ t v) ,(read-back-neutral Γ ne))] 670 | [(N-cong ne (THE (PI y Av c) v)) 671 | `(cong ,(read-back-neutral Γ ne) 672 | ,(read-back-type Γ (val-of-closure c 'ABSURD)) 673 | ,(read-back Γ (PI y Av c) v))] 674 | [(N-symm ne) 675 | `(symm ,(read-back-neutral Γ ne))] 676 | [(N-ind-= ne (THE mot-t mot) (THE b-t b)) 677 | `(ind-= ,(read-back-neutral Γ ne) 678 | ,(read-back Γ mot-t mot) 679 | ,(read-back Γ b-t b))] 680 | [(N-head ne) 681 | `(head ,(read-back-neutral Γ ne))] 682 | [(N-tail ne) 683 | `(tail ,(read-back-neutral Γ ne))] 684 | [(N-ind-Vec1 len (THE es-t es-v) (THE mot-t mot) (THE b-t b) (THE s-t s)) 685 | `(ind-Vec ,(read-back-neutral Γ len) 686 | ,(read-back Γ es-t es-v) 687 | ,(read-back Γ mot-t mot) 688 | ,(read-back Γ b-t b) 689 | ,(read-back Γ s-t s))] 690 | [(N-ind-Vec2 (THE len-t len-v) es (THE mot-t mot) (THE b-t b) (THE s-t s)) 691 | `(ind-Vec ,(read-back Γ len-t len-v) 692 | ,(read-back-neutral Γ es) 693 | ,(read-back Γ mot-t mot) 694 | ,(read-back Γ b-t b) 695 | ,(read-back Γ s-t s))] 696 | [(N-ind-Vec12 len es (THE mot-t mot) (THE b-t b) (THE s-t s)) 697 | `(ind-Vec ,(read-back-neutral Γ len) 698 | ,(read-back-neutral Γ es) 699 | ,(read-back Γ mot-t mot) 700 | ,(read-back Γ b-t b) 701 | ,(read-back Γ s-t s))] 702 | [(N-ind-Either tgt (THE mot-tv mot-v) (THE l-tv l-v) (THE r-tv r-v)) 703 | `(ind-Either ,(read-back-neutral Γ tgt) 704 | ,(read-back Γ mot-tv mot-v) 705 | ,(read-back Γ l-tv l-v) 706 | ,(read-back Γ r-tv r-v))] 707 | [(N-ap tgt (THE arg-tv arg-v)) 708 | `(,(read-back-neutral Γ tgt) 709 | ,(read-back Γ arg-tv arg-v))] 710 | [(N-var x) x] 711 | [(N-TODO where tyv) `(TODO ,where ,(read-back-type Γ tyv))])) 712 | 713 | 714 | ;;; General-purpose helpers 715 | 716 | ;; Given a value for a closure's free variable, find the value. This 717 | ;; cannot be used for DELAY-CLOS, because DELAY-CLOS's laziness 718 | ;; closures do not have free variables, but are instead just delayed 719 | ;; computations. 720 | (: val-of-closure (-> Closure Value Value)) 721 | (define (val-of-closure c v) 722 | (match c 723 | [(FO-CLOS ρ x e) 724 | (val-of (extend-env ρ x v) e)] 725 | [(HO-CLOS fun) (fun v)])) 726 | 727 | ;; Find the value of an expression in the environment that 728 | ;; corresponds to a context. 729 | (: val-in-ctx (-> Ctx Core Value)) 730 | (define (val-in-ctx Γ e) 731 | (val-of (ctx->env Γ) e)) 732 | 733 | 734 | 735 | ;; Local Variables: 736 | ;; eval: (put 'pmatch 'racket-indent-function 1) 737 | ;; eval: (put 'vmatch 'racket-indent-function 1) 738 | ;; eval: (put 'pmatch-who 'racket-indent-function 2) 739 | ;; eval: (put 'primitive 'racket-indent-function 1) 740 | ;; eval: (put 'derived 'racket-indent-function 0) 741 | ;; eval: (put 'data-constructor 'racket-indent-function 1) 742 | ;; eval: (put 'type-constructor 'racket-indent-function 1) 743 | ;; eval: (put 'tests-for 'racket-indent-function 1) 744 | ;; eval: (put 'hole 'racket-indent-function 1) 745 | ;; eval: (put 'Π 'racket-indent-function 1) 746 | ;; eval: (put 'Π* 'racket-indent-function 2) 747 | ;; eval: (put 'PI* 'racket-indent-function 1) 748 | ;; eval: (put 'Σ 'racket-indent-function 1) 749 | ;; eval: (put (intern "?") 'racket-indent-function 1) 750 | ;; eval: (put 'trace-type-checker 'racket-indent-function 1) 751 | ;; eval: (put 'go-on 'racket-indent-function 1) 752 | ;; eval: (setq whitespace-line-column 70) 753 | ;; End: 754 | -------------------------------------------------------------------------------- /parser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;; This module contains the parsers that convert Pie concrete syntax 3 | ;;; into source-code-annotated Pie input ASTs. 4 | 5 | 6 | (require "basics.rkt" "typechecker.rkt" 7 | (prefix-in kw: "pie-info.rkt") 8 | racket/match 9 | syntax/parse 10 | (for-syntax syntax/parse) 11 | (for-syntax racket/syntax)) 12 | (provide (all-defined-out)) 13 | 14 | (define-syntax-class pie-id 15 | #:description "valid Pie name" 16 | (pattern name:id #:when (var-name? (syntax->datum #'name)))) 17 | 18 | (begin-for-syntax 19 | (define-syntax-class pie-id 20 | #:description "valid Pie name" 21 | (pattern name:id #:when (var-name? (syntax->datum #'name))))) 22 | 23 | (define (syntax->srcloc stx) 24 | (syntax->location stx) 25 | #; 26 | (srcloc (syntax-source stx) 27 | (syntax-line stx) 28 | (syntax-column stx) 29 | (syntax-position stx) 30 | (syntax-span stx))) 31 | 32 | (define (binding-site id) 33 | (binder (syntax->srcloc id) (syntax->datum id))) 34 | 35 | (define (make-U loc) 36 | (@ (syntax->srcloc loc) 'U)) 37 | 38 | 39 | (define (make--> loc A B Cs) 40 | (@ (syntax->srcloc loc) 41 | (list* '-> A B Cs))) 42 | 43 | 44 | (define (make-Nat loc) 45 | (@ (syntax->srcloc loc) 'Nat)) 46 | 47 | 48 | (define (make-zero loc) 49 | (@ (syntax->srcloc loc) 'zero)) 50 | 51 | 52 | (define (make-add1 loc n) 53 | (@ (syntax->srcloc loc) `(add1 ,n))) 54 | 55 | 56 | (define (make-lambda loc xs body) 57 | (@ (syntax->srcloc loc) `(λ ,xs ,body))) 58 | 59 | 60 | (define (make-Pi loc args body) 61 | (@ (syntax->srcloc loc) `(Π ,args ,body))) 62 | 63 | 64 | (define (make-Sigma loc args body) 65 | (@ (syntax->srcloc loc) `(Σ ,args ,body))) 66 | 67 | 68 | (define (typed-binders A Bs) 69 | (cons A Bs)) 70 | 71 | 72 | (define (make-ap loc rator rand0 rands) 73 | (@ (syntax->srcloc loc) 74 | (list* rator rand0 rands))) 75 | 76 | 77 | (define (make-Atom loc) 78 | (@ (syntax->srcloc loc) 'Atom)) 79 | 80 | 81 | (define (make-Trivial loc) 82 | (@ (syntax->srcloc loc) 'Trivial)) 83 | 84 | 85 | (define (make-sole loc) 86 | (@ (syntax->srcloc loc) 'sole)) 87 | 88 | 89 | (define (make-List loc E) 90 | (@ (syntax->srcloc loc) `(List ,E))) 91 | 92 | 93 | (define (make-Vec loc E len) 94 | (@ (syntax->srcloc loc) `(Vec ,E ,len))) 95 | 96 | 97 | (define (make-Either loc L R) 98 | (@ (syntax->srcloc loc) `(Either ,L ,R))) 99 | 100 | 101 | (define (make-nil loc) 102 | (@ (syntax->srcloc loc) 'nil)) 103 | 104 | 105 | (define (make-:: loc x xs) 106 | (@ (syntax->srcloc loc) `(:: ,x ,xs))) 107 | 108 | 109 | (define (make-vec:: loc x xs) 110 | (@ (syntax->srcloc loc) `(vec:: ,x ,xs))) 111 | 112 | 113 | (define (make-vecnil loc) 114 | (@ (syntax->srcloc loc) 'vecnil)) 115 | 116 | 117 | (define (make-Absurd loc) 118 | (@ (syntax->srcloc loc) 'Absurd)) 119 | 120 | 121 | (define (make-Pair loc A B) 122 | (@ (syntax->srcloc loc) `(Pair ,A ,B))) 123 | 124 | 125 | (define (make-cons loc a d) 126 | (@ (syntax->srcloc loc) `(cons ,a ,d))) 127 | 128 | 129 | (define (make-the loc a d) 130 | (@ (syntax->srcloc loc) `(the ,a ,d))) 131 | 132 | 133 | (define (make-ind-Absurd loc a d) 134 | (@ (syntax->srcloc loc) `(ind-Absurd ,a ,d))) 135 | 136 | 137 | (define (make-trans loc p1 p2) 138 | (@ (syntax->srcloc loc) `(trans ,p1 ,p2))) 139 | 140 | 141 | (define (make-cong loc p1 p2) 142 | (@ (syntax->srcloc loc) `(cong ,p1 ,p2))) 143 | 144 | (define (make-ind-= loc tgt mot base) 145 | (@ (syntax->srcloc loc) `(ind-= ,tgt ,mot ,base))) 146 | 147 | (define (make-which-Nat loc e1 e2 e3) 148 | (@ (syntax->srcloc loc) `(which-Nat ,e1 ,e2 ,e3))) 149 | 150 | 151 | (define (make-iter-Nat loc e1 e2 e3) 152 | (@ (syntax->srcloc loc) `(iter-Nat ,e1 ,e2 ,e3))) 153 | 154 | 155 | (define (make-rec-Nat loc e1 e2 e3) 156 | (@ (syntax->srcloc loc) `(rec-Nat ,e1 ,e2 ,e3))) 157 | 158 | 159 | (define (make-ind-Nat loc e1 e2 e3 e4) 160 | (@ (syntax->srcloc loc) `(ind-Nat ,e1 ,e2 ,e3 ,e4))) 161 | 162 | 163 | (define (make-rec-List loc e1 e2 e3) 164 | (@ (syntax->srcloc loc) `(rec-List ,e1 ,e2 ,e3))) 165 | 166 | 167 | (define (make-ind-List loc e1 e2 e3 e4) 168 | (@ (syntax->srcloc loc) `(ind-List ,e1 ,e2 ,e3 ,e4))) 169 | 170 | 171 | (define (make-ind-Either loc e1 e2 e3 e4) 172 | (@ (syntax->srcloc loc) `(ind-Either ,e1 ,e2 ,e3 ,e4))) 173 | 174 | 175 | (define (make-ind-Vec loc e1 e2 e3 e4 e5) 176 | (@ (syntax->srcloc loc) `(ind-Vec ,e1 ,e2 ,e3 ,e4 ,e5))) 177 | 178 | 179 | (define (make-= loc e1 e2 e3) 180 | (@ (syntax->srcloc loc) `(= ,e1 ,e2 ,e3))) 181 | 182 | 183 | (define (make-replace loc e1 e2 e3) 184 | (@ (syntax->srcloc loc) `(replace ,e1 ,e2 ,e3))) 185 | 186 | 187 | (define (make-symm loc e) 188 | (@ (syntax->srcloc loc) `(symm ,e))) 189 | 190 | 191 | (define (make-head loc e) 192 | (@ (syntax->srcloc loc) `(head ,e))) 193 | 194 | 195 | (define (make-tail loc e) 196 | (@ (syntax->srcloc loc) `(tail ,e))) 197 | 198 | 199 | (define (make-same loc e) 200 | (@ (syntax->srcloc loc) `(same ,e))) 201 | 202 | 203 | (define (make-left loc e) 204 | (@ (syntax->srcloc loc) `(left ,e))) 205 | 206 | 207 | (define (make-right loc e) 208 | (@ (syntax->srcloc loc) `(right ,e))) 209 | 210 | 211 | (define (make-car loc e) 212 | (@ (syntax->srcloc loc) `(car ,e))) 213 | 214 | 215 | (define (make-cdr loc e) 216 | (@ (syntax->srcloc loc) `(cdr ,e))) 217 | 218 | 219 | (define (make-quote loc a) 220 | (@ (syntax->srcloc loc) `(quote ,a))) 221 | 222 | 223 | (define (make-var-ref loc a) 224 | (@ (syntax->srcloc loc) a)) 225 | 226 | 227 | (define (make-nat-literal loc n) 228 | (@ (syntax->srcloc loc) n)) 229 | 230 | 231 | (define (make-TODO loc) 232 | (@ (syntax->srcloc loc) 'TODO)) 233 | 234 | 235 | (define (parse-pie stx) 236 | (syntax-parse stx 237 | #:datum-literals (U 238 | Nat zero add1 239 | which-Nat iter-Nat rec-Nat ind-Nat 240 | → -> Pi Π ∏ the lambda λ Atom quote 241 | cons car cdr Sigma Σ Pair 242 | Trivial sole 243 | List :: nil ind-List rec-List 244 | Absurd ind-Absurd 245 | = same replace symm trans cong ind-= 246 | head tail Vec vec:: vecnil ind-Vec 247 | Either left right ind-Either 248 | TODO) 249 | [U 250 | (make-U stx)] 251 | [Nat 252 | (make-Nat stx)] 253 | [(→ ~! A B C ...) 254 | (make--> stx 255 | (parse-pie #'A) 256 | (parse-pie #'B) 257 | (map parse-pie (syntax->list #'(C ...))))] 258 | [(-> ~! A B C ...) 259 | (make--> stx 260 | (parse-pie #'A) 261 | (parse-pie #'B) 262 | (map parse-pie (syntax->list #'(C ...))))] 263 | [zero 264 | (make-zero stx)] 265 | [(add1 ~! n) 266 | (make-add1 stx (parse-pie #'n))] 267 | [(lambda ~! ((~describe "argument name" x0:pie-id) 268 | (~describe "argument name" x:pie-id) 269 | ...) 270 | b) 271 | (make-lambda stx 272 | (map binding-site (syntax->list #'(x0 x ...))) 273 | (parse-pie #'b))] 274 | [(λ ~! ((~describe "argument name" x0:pie-id) 275 | (~describe "argument name" x:pie-id) 276 | ...) 277 | b) 278 | (make-lambda stx 279 | (map binding-site (syntax->list #'(x0 x ...))) 280 | (parse-pie #'b))] 281 | [(Pi ~! more ...) 282 | (parse-pie #'(Π more ...))] 283 | [(∏ ~! more ...) 284 | (parse-pie #'(Π more ...))] 285 | [(Π ~! (~describe "argument names and types" 286 | ((x0:pie-id A0) (x:pie-id A) ...)) 287 | (~describe "result type" B)) 288 | (make-Pi stx 289 | (typed-binders (list (binding-site #'x0) (parse-pie #'A0)) 290 | (for/list ([b (syntax->list #'((x A) ...))]) 291 | (match (syntax->list b) 292 | [(list x A) 293 | (list (binding-site x) 294 | (parse-pie A))]))) 295 | (parse-pie #'B))] 296 | [(Sigma ~! more ...) 297 | (parse-pie (syntax/loc stx (Σ more ...)))] 298 | [(Σ ~! (~describe "car names and types" 299 | ((x0:pie-id A0) (x:pie-id A) ...)) 300 | (~describe "cdr type" B)) 301 | (make-Sigma stx 302 | (typed-binders (list (binding-site #'x0) (parse-pie #'A0)) 303 | (for/list ([b (syntax->list #'((x A) ...))]) 304 | (match (syntax->list b) 305 | [(list x A) 306 | (list (binding-site x) 307 | (parse-pie A))]))) 308 | (parse-pie #'B))] 309 | [(Pair ~! A D) 310 | (make-Pair stx (parse-pie #'A) (parse-pie #'D))] 311 | [(cons ~! a d) 312 | (make-cons stx (parse-pie #'a) (parse-pie #'d))] 313 | [(car ~! p) 314 | (make-car stx (parse-pie #'p))] 315 | [(cdr ~! p) 316 | (make-cdr stx (parse-pie #'p))] 317 | [(the ~! t e) 318 | (make-the stx (parse-pie #'t) (parse-pie #'e))] 319 | [(which-Nat ~! tgt b s) 320 | (make-which-Nat stx (parse-pie #'tgt) (parse-pie #'b) (parse-pie #'s))] 321 | [(rec-Nat ~! tgt b s) 322 | (make-rec-Nat stx (parse-pie #'tgt) (parse-pie #'b) (parse-pie #'s))] 323 | [(iter-Nat ~! tgt b s) 324 | (make-iter-Nat stx (parse-pie #'tgt) (parse-pie #'b) (parse-pie #'s))] 325 | [(ind-Nat ~! tgt mot b s) 326 | (make-ind-Nat stx (parse-pie #'tgt) (parse-pie #'mot) (parse-pie #'b) (parse-pie #'s))] 327 | [Atom 328 | (make-Atom stx)] 329 | [(quote ~! a:id) 330 | (make-quote stx (syntax->datum #'a))] 331 | [Trivial 332 | (make-Trivial stx)] 333 | [sole 334 | (make-sole stx)] 335 | [(List ~! E) 336 | (make-List stx (parse-pie #'E))] 337 | [nil 338 | (make-nil stx)] 339 | [(:: ~! e es) 340 | (make-:: stx (parse-pie #'e) (parse-pie #'es))] 341 | [(ind-List ~! tgt mot b s) 342 | (make-ind-List stx (parse-pie #'tgt) (parse-pie #'mot) (parse-pie #'b) (parse-pie #'s))] 343 | [(rec-List ~! tgt b s) 344 | (make-rec-List stx (parse-pie #'tgt) (parse-pie #'b) (parse-pie #'s))] 345 | [x:pie-id 346 | (make-var-ref stx (syntax->datum #'x.name))] 347 | [Absurd 348 | (make-Absurd stx)] 349 | [(ind-Absurd ~! tgt mot) 350 | (make-ind-Absurd stx (parse-pie #'tgt) (parse-pie #'mot))] 351 | [n:nat 352 | (make-nat-literal stx (syntax->datum #'n))] 353 | [(= ~! A from to) 354 | (make-= stx (parse-pie #'A) (parse-pie #'from) (parse-pie #'to))] 355 | [(same ~! e) 356 | (make-same stx (parse-pie #'e))] 357 | [(replace ~! tgt mot b) 358 | (make-replace stx (parse-pie #'tgt) (parse-pie #'mot) (parse-pie #'b))] 359 | [(trans ~! p1 p2) 360 | (make-trans stx (parse-pie #'p1) (parse-pie #'p2))] 361 | [(cong ~! p1 p2) 362 | (make-cong stx (parse-pie #'p1) (parse-pie #'p2))] 363 | [(ind-= ~! (~describe "target" tgt) (~describe "motive" mot) (~describe "base" base)) 364 | (make-ind-= stx (parse-pie #'tgt) (parse-pie #'mot) (parse-pie #'base))] 365 | [(symm ~! p) 366 | (make-symm stx (parse-pie #'p))] 367 | [(Vec ~! E len) 368 | (make-Vec stx (parse-pie #'E) (parse-pie #'len))] 369 | [vecnil 370 | (make-vecnil stx)] 371 | [(vec:: ~! h t) 372 | (make-vec:: stx (parse-pie #'h) (parse-pie #'t))] 373 | [(head ~! es) 374 | (make-head stx (parse-pie #'es))] 375 | [(tail ~! es) 376 | (make-tail stx (parse-pie #'es))] 377 | [(ind-Vec ~! k xs m b s) 378 | (make-ind-Vec stx (parse-pie #'k) (parse-pie #'xs) (parse-pie #'m) (parse-pie #'b) (parse-pie #'s))] 379 | [(Either ~! L R) 380 | (make-Either stx (parse-pie #'L) (parse-pie #'R))] 381 | [(left ~! l) 382 | (make-left stx (parse-pie #'l))] 383 | [(right ~! r) 384 | (make-right stx (parse-pie #'r))] 385 | [(ind-Either ~! tgt mot l r) 386 | (make-ind-Either stx (parse-pie #'tgt) (parse-pie #'mot) (parse-pie #'l) (parse-pie #'r))] 387 | [(~describe "TODO" TODO) 388 | (make-TODO stx)] 389 | [(~describe "function application" 390 | ((~describe "function" rator) 391 | (~describe "first argument" rand0) 392 | (~describe "more arguments" rand) ...)) 393 | (make-ap stx (parse-pie #'rator) (parse-pie #'rand0) (map parse-pie (syntax->list #'(rand ...))))])) 394 | 395 | (define (parse-pie-decl stx) 396 | (syntax-parse stx 397 | #:datum-literals (claim define check-same) 398 | [(~describe "claim" 399 | (claim ~! 400 | (~describe "name" x:pie-id) 401 | (~describe "type" type))) 402 | `(claim ,(syntax->datum #'x) 403 | ,(syntax->srcloc #'x) 404 | ,(parse-pie #'type))] 405 | [(~describe "definition" 406 | (define ~! 407 | (~describe "name" x:pie-id) 408 | (~describe "definiens" e))) 409 | `(definition 410 | ,(syntax->datum #'x) 411 | ,(syntax->srcloc #'x) 412 | ,(parse-pie #'e))] 413 | [(~describe "sameness check" 414 | (check-same ~! 415 | (~describe "type" type) 416 | (~describe (format "first ~a" (syntax->datum #'type)) e1) 417 | (~describe (format "second ~a" (syntax->datum #'type)) e2))) 418 | `(check-same ,(syntax->srcloc stx) 419 | ,(parse-pie #'type) 420 | ,(parse-pie #'e1) 421 | ,(parse-pie #'e2))] 422 | [(~describe "expression" e) 423 | `(expression ,(parse-pie #'e))])) 424 | 425 | 426 | (define-for-syntax (add-disappeared stx id) 427 | (syntax-property stx 428 | 'disappeared-use 429 | (syntax-property (syntax-local-introduce id) 430 | 'original-for-check-syntax 431 | #t))) 432 | 433 | (define-syntax (pie->binders expr) 434 | (define stx 435 | (syntax-parse expr 436 | [(_ expr) #'expr])) 437 | (syntax-parse stx 438 | #:datum-literals (U 439 | Nat zero add1 440 | which-Nat iter-Nat rec-Nat ind-Nat 441 | → -> Pi Π ∏ the lambda λ Atom quote 442 | cons car cdr Sigma Σ Pair 443 | Trivial sole 444 | List :: nil ind-List rec-List 445 | Absurd ind-Absurd 446 | = same replace symm trans cong ind-= 447 | head tail Vec vec:: vecnil ind-Vec 448 | Either left right ind-Either 449 | TODO) 450 | [U 451 | (add-disappeared (syntax/loc stx kw:U) 452 | stx)] 453 | [Nat 454 | (add-disappeared (syntax/loc stx kw:Nat) 455 | stx)] 456 | [(→ ~! A B C ...) 457 | (with-syntax ([A* #'(pie->binders A)] 458 | [B* #'(pie->binders B)] 459 | [(C* ...) #'((pie->binders C) ...)] 460 | [arr (syntax/loc (car (syntax-e stx)) kw:→)]) 461 | (add-disappeared (syntax/loc stx (arr A* B* C* ...)) 462 | (car (syntax-e stx))))] 463 | [(-> ~! A B C ...) 464 | (with-syntax ([A* #'(pie->binders A)] 465 | [B* #'(pie->binders B)] 466 | [(C* ...) #'((pie->binders C) ...)] 467 | [arr (syntax/loc (car (syntax-e stx)) kw:->)]) 468 | (add-disappeared (syntax/loc stx (arr A* B* C* ...)) 469 | (car (syntax-e stx))))] 470 | [zero 471 | (add-disappeared (syntax/loc stx kw:zero) 472 | stx)] 473 | [(add1 ~! n) 474 | (with-syntax ([n* #'(pie->binders n)] 475 | [succ (syntax/loc (car (syntax-e stx)) kw:add1)]) 476 | (add-disappeared (syntax/loc stx (succ n*)) 477 | (car (syntax-e stx))))] 478 | [(lambda ~! (x0:id x:id ...) b) 479 | (with-syntax ([lam/loc (syntax/loc (car (syntax-e stx)) kw:lambda)] 480 | [b/bindings #'(pie->binders b)]) 481 | (add-disappeared (syntax/loc stx 482 | (void lam/loc 483 | (let* ([x0 (void)] [x (void)] ...) 484 | b/bindings))) 485 | (car (syntax-e stx))))] 486 | [(λ ~! (x0:id x:id ...) b) 487 | (with-syntax ([lam/loc (syntax/loc (car (syntax-e stx)) kw:λ)] 488 | [b/bindings #'(pie->binders b)]) 489 | (add-disappeared (syntax/loc stx 490 | (void lam/loc 491 | (let* ([x0 (void)] [x (void)] ...) 492 | b/bindings))) 493 | (car (syntax-e stx))))] 494 | [(Pi ~! ((x0:id A0) (x:id A) ...) B) 495 | (with-syntax ([sig/loc (syntax/loc (car (syntax-e stx)) kw:Pi)] 496 | [A0* #'(pie->binders A0)] 497 | [(A* ...) #'((pie->binders A) ...)] 498 | [B* #'(pie->binders B)]) 499 | (add-disappeared (syntax/loc stx 500 | (void sig/loc (let* ([x0 A0*] [x A*] ...) B*))) 501 | (car (syntax-e stx))))] 502 | [(Π ~! ((x0:id A0) (x:id A) ...) B) 503 | (with-syntax ([sig/loc (syntax/loc (car (syntax-e stx)) kw:Π)] 504 | [A0* #'(pie->binders A0)] 505 | [(A* ...) #'((pie->binders A) ...)] 506 | [B* #'(pie->binders B)]) 507 | (add-disappeared (syntax/loc stx 508 | (void sig/loc (let* ([x0 A0*] [x A*] ...) B*))) 509 | (car (syntax-e stx))))] 510 | [(∏ ~! ((x0:id A0) (x:id A) ...) B) 511 | (with-syntax ([sig/loc (syntax/loc (car (syntax-e stx)) kw:∏)] 512 | [A0* #'(pie->binders A0)] 513 | [(A* ...) #'((pie->binders A) ...)] 514 | [B* #'(pie->binders B)]) 515 | (add-disappeared (syntax/loc stx 516 | (void sig/loc (let* ([x0 A0*] [x A*] ...) B*))) 517 | (car (syntax-e stx))))] 518 | [(Sigma ~! ((x0:id A0) (x:id A) ...) B) 519 | (with-syntax ([sig/loc (syntax/loc (car (syntax-e stx)) kw:Sigma)] 520 | [A0* #'(pie->binders A0)] 521 | [(A* ...) #'((pie->binders A) ...)] 522 | [B* #'(pie->binders B)]) 523 | (add-disappeared (syntax/loc stx 524 | (void sig/loc (let* ([x0 A0*] [x A*] ...) B*))) 525 | (car (syntax-e stx))))] 526 | [(Σ ~! ((x0:id A0) (x:id A) ...) B) 527 | (with-syntax ([sig/loc (syntax/loc (car (syntax-e stx)) kw:Σ)] 528 | [A0* #'(pie->binders A0)] 529 | [(A* ...) #'((pie->binders A) ...)] 530 | [B* #'(pie->binders B)]) 531 | (add-disappeared (syntax/loc stx (void sig/loc (let* ([x0 A0*] [x A*] ...) B*))) 532 | (car (syntax-e stx))))] 533 | [(Pair ~! A D) 534 | (with-syntax ([A* #'(pie->binders A)] 535 | [D* #'(pie->binders D)] 536 | [pair/loc (syntax/loc (car (syntax-e stx)) kw:Pair)]) 537 | (add-disappeared (syntax/loc stx (void pair/loc A* D*)) 538 | (car (syntax-e stx))))] 539 | [(cons ~! a d) 540 | (with-syntax ([a* #'(pie->binders a)] 541 | [d* #'(pie->binders d)] 542 | [cons/loc (syntax/loc (car (syntax-e stx)) kw:cons)]) 543 | (add-disappeared (syntax/loc stx (void cons/loc a* d*)) 544 | (car (syntax-e stx))))] 545 | [(car ~! p) 546 | (with-syntax ([p* #'(pie->binders p)] 547 | [car/loc (syntax/loc (car (syntax-e stx)) kw:car)]) 548 | (add-disappeared (syntax/loc stx (void car/loc p*)) 549 | (car (syntax-e stx))))] 550 | [(cdr ~! p) 551 | (with-syntax ([p* #'(pie->binders p)] 552 | [cdr/loc (syntax/loc (car (syntax-e stx)) kw:cdr)]) 553 | (add-disappeared (syntax/loc stx (void cdr/loc p*)) 554 | (car (syntax-e stx))))] 555 | [(the ~! t e) 556 | (with-syntax ([t* #'(pie->binders t)] 557 | [e* #'(pie->binders e)] 558 | [the/loc (syntax/loc (car (syntax-e stx)) kw:the)]) 559 | (add-disappeared (syntax/loc stx (void the/loc t* e*)) 560 | (car (syntax-e stx))))] 561 | [(which-Nat ~! tgt b s) 562 | (with-syntax ([tgt* #'(pie->binders tgt)] 563 | [b* #'(pie->binders b)] 564 | [s* #'(pie->binders s)] 565 | [which-Nat/loc (syntax/loc (car (syntax-e stx)) kw:which-Nat)]) 566 | (add-disappeared (syntax/loc stx (void which-Nat/loc tgt* b* s*)) 567 | (car (syntax-e stx))))] 568 | [(rec-Nat ~! tgt b s) 569 | (with-syntax ([tgt* #'(pie->binders tgt)] 570 | [b* #'(pie->binders b)] 571 | [s* #'(pie->binders s)] 572 | [rec-Nat/loc (syntax/loc (car (syntax-e stx)) kw:rec-Nat)]) 573 | (add-disappeared (syntax/loc stx (void rec-Nat/loc tgt* b* s*)) 574 | (car (syntax-e stx))))] 575 | [(iter-Nat ~! tgt b s) 576 | (with-syntax ([tgt* #'(pie->binders tgt)] 577 | [b* #'(pie->binders b)] 578 | [s* #'(pie->binders s)] 579 | [iter-Nat/loc (syntax/loc (car (syntax-e stx)) kw:iter-Nat)]) 580 | (add-disappeared (syntax/loc stx (void iter-Nat/loc tgt* b* s*)) 581 | (car (syntax-e stx))))] 582 | [(ind-Nat ~! tgt mot b s) 583 | (with-syntax ([tgt* #'(pie->binders tgt)] 584 | [mot* #'(pie->binders mot)] 585 | [b* #'(pie->binders b)] 586 | [s* #'(pie->binders s)] 587 | [ind-Nat/loc (syntax/loc (car (syntax-e stx)) kw:ind-Nat)]) 588 | (add-disappeared (syntax/loc stx (void ind-Nat/loc tgt* mot* b* s*)) 589 | (car (syntax-e stx))))] 590 | [Atom 591 | (add-disappeared (syntax/loc stx kw:Atom) 592 | stx)] 593 | [(quote ~! a:id) 594 | (with-syntax ([quote/loc (syntax/loc (car (syntax-e stx)) kw:quote)]) 595 | (add-disappeared (syntax/loc stx (void quote/loc 'a)) 596 | (car (syntax-e stx))))] 597 | [Trivial 598 | (add-disappeared (syntax/loc stx kw:Trivial) stx)] 599 | [sole 600 | (add-disappeared (syntax/loc stx kw:sole) 601 | stx)] 602 | [(List ~! E) 603 | (with-syntax ([E* #'(pie->binders E)] 604 | [List/loc (syntax/loc (car (syntax-e stx)) kw:List)]) 605 | (add-disappeared (syntax/loc stx (void List/loc E*)) 606 | (car (syntax-e stx))))] 607 | [nil 608 | (add-disappeared (syntax/loc stx kw:nil) 609 | stx)] 610 | [(:: ~! a d) 611 | (with-syntax ([a* #'(pie->binders a)] 612 | [d* #'(pie->binders d)] 613 | [::/loc (syntax/loc (car (syntax-e stx)) kw:::)]) 614 | (add-disappeared (syntax/loc stx (void ::/loc a* d*)) 615 | (car (syntax-e stx))))] 616 | [(ind-List ~! tgt mot b s) 617 | (with-syntax ([tgt* #'(pie->binders tgt)] 618 | [mot* #'(pie->binders mot)] 619 | [b* #'(pie->binders b)] 620 | [s* #'(pie->binders s)] 621 | [ind-List/loc (syntax/loc (car (syntax-e stx)) kw:ind-List)]) 622 | (add-disappeared (syntax/loc stx (void ind-List/loc tgt* mot* b* s*)) 623 | (car (syntax-e stx))))] 624 | [(rec-List ~! tgt b s) 625 | (with-syntax ([tgt* #'(pie->binders tgt)] 626 | [b* #'(pie->binders b)] 627 | [s* #'(pie->binders s)] 628 | [rec-List/loc (syntax/loc (car (syntax-e stx)) kw:rec-List)]) 629 | (add-disappeared (syntax/loc stx (void rec-List/loc tgt* b* s*)) 630 | (car (syntax-e stx))))] 631 | [x:pie-id 632 | stx] 633 | [Absurd 634 | (add-disappeared (syntax/loc stx kw:Absurd) stx)] 635 | [(ind-Absurd ~! tgt mot) 636 | (with-syntax ([tgt* #'(pie->binders tgt)] 637 | [mot* #'(pie->binders mot)] 638 | [ind-Absurd/loc (syntax/loc (car (syntax-e stx)) kw:ind-Absurd)]) 639 | (add-disappeared (syntax/loc stx (void ind-Absurd/loc tgt* mot*)) 640 | (car (syntax-e stx))))] 641 | [n:nat 642 | (syntax/loc stx (void n))] 643 | [(= ~! A from to) 644 | (with-syntax ([A* #'(pie->binders A)] 645 | [from* #'(pie->binders from)] 646 | [to* #'(pie->binders to)] 647 | [=/loc (syntax/loc (car (syntax-e stx)) kw:=)]) 648 | (add-disappeared (syntax/loc stx (void =/loc A* from* to*)) 649 | (car (syntax-e stx))))] 650 | [(same ~! e) 651 | (with-syntax ([e* #'(pie->binders e)] 652 | [same/loc (syntax/loc (car (syntax-e stx)) kw:same)]) 653 | (add-disappeared (syntax/loc stx (void same/loc e*)) 654 | (car (syntax-e stx))))] 655 | [(replace ~! tgt mot b) 656 | (with-syntax ([tgt* #'(pie->binders tgt)] 657 | [mot* #'(pie->binders mot)] 658 | [b* #'(pie->binders b)] 659 | [replace/loc (syntax/loc (car (syntax-e stx)) kw:replace)]) 660 | (add-disappeared (syntax/loc stx (void replace/loc tgt* mot* b*)) 661 | (car (syntax-e stx))))] 662 | [(trans ~! a d) 663 | (with-syntax ([a* #'(pie->binders a)] 664 | [d* #'(pie->binders d)] 665 | [trans/loc (syntax/loc (car (syntax-e stx)) kw:trans)]) 666 | (add-disappeared (syntax/loc stx (void trans/loc a* d*)) 667 | (car (syntax-e stx))))] 668 | [(cong ~! a d) 669 | (with-syntax ([a* #'(pie->binders a)] 670 | [d* #'(pie->binders d)] 671 | [cong/loc (syntax/loc (car (syntax-e stx)) kw:cong)]) 672 | (add-disappeared (syntax/loc stx (void cong/loc a* d*)) 673 | (car (syntax-e stx))))] 674 | [(symm ~! p) 675 | (with-syntax ([p* #'(pie->binders p)] 676 | [symm/loc (syntax/loc (car (syntax-e stx)) kw:symm)]) 677 | (add-disappeared (syntax/loc stx (void symm/loc p*)) 678 | (car (syntax-e stx))))] 679 | [(ind-= ~! tgt mot base) 680 | (with-syntax ([tgt* #'(pie->binders tgt)] 681 | [mot* #'(pie->binders mot)] 682 | [base* #'(pie->binders base)] 683 | [ind-=/loc (syntax/loc (car (syntax-e stx)) kw:ind-=)]) 684 | (add-disappeared (syntax/loc stx (void ind-=/loc tgt* mot* base*)) 685 | (car (syntax-e stx))))] 686 | [(Vec ~! E len) 687 | (with-syntax ([E* #'(pie->binders E)] 688 | [len* #'(pie->binders len)] 689 | [Vec/loc (syntax/loc (car (syntax-e stx)) kw:Vec)]) 690 | (add-disappeared (syntax/loc stx (void Vec/loc E* len*)) 691 | (car (syntax-e stx))))] 692 | [vecnil 693 | (add-disappeared (syntax/loc stx kw:vecnil) 694 | stx)] 695 | [(vec:: ~! a d) 696 | (with-syntax ([a* #'(pie->binders a)] 697 | [d* #'(pie->binders d)] 698 | [vec::/loc (syntax/loc (car (syntax-e stx)) kw:vec::)]) 699 | (add-disappeared (syntax/loc stx (void vec::/loc a* d*)) 700 | (car (syntax-e stx))))] 701 | [(head ~! p) 702 | (with-syntax ([p* #'(pie->binders p)] 703 | [head/loc (syntax/loc (car (syntax-e stx)) kw:head)]) 704 | (add-disappeared (syntax/loc stx (void head/loc p*)) 705 | (car (syntax-e stx))))] 706 | [(tail ~! p) 707 | (with-syntax ([p* #'(pie->binders p)] 708 | [tail/loc (syntax/loc (car (syntax-e stx)) kw:tail)]) 709 | (add-disappeared (syntax/loc stx (void tail/loc p*)) 710 | (car (syntax-e stx))))] 711 | [(ind-Vec ~! k tgt mot b s) 712 | (with-syntax ([k* #'(pie->binders k)] 713 | [tgt* #'(pie->binders tgt)] 714 | [mot* #'(pie->binders mot)] 715 | [b* #'(pie->binders b)] 716 | [s* #'(pie->binders s)] 717 | [ind-Vec/loc (syntax/loc (car (syntax-e stx)) kw:ind-Vec)]) 718 | (add-disappeared (syntax/loc stx (void ind-Vec/loc k* tgt* mot* b* s*)) 719 | (car (syntax-e stx))))] 720 | [(Either ~! L R) 721 | (with-syntax ([L* #'(pie->binders L)] 722 | [R* #'(pie->binders R)] 723 | [Either/loc (syntax/loc (car (syntax-e stx)) kw:Either)]) 724 | (add-disappeared (syntax/loc stx (void Either/loc L* R*)) 725 | (car (syntax-e stx))))] 726 | [(left ~! p) 727 | (with-syntax ([p* #'(pie->binders p)] 728 | [left/loc (syntax/loc (car (syntax-e stx)) kw:left)]) 729 | (add-disappeared (syntax/loc stx (void left/loc p*)) 730 | (car (syntax-e stx))))] 731 | [(right ~! p) 732 | (with-syntax ([p* #'(pie->binders p)] 733 | [right/loc (syntax/loc (car (syntax-e stx)) kw:right)]) 734 | (add-disappeared (syntax/loc stx (void right/loc p*)) 735 | (car (syntax-e stx))))] 736 | [(ind-Either ~! tgt mot l r) 737 | (with-syntax ([tgt* #'(pie->binders tgt)] 738 | [mot* #'(pie->binders mot)] 739 | [l* #'(pie->binders l)] 740 | [r* #'(pie->binders r)] 741 | [ind-Either/loc (syntax/loc (car (syntax-e stx)) kw:ind-Either)]) 742 | (add-disappeared (syntax/loc stx (void ind-Either/loc tgt* mot* l* r*)) 743 | (car (syntax-e stx))))] 744 | [(~describe "TODO" TODO) 745 | (add-disappeared (syntax/loc stx kw:TODO) 746 | stx)] 747 | [(~describe "application" (rator rand0 rand ...)) 748 | (with-syntax ([rator* #'(pie->binders rator)] 749 | [rand0* #'(pie->binders rand0)] 750 | [(rand* ...) #'((pie->binders rand) ...)]) 751 | (syntax/loc stx (void rator* rand0* rand* ...)))] 752 | [_ #'(void)])) 753 | 754 | (define-syntax (pie-decl->binders decl) 755 | (define stx 756 | (syntax-parse decl 757 | [(_ decl) #'decl])) 758 | (syntax-parse stx 759 | #:datum-literals (claim define check-same) 760 | [(~describe "claim" 761 | (claim ~! 762 | (~describe "name" x:id) 763 | (~describe "type" type))) 764 | (with-syntax ([claim/loc (syntax/loc (car (syntax-e stx)) kw:claim)] 765 | [claim-var (format-id #'x "internal-claim-binding-~a" #'x #:source #'x)] 766 | [claim-ty #'(pie->binders type)]) 767 | (syntax-property 768 | (add-disappeared (syntax/loc stx 769 | (define claim-var (void claim/loc claim-ty))) 770 | (car (syntax-e stx))) 771 | 'disappeared-binding (syntax-local-introduce #'x)))] 772 | [(~describe "definition" 773 | (define ~! 774 | (~describe "name" x:id) 775 | (~describe "definiens" e))) 776 | (with-syntax ([define/loc (syntax/loc (car (syntax-e stx)) kw:define)] 777 | [claim-var (format-id #'x "internal-claim-binding-~a" #'x)] 778 | [define-e #'(pie->binders e)]) 779 | (add-disappeared (add-disappeared 780 | (syntax/loc stx 781 | (define x (void define/loc claim-var define-e))) 782 | (car (syntax-e stx))) 783 | #'x))] 784 | [(~describe "sameness check" 785 | (check-same ~! 786 | (~describe "type" type) 787 | (~describe (format "first ~a" (syntax->datum #'type)) e1) 788 | (~describe (format "second ~a" (syntax->datum #'type)) e2))) 789 | (with-syntax ([check-same/loc (syntax/loc (car (syntax-e stx)) kw:check-same)] 790 | [type* #'(pie->binders type)] 791 | [e1* #'(pie->binders e1)] 792 | [e2* #'(pie->binders e2)]) 793 | (add-disappeared (syntax/loc stx (void check-same/loc type* e1* e2*)) (car (syntax-e stx))))] 794 | [(~describe "expression" e) 795 | #'(pie->binders e)])) 796 | 797 | 798 | -------------------------------------------------------------------------------- /pie-err.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/string racket/port racket/match) 3 | (require "locations.rkt") 4 | (require "resugar.rkt") 5 | (require "pretty.rkt") 6 | 7 | (provide (all-defined-out)) 8 | 9 | (struct exn:fail:pie exn:fail (where) 10 | #:property prop:exn:srclocs 11 | (lambda (e) 12 | (match (exn:fail:pie-where e) 13 | [(list raw-src line col pos span) 14 | ;; DrRacket highlights more consistently if we 15 | ;; return an actual path for the source when 16 | ;; the source string corresponds to a valid 17 | ;; file on the user's machine. 18 | (define src (if (and (string? raw-src) 19 | (file-exists? raw-src)) 20 | (string->path raw-src) 21 | raw-src)) 22 | (list (srcloc src line col pos span))])) 23 | #:transparent) 24 | 25 | (define (raise-pie-error where msg) 26 | (raise (exn:fail:pie (with-output-to-string 27 | (lambda () 28 | (pprint-message msg))) 29 | (current-continuation-marks) 30 | (location->srcloc where)))) 31 | -------------------------------------------------------------------------------- /pie-info.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base syntax/parse)) 3 | 4 | (provide (all-defined-out)) 5 | 6 | (define-syntax (define-pie-keyword stx) 7 | (syntax-parse stx 8 | [(_ kw:id) 9 | #'(define-syntax (kw inner-stx) 10 | (syntax-parse inner-stx 11 | #:literals (kw) 12 | [kw #'(void)] 13 | [(kw e (... ...)) #'(void e (... ...))]))])) 14 | 15 | (define-syntax (define-pie-keywords stx) 16 | (syntax-parse stx 17 | [(_ kw:id ...) 18 | #'(begin 19 | (define-pie-keyword kw) 20 | ...)])) 21 | 22 | (define-pie-keywords 23 | U 24 | Nat zero add1 which-Nat iter-Nat rec-Nat ind-Nat 25 | -> → Π Pi ∏ λ lambda 26 | quote Atom 27 | car cdr cons Σ Sigma Pair 28 | Trivial sole 29 | List :: nil rec-List ind-List 30 | Absurd ind-Absurd 31 | = same replace trans cong symm ind-= 32 | Vec vecnil vec:: head tail ind-Vec 33 | Either left right ind-Either 34 | TODO the 35 | check-same claim define) 36 | -------------------------------------------------------------------------------- /pie.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label (only-meta-in 0 pie)) 4 | racket/sandbox scribble/example 5 | (for-syntax racket/base syntax/parse)) 6 | 7 | @(define ev 8 | (parameterize ([sandbox-output 'string] 9 | [sandbox-error-output 'string]) 10 | (make-evaluator 'pie))) 11 | 12 | @(define-syntax (ex stx) 13 | (syntax-parse stx 14 | [(_ e ...) 15 | (syntax/loc stx 16 | (examples #:eval ev e ...))])) 17 | 18 | @(define-syntax (pie stx) 19 | (syntax-parse stx 20 | [(_ e ...) 21 | (syntax/loc stx 22 | (racket e ...))])) 23 | 24 | @(define-syntax (pieblock stx) 25 | (syntax-parse stx 26 | [(_ e ...) 27 | (syntax/loc stx 28 | (racketblock e ...))])) 29 | 30 | @(define-syntax (def-type-constructor stx) 31 | (syntax-parse stx 32 | [(_ con:id content ...) 33 | (syntax/loc stx 34 | (defform #:kind "type constructor" #:id con con content ...))] 35 | [(_ con-expr content ...) 36 | (syntax/loc stx 37 | (defform #:kind "type constructor" con-expr content ...))])) 38 | 39 | 40 | @(define-syntax (def-constructor stx) 41 | (syntax-parse stx 42 | [(_ con:id content ...) 43 | (syntax/loc stx 44 | (defthing #:kind "constructor" con content ...))] 45 | [(_ con-expr content ...) 46 | (syntax/loc stx 47 | (defproc #:kind "constructor" con-expr content ...))])) 48 | 49 | 50 | @(define-syntax (def-eliminator stx) 51 | (syntax-parse stx 52 | [(_ elim-expr content ...) 53 | (syntax/loc stx 54 | (defproc #:kind "eliminator" elim-expr content ...))])) 55 | 56 | 57 | @title{The Pie Reference} 58 | @author{David Thrane Christiansen and Daniel P. Friedman} 59 | 60 | 61 | 62 | @defmodule[pie #:lang]{ 63 | Pie is a little language with dependent types that accompanies 64 | @hyperlink["http://thelittletyper.com"]{@emph{The Little Typer}}. 65 | } 66 | 67 | @table-of-contents[] 68 | 69 | @section{Using Pie in DrRacket} 70 | Pie is implemented as a Racket language. While other editors may work, Pie 71 | is currently supported best in DrRacket. 72 | 73 | After installing Pie from the Racket package database, open DrRacket. 74 | Change the first line to read @tt{#lang pie}, and then start typing. 75 | If DrRacket's "Background Expansion" feature is enabled, the type checker 76 | will run every time the file is modified, whether or not it is run. 77 | Otherwise, invoke the type checker using the "Run" button. It may be 78 | convenient to enable the option in DrRacket to show gold highlighting on 79 | errors, because it causes type errors to be highlighted while typing. 80 | 81 | Alternatively, it is also possible to use any editor to create a Pie program, 82 | and then save it to a file. Run the file with the command-line version of 83 | Racket to test it. 84 | 85 | The 86 | @other-doc['(lib "todo-list/scribblings/todo-list.scrbl")] 87 | is supported by Pie. Each @pie[TODO] in the program is listed. 88 | 89 | @section{General-Purpose Expressions} 90 | @defform[#:kind "type annotation" (the type expr)]{ 91 | Asserts that @pie[expr] is a @pie[type]. This can be necessary when there is 92 | insufficient information for Pie to discover an expression's type. 93 | @ex[(eval:error nil) 94 | (the (List Nat) 95 | nil) 96 | (eval:error (cons 2 (same 2))) 97 | (the (Σ ((n Nat)) 98 | (= Nat n n)) 99 | (cons 2 (same 2))) 100 | (the (Σ ((n Nat)) 101 | (= Nat n 2)) 102 | (cons 2 (same 2)))] 103 | } 104 | @defform[#:kind "incomplete expression" #:id TODO TODO]{ 105 | @pie[TODO] represents a part of a program that is not yet written, corresponding 106 | to the empty boxes in @emph{The Little Typer}. Users may optionally leave a note 107 | or other expression behind as a reminder. 108 | } 109 | 110 | @section{Types, Constructors, and Eliminators} 111 | @subsection{Absurd} 112 | @def-type-constructor[Absurd]{ 113 | @pie[Absurd] is a type with no values. 114 | } 115 | @def-eliminator[(ind-Absurd [target Absurd] [motive U]) motive]{ 116 | Given an @pie[Absurd] expression, @pie[ind-Absurd] can have any type at all. 117 | @ex[(the (→ Absurd 118 | Nat) 119 | (λ (nope) 120 | (ind-Absurd nope Nat)))] 121 | } 122 | 123 | @subsection{Trivial} 124 | @def-type-constructor[Trivial]{@pie[Trivial] is a type with exactly one value.} 125 | @def-constructor[sole Trivial]{ 126 | @pie[sole] is the only @pie[Trivial] value, and every @pie[Trivial] expression 127 | is the same @pie[Trivial] as @pie[sole]. 128 | @ex[sole 129 | (check-same (→ Trivial 130 | Trivial) 131 | (λ (x) 132 | sole) 133 | (λ (y) 134 | y))] 135 | } 136 | 137 | @subsection{Atoms} 138 | @def-type-constructor[Atom]{Atoms are like Lisp symbols.} 139 | @def-constructor[(quote [atom identifier]) Atom]{ 140 | Each atom is a constructor. @pie[quote] is always written with a single 141 | tick mark. 142 | @ex['grønkål 143 | 'agurk] 144 | } 145 | 146 | @subsection{Natural Numbers} 147 | @def-type-constructor[Nat]{ 148 | The natural numbers, called @pie[Nat], are all the numbers greater than or equal to zero. 149 | } 150 | @def-constructor[zero Nat]{@pie[zero] is the smallest @pie[Nat].} 151 | @def-constructor[(add1 [n Nat]) Nat]{@pie[add1] makes a @pie[Nat] one larger.} 152 | @def-eliminator[(which-Nat [target Nat] [base _X] [step (-> Nat _X)]) _X]{ 153 | @pie[which-Nat] is a case operator on @pie[Nat]. 154 | @ex[(which-Nat 0 0 (λ (smaller) smaller)) 155 | (which-Nat 17 0 (λ (smaller) smaller))] 156 | } 157 | @def-eliminator[(iter-Nat [target Nat] [base _X] [step (-> _X _X)]) _X]{ 158 | @pie[iter-Nat] applies @pie[step] to @pie[base] @pie[target] times. 159 | @ex[(iter-Nat 5 160 | 0 161 | (λ (x) 162 | (add1 (add1 x))))] 163 | } 164 | @def-eliminator[(rec-Nat [target Nat] [base _X] [step (-> Nat _X _X)]) X]{ 165 | @pie[rec-Nat] is primitive recursion on @pie[Nat]. If @pie[target] is 166 | @pie[zero], then the whole expression is @pie[base]. If @pie[target] is 167 | @pie[(add1 _n)], then the whole expression is 168 | @pie[(step _n (rec-Nat _n base step))]. 169 | } 170 | @def-eliminator[(ind-Nat [target Nat] 171 | [motive (-> Nat U)] 172 | [base (motive zero)] 173 | [step (Π ((n Nat)) 174 | (-> (motive n) 175 | (motive (add1 n))))]) 176 | (motive target)]{ 177 | @pie[ind-Nat] is induction on @pie[Nat]. @pie[motive] is an @pie[(→ Nat U)], 178 | and the whole expression's type is @pie[(motive target)]. @pie[ind-Nat] 179 | computes identically to @pie[rec-Nat]; the type is, however, more expressive. 180 | } 181 | 182 | @subsection{Pairs} 183 | @def-type-constructor[(Σ ((x A1) (y A2) ...) D)]{ 184 | The values of @pie[(Σ ((_x _A)) _D)] are @pie[(cons _a _d)], where 185 | @pie[_a] is an @pie[_A] and the type of @pie[_d] is found by consistently 186 | replacing @pie[_x] with @pie[_a] in @pie[_D]. 187 | 188 | @pie[(Σ ((x A1) (y A2) ...) D)] is an abbreviation for the nested @pie[Σ]-expressions 189 | @pieblock[(Σ ((x A1)) 190 | (Σ ((y A2)) 191 | ... 192 | D))] 193 | } 194 | @def-type-constructor[(Sigma ((x A1) (y A2) ...) D)]{@pie[Sigma] is an alias for @pie[Σ]} 195 | @def-type-constructor[(Pair A D)]{A shorter way of writing @pie[(Σ ((x A)) D)] when @pie[x] is not used.} 196 | @def-constructor[(cons [a A] [d D^]) (Σ ((x A)) D)]{ 197 | @pie[cons] is the constructor for @pie[Σ]. @pie[D^] is the result of 198 | consistently replacing each @pie[x] in @pie[D] with @pie[a]. 199 | } 200 | @def-eliminator[(car [p (Σ ((x _A)) _D)]) _A]{ 201 | The first projection of a pair. If @pie[p] is a @pie[(Σ ((_x _A)) _D)], then 202 | @pie[(car p)] is an @pie[_A]. Furthermore, @pie[(car (cons _a _d))] is @pie[_a]. 203 | } 204 | @def-eliminator[(cdr [p (Σ ((x _A)) _D)]) _D]{ 205 | The second projection of a pair. If @pie[p] is a @pie[(Σ ((_x _A)) _D)], then 206 | @pie[(cdr p)] is a @pie[_D] where each @pie[_x] has been replaced by @pie[(car p)]. 207 | Furthermore, @pie[(cdr (cons _a _d))] is @pie[_d]. 208 | } 209 | 210 | @subsection{Functions} 211 | @def-type-constructor[(Π ((x X1) (y X2) ...) B)]{ 212 | Function types are written with @pie[Π]. 213 | All functions take exactly one argument, and what appears to be a multiple-argument 214 | function or function type is actually a Curried function. In other words, 215 | @pie[(Π ((x X1) (y X2) ...) B)] is an abbreviation for 216 | @pieblock[(Π ((x X1)) 217 | (Π ((y X2)) 218 | ... 219 | B))] 220 | The type of a function application is found by substituting the actual argument for 221 | the argument name in the return type. 222 | @ex[((the (Π ((n Nat)) 223 | (= Nat n n)) 224 | (λ (n) 225 | (same n))) 226 | 5) 227 | ((the (Π ((n Nat)) 228 | (= Nat n n)) 229 | (λ (n) 230 | (same n))) 231 | 15)] 232 | } 233 | @def-type-constructor[(Pi ((x X1) (y X2) ...) B)]{ 234 | @pie[Pi] is an alias for @pie[Π]. 235 | } 236 | @def-type-constructor[(∏ ((x X1) (y X2) ...) B)]{ 237 | @pie[∏] is an alias for @pie[Π] that is easier to type on some keyboards. 238 | } 239 | @def-type-constructor[(→ X1 X2 ... B)]{ 240 | @pie[→], pronounced "arrow", is shorter way of writing @pie[(Π ((x X1) (x X2) ...) B)] when the identifiers @racket[x ...] are not used.} 241 | @def-type-constructor[(-> X1 X2 ... B)]{@pie[->] is an alias for @pie[→].} 242 | @defform[#:kind "constructor" 243 | #:literals (x1 x2) 244 | (λ (x1 x2 ...) b)]{ 245 | Functions are constructed with @pie[λ]. @pie[(λ (x1 x2 ...) b)] is a 246 | @pie[(Π ((x1 X1) (x2 X2) ...) B)] if when @pie[x1] is a @pie[X1], @pie[x2] is a @pie[X2], ..., 247 | then @pie[b] is a @pie[B]. 248 | 249 | What may appear to be multiple-argument functions are actually nested one-argument functions. 250 | @ex[(the (→ Atom Atom 251 | Atom) 252 | (λ (food beverage) 253 | food)) 254 | (the (→ Atom 255 | (→ Atom 256 | Atom)) 257 | (λ (food) 258 | (λ (beverage) 259 | food))) 260 | (check-same (→ Atom Atom 261 | Atom) 262 | (λ (food) 263 | (λ (beverage) 264 | beverage)) 265 | (λ (food beverage) 266 | beverage))] 267 | } 268 | @defform[#:kind "constructor" (lambda (x1 x2 ...) b)]{@pie[lambda] is an alias for @pie[λ].} 269 | 270 | @subsection{Lists} 271 | @def-type-constructor[(List E)]{ 272 | @pie[(List E)] is the type of lists in which all entries are @pie[E]s. 273 | } 274 | @def-constructor[nil (List _E)]{ 275 | @ex[(the (List Atom) nil) 276 | (eval:error nil) 277 | (the (List (→ Nat 278 | Nat)) 279 | nil)] 280 | } 281 | @def-constructor[(:: [e _E] [es (List _E)]) (List _E)]{ 282 | @ex[(:: 0 (:: 1 (:: 2 nil))) 283 | (eval:error (:: 0 (:: 'one (:: 2 nil))))] 284 | } 285 | @def-eliminator[(rec-List [target (List _E)] 286 | 287 | [base _X] 288 | [step (-> E (List _E) _X _X)]) 289 | _X]{ 290 | @pie[rec-List] is primitive recursion on lists. 291 | If @pie[target] is @pie[nil], the result is @pie[base]. If @pie[target] 292 | is @pie[(:: _e _es)], then the result is @pie[(step _e _es (rec-List _es base step))]. 293 | @ex[(rec-List (the (List Atom) nil) 294 | zero 295 | (λ (e es len-1) 296 | (add1 len-1))) 297 | (rec-List (:: 'rødbeder 298 | (:: 'gulerødder 299 | (:: 'kartofler nil))) 300 | zero 301 | (λ (e es len-1) 302 | (add1 len-1)))] 303 | } 304 | @def-eliminator[(ind-List [target (List _E)] 305 | [motive (-> (List _E) U)] 306 | [base (motive nil)] 307 | [step (Π ((e _E) 308 | (es (List _E))) 309 | (-> (motive es) 310 | (motive (:: e es))))]) 311 | (motive target)]{ 312 | @pie[ind-List] is induction on lists. When @pie[target] is a @pie[(List _E)], t 313 | the whole expression's type is @pie[(motive target)], the type of 314 | @pie[base] is @pie[(motive nil)], and the type of @pie[step] is 315 | @pieblock[(Π ((e _E) 316 | (es (List _E))) 317 | (→ (motive es) 318 | (motive (:: e es))))]. 319 | @pie[ind-List] computes just like @pie[rec-List]. 320 | 321 | @ex[(ind-List (:: 'ananas 322 | (:: 'granatæble 323 | nil)) 324 | (λ (es) 325 | Nat) 326 | zero 327 | (λ (e es len) 328 | (add1 len))) 329 | (ind-List (:: 'ananas 330 | (:: 'granatæble 331 | nil)) 332 | (λ (es) 333 | (= (List Atom) es es)) 334 | (same nil) 335 | (λ (e es es=es) 336 | (cong es=es 337 | (the (→ (List Atom) 338 | (List Atom)) 339 | (λ (xs) 340 | (:: e xs))))))] 341 | } 342 | 343 | @subsection{Vectors} 344 | @def-type-constructor[(Vec E len)]{ 345 | A @pie[(Vec E len)] is a list that contains precisely @pie[len] entries, 346 | each of which is an @pie[E]. 347 | } 348 | @def-constructor[vecnil (Vec _E zero)]{ 349 | @pie[vecnil] is an empty @pie[Vec]. 350 | @ex[(the (Vec Nat zero) vecnil) 351 | (the (Vec Atom zero) vecnil) 352 | (eval:error (the (Vec Atom 4) vecnil)) 353 | (eval:error vecnil)] 354 | } 355 | @def-constructor[(vec:: [e _E] [es (Vec _E k)]) (Vec _E (add1 k))]{ 356 | @ex[(the (Vec Nat 2) (vec:: 17 (vec:: 6 vecnil))) 357 | (eval:error (the (Vec Nat 3) (vec:: 17 (vec:: 6 vecnil)))) 358 | (eval:error (vec:: 17 (vec:: 6 vecnil)))] 359 | } 360 | @def-eliminator[(head [es (Vec _E (add1 k))]) _E]{ 361 | @pie[head] finds the first entry in a non-empty @pie[Vec]. 362 | @ex[(head (the (Vec Atom 1) (vec:: 'æbler vecnil))) 363 | (eval:error (head (the (Vec Atom 0) vecnil)))] 364 | } 365 | @def-eliminator[(tail [es (Vec _E (add1 k))]) (Vec _E k)]{ 366 | @pie[tail] finds the all but the first entry in a non-empty @pie[Vec]. 367 | @ex[(tail (the (Vec Atom 2) (vec:: 'pærer (vec:: 'æbler vecnil)))) 368 | (eval:error (tail (the (Vec Atom 0) vecnil)))] 369 | } 370 | @def-eliminator[(ind-Vec [target-1 Nat] 371 | [target-2 (Vec _E target-1)] 372 | [motive (Π ((k Nat)) 373 | (→ (Vec _E k) 374 | U))] 375 | [base (motive zero vecnil)] 376 | [step (Π ((k Nat) 377 | (e _E) 378 | (es (Vec _E k))) 379 | (→ (motive k es) 380 | (motive (add1 k) (vec:: e es))))]) 381 | (motive target-1 target-2)]{ 382 | Induction on vectors is used to prove things about any vector. 383 | @pie[target-1] is the length, and @pie[target-2] is the vector itself. 384 | The motive is a 385 | @pieblock[(Π ((k Nat)) 386 | (→ (Vec _E k) 387 | U))] 388 | The @pie[base] is a @pie[(motive zero vecnil)], 389 | and the @pie[step] is a 390 | @pieblock[(Π ((k Nat) 391 | (e _E) 392 | (es (Vec _E k))) 393 | (→ (motive k es) 394 | (motive (add1 k) (vec:: e es))))] 395 | } 396 | 397 | @subsection{Either} 398 | @def-type-constructor[(Either L R)]{ 399 | @pie[Either] represents that there are two possibilities: either an @pie[L] 400 | with @pie[left] on top, or an @pie[R] with @pie[right] on top. 401 | } 402 | @def-constructor[(left [l _L]) (Either _L _R)]{ 403 | @ex[(the (Either Nat Atom) (left 3)) 404 | (eval:error (the (Either Nat Atom) (left 'rosenkål)))] 405 | } 406 | @def-constructor[(right [r _R]) (Either _L _R)]{ 407 | @ex[(the (Either Nat Atom) (right 'blomkål)) 408 | (eval:error (the (Either Nat Atom) (right 8)))] 409 | } 410 | @def-eliminator[(ind-Either [target (Either _X _Y)] 411 | [motive (→ (Either _X _Y) U)] 412 | [on-left (Π ((l _L)) 413 | (motive (left l)))] 414 | [on-right (Π ((r _R)) 415 | (motive (right r)))]) 416 | (motive target)]{ 417 | Induction on @pie[Either] consists of showing how to fulfill the motive for 418 | both constructors. 419 | @ex[(ind-Either (the (Either Nat Atom) (left 5)) 420 | (λ (e) 421 | Nat) 422 | (λ (n) 423 | n) 424 | (λ (a) 425 | 17)) 426 | (ind-Either (the (Either Nat Atom) (right 'peberfrugt)) 427 | (λ (e) 428 | Nat) 429 | (λ (n) 430 | n) 431 | (λ (a) 432 | 17))] 433 | } 434 | 435 | @subsection{Equality} 436 | @def-type-constructor[(= X from to)]{ 437 | The equality type's values are evidence that @pie[from] and @pie[to] 438 | are equal. 439 | } 440 | @def-constructor[(same [e _X]) (= _X e e)]{ 441 | If @pie[e] is an @pie[X], then @pie[(same e)] is an @pie[(= X e e)], because 442 | @pie[e] is the same @pie[X] as @pie[e]. 443 | @ex[(the (= Nat 2 2) (same 2))] 444 | } 445 | @def-eliminator[(replace [target (= _X _from _to)] 446 | [motive (→ _X U)] 447 | [base (motive _from)]) 448 | (motive _to)]{ 449 | If @pie[target] is an @pie[(= _X _from _to)], @pie[motive] is an 450 | @pieblock[(→ _X 451 | U)] 452 | and @pie[base] is a @pie[(motive _from)], then 453 | @pie[(replace target motive base)] is a @pie[(motive _to)]. 454 | } 455 | @def-eliminator[(symm [target (= _A _from _to)]) (= _A _to _from)]{ 456 | If @pie[target] is an @pie[(= _A _from _to)], then @pie[(symm target)] is an 457 | @pie[(= _A _to _from)]. 458 | @ex[(the (Π ((x Nat) 459 | (y Nat)) 460 | (→ (= Nat x y) 461 | (= Nat y x))) 462 | (λ (x y p) 463 | (symm p)))] 464 | } 465 | @def-eliminator[(trans [target-1 (= _X _from _middle)] 466 | [target-2 (= _X _middle _to)]) 467 | (= _X _from _to)]{ 468 | @pie[trans] is used to "glue together" evidence of equality. If @pie[target-1] 469 | is an @pie[(= _X _from _middle)] and @pie[target-2] is an @pie[(= _X _middle _to)], 470 | then @pie[(trans target-1 target-2)] is an @pie[(= _X _from _to)]. 471 | } 472 | @def-eliminator[(cong [target (= _X _from _to)] [fun (→ _X _Y)]) 473 | (= _Y (fun _from) (fun _to))]{ 474 | @pie[cong] shows that all functions respect equality. In particular, 475 | if @pie[target] is an @pie[(= _X _from _to)] and @pie[fun] is an 476 | @pieblock[(→ _X 477 | _Y)] 478 | then @pie[(cong target fun)] is an 479 | @pieblock[(= _Y (fun _from) (fun _to))] 480 | } 481 | @def-eliminator[(ind-= [target (= _A _from _to)] 482 | [motive (Π ((x _A)) 483 | (-> (= _A _from x) 484 | U))] 485 | [base (motive _from (same _from))]) 486 | (motive _to target)]{ 487 | The induction principle on equality evidence takes a target which is an 488 | @pie[(= _A _from _to)], a motive which is a 489 | @pieblock[(Π ((x _A)) 490 | (-> (= _A _from x) 491 | U))] 492 | and a base which is a @pie[(motive _from (same _from))]. The entire expression 493 | is then a @pie[(motive _to target)]. 494 | } 495 | 496 | @subsection{Universe} 497 | @def-type-constructor[U]{ 498 | The universe describes all types except itself and those types that could contain 499 | @pie[U]. 500 | @ex[(the U Nat) 501 | (eval:error (the U U)) 502 | (the U (List Atom)) 503 | (eval:error (the U (List U)))] 504 | } 505 | 506 | @section{Declarations} 507 | In addition to expressions, Pie has three syntactic forms that are only valid 508 | at the top level of a program. 509 | 510 | @subsection{Definitions} 511 | @defform[#:kind "declaration" (claim x type)]{ 512 | Before using @pie[define] to associate a name with an expression, it is first necessary to associate 513 | the expression's type with the name using @pie[claim]. 514 | } 515 | @defform[#:kind "declaration" (define x expr)]{ 516 | Associate the expression @pie[expr] with the name @pie[x], after having already @pie[claim]ed its type. 517 | } 518 | 519 | @subsection{Testing Pie programs} 520 | @defform[#:kind "declaration" (check-same type expr1 expr2)]{ 521 | Check that @pie[expr1] is the same @pie[type] as @pie[expr2], and fail if not. 522 | 523 | @ex[(check-same Nat 4 4) 524 | (check-same Atom 'kirsebær 'kirsebær) 525 | (eval:error (check-same Atom 4 'four)) 526 | (eval:error (check-same Atom 'kirsebær 'hindbær))] 527 | 528 | 529 | Because of the η-rules for @pie[Π] and @pie[Absurd], every proof of a negation 530 | is the same as every other proof. This is useful when testing programs that 531 | produce proofs. 532 | 533 | @ex[(check-same (→ (→ (= Nat 2 3) 534 | Absurd) 535 | (→ (= Nat 2 3) 536 | Absurd) 537 | (→ (= Nat 2 3) 538 | Absurd)) 539 | (λ (f g) 540 | f) 541 | (λ (f g) 542 | g))] 543 | } 544 | -------------------------------------------------------------------------------- /pretty.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/function racket/list racket/match) 5 | 6 | (require "resugar.rkt") 7 | 8 | (provide pprint-pie pprint-message indented) 9 | 10 | (define indentation (make-parameter 0)) 11 | 12 | (define-syntax indented 13 | (syntax-rules () 14 | [(_ i e ...) 15 | (parameterize ([indentation (+ i (indentation))]) 16 | (begin e ...))])) 17 | 18 | (define (spaces n) 19 | (for ([i (in-range n)]) 20 | (printf " "))) 21 | 22 | (define (space) (spaces 1)) 23 | 24 | (define (indent) 25 | (spaces (indentation))) 26 | 27 | (define (start-line) 28 | (indent)) 29 | 30 | (define (terpri) 31 | (printf "\n") 32 | (start-line)) 33 | 34 | (define (l) 35 | (printf "(")) 36 | 37 | (define (r) 38 | (printf ")")) 39 | 40 | (define-syntax parens 41 | (syntax-rules () 42 | ((_ e ...) 43 | (begin (l) 44 | (indented 1 e ...) 45 | (r))))) 46 | 47 | (define (top-binder? sym) 48 | (and (symbol? sym) 49 | (or (eqv? sym '?) 50 | (eqv? sym 'Pi) 51 | (eqv? sym 'Π) 52 | (eqv? sym 'Sigma) 53 | (eqv? sym 'Σ)))) 54 | 55 | (define (ind? sym) 56 | (and (symbol? sym) 57 | (let ([str (symbol->string sym)]) 58 | (and (>= (string-length str) 4) 59 | (string=? (substring str 0 4) "ind-"))))) 60 | 61 | (define (simple-elim? sym) 62 | (and (symbol? sym) 63 | (or (eqv? sym 'which-Nat) 64 | (eqv? sym 'iter-Nat) 65 | (let ([str (symbol->string sym)]) 66 | (and (>= (string-length str) 4) 67 | (string=? (substring str 0 4) "rec-")))))) 68 | 69 | (define (sep s op args) 70 | (match args 71 | ['() (void)] 72 | [(list b) (op b)] 73 | [(cons b bs) (op b) (s) (sep s op bs)])) 74 | 75 | (define (vsep op args) 76 | (sep terpri op args)) 77 | (define (hsep op args) 78 | (sep space op args)) 79 | 80 | (define (annots bindings) 81 | (define (print-binding b) 82 | (match b 83 | [(list (app symbol->string x) ty) 84 | (parens 85 | (printf x) 86 | (space) 87 | (indented (+ (string-length x) 2) 88 | (print-pie ty)))])) 89 | (vsep print-binding bindings)) 90 | 91 | (define (atomic? x) 92 | (match x 93 | [(? symbol?) #t] 94 | [(? number?) #t] 95 | [(list 'quote _) #t] 96 | [_ #f])) 97 | 98 | ;; Print a high-level Pie expression 99 | (define (print-pie expr) 100 | ;; Always display something, even if the print code is borked 101 | (with-handlers ([exn:fail? (lambda (e) 102 | (display expr))]) 103 | (match expr 104 | [(list (? top-binder? (app symbol->string binder-string)) 105 | bindings 106 | body) 107 | (parens (printf binder-string) 108 | (spaces 1) 109 | (indented (add1 (string-length binder-string)) 110 | (parens (annots bindings))) 111 | (terpri) 112 | (print-pie body))] 113 | [(list (or 'lambda 'λ) (list-rest args) body) 114 | (parens 115 | (display 'λ) (space) (parens (hsep display args)) 116 | (indented 1 (terpri) (print-pie body)))] 117 | [(cons (or '-> '→) (app reverse (cons ret (app reverse args)))) 118 | (parens (display "→") 119 | (if (andmap atomic? args) 120 | (begin (space) 121 | (hsep display args)) 122 | (indented 3 123 | (space) 124 | (vsep print-pie 125 | args))) 126 | (indented 1 (terpri) (print-pie ret)) )] 127 | [(list 'quote x) (printf "'~a" x)] 128 | [(cons (and op (? ind? (app symbol->string elim))) args) 129 | (define target-count 130 | (case op 131 | [(ind-Vec trans) 2] 132 | [else 1])) 133 | (define-values (targets normal) 134 | (split-at args target-count)) 135 | (parens 136 | (display elim) 137 | (space) 138 | (hsep print-pie targets) 139 | (match normal 140 | [(list) (void)] 141 | [(cons motive others) 142 | (indented 2 (terpri) (vsep print-pie (cons motive others)))]))] 143 | [(cons (and op (? simple-elim? (app symbol->string elim))) args) 144 | (match-define (cons target normal) args) 145 | (parens 146 | (display elim) 147 | (space) 148 | (print-pie target) 149 | (match normal 150 | [(list) (void)] 151 | [others 152 | (indented 2 153 | (terpri) 154 | (vsep print-pie others))]))] 155 | [(list-rest (? symbol? op) (? atomic? arg) args) 156 | #:when (and (< (length args) 20) 157 | (andmap atomic? args)) 158 | (parens 159 | (hsep print-pie 160 | (cons op (cons arg args))))] 161 | [(list-rest (? symbol? op) arg args) 162 | (parens (print-pie op) (space) 163 | (indented (add1 (string-length (symbol->string op))) 164 | (print-pie arg)) 165 | (indented 1 166 | (when (pair? args) 167 | (terpri) 168 | (vsep print-pie 169 | args))))] 170 | [(list-rest op args) 171 | (parens (print-pie op) 172 | (indented 1 173 | (terpri) 174 | (vsep print-pie args)))] 175 | [other (display other)]))) 176 | 177 | (define (pprint-pie expr (description "")) 178 | (start-line) 179 | (indented (string-length description) 180 | (when (not (string=? description "")) 181 | (display description)) 182 | (print-pie expr))) 183 | 184 | (define (pprint-claim name ty) 185 | (start-line) 186 | (parens 187 | (indented 1 188 | (display 'claim) (space) (display name) (terpri) 189 | (print-pie ty)))) 190 | 191 | (define (pprint-message msg) 192 | (start-line) 193 | (for ([part (in-list msg)]) 194 | (cond [(string? part) 195 | (display part)] 196 | [(symbol? part) 197 | (space) 198 | (display part) 199 | (space)] 200 | [else (indented 2 (terpri) (print-pie (resugar part))) (terpri)]))) 201 | -------------------------------------------------------------------------------- /rep.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;;; This module contains utilities for interacting with Pie from the 4 | ;;; Racket REPL and in test suites. 5 | 6 | (require "basics.rkt") 7 | (require "typechecker.rkt") 8 | (require "normalize.rkt") 9 | (require racket/match) 10 | (provide (all-defined-out)) 11 | 12 | (: norm-type (-> Ctx Src (Perhaps Core))) 13 | (define (norm-type Γ e) 14 | (go-on ((e-out (is-type Γ '() e))) 15 | (go (read-back-type Γ (val-in-ctx Γ e-out))))) 16 | 17 | (: rep (-> Ctx Src (Perhaps (List 'the Core Core)))) 18 | (define (rep Γ e) 19 | (go-on ((`(the ,t-out ,e-out) (synth Γ '() e))) 20 | (let ((tv (val-in-ctx Γ t-out)) 21 | (v (val-in-ctx Γ e-out))) 22 | (go `(the ,(read-back-type Γ tv) 23 | ,(read-back Γ tv v)))))) 24 | 25 | (: norm (-> Ctx Src (Perhaps Core))) 26 | (define (norm Γ e) 27 | (match (go-on ((`(the ,t-out ,e-out) (synth Γ '() e))) 28 | (let ((tv (val-in-ctx Γ t-out)) 29 | (v (val-in-ctx Γ e-out))) 30 | (go `(the ,(read-back-type Γ tv) 31 | ,(read-back Γ tv v))))) 32 | [(go e) (go e)] 33 | [(stop where msg) 34 | (match (norm-type Γ e) 35 | [(go out) (go out)] 36 | [_ (stop where msg)])])) 37 | 38 | 39 | (: type-or-expr (-> Ctx Src (Perhaps Ctx))) 40 | (define (type-or-expr Γ e) 41 | (match (rep Γ e) 42 | [(go out) 43 | (begin (displayln out) 44 | (go Γ))] 45 | [(stop where msg) 46 | (match (norm-type Γ e) 47 | [(go out) (begin (displayln out) (go Γ))] 48 | [_ (stop where msg)])])) 49 | 50 | (: check-same (-> Ctx Loc Src Src Src (Perhaps Void))) 51 | (define (check-same Γ loc t a b) 52 | (go-on ((t-out (is-type Γ '() t)) 53 | (tv (go (val-in-ctx Γ t-out))) 54 | (a-out (check Γ '() a tv)) 55 | (b-out (check Γ '() b tv)) 56 | (av (go (val-in-ctx Γ a-out))) 57 | (bv (go (val-in-ctx Γ b-out)))) 58 | (convert Γ loc tv av bv))) 59 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /resugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match) 4 | (require (only-in "basics.rkt" var-name?)) 5 | 6 | (provide resugar) 7 | 8 | (define (resugar ll-term) 9 | (cdr (resugar* ll-term))) 10 | 11 | (define (resugar* ll-term) 12 | (match ll-term 13 | [`U 14 | (cons '() 'U)] 15 | [`(TODO . ,_) 16 | (cons '() 'TODO)] 17 | [`zero 18 | (cons '() 0)] 19 | [`(add1 ,n) 20 | (let ([resugared-n (resugar* n)]) 21 | (cons (car resugared-n) 22 | (if (or (eqv? (cdr resugared-n) 0) 23 | (positive-number? (cdr resugared-n))) 24 | (add1 (cdr resugared-n)) 25 | `(add1 ,(cdr resugared-n)))))] 26 | [`',sym 27 | (cons '() `',sym)] 28 | [(? symbol? x) 29 | (if (pie-keyword? x) 30 | (cons '() x) 31 | (cons `(,x) x))] 32 | [`(λ (,x) ,result) 33 | (let ((resugared (resugar* result))) 34 | (cons (remv* `(,x) (car resugared)) 35 | (add-λ x (cdr resugared))))] 36 | [`(Π ((,x ,arg-type)) ,result-type) 37 | (let ((arg (resugar* arg-type)) 38 | (res (resugar* result-type))) 39 | (if (memv x (car res)) 40 | (cons (append (car arg) (remv* `(,x) (car res))) 41 | (add-Π x (cdr arg) (cdr res))) 42 | (cons (append (car arg) (car res)) 43 | (add--> (cdr arg) (cdr res)))))] 44 | [`(Σ ((,x ,car-type)) ,cdr-type) 45 | (let ((a-t (resugar* car-type)) 46 | (d-t (resugar* cdr-type))) 47 | (if (memv x (car d-t)) 48 | (cons (append (car a-t) (remv* `(,x) (car d-t))) 49 | (add-Σ x (cdr a-t) (cdr d-t))) 50 | (cons (append (car a-t) (car d-t)) 51 | `(Pair ,(cdr a-t) ,(cdr d-t)))))] 52 | [`(:: ,hd (nil)) 53 | (let ((hd-out (resugar* hd))) 54 | (cons (car hd-out) 55 | `(list ,(cdr hd-out))))] 56 | [`(:: ,hd ,tl) 57 | (let ([resugared-hd (resugar* hd)] 58 | [resugared-tl (resugar* tl)]) 59 | (cons (append (car resugared-hd) (car resugared-tl)) 60 | (if (and (pair? (cdr resugared-tl)) 61 | (eqv? (car (cdr resugared-tl)) 62 | 'list)) 63 | `(list ,(cdr resugared-hd) . ,(cdr (cdr resugared-tl))) 64 | `(:: ,(cdr resugared-hd) ,(cdr resugared-tl)))))] 65 | [`(vec:: ,hd (vecnil)) 66 | (let ((hd-out (resugar* hd))) 67 | (cons (car hd-out) 68 | `(vec ,(cdr hd-out))))] 69 | [`(vec:: ,hd ,tl) 70 | (let ([resugared-hd (resugar* hd)] 71 | [resugared-tl (resugar* tl)]) 72 | (cons (append (car resugared-hd) (car resugared-tl)) 73 | (if (and (pair? (cdr resugared-tl)) 74 | (eqv? (car (cdr resugared-tl)) 75 | 'list)) 76 | `(vec ,(cdr resugared-hd) . ,(cdr (cdr resugared-tl))) 77 | `(vec:: ,(cdr resugared-hd) ,(cdr resugared-tl)))))] 78 | [`(replace ,t ,tgt ,mot ,base) 79 | (let ((resugared-t (resugar* t)) 80 | (resugared-tgt (resugar* tgt)) 81 | (resugared-mot (resugar* mot)) 82 | (resugared-base (resugar* base))) 83 | (cons (append (car resugared-t) (car resugared-tgt) (car resugared-mot) (car resugared-base)) 84 | `(replace (the ,(cdr resugared-t) ,(cdr resugared-tgt)) 85 | ,(cdr resugared-mot) 86 | ,(cdr resugared-base))))] 87 | [`(cong ,tgt ,t ,fun) 88 | (let ((resugared-tgt (resugar* tgt)) 89 | (resugared-fun (resugar* fun))) 90 | (cons (append (car resugared-tgt) (car resugared-fun)) 91 | `(cong ,(cdr resugared-tgt) 92 | ,(cdr resugared-fun))))] 93 | [`(,kw . ,args) 94 | #:when (pie-keyword? kw) 95 | (let ((resugared-args (map (lambda (arg) (resugar* arg)) args))) 96 | (cons (apply append (map car resugared-args)) 97 | `(,kw . ,(map cdr resugared-args))))] 98 | [`(,op ,arg) 99 | (let ([resugared-op (resugar* op)] 100 | [resugared-arg (resugar* arg)]) 101 | (cons (append (car resugared-op) (car resugared-arg)) 102 | (cond [(not (pair? (cdr resugared-op))) 103 | `(,(cdr resugared-op) ,(cdr resugared-arg))] 104 | [(pie-keyword? (car (cdr resugared-op))) 105 | `(,(cdr resugared-op) ,(cdr resugared-arg))] 106 | [else 107 | (append (cdr resugared-op) `(,(cdr resugared-arg)))])))] 108 | ;;; Resugaring should never crash, no matter how odd the code is 109 | [`,any-term (cons '() any-term)])) 110 | 111 | (define (add-λ x term) 112 | (match term 113 | [`(λ ,xs ,result) 114 | `(λ (,x . ,xs) ,result)] 115 | [`,non-λ 116 | `(λ (,x) ,non-λ)])) 117 | 118 | (define (add-Π x arg-type term) 119 | (match term 120 | [`(Π ,args ,result-type) 121 | `(Π ((,x ,arg-type) . ,args) ,result-type)] 122 | [`,non-Π 123 | `(Π ((,x ,arg-type)) ,non-Π)])) 124 | 125 | (define (add--> arg-type term) 126 | (match term 127 | [`(→ . ,types) 128 | `(→ ,arg-type . ,types)] 129 | [`,non--> 130 | `(→ ,arg-type ,non-->)])) 131 | 132 | (define (add-Σ x arg-type term) 133 | (match term 134 | [`(Σ ,args ,result-type) 135 | `(Σ ((,x ,arg-type) . ,args) ,result-type)] 136 | [`,non-Σ 137 | `(Σ ((,x ,arg-type)) ,non-Σ)])) 138 | 139 | (define (add-? x hole-type term) 140 | (match term 141 | [`(? ,args ,body) 142 | `(? ((,x ,hole-type) . ,args) ,body)] 143 | [`,non-? 144 | `(? ((,x ,hole-type)) ,non-?)])) 145 | 146 | 147 | (define (positive-number? x) 148 | (exact-positive-integer? x)) 149 | 150 | (define (quoted-symbol? term) 151 | (match term 152 | [`',x (legal-symbol? x)] 153 | [`,non-x #f])) 154 | 155 | (define (legal-symbol? sym) 156 | (and (symbol? sym) 157 | (all-symbol-char? (string->list (symbol->string sym))))) 158 | 159 | (define (all-symbol-char? chars) 160 | (cond 161 | [(null? chars) 162 | #t] 163 | [(symbol-char? (car chars)) 164 | (all-symbol-char? (cdr chars))] 165 | [(not (symbol-char? (car chars))) 166 | #f])) 167 | 168 | (define (symbol-char? char) 169 | (or (char-alphabetic? char) 170 | (char=? char #\-))) 171 | 172 | (define (pie-keyword? x) 173 | (and (symbol? x) (not (var-name? x)))) 174 | -------------------------------------------------------------------------------- /serialization.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (require "basics.rkt" (only-in "normalize.rkt" read-back-ctx val-of-ctx)) 4 | ;(require racket/match racket/port racket/contract) 5 | 6 | (provide dump restore) 7 | 8 | (: dump (-> Serializable-Ctx String)) 9 | (define (dump v) 10 | (with-output-to-string 11 | (lambda () 12 | (parameterize ((print-graph #t)) 13 | (write v))))) 14 | 15 | (: restore (-> String Serializable-Ctx)) 16 | (define (restore str) 17 | ;; (printf "Restoring:\n\t~v\n\n" str) 18 | (with-input-from-string str 19 | (lambda () 20 | (define v (read)) 21 | (if (serializable-ctx? v) 22 | v 23 | (error 'restore "Invalid deserialized context: ~a" v))))) 24 | -------------------------------------------------------------------------------- /show-goal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match racket/format racket/port racket/string) 4 | 5 | (require "resugar.rkt" "pretty.rkt") 6 | 7 | (provide goal->strings indent-string) 8 | 9 | ;;; This module implements showing TODO goals to users in the format 10 | ;;; described in the second recess of The Little Typer. 11 | 12 | (define (goal->strings loc Γ t) 13 | (define hole-summary 14 | (with-output-to-string 15 | (lambda () 16 | (pprint-pie (resugar t))))) 17 | (define free-vars 18 | (for/list ([H Γ] 19 | #:when (and (pair? H) 20 | (pair? (cdr H)) 21 | (pair? (cadr H)) 22 | (eqv? (caadr H) 'free))) 23 | (match-define (list x (list 'free ty)) H) 24 | (list x ty))) 25 | (define var-width 26 | (apply max 0 27 | (for/list ([b free-vars]) 28 | (string-length (symbol->string (car b)))))) 29 | (define hyps 30 | (for/list ([b free-vars]) 31 | (match-define (list x ty) b) 32 | (define padded-x 33 | (~a x 34 | #:align 'right 35 | #:min-width (add1 var-width) 36 | #:left-pad-string " ")) 37 | (~a 38 | padded-x 39 | " : " 40 | (resugar ty)))) 41 | (define conclusion 42 | (indent-string 1 hole-summary)) 43 | (define inference-bar 44 | (make-string 45 | (apply max 7 46 | (+ 2 (max-line-length hole-summary)) 47 | (for/list ([h hyps]) 48 | ;; The add1 is to make the line extend at least one 49 | ;; space past the width of the premise 50 | (add1 (max-line-length h)))) 51 | #\-)) 52 | (list hole-summary 53 | (string-join (append (reverse hyps) 54 | (list inference-bar 55 | conclusion)) 56 | "\n"))) 57 | 58 | 59 | (define (indent-string how-much str) 60 | (define pad (make-string how-much #\space)) 61 | (apply string-append 62 | (for/list ([line (in-list (string-split str "\n"))]) 63 | (string-append pad line "\n")))) 64 | 65 | 66 | 67 | (define (max-line-length str) 68 | (apply max 0 69 | (for/list ([line (in-list (string-split str "\n"))]) 70 | (string-length line)))) 71 | -------------------------------------------------------------------------------- /slideshow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "basics.rkt" "gui/main.rkt" "gui/pie-styles.rkt" "gui/print-gui.rkt") 4 | (require (only-in slideshow slide interactive inset text)) 5 | (require (only-in racket/gui/base get-display-size)) 6 | (require (only-in racket/gui 7 | editor-canvas% 8 | add-editor-keymap-functions 9 | add-text-keymap-functions)) 10 | (require (only-in framework panel:vertical-dragable%)) 11 | 12 | (provide pie-slide) 13 | 14 | (define (pie-on-slide-frame f 15 | #:initial-contents [contents ""] 16 | #:font-size [font-size #f] 17 | #:pie-context [pie-context init-ctx]) 18 | (define panel (new panel:vertical-dragable% [parent f])) 19 | (send panel set-orientation (pie-slide-orientation-horizontal?)) 20 | (parameterize ([current-pie-gui-font-size (or font-size 40)]) 21 | (define fb (new pie-feedback%)) 22 | (define ed (new pie-text% 23 | [feedback fb] 24 | [pie-context pie-context] 25 | [initial-contents contents])) 26 | 27 | (define c (new editor-canvas% [parent panel] [editor ed] [style '(hide-hscroll auto-vscroll no-border)])) 28 | (define fbc (new editor-canvas% [parent panel] [editor fb] [style '(hide-hscroll auto-vscroll no-border)])) 29 | 30 | (send panel set-percentages '(2/3 1/3)) 31 | 32 | (for ([ed (list fb ed)]) 33 | (define keymap (send ed get-keymap)) 34 | (add-editor-keymap-functions keymap) 35 | (add-text-keymap-functions keymap))) 36 | 37 | void) 38 | 39 | (define (pie-slide contents 40 | #:title [title ""] 41 | #:font-size [font-size #f] 42 | #:pie-context [pie-context init-ctx]) 43 | (slide #:title title 44 | (interactive (inset (text "Pie") 450 300) 45 | (lambda (f) 46 | (pie-on-slide-frame 47 | f 48 | #:initial-contents contents 49 | #:font-size (and font-size 50 | (let-values ([(h w) 51 | (get-display-size #t)]) 52 | (round (* (/ h 768) font-size)))) 53 | #:pie-context pie-context))))) 54 | -------------------------------------------------------------------------------- /test-todo-output.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit racket/port) 4 | 5 | (check-equal? 6 | (regexp-replace* 7 | #px"todo-test\\.pie:(\\d+)(:|\\.)(\\d+)" 8 | (with-output-to-string 9 | (lambda () (dynamic-require "todo-test.pie" #f))) 10 | (lambda (matched-string line delim col) 11 | (format "todo-test.pie:~a.~a" line col))) 12 | "/pie/todo-test.pie:10.15: TODO:\n n : Nat\n n-1 : Nat\n peas-of-n-1 : (Vec Atom n-1)\n------------------------------\n Atom\n\n\n/pie/todo-test.pie:10.20: TODO:\n n : Nat\n n-1 : Nat\n peas-of-n-1 : (Vec Atom n-1)\n------------------------------\n (Vec Atom n-1)\n\n\n/pie/todo-test.pie:13.17: TODO: Nat\n\n/pie/todo-test.pie:15.19: TODO: \n (Π ((n Nat))\n (Vec Atom n))\n\n\n") 13 | -------------------------------------------------------------------------------- /todo-test.pie: -------------------------------------------------------------------------------- 1 | #lang pie 2 | 3 | (claim peas (Pi ((n Nat)) (Vec Atom n))) 4 | (define peas 5 | (λ (n) 6 | (ind-Nat n 7 | (lambda (k) (Vec Atom k)) 8 | vecnil 9 | (λ (n-1 peas-of-n-1) 10 | (vec:: TODO TODO))))) 11 | 12 | (claim some-nat Nat) 13 | (define some-nat TODO) 14 | (claim multi-line (Pi ((n Nat)) (Vec Atom n))) 15 | (define multi-line TODO) -------------------------------------------------------------------------------- /tooltip.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require syntax/srcloc) 3 | (require racket/logging racket/string) 4 | (require (only-in "basics.rkt" var-name?)) 5 | (provide attach-tooltip log-all-tooltips!) 6 | 7 | ;; Tooltip handling for DrRacket. Tooltips are both logged and expanded so that 8 | ;; Emacs can get them from the expanded version and DrRacket can get them from 9 | ;; the online expander even if there's an error. 10 | 11 | (define-logger online-check-syntax) 12 | 13 | (define tooltips-queue (box '())) 14 | 15 | (define (keyword? x) (and (symbol? x) (not (var-name? x)))) 16 | 17 | (define (attach-tooltip stx where msg) 18 | (if (or (and (string? msg) (string=? (string-trim msg) "")) 19 | (eqv? where #f) 20 | (not (source-location? where))) 21 | stx 22 | (let ([tooltip 23 | (cond 24 | [(or (not (syntax? where)) 25 | (not (pair? (syntax-e where))) 26 | (let ([fst (car (syntax-e where))]) 27 | (and (identifier? fst) 28 | (free-identifier=? fst #'quote)))) 29 | (list (vector where 30 | (sub1 (source-location-position where)) 31 | (+ (sub1 (source-location-position where)) (source-location-span where)) 32 | msg))] 33 | [(and (syntax? where) 34 | (pair? (syntax-e where)) 35 | (let ([fst (car (syntax-e where))]) 36 | (and (identifier? fst) 37 | (keyword? (syntax-e fst))))) 38 | (let ([fst (car (syntax-e where))]) 39 | (list (vector where 40 | (sub1 (source-location-position where)) 41 | (+ (sub1 (source-location-position fst)) 42 | (source-location-span fst)) 43 | msg) 44 | (vector where 45 | (sub1 (+ (sub1 (source-location-position where)) 46 | (source-location-span where))) 47 | (+ (sub1 (source-location-position where)) 48 | (source-location-span where)) 49 | msg)))] 50 | [else 51 | (list (vector where 52 | (sub1 (source-location-position where)) 53 | (source-location-position where) 54 | msg) 55 | (vector where 56 | (sub1 (+ (sub1 (source-location-position where)) 57 | (source-location-span where))) 58 | (+ (sub1 (source-location-position where)) 59 | (source-location-span where)) 60 | msg))])]) 61 | (set-box! tooltips-queue (append tooltip (unbox tooltips-queue))) 62 | (syntax-property stx 63 | 'mouse-over-tooltips 64 | tooltip)))) 65 | 66 | ;; We log all the tooltips at once _after_ type checking to avoid 67 | ;; performance issues in DrRacket that occur when logging 68 | ;; them individually _during_ type checking. 69 | (define (log-all-tooltips!) 70 | (log-message online-check-syntax-logger 71 | 'info 72 | "ignored" 73 | (list (syntax-property #'(void) 'mouse-over-tooltips (unbox tooltips-queue))))) --------------------------------------------------------------------------------