├── .gitignore ├── call.jpg ├── bingus-test ├── tests │ ├── list-of-numbers-product-res.rkt │ ├── bunch-of-numbers-product-res.rkt │ ├── nesting-doll-green-doll-res.rkt │ ├── list-of-numbers.rkt~ │ ├── nesting-doll.rkt │ ├── list-of-numbers.rkt │ ├── bunch-of-numbers.rkt │ └── even-more-points.rkt ├── info.rkt └── run-tests.rkt ├── bingus-quickscript ├── info.rkt ├── register.rkt ├── unregister.rkt └── scripts │ └── bingus.rkt ├── bingus └── info.rkt ├── bingus-lib ├── info.rkt ├── init-environment.rkt ├── parser │ ├── from-checkers │ │ ├── data-def-parsing.rkt │ │ ├── parsing-submission.rkt │ │ ├── err-msg.rkt │ │ ├── permute.rkt │ │ ├── check-signature.rkt │ │ ├── grouped.rkt │ │ └── datadef.rkt │ └── parse.rkt ├── satisfies.rkt ├── queue.rkt ├── util.rkt ├── main.rkt ├── unparse.rkt ├── ast.rkt ├── synth.rkt └── data-definition.rkt ├── README.md └── bingus-examples ├── mult-numbers.rkt ├── mult-tree.rkt~ └── mult-tree.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *.zo 2 | compiled/ 3 | -------------------------------------------------------------------------------- /call.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ralsei/bingus/HEAD/call.jpg -------------------------------------------------------------------------------- /bingus-test/tests/list-of-numbers-product-res.rkt: -------------------------------------------------------------------------------- 1 | (define (product xs) 2 | (cond [(empty? xs) 1] 3 | [else (* (product (rest xs)) (first xs))])) 4 | -------------------------------------------------------------------------------- /bingus-test/tests/bunch-of-numbers-product-res.rkt: -------------------------------------------------------------------------------- 1 | (define (product bon) 2 | (cond [(none? bon) 1] 3 | [(some? bon) (* (some-first bon) 4 | (product (some-rest bon)))])) 5 | -------------------------------------------------------------------------------- /bingus-test/tests/nesting-doll-green-doll-res.rkt: -------------------------------------------------------------------------------- 1 | (define (green-doll d) 2 | (cond [(small-doll? d) (make-small-doll "green")] 3 | [(larger-doll? d) (make-larger-doll (green-doll (larger-doll-smaller d)))])) 4 | -------------------------------------------------------------------------------- /bingus-quickscript/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "bingus-quickscript") 4 | 5 | (define pkg-desc "A DrRacket Quickscript to run Bingus") 6 | (define version "0.1") 7 | (define deps '("gui-lib" 8 | "bingus-lib" 9 | "base" 10 | "quickscript")) 11 | -------------------------------------------------------------------------------- /bingus-quickscript/register.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/runtime-path 4 | (only-in quickscript/library add-third-party-script-directory!))) 5 | 6 | (begin-for-syntax 7 | (define-runtime-path script-dir "scripts") 8 | (add-third-party-script-directory! script-dir)) 9 | -------------------------------------------------------------------------------- /bingus/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define pkg-desc "A program synthesizer for the How to Design Programs curriculum") 6 | (define version "0.0001") 7 | 8 | (define deps '("bingus-lib" 9 | "bingus-quickscript")) 10 | (define implies '("bingus-lib" 11 | "bingus-quickscript")) 12 | -------------------------------------------------------------------------------- /bingus-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "bingus") 4 | 5 | (define pkg-desc "A program synthesizer for the How to Design Programs curriculum (library only)") 6 | (define version "0.1") 7 | 8 | (define deps '("base" 9 | "htdp-lib" 10 | "rackunit-lib" 11 | "sandbox-lib" 12 | "zippers")) 13 | -------------------------------------------------------------------------------- /bingus-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "bingus-test") 4 | 5 | (define test-omit-paths '("./info.rkt")) 6 | (define test-responsibles '((all hazel@knightsofthelambdacalcul.us))) 7 | 8 | (define pkg-desc "Tests for Bingus") 9 | (define version "0.0001") 10 | (define deps '("base" 11 | "rackunit-lib" 12 | "bingus-lib")) 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Bingus 2 | 3 | A _deeply_ work-in-progress program synthesizer for student code. 4 | Takes `check-expect`s and signatures, and outputs a program with that 5 | signature satisfying the checks. 6 | 7 | ## Installation 8 | 9 | `raco pkg install` 10 | 11 | ## Usage 12 | 13 | Don't. Not yet. 14 | 15 | ## Why's it called Bingus? 16 | 17 | ![incoming call from bingus](./call.jpg) 18 | -------------------------------------------------------------------------------- /bingus-quickscript/unregister.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript/library 3 | racket/runtime-path) 4 | 5 | ;;; To remove the script directory from Quickscript's library, 6 | ;;; run this file in DrRacket, or on the command line with 7 | ;;; $ racket -l bingus-quickscript/register 8 | 9 | (define-runtime-path script-dir "scripts") 10 | (remove-third-party-script-directory! script-dir) 11 | -------------------------------------------------------------------------------- /bingus-lib/init-environment.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "ast.rkt") 3 | (provide init-bsl-environment) 4 | 5 | (define init-bsl-environment 6 | (hash 'add1 (function$ (list (number-atom$)) (number-atom$) #f) 7 | '+ (function$ (list (number-atom$) (number-atom$)) (number-atom$) #f) 8 | '* (function$ (list (number-atom$) (number-atom$)) (number-atom$) #f) 9 | '- (function$ (list (number-atom$)) (number-atom$) #f) 10 | 'max (function$ (list (number-atom$) (number-atom$)) (number-atom$) #f) 11 | 'min (function$ (list (number-atom$) (number-atom$)) (number-atom$) #f) 12 | )) 13 | -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/data-def-parsing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide add-all-dd) 3 | 4 | ; A DataDefinition is (cons Symbol Symbol) 5 | 6 | ; ds->dd : String -> DataDefinition 7 | (define (ds->dd ds) 8 | (let* ([data-def (regexp-match 9 | #px"(?mi:^[\\s;]*an?\\s+(.*\\S)\\s+is\\s+(?:an?\\s+)?(.*\\S)\\s*$)" 10 | ds)] 11 | [from-type (second data-def)] 12 | [to-type (third data-def)]) 13 | (cons (string->symbol (string-downcase from-type)) 14 | (string->symbol (string-downcase to-type))))) 15 | 16 | (define (add-all-dd dds env) 17 | (append (map ds->dd dds) env)) -------------------------------------------------------------------------------- /bingus-test/tests/list-of-numbers.rkt~: -------------------------------------------------------------------------------- 1 | #lang htdp/bsl 2 | 3 | ;; A ListOfNumbers is one of: 4 | ;; - empty 5 | ;; - (cons Number ListOfNumbers) 6 | 7 | ;; product : ListOfNumbers -> Number 8 | ;; multiplies all the elements of the input list 9 | (check-expect (product empty) 1) 10 | (check-expect (product (list 1 2 3)) 6) 11 | (check-expect (product (list 5 7 1)) 35) 12 | 13 | (define (product xs) 14 | ...) 15 | 16 | ;; add-ns : Number ListOfNumbers -> ListOfNumbers 17 | ;; adds n to each element of the input list 18 | (check-expect (add-ns 3 empty) empty) 19 | (check-expect (add-ns 4 (list 1 2 3)) 20 | (list 5 6 7)) 21 | (check-expect (add-ns 9 (list 3 27 2)) 22 | (list (+ 3 9) (+ 27 9) (+ 9 2))) 23 | 24 | (define (add-ns n xs) 25 | ...) 26 | -------------------------------------------------------------------------------- /bingus-test/tests/nesting-doll.rkt: -------------------------------------------------------------------------------- 1 | #lang htdp/bsl 2 | 3 | ;; A Doll is one of: 4 | ;; - (make-small-doll String) 5 | ;; - (make-larger-doll Doll) 6 | (define-struct small-doll (color)) 7 | (define-struct larger-doll (smaller)) 8 | 9 | ;; green-doll : Doll -> Doll 10 | ;; takes a doll and returns a similar doll, but the smallest doll is green 11 | (check-expect (green-doll (make-small-doll "red")) (make-small-doll "green")) 12 | (check-expect (green-doll (make-larger-doll (make-small-doll "green"))) 13 | (make-larger-doll (make-small-doll "green"))) 14 | (check-expect (green-doll (make-larger-doll (make-larger-doll (make-small-doll "purple")))) 15 | (make-larger-doll (make-larger-doll (make-small-doll "green")))) 16 | 17 | (define (green-doll d) 18 | ...) 19 | -------------------------------------------------------------------------------- /bingus-lib/satisfies.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/sandbox 3 | "ast.rkt") 4 | (provide satisfies?) 5 | 6 | ;; we use racket/base largely for speed -- otherwise, we would have to recreate the evaluator 7 | ;; every time, since *SL doesn't allow redefinitions 8 | ;; 9 | ;; plus, the η-contraction phase (if there is one) will mean we can check before eta-contraction here 10 | ;; since racket supports it but BSL doesn't 11 | (define base-eval 12 | (let ([ev (make-evaluator 'racket/base)]) 13 | (ev '(require racket/list)) 14 | ev)) 15 | 16 | (define (run-eval quoted) 17 | (call-in-sandbox-context 18 | base-eval 19 | (thunk (eval quoted)))) 20 | 21 | (define (satisfies? data prog checks) 22 | (run-eval data) 23 | (run-eval prog) 24 | (for/and ([check (in-list checks)]) 25 | (match-define (check^ actual expected) check) 26 | (equal? (run-eval actual) (run-eval expected)))) 27 | -------------------------------------------------------------------------------- /bingus-examples/mult-numbers.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname mult-numbers) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f () #f))) 4 | ; A BunchOfNumbers is one of: 5 | ; - (make-none) 6 | ; - (make-some Number BunchOfNumbers) 7 | (define-struct none []) 8 | (define-struct some [first rest]) 9 | 10 | ; product : BunchOfNumbers -> Number 11 | ; multiplies all elements in a BunchOfNumbers 12 | (define (product bon) 13 | ...) 14 | 15 | (check-expect (product (make-none)) 1) 16 | (check-expect (product (make-some 1 (make-some 2 (make-some 3 (make-none))))) 17 | 6) 18 | (check-expect (product (make-some 5 (make-some 7 (make-some 1 (make-none))))) 19 | 35) -------------------------------------------------------------------------------- /bingus-examples/mult-tree.rkt~: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname mult-tree) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f () #f))) 4 | ; A TreeOfNumbers is one of: 5 | ; - (make-leaf Number) 6 | ; - (make-node TreeOfNumbers TreeOfNumbers) 7 | (define-struct leaf [n]) 8 | (define-struct node [left right]) 9 | 10 | ; prod-tree : TreeOfNumbers -> Number 11 | ; multiplies all elements in a TreeOfNumbers 12 | (define (prod-tree ton) 13 | ...) 14 | 15 | (check-expect (prod-tree (make-leaf 3)) 3) 16 | (check-expect (prod-tree (make-node (make-leaf 3) (make-leaf 9))) 17 | 27) 18 | (check-expect (prod-tree (make-node (make-node (make-leaf 3) (make-leaf 9)) 19 | (make-leaf 3))) 20 | 81) -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/parsing-submission.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "data-def-parsing.rkt" 3 | "check-signature.rkt") 4 | (provide parse-submission) 5 | 6 | ; mode controls what is parsed 7 | ; - 'a is for all lines 8 | ; - 'c is for all comments 9 | ; - 'd is for all data definitions 10 | ; - 's is for all signatures 11 | 12 | (define (parse submitted-string [mode 'a]) 13 | (let ([regexp-exp 14 | (match mode 15 | ['a #px"(?m:^.*$)"] 16 | ['c #px"(?m:^\\s*;.*$)"] 17 | ['d #px"(?mi:^\\s*;[\\s;]*an?\\s+(.*\\S)\\s+is\\s+(?:an?\\s+)?(.*\\S)\\s*$)"] 18 | ['s #px"(?m:^\\s*;[\\s;]*([^][(){}\",'`|;#\\s]+)\\s*:\\s*(.*?)\\s*--*>\\s*(.*?)\\s*$)"] 19 | )]) 20 | (regexp-match* regexp-exp submitted-string))) 21 | 22 | (define (parse-submission ss) 23 | (let ([signatures (parse ss 's)] 24 | [dd (parse ss 'd)]) 25 | (values (add-all-dd dd '()) 26 | (map ss->signature signatures)))) 27 | 28 | -------------------------------------------------------------------------------- /bingus-lib/queue.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (struct-out queue) 3 | empty-queue 4 | queue-empty? 5 | enqueue 6 | dequeue) 7 | 8 | (struct queue (pop push) #:transparent) 9 | 10 | (define empty-queue (queue '() '())) 11 | 12 | (define (queue-empty? q) 13 | (match q 14 | [(queue '() '()) #t] 15 | [(queue _ _) #f])) 16 | 17 | (define (enqueue x q) 18 | (queue (queue-pop q) (cons x (queue-push q)))) 19 | 20 | (define (dequeue q) 21 | (match q 22 | [(queue '() '()) (error 'dequeue "empty queue")] 23 | [(queue (cons x xs) push) (values x (queue xs push))] 24 | [(queue '() push) (dequeue (queue (reverse push) '()))])) 25 | 26 | (module+ test 27 | (require rackunit) 28 | 29 | (define q (enqueue 1 (enqueue 2 (enqueue 3 empty-queue)))) 30 | (define-values (v1 q1) (dequeue q)) 31 | (check-equal? v1 3) 32 | (define-values (v2 q2) (dequeue q1)) 33 | (check-equal? v2 2) 34 | (define-values (v3 q3) (dequeue q2)) 35 | (check-equal? v3 1)) 36 | -------------------------------------------------------------------------------- /bingus-test/tests/list-of-numbers.rkt: -------------------------------------------------------------------------------- 1 | #lang htdp/bsl 2 | 3 | ;; A ListOfNumbers is one of: 4 | ;; - empty 5 | ;; - (cons Number ListOfNumbers) 6 | 7 | ;; product : ListOfNumbers -> Number 8 | ;; multiplies all the elements of the input list 9 | (check-expect (product empty) 1) 10 | (check-expect (product (list 1 2 3)) 6) 11 | (check-expect (product (list 5 7 1)) 35) 12 | 13 | (define (product xs) 14 | ...) 15 | 16 | ;; len : ListOfNumbers -> Number 17 | ;; computes the length of the input list 18 | (check-expect (len empty) 0) 19 | (check-expect (len (list 1)) 1) 20 | (check-expect (len (list 9 2 1)) 3) 21 | 22 | (define (len xs) 23 | ...) 24 | 25 | ;; add-ns : Number ListOfNumbers -> ListOfNumbers 26 | ;; adds n to each element of the input list 27 | (check-expect (add-ns 3 empty) empty) 28 | (check-expect (add-ns 4 (list 1 2 3)) 29 | (list 5 6 7)) 30 | (check-expect (add-ns 9 (list 3 27 2)) 31 | (list (+ 3 9) (+ 27 9) (+ 9 2))) 32 | 33 | (define (add-ns n xs) 34 | ...) 35 | -------------------------------------------------------------------------------- /bingus-test/tests/bunch-of-numbers.rkt: -------------------------------------------------------------------------------- 1 | #lang htdp/bsl 2 | 3 | ;; A BunchOfNumbers is one of: 4 | ;; - (make-none) 5 | ;; - (make-some Number BunchOfNumbers) 6 | (define-struct none []) 7 | (define-struct some [first rest]) 8 | 9 | ;; product : BunchOfNumbers -> Number 10 | ;; multiplies all the elements in the input 11 | (check-expect (product (make-none)) 1) 12 | (check-expect (product (make-some 1 (make-some 2 (make-some 3 (make-none))))) 6) 13 | (check-expect (product (make-some 5 (make-some 7 (make-some 1 (make-none))))) 35) 14 | 15 | (define (product bon) 16 | ...) 17 | 18 | ;; my-length : BunchOfNumbers -> Number 19 | ;; counts the number of elements in the given BunchOfNumbers 20 | (check-expect (my-length (make-none)) 0) 21 | (check-expect (my-length (make-some 1 (make-none))) 1) 22 | (check-expect (my-length (make-some 1 (make-some 2 (make-none)))) 2) 23 | (check-expect (my-length (make-some 1 (make-some 2 (make-some 3 (make-some 6 (make-some 9 (make-none))))))) 24 | 5) 25 | 26 | (define (my-length bon) 27 | ...) 28 | -------------------------------------------------------------------------------- /bingus-lib/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/provide-syntax 3 | (for-syntax syntax/parse)) 4 | (provide TODO 5 | pascal->kebab 6 | structs-out 7 | set-add* 8 | 9 | current-resolved-system 10 | current-function-name 11 | current-function-type 12 | current-function-arguments) 13 | 14 | (define (TODO . _) (error "unimplemented")) 15 | 16 | (define (pascal->kebab str) 17 | (string-downcase 18 | (regexp-replace* #px"(?symbol procname)))) 19 | 20 | ;; Port Symbol -> Program 21 | (define (synthesize port proc-to-synthesize [args #f]) 22 | (define peek-port (peeking-input-port port)) 23 | (define lines (port->lines peek-port)) 24 | (define sexps (read-file-with-lang port)) 25 | 26 | ; grab the datadefs 27 | (define system (checkers-dds->bingus-system 28 | (parse-datadefs lines fresh-eval #:built-in '()) 29 | sexps)) 30 | ; the signature 31 | (define sig (checkers-polysigs->bingus-signature 32 | (parse-polysigs lines fresh-eval) 33 | proc-to-synthesize)) 34 | ; and the checks 35 | (define checks (parse-checks sexps proc-to-synthesize)) 36 | ; let 'er rip 37 | (run-synth proc-to-synthesize sig system checks 38 | #:debug? (debug-mode) 39 | #:args args)) 40 | 41 | (module+ main 42 | (define-values (filename procname) (parse-command-line-args)) 43 | (pretty-write (call-with-input-file filename (curryr synthesize procname)))) 44 | -------------------------------------------------------------------------------- /bingus-test/tests/even-more-points.rkt: -------------------------------------------------------------------------------- 1 | #lang htdp/bsl 2 | 3 | ;; A Point is a (make-point Number Number) 4 | (define-struct point [x y]) 5 | 6 | ;; A EvenMorePoints is one of: 7 | ;; - (make-none) 8 | ;; - (make-one Point) 9 | ;; - (make-two Point Point) 10 | ;; - (make-three Point Point Point) 11 | (define-struct none []) 12 | (define-struct one [first]) 13 | (define-struct two [first second]) 14 | (define-struct three [first second third]) 15 | 16 | ;; add-point : Point EvenMorePoints -> EvenMorePoints 17 | ;; Adds a point to the given EvenMorePoints, discarding the third if we run 18 | ;; out of space. 19 | (check-expect (add-point (make-point 3 2) (make-none)) 20 | (make-one (make-point 3 2))) 21 | (check-expect (add-point (make-point 3 2) 22 | (make-one (make-point 4 5))) 23 | (make-two (make-point 3 2) 24 | (make-point 4 5))) 25 | (check-expect (add-point (make-point 9 2) 26 | (make-two (make-point 9 3) 27 | (make-point 8 7))) 28 | (make-three (make-point 9 2) 29 | (make-point 9 3) 30 | (make-point 8 7))) 31 | (check-expect (add-point (make-point 10 10) 32 | (make-three (make-point 9 2) 33 | (make-point 9 3) 34 | (make-point 8 7))) 35 | (make-three (make-point 10 10) 36 | (make-point 9 2) 37 | (make-point 9 3))) 38 | 39 | (define (add-point p emp) 40 | ...) 41 | -------------------------------------------------------------------------------- /bingus-examples/mult-tree.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname mult-tree) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f () #f))) 4 | ; A TreeOfNumbers is one of: 5 | ; - (make-leaf Number) 6 | ; - (make-node TreeOfNumbers TreeOfNumbers) 7 | (define-struct leaf [n]) 8 | (define-struct node [left right]) 9 | 10 | ; prod-tree : TreeOfNumbers -> Number 11 | ; multiplies all elements in a TreeOfNumbers 12 | (define (prod-tree ton) 13 | ...) 14 | 15 | (check-expect (prod-tree (make-leaf 3)) 3) 16 | (check-expect (prod-tree (make-node (make-leaf 3) (make-leaf 9))) 17 | 27) 18 | (check-expect (prod-tree (make-node (make-node (make-leaf 3) (make-leaf 9)) 19 | (make-leaf 3))) 20 | 81) 21 | 22 | ; depth : TreeOfNumbers -> Number 23 | (check-expect (depth (make-leaf 3)) 0) 24 | (check-expect (depth (make-node (make-leaf 4) (make-leaf 4))) 1) 25 | (check-expect (depth (make-node (make-leaf 2) 26 | (make-node (make-leaf 4) (make-leaf 3)))) 27 | 2) 28 | (check-expect (depth (make-node (make-node (make-leaf 4) (make-leaf 1)) 29 | (make-leaf 3))) 30 | 2) 31 | (check-expect (depth (make-node (make-node (make-leaf 4) (make-leaf 1)) 32 | (make-node (make-leaf 9) (make-leaf 2)))) 33 | 2) 34 | 35 | (define (depth ton) 36 | ...) 37 | -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/err-msg.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide err-msg-incorrect-def 4 | err-msg-signature-nonexistent 5 | err-msg-signature-incorrect 6 | err-msg-signature-multiple 7 | err-msg-steps 8 | err-msg-all-input 9 | err-msg-all-output 10 | err-msg-defined 11 | err-msg-use-abstractions 12 | err-msg-dont-process-list) 13 | 14 | (define (err-msg-incorrect-def fn) 15 | (format "The \"~a\" function doesn't work correctly. Test more examples." fn)) 16 | 17 | (define (err-msg-signature-nonexistent fn) 18 | (format "You are missing a signature for the \"~a\" function! See step 2 of the design recipe in the videos for lecture 4." fn)) 19 | 20 | (define (err-msg-signature-incorrect fn) 21 | (format "Your signature for the \"~a\" function is incorrect. Does it have the right number of inputs? Do you need to support it with a data definition? See step 1 of the design recipe." fn)) 22 | 23 | (define (err-msg-signature-multiple fn) 24 | (format "There are multiple different signatures for the \"~a\" function!" fn)) 25 | 26 | (define (err-msg-steps location) 27 | (format "The step-by-step calculations in ~a seem to be incomplete or incorrect." location)) 28 | 29 | (define (err-msg-all-input name) 30 | (format "Test \"~a\" with every possible kind of input." name)) 31 | 32 | (define (err-msg-all-output name) 33 | (format "Test \"~a\" with every possible kind of output." name)) 34 | 35 | (define (err-msg-defined name) 36 | (format "The function named \"~a\" is not defined." name)) 37 | 38 | (define (err-msg-use-abstractions name abstractions) 39 | (format "Make sure the function \"~a\" uses the abstractions ~a" name abstractions)) 40 | 41 | (define (err-msg-dont-process-list name abstractions) 42 | (format "The definition of the function \"~a\" should not process the input list using \"empty?\", \"cons?\", \"first\", or \"rest\". Instead, give the list to ~a." name abstractions)) 43 | -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/permute.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require rackunit) 3 | (provide permute-list inverse-permute-list 4 | permute-index inverse-permute-index 5 | inverse-permutation) 6 | 7 | ; A Permutation is one of: 8 | ; - #f 9 | ; - [ListOf NaturalNumber] 10 | ; Generally, the #:permute argument is a list of indices into our solution, 11 | ; and its inverse-permutation would be a list of indices into the submission. 12 | 13 | ; permute-list : Permutation [ListOf X] -> [ListOf X] 14 | (define (permute-list perm lst) 15 | (if perm 16 | (for/list ([i perm]) (list-ref lst i)) 17 | lst)) 18 | (check-equal? (permute-list '(1 2 0) '(a b c)) '(b c a)) 19 | (check-equal? (permute-list #f '(a b c)) '(a b c)) 20 | 21 | ; inverse-permute-list : Permutation [ListOf X] -> [ListOf X] 22 | (define (inverse-permute-list perm lst) 23 | (if perm 24 | (map cdr (sort (map cons perm lst) 25 | < #:key car)) 26 | lst)) 27 | (check-equal? (inverse-permute-list '(1 2 0) '(a b c)) '(c a b)) 28 | (check-equal? (inverse-permute-list #f '(a b c)) '(a b c)) 29 | 30 | ; permute-index : Permutation NaturalNumber -> NaturalNumber 31 | (define (permute-index perm index) 32 | (if perm (list-ref perm index) index)) 33 | 34 | ; inverse-permute-index : Permutation NaturalNumber -> NaturalNumber 35 | (define (inverse-permute-index perm index) 36 | (if perm (index-of perm index) index)) 37 | 38 | ; inverse-permutation : Permutation -> Permutation 39 | (define (inverse-permutation perm) 40 | (and perm (map cdr (sort (for/list ([i (in-list perm)] [j (in-naturals)]) 41 | (cons i j)) 42 | < #:key car)))) 43 | (check-equal? (inverse-permutation '(1 2 0)) '(2 0 1)) 44 | (check-equal? (inverse-permutation '(3 2 1 0)) '(3 2 1 0)) 45 | (check-equal? (inverse-permutation '(0 1 2 3)) '(0 1 2 3)) 46 | (check-equal? (inverse-permutation '(1 2 0 3)) '(2 0 1 3)) 47 | (check-equal? (inverse-permutation #f) #f) 48 | -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/check-signature.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide signature 3 | ss->signature 4 | signature-exists? 5 | signature-correct?) 6 | 7 | (require "data-def-parsing.rkt") 8 | 9 | ; A Signature is (signature Symbol [ListOf Symbol] Symbol) 10 | (struct signature (name args return-type) 11 | #:transparent) 12 | 13 | ; transform : String -> Symbol 14 | (define transform (compose string->symbol string-downcase)) 15 | 16 | ; check-signature : Signature ListofSignature ListofDataDefinition -> Boolean 17 | (define (check-signature s correct-env dds) 18 | (type-check-function (reduce-signature dds s) correct-env)) 19 | 20 | ; reduce-signature : ListofDataDefinition Signature -> Signature 21 | (define (reduce-signature dds s) 22 | (let ([args^ (map (curry reduce-type dds) (signature-args s))] 23 | [return-type^ (reduce-type dds (signature-return-type s))]) 24 | (signature (signature-name s) args^ return-type^))) 25 | 26 | ; reduce-type : ListofDataDefinition Symbol -> Symbol 27 | (define (reduce-type env t) 28 | (reduce-type/a env t '())) 29 | 30 | ; reduce-type/a : ListofDataDefinition Symbol ListofSymbol -> Symbol 31 | (define (reduce-type/a env t seen) 32 | (cond 33 | [(memv t seen) t] ; cycle among data definitions 34 | [(memv t '(number boolean image string naturalnumber listofnumber listofboolean)) 35 | t] 36 | [(dict-has-key? env t) 37 | (reduce-type/a env (dict-ref env t) (cons t seen))] 38 | [else t])) 39 | 40 | ; ss->signature : String -> Signature 41 | (define (ss->signature ss) 42 | (let* ([res (regexp-match #px"(?m:^[\\s;]*([^][(){}\",'`|;#\\s]+)\\s*:\\s*(.*?)\\s*--*>\\s*(.*?)\\s*$)" ss)] 43 | [name (second res)] 44 | [arg-types (string-split (third res))] 45 | [rt-type (fourth res)]) 46 | (signature (string->symbol name) (map transform arg-types) (transform rt-type)))) 47 | 48 | ; type-check-function : Signature ListofSignature -> Boolean 49 | (define (type-check-function signature* correct-env) 50 | (equal? signature* (get-signature (signature-name signature*) correct-env))) 51 | 52 | ; get-signature : Symbol ListofSignature -> [Either #f Signature] 53 | (define (get-signature name env) 54 | (cond 55 | [(empty? env) #f] 56 | [else (if (equal? name (signature-name (first env))) 57 | (first env) 58 | (get-signature name (rest env)))])) 59 | 60 | ; signature-exists? : Symbol ListofSignature -> Boolean 61 | (define (signature-exists? f env) 62 | (if (get-signature f env) 63 | #t #f)) 64 | 65 | ; signature-correct? : String ListofDataDefinition ListofSignature ListofSignature -> Boolean 66 | (define (signature-correct? f dds parsed-env correct-env) 67 | (check-signature (get-signature f parsed-env) correct-env dds)) 68 | -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/grouped.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require rackunit) 3 | (provide grouped-string-split) 4 | 5 | ; group : [ListOf String] -> [ListOf String] 6 | ; Try to concatenate every subsequence of `strings` that begins with some car 7 | ; in `delims`, ends with the corresponding cdr, and does not otherwise contain 8 | ; any string in `delims` 9 | (define (group strings) 10 | (define delims '(("(" . ")") ("[" . "]"))) 11 | (cond [(null? strings) strings] 12 | [(assoc (car strings) delims) 13 | => (lambda (delim) (let accum ([rest (cdr strings)] 14 | [seen (list (car strings))]) 15 | ; *Accumulator*: `seen` is the reverse list of strings that 16 | ; does not contain any string in `delims`, since the most recent 17 | ; (car delim) inclusive 18 | (cond [(null? rest) 19 | ; (car delim) unmatched 20 | (reverse seen)] 21 | [(string=? (car rest) (cdr delim)) 22 | ; (car delim) matched (cdr delim) 23 | (cons (foldl string-append (car rest) seen) 24 | (group (cdr rest)))] 25 | [(for/or ([d delims]) (or (string=? (car rest) (car d)) 26 | (string=? (car rest) (cdr d)))) 27 | ; group broken by some string in `delims` 28 | (foldl cons (group rest) seen)] 29 | [else (accum (cdr rest) (cons (car rest) seen))])))] 30 | [else (cons (car strings) (group (cdr strings)))])) 31 | (check-equal? (group (list " " "(" "a" "(" "b" ")" ")" ")" " ")) 32 | (list " " "(" "a" "(b)" ")" ")" " ")) 33 | (check-equal? (group (list " " "(" "a" "(b)" ")" ")" " ")) 34 | (list " " "(a(b))" ")" " ")) 35 | (check-equal? (group (list " " "(a(b))" ")" " ")) 36 | (list " " "(a(b))" ")" " ")) 37 | 38 | ; grouped-string-split : String -> [ListOf String] 39 | ; Do our best to interpret a string as a list of things that might include 40 | ; nested parenthesized, bracketed, or double-quoted parts. Also arrows--> 41 | ;(check-equal? (grouped-string-split " apple banana \t cherry\n\r") 42 | ; (list "apple" "banana" "cherry")) 43 | (define (grouped-string-split s) 44 | (define parts1 45 | (regexp-match* #px"\\\"(?:\\\\.|[^\\\"])*\\\"|[^][(){}\",'`|;#\\s]+|." s)) 46 | (define parts2 47 | (for*/list ([part1 parts1] 48 | [part2 (if (string-prefix? part1 "\"") 49 | (in-value part1) 50 | (in-list (regexp-match* #px"-+>" part1 #:gap-select? #t)))]) 51 | part2)) 52 | (let loop ([strings parts2]) 53 | (let ([grouped (group strings)]) 54 | (if (> (length strings) (length grouped)) 55 | (loop grouped) 56 | (filter (lambda (s) (regexp-match? #px"\\S" s)) grouped))))) 57 | (check-equal? (grouped-string-split " (a(b))) foo ") 58 | (list "(a(b))" ")" "foo")) 59 | (check-equal? (grouped-string-split " (a[b)]) foo ") 60 | (list "(" "a" "[" "b" ")" "]" ")" "foo")) 61 | (check-equal? (grouped-string-split "--->[A->B][[A->B]->C]") 62 | (list "--->" "[A->B]" "[[A->B]->C]")) 63 | -------------------------------------------------------------------------------- /bingus-lib/unparse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "ast.rkt" 3 | "util.rkt") 4 | (provide unparse 5 | unparse-system) 6 | 7 | (define (unparse exp) 8 | (match exp 9 | [y #:when (or (symbol? y) 10 | (number? y) 11 | (string? y) 12 | (boolean? y)) 13 | y] 14 | ; we should only have one lambda, for now 15 | ; and we can always unparse it into defines for BSL 16 | [(lambda^ formals body) 17 | `(define (,(current-function-name) ,@formals) ,(unparse body))] 18 | [(app^ rator rand) 19 | `(,(unparse rator) ,@(map unparse rand))] 20 | [(cond^ clauses) 21 | `(cond ,@(map unparse clauses))] 22 | [(cond-case^ question answer) 23 | `(,(unparse question) ,(unparse answer))] 24 | [(hole^ can-fill-const? cenv sig checks) 25 | `(... : ,(unparse-signature sig))] 26 | [_ (error 'unparse "unsupported form: ~a" exp)])) 27 | 28 | ; basically only for debugging 29 | (define (unparse-signature sig) 30 | (match sig 31 | [(number-atom$) 'Number] 32 | [(string-atom$) 'String] 33 | [(boolean-atom$) 'Boolean] 34 | [(function$ ins out _) 35 | `(,@(map unparse-signature ins) -> ,(unparse-signature out))] 36 | [else (string->symbol sig)])) 37 | 38 | ;; insert define-structs if there are some 39 | (define (unparse-struct decl) 40 | (match-define (product$ name fields) decl) 41 | `(define-struct 42 | ,(string->symbol name) 43 | (,@(map (compose string->symbol product-field$-name) fields)))) 44 | 45 | (define (unparse-system sys) 46 | `(begin 47 | ,@(let loop ([current-sigs (map defn$-type sys)] 48 | [defstructs '()]) 49 | (cond [(empty? current-sigs) defstructs] 50 | [(product$? (first current-sigs)) 51 | (loop (rest current-sigs) 52 | (cons (unparse-struct (first current-sigs)) 53 | defstructs))] 54 | [(sum$? (first current-sigs)) 55 | (loop (rest current-sigs) 56 | (append defstructs 57 | (loop (map sum-case$-type (sum$-cases (first current-sigs))) 58 | '())))] 59 | [else 60 | (loop (rest current-sigs) 61 | defstructs)])))) 62 | 63 | (module+ test 64 | (require rackunit) 65 | 66 | (check-equal? 67 | (unparse 68 | (lambda^ '(tl) 69 | (cond^ (list 70 | (cond-case^ (app^ 'string=? (list 'c "red")) "green") 71 | (cond-case^ (app^ 'string=? (list 'c "yellow")) "red") 72 | (cond-case^ (app^ 'string=? (list 'c "green")) "yellow"))))) 73 | '(define (func tl) 74 | (cond [(string=? c "red") "green"] 75 | [(string=? c "yellow") "red"] 76 | [(string=? c "green") "yellow"]))) 77 | 78 | (check-equal? 79 | (unparse-struct 80 | (product$ "fishtail-palm" 81 | (list 82 | (product-field$ "sapwood" "Seeker") 83 | (product-field$ "duramen" "Tokamak") 84 | (product-field$ "stump" "Topspin")))) 85 | '(define-struct fishtail-palm (sapwood duramen stump))) 86 | 87 | (define bon-system 88 | (list 89 | (defn$ "BunchOfNumbers" 90 | (sum$ (list (sum-case$ (product$ "none" '())) 91 | (sum-case$ (product$ "some" 92 | (list 93 | (product-field$ "first" (number-atom$)) 94 | (product-field$ "rest" "BunchOfNumbers"))))))))) 95 | 96 | (check-equal? 97 | (unparse-system bon-system) 98 | '(begin 99 | (define-struct some (first rest)) 100 | (define-struct none ())))) 101 | -------------------------------------------------------------------------------- /bingus-lib/parser/parse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "from-checkers/datadef.rkt" 3 | "../ast.rkt" 4 | "../util.rkt") 5 | 6 | (provide read-file-with-lang 7 | parse-checks 8 | checkers-dds->bingus-system 9 | checkers-polysigs->bingus-signature) 10 | 11 | (define (read-until-eof prt) 12 | (let loop ([r (read prt)]) 13 | (cond [(eof-object? r) '()] 14 | [else (cons r (loop (read prt)))]))) 15 | 16 | (define (read-file-with-lang prt) 17 | (define prog 18 | (parameterize ([read-accept-reader #t]) 19 | (read-until-eof prt))) 20 | (match prog 21 | ;; sigh 22 | [`(module ,_ ,_ (#%module-begin ,xs ...)) xs] 23 | [`((module ,_ ,_ (#%module-begin ,xs ...))) xs] 24 | ;; not a module (read from defn window or sth) 25 | [x x])) 26 | 27 | ;; assuming all checks take the form (check-expect (NAME INPUTS ...) OUTPUT) 28 | (define (parse-checks prog fn-name) 29 | (for/list ([l (in-list prog)] 30 | #:when (match l 31 | [`(check-expect (,(== fn-name) ,_ ...) ,_) #t] 32 | [_ #f])) 33 | (match l 34 | [`(check-expect ,actual ,expected) (check^ actual expected)]))) 35 | 36 | (define (parse-struct-fields prog product-name product-field-sigs) 37 | (for/list ([l (in-list prog)] 38 | #:when (begin 39 | (match l 40 | [`(define-struct ,(== (string->symbol product-name) ) ,_ ...) #t] 41 | [_ #f]))) 42 | (match l 43 | [`(define-struct ,_ ,flds) 44 | (map product-field$ 45 | (map ~a flds) 46 | (map (λ (x) (checkers-pattern->bingus-pattern x prog)) product-field-sigs))]))) 47 | 48 | (define (checkers-pattern->bingus-pattern dp [prog #f]) 49 | (match dp 50 | [(data-id 'number) (number-atom$)] 51 | [(data-id 'string) (string-atom$)] 52 | [(data-id 'boolean) (boolean-atom$)] 53 | [(data-id 'empty) (empty$)] 54 | [(data-id 'true) (singleton-atom$ #t)] 55 | [(data-id 'false) (singleton-atom$ #f)] 56 | [(data-id name) (~a name)] 57 | [(data-literal val) (singleton-atom$ val)] 58 | [(data-make 'cons `(,a ,d)) 59 | (cons$ (checkers-pattern->bingus-pattern a prog) 60 | (checkers-pattern->bingus-pattern d prog))] 61 | [(data-make proc args) 62 | (cond [(not prog) (error 'checkers-pattern->bingus-pattern 63 | "attempted to parse data-make without a read program")] 64 | [else 65 | (define prod-name (string-trim (~a proc) "make-")) 66 | (define flds (parse-struct-fields prog prod-name args)) 67 | ;; HACK: what 68 | (product$ prod-name (car flds))])] 69 | [(data-app _ _) 70 | (error 'checkers-datadef->bingus-datadef "type applications unsupported in BSL")])) 71 | 72 | (define (checkers-datadef->bingus-datadef name dd prog) 73 | (match-define (datadef '() '() data-patterns) dd) 74 | 75 | (defn$ (~a name) 76 | (cond [(empty? (rest data-patterns)) 77 | (checkers-pattern->bingus-pattern (first data-patterns) prog)] 78 | [else (sum$ (map (λ (x) 79 | (sum-case$ (checkers-pattern->bingus-pattern x prog))) 80 | data-patterns))]))) 81 | 82 | (define (checkers-dds->bingus-system dds prog) 83 | (for/list ([(k v) (in-hash dds)]) 84 | (checkers-datadef->bingus-datadef k v prog))) 85 | 86 | (define (checkers-polysigs->bingus-signature polysigs fn-name) 87 | ; don't need type applications for BSL. 88 | ; also there should only be one thing in the output list 89 | (match-define (polysig _ _ ins (list out)) 90 | (for/first ([s (in-list polysigs)] 91 | #:when (equal? (polysig-name s) fn-name)) 92 | s)) 93 | ;; XXX: ...how does this process sum types? 94 | (function$ (map (compose checkers-pattern->bingus-pattern car) ins) 95 | (checkers-pattern->bingus-pattern out) 96 | #f)) 97 | -------------------------------------------------------------------------------- /bingus-lib/ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require zippers 3 | 4 | "util.rkt") 5 | (provide 6 | ;;;; SIGNATURES 7 | (structs-out anything$ 8 | number-atom$ 9 | string-atom$ 10 | boolean-atom$ 11 | singleton-atom$ 12 | function$ 13 | product$ 14 | product-field$ 15 | sum$ 16 | sum-case$ 17 | cons$ 18 | empty$ 19 | defn$ 20 | recur$) 21 | ;;;; SYNTAX 22 | (structs-out lambda^ 23 | app^ 24 | cond^ 25 | cond-case^ 26 | hole^) 27 | (struct-zipper-out lambda^ 28 | app^ 29 | cond^ 30 | cond-case^) 31 | ;;;; SYNTAX HELPERS 32 | plug/ast 33 | first-hole/ast 34 | next-hole/ast 35 | complete? 36 | function-signature-arity 37 | ;;;; CHECKS 38 | (struct-out check^)) 39 | 40 | ;;;; SIGNATURES 41 | ;; NOTE: 42 | ;; - we probably want a better way to think about recursion in the AST 43 | ;; (but recursion comes later) 44 | 45 | ;; anything 46 | (struct anything$ () #:transparent) 47 | 48 | ;; atomic datatypes 49 | ;; one of: Number, String, Boolean 50 | (struct number-atom$ () #:transparent) 51 | (struct string-atom$ () #:transparent) 52 | (struct boolean-atom$ () #:transparent) 53 | 54 | ;; single values 55 | ;; not actually used alone (generally), usually used as part of enums 56 | ;; parser should account for that 57 | (struct singleton-atom$ (value) #:transparent) 58 | 59 | ;; functions 60 | ;; Number String -> Number 61 | ;; => 62 | ;; (function$ (list (number-atom$) (string-atom$)) (number-atom$) #f) 63 | (struct function$ (inputs output constructor?) #:transparent) 64 | 65 | ;; compute the arity of the function 66 | (define (function-signature-arity fn) 67 | (length (function$-inputs fn))) 68 | 69 | ;; structures/products 70 | (struct product$ (name fields) #:transparent) 71 | (struct product-field$ (name type) #:transparent) 72 | 73 | ;; enumerations/sums 74 | ;; A TrafficLight is one of: 75 | ;; - "red" 76 | ;; - "yellow" 77 | ;; - "green" 78 | ;; => 79 | ;; (sum$ 80 | ;; (list 81 | ;; (sum-case$ (singleton-atom$ "red")) 82 | ;; (sum-case$ (singleton-atom$ "yellow")) 83 | ;; (sum-case$ (singleton-atom$ "green")))) 84 | (struct sum$ (cases) #:transparent) 85 | (struct sum-case$ (type) #:transparent) 86 | 87 | ;; lists 88 | (struct empty$ () #:transparent) 89 | (struct cons$ (first rest) #:transparent) 90 | 91 | ;; definitions -- top-level signatures 92 | (struct defn$ (name type) #:transparent) 93 | 94 | ;; marks recursion in a resolved system 95 | ;; TODO: mutual recursion -- hence why the `on` field is here 96 | ;; right now it's just set to the name of the type and is unused 97 | (struct recur$ (on) #:transparent) 98 | 99 | ;;;; SYNTAX 100 | ;; variables are just symbols 101 | ;; numbers are just numbers 102 | ;; strings are just strings 103 | ;; 104 | ;; this might be changed, since BSL has symbols 105 | ;; (but we don't encourage using them in 211, at least) 106 | 107 | ;; (lambda (x y) x) 108 | ;; => (lambda^ (list 'x 'y) 'x) 109 | (struct lambda^ (formals body) #:transparent) 110 | 111 | ;; (string=? c "red") 112 | ;; => 113 | ;; (app^ 'string=? (list 'c "red")) 114 | (struct app^ (rator rand) #:transparent) 115 | 116 | ;; (cond [(string=? c "red") "blue"] 117 | ;; [(string=? c "blue") "red"]) 118 | ;; => 119 | ;; (cond^ 120 | ;; (list 121 | ;; (cond-case^ (app 'string=? (list 'c "red")) "blue") 122 | ;; (cond-case^ (app 'string=? (list 'c "blue")) "red"))) 123 | (struct cond^ (clauses) #:transparent) 124 | (struct cond-case^ (question answer) #:transparent) 125 | 126 | ;; holes 127 | (struct hole^ (can-fill-const? cenv signature checks) #:transparent) 128 | 129 | ;; zipper frames 130 | ;; we explicitly don't define one for a hole, since you shouldn't be able 131 | ;; to zip into one 132 | (define-struct-zipper-frames lambda^ app^ cond^ cond-case^) 133 | 134 | ;; utility functions (derived movements) 135 | ;; go all the way left through the ast 136 | (define (first/ast exp) 137 | (match-define (zipper focus _) exp) 138 | (cond [(hole^? focus) exp] 139 | [(lambda^? focus) (first/ast (down/lambda^-body exp))] 140 | [(list? focus) 141 | (cond [(empty? focus) exp] 142 | [else (first/ast (down/list-first exp))])] 143 | [(app^? focus) (first/ast (down/app^-rand exp))] 144 | [(cond^? focus) (first/ast (down/cond^-clauses exp))] 145 | [(cond-case^? focus) (first/ast (down/cond-case^-answer exp))] 146 | ;; numbers, symbols, etc 147 | [else exp])) 148 | 149 | ;; goes to the next ancestor 150 | (define (next-ancestor/ast exp) 151 | (cond [(zipper-at-top? exp) exp] 152 | [else 153 | (match-define (zipper focus (cons first-ctx _)) exp) 154 | (cond 155 | [(list-item-frame? first-ctx) 156 | (cond [(empty? (list-item-frame-to-right first-ctx)) (up exp)] 157 | [else (right/list exp)])] 158 | [else (next-ancestor/ast (up exp))])])) 159 | 160 | (define (next/ast exp) 161 | (first/ast (next-ancestor/ast exp))) 162 | 163 | (define (first-hole/ast exp) 164 | (match-define (and result (zipper focus _)) (first/ast exp)) 165 | (cond [(equal? result exp) result] 166 | [(zipper-at-top? result) result] 167 | [(hole^? focus) result] 168 | [else (first-hole/ast (next/ast exp))])) 169 | 170 | (define (next-hole/ast exp) 171 | (match-define (and result (zipper focus _)) (next/ast exp)) 172 | (cond [(zipper-at-top? exp) exp] 173 | [(hole^? focus) result] 174 | [else (next-hole/ast (up exp))])) 175 | 176 | ;; fill the given hole, and go to the next one 177 | (define (plug/ast fill exp) 178 | (cond [(hole^? (zipper-focus exp)) (edit (const fill) exp)] 179 | [else (error 'plug/ast "not focused on a hole: ~a" exp)])) 180 | 181 | (define (complete? unzipped-exp) 182 | (match unzipped-exp 183 | [y #:when (or (symbol? y) 184 | (number? y) 185 | (string? y) 186 | (boolean? y)) 187 | #t] 188 | [(lambda^ _ body) (complete? body)] 189 | [(app^ _ rand) (complete? rand)] 190 | [(cond^ clauses) (andmap complete? clauses)] 191 | [(cond-case^ question answer) (and (complete? question) 192 | (complete? answer))] 193 | [(? list?) (andmap complete? unzipped-exp)] 194 | [(hole^ _ _ _ _) #f] 195 | [_ (error 'complete? "unsupported form: ~a" unzipped-exp)])) 196 | 197 | ;;;; CHECKS 198 | ;; (check-expect (add1 5) 6) 199 | ;; => (check^ '(add1 5) 6) 200 | (struct check^ (actual expected) #:transparent) 201 | -------------------------------------------------------------------------------- /bingus-lib/synth.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/hash 3 | zippers 4 | 5 | "ast.rkt" 6 | "data-definition.rkt" 7 | "init-environment.rkt" 8 | "queue.rkt" 9 | "satisfies.rkt" 10 | "unparse.rkt" 11 | "util.rkt") 12 | (provide run-synth) 13 | 14 | ;;;; PARTIAL PROGRAMS 15 | ;; a partial program is a zipper of an AST. 16 | 17 | ;; an refinement is a pair of functions: 18 | ;; - partial-program? -> partial-program? 19 | ;; that applies an action to a partial program 20 | ;; - partial-program? -> boolean? 21 | ;; that determines if the action can be applied 22 | ;; 23 | ;; we don't check if it can be applied before applying it, 24 | ;; that's done during the BFS. 25 | ;; 26 | ;; we terminate when we're no longer focused on a hole. 27 | ;; each refinement should jump to the next hole. 28 | (struct program-refinement (refine possible?) 29 | #:property prop:procedure (struct-field-index refine) 30 | #:transparent) 31 | 32 | (define (can-refine? refinement partial-prog) 33 | ((program-refinement-possible? refinement) partial-prog)) 34 | 35 | ;; if we have a function type, introduce binders 36 | ;; function$ → lambda^ 37 | ;; 38 | ;; (this is probably what the Myth paper means by η-long form, 39 | ;; since we always do this) 40 | (define refine/introduce-lambda 41 | (let () 42 | (define (introduce-lambda partial-prog) 43 | (match-define (zipper (hole^ _ cenv (function$ ins out _) checks) _) 44 | partial-prog) 45 | 46 | (define args 47 | (cond [(current-function-arguments) => identity] 48 | [else (map (thunk* (gensym)) ins)])) 49 | 50 | (define with-binders 51 | (hash-union (for/hash ([arg (in-list args)] 52 | [ty (in-list ins)]) 53 | (values arg ty)) 54 | cenv)) 55 | 56 | (define with-struct-accessors 57 | (apply hash-union with-binders 58 | (for/list ([arg (in-list args)] 59 | [ty (in-list ins)] 60 | #:do [(define decl 61 | (and (string? ty) 62 | (hash-ref (current-resolved-system) ty)))] 63 | #:when (product$? decl)) 64 | (generate-product-environment decl 65 | #:var-name arg 66 | #:cenv cenv 67 | #:checks checks)))) 68 | 69 | (first-hole/ast 70 | (plug/ast (lambda^ args (hole^ #t with-struct-accessors out checks)) 71 | partial-prog))) 72 | 73 | (define (can-introduce-lambda? partial-prog) 74 | (match partial-prog 75 | [(zipper (hole^ _ _ (function$ _ _ _) _) _) #t] 76 | [_ #f])) 77 | 78 | (program-refinement introduce-lambda can-introduce-lambda?))) 79 | 80 | (define (refine/guess-var v) 81 | (define (guess-var partial-prog) 82 | ((cond [(complete? v) next-hole/ast] 83 | [else first-hole/ast]) 84 | (plug/ast v partial-prog))) 85 | 86 | (define (can-guess-var? partial-prog) 87 | (match-define (zipper focus _) partial-prog) 88 | (and (hole^? focus) 89 | (equal? (hash-ref (hole^-cenv focus) v #f) (hole^-signature focus)))) 90 | 91 | (program-refinement guess-var can-guess-var?)) 92 | 93 | (define (refine/guess-const c) 94 | (define (guess-const partial-prog) 95 | (next-hole/ast (plug/ast c partial-prog))) 96 | 97 | (define (can-guess-const? partial-prog) 98 | (match-define (zipper focus _) partial-prog) 99 | (and (hole^? focus) 100 | (hole^-can-fill-const? focus) 101 | (match (hole^-signature focus) 102 | [(number-atom$) (number? c)] 103 | [(string-atom$) (string? c)] 104 | [(boolean-atom$) (boolean? c)] 105 | [_ #f]))) 106 | 107 | (program-refinement guess-const can-guess-const?)) 108 | 109 | (define (refine/guess-app fn) 110 | (define (guess-app partial-prog) 111 | (match-define (zipper (hole^ _ cenv sig checks) _) 112 | partial-prog) 113 | (match-define (function$ ins _ constructor?) (hash-ref cenv fn)) 114 | 115 | (define args 116 | (cond ;; at least one argument should be a non-constant 117 | ;; (ex. (+ 3 5) is useless) 118 | ;; unless it's a constructor 119 | [constructor? 120 | (map (λ (in) (hole^ #t cenv in checks)) ins)] 121 | ;; BSL doesn't allow nullary functions, so we don't need to check empty 122 | [else 123 | (cons (hole^ #f cenv (first ins) checks) 124 | (map (λ (in) (hole^ #t cenv in checks)) (rest ins)))])) 125 | 126 | (first-hole/ast (plug/ast (app^ fn args) partial-prog))) 127 | 128 | (define (can-guess-app? partial-prog) 129 | (match-define (zipper focus _) partial-prog) 130 | (and (hole^? focus) 131 | (let ([sig (hash-ref (hole^-cenv focus) fn #f)]) 132 | (and (function$? sig) 133 | (equal? (function$-output sig) (hole^-signature focus)))))) 134 | 135 | (program-refinement guess-app can-guess-app?)) 136 | 137 | ;; HACK: make this non-global after demos -- but boy does it make things fast 138 | (define SPLITS (mutable-set)) 139 | 140 | (define (refine/guess-template sum var-name) 141 | (define (guess-template partial-prog) 142 | (match-define (zipper (hole^ _ cenv sig checks) _) 143 | partial-prog) 144 | 145 | (set-add! SPLITS var-name) 146 | 147 | (first-hole/ast 148 | (plug/ast (generate-sum-template sum 149 | #:var-name var-name 150 | #:cenv cenv 151 | #:signature sig 152 | #:checks checks) 153 | partial-prog))) 154 | 155 | (define (can-guess-template? partial-prog) 156 | ; we can actually *always* guess a template, so long as we have something 157 | ; that works 158 | (match-define (zipper focus _) partial-prog) 159 | (and (hole^? focus) 160 | (not (app^? var-name)) 161 | (not (set-member? SPLITS var-name)) 162 | ; products are handled by introduce-lambda, 163 | ; where they're added to the environment as variables 164 | (sum$? (hash-ref (current-resolved-system) 165 | (hash-ref (hole^-cenv focus) var-name) 166 | #f)))) 167 | 168 | (program-refinement guess-template can-guess-template?)) 169 | 170 | (define (extract-constants checks) 171 | (define (extract-from-quoted exp) 172 | (match exp 173 | ['() (set)] 174 | [(cons x ys) 175 | #:when (or (number? x) 176 | (string? x) 177 | (boolean? x)) 178 | (set-add (extract-from-quoted ys) x)] 179 | [(cons xs ys) 180 | #:when (list? xs) 181 | (set-union (extract-from-quoted xs) 182 | (extract-from-quoted ys))] 183 | [(cons _ ys) (extract-from-quoted ys)] 184 | [_ (set exp)])) 185 | 186 | (for/fold ([consts (set)]) 187 | ([check (in-list checks)]) 188 | (set-union consts 189 | (extract-from-quoted (check^-actual check)) 190 | (extract-from-quoted (check^-expected check))))) 191 | 192 | ;; XXX: there should be some kind of weighting here 193 | (define (possible-refinements partial-prog) 194 | (match-define (zipper (hole^ _ cenv _ checks) _) partial-prog) 195 | 196 | (define possible 197 | (append (list refine/introduce-lambda) 198 | (for/list ([(var ty) (in-hash cenv)] 199 | #:when (not (function$? ty))) 200 | (refine/guess-var var)) 201 | (for/list ([atom (in-set (extract-constants checks))]) 202 | (refine/guess-const atom)) 203 | (for/list ([(var ty) (in-hash cenv)] 204 | #:when (function$? ty)) 205 | (refine/guess-app var)) 206 | (for/list ([(var ty) (in-hash cenv)]) 207 | (refine/guess-template ty var)))) 208 | 209 | (for/list ([movement (in-list possible)] 210 | #:when (can-refine? movement partial-prog)) 211 | movement)) 212 | 213 | (define (run-synth function-name init-ty system checks 214 | #:debug? [debug? #f] 215 | #:args [args #f]) 216 | (set-clear! SPLITS) 217 | 218 | (parameterize ([current-resolved-system (resolve-system system)] 219 | [current-function-name function-name] 220 | [current-function-type init-ty] 221 | [current-function-arguments args]) 222 | (define (do-bfs q) 223 | (cond [(queue-empty? q) #f] 224 | [else 225 | (define-values (prog others) (dequeue q)) 226 | 227 | (match-define (zipper focus _) prog) 228 | (when debug? 229 | (pretty-write (unparse (rebuild prog)))) 230 | (cond [(not (hole^? focus)) 231 | (define expr (rebuild prog)) 232 | (cond [(satisfies? (unparse-system system) 233 | (unparse expr) 234 | checks) 235 | expr] 236 | [else (do-bfs others)])] 237 | [else 238 | (define next-layer 239 | (for/fold ([new-queue others]) 240 | ([movement (in-list (possible-refinements prog))]) 241 | (enqueue (movement prog) new-queue))) 242 | (cond [(empty? next-layer) (do-bfs others)] 243 | [else (do-bfs next-layer)])])])) 244 | 245 | (unparse 246 | (do-bfs (enqueue 247 | (zip (hole^ #f 248 | (hash-union init-bsl-environment 249 | (system->environment system)) 250 | init-ty 251 | checks)) 252 | empty-queue))))) 253 | -------------------------------------------------------------------------------- /bingus-lib/data-definition.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/hash 3 | racket/syntax 4 | 5 | "ast.rkt" 6 | "util.rkt") 7 | (provide resolve-system 8 | generate-sum-template 9 | generate-product-environment 10 | system->environment) 11 | 12 | (define (system-ref name system) 13 | (for/first ([defn (in-list system)] 14 | #:when (equal? (defn$-name defn) name)) 15 | (defn$-type defn))) 16 | 17 | ;; a system is a list of defn$ses, 18 | ;; which correspond to top-level definitions 19 | ;; 20 | ;; a resolved system is a hash of strings to signatures, 21 | ;; with no definitions, and no indirection 22 | ;; 23 | ;; recursion is replaced with a marker, which signifies the type 24 | ;; to recur on 25 | ;; NOTE: right now that's just the single type, since we don't 26 | ;; synthesize helpers 27 | (define (resolve-system system) 28 | (define (insert-recursion name sig) 29 | (match sig 30 | [(? string?) (cond [(equal? sig name) (recur$ sig)] 31 | [else (resolve-defn sig)])] 32 | [(product$ n fields) (product$ n 33 | (for/list ([field (in-list fields)]) 34 | (insert-recursion name field)))] 35 | [(product-field$ n type) (product-field$ n (insert-recursion name type))] 36 | [(sum$ cases) (sum$ (for/list ([c (in-list cases)]) 37 | (insert-recursion name c)))] 38 | [(sum-case$ ty) (sum-case$ (insert-recursion name ty))] 39 | [(cons$ a d) (cons$ (insert-recursion name a) 40 | (insert-recursion name d))] 41 | ;; TODO: look into this more. this is very wrong lol 42 | [y y])) 43 | 44 | (define (resolve-defn name) 45 | (let loop ([current-val name]) 46 | (cond [(not (string? current-val)) (insert-recursion name current-val)] 47 | [else (loop (system-ref name system))]))) 48 | 49 | (for/hash ([decl (in-list system)]) 50 | (values (defn$-name decl) 51 | (resolve-defn (defn$-name decl))))) 52 | 53 | ;; turn each product field into an entry in the environment, 54 | ;; UNLESS it's recursive, in which case insert recursion here 55 | (define (generate-product-environment ty 56 | #:var-name var-name 57 | #:cenv orig-cenv 58 | #:checks checks) 59 | (match-define (product$ struct-name fields) ty) 60 | 61 | (for/fold ([cenv (hash)]) 62 | ([fld (in-list fields)]) 63 | (match-define (product-field$ accessor-name out) fld) 64 | (define accessor 65 | (format-symbol "~a-~a" struct-name accessor-name)) 66 | 67 | ;; TODO: this will decrease the size of all recursive arguments, not just one 68 | ;; I'm not sure if we should bother with not doing that 69 | (match out 70 | [(recur$ on) 71 | (match-define (function$ ins out^ _) (current-function-type)) 72 | ;; everything's a hole, except our recursion, which is structurally decreasing 73 | (define recursion-args 74 | (for/list ([in (in-list ins)]) 75 | (cond [(equal? in on) (app^ accessor (list var-name))] 76 | [else (hole^ #t orig-cenv in checks)]))) 77 | 78 | (hash-set* cenv 79 | (app^ accessor (list var-name)) on 80 | (app^ (current-function-name) 81 | recursion-args) out^)] 82 | [_ (hash-set cenv (app^ accessor (list var-name)) out)]))) 83 | 84 | (define (generate-cons-environment ty 85 | #:var-name var-name 86 | #:cenv cenv 87 | #:checks checks) 88 | (match-define (cons$ a d) ty) 89 | 90 | (match d 91 | [(recur$ on) 92 | (match-define (function$ ins out _) (current-function-type)) 93 | (define recursion-args 94 | (for/list ([in (in-list ins)]) 95 | (cond [(equal? in on) (app^ 'rest (list var-name))] 96 | [else (hole^ #t cenv in checks)]))) 97 | (hash-set* cenv 98 | (app^ 'first (list var-name)) a 99 | (app^ 'rest (list var-name)) on 100 | (app^ (current-function-name) 101 | recursion-args) out)] 102 | [_ (hash-set* cenv 103 | (app^ 'first (list var-name)) a 104 | (app^ 'rest (list var-name)) d)])) 105 | 106 | (define (generate-sum-template name 107 | #:var-name var-name 108 | #:cenv cenv 109 | #:signature sig 110 | #:checks checks) 111 | (define (generate-cond-clause ty) 112 | (match ty 113 | [(singleton-atom$ val) 114 | (cond-case^ 115 | (cond [(string? val) (app^ 'string=? (list var-name val))] 116 | [(number? val) (app^ '= (list var-name val))] 117 | [(boolean? val) (if val 118 | (app^ 'not (app^ 'false? (list var-name))) 119 | (app^ 'false? (list var-name)))] 120 | [else (error 'generate-sum-template 121 | "invalid singleton value: ~a of signature ~a" 122 | val ty)]) 123 | (hole^ #t cenv sig checks))] 124 | [(empty$) 125 | (cond-case^ (app^ 'empty? (list var-name)) 126 | (hole^ #t cenv sig checks))] 127 | [(cons$ a d) 128 | (cond-case^ (app^ 'cons? (list var-name)) 129 | (hole^ #t 130 | (generate-cons-environment ty 131 | #:var-name var-name 132 | #:cenv cenv 133 | #:checks checks) 134 | sig 135 | checks))] 136 | [(product$ name _) 137 | (cond-case^ 138 | (app^ (string->symbol (string-append name "?")) (list var-name)) 139 | (hole^ #t 140 | (hash-union cenv (generate-product-environment ty 141 | #:var-name var-name 142 | #:cenv cenv 143 | #:checks checks) 144 | #:combine (λ (x y) x)) 145 | sig 146 | ;; TODO: narrow checks here 147 | checks))] 148 | [_ (error 'generate-sum-template "currently unsupported: ~a" ty)])) 149 | 150 | (match-define (sum$ cases) (hash-ref (current-resolved-system) name)) 151 | (cond^ 152 | (map (λ (x) 153 | (generate-cond-clause (sum-case$-type x))) 154 | cases))) 155 | 156 | ;; turns a system into an environment, by putting product accessors in scope 157 | ;; TODO: this has to be recursive now, b/c unions 158 | (define (system->environment system) 159 | (define (get-constructors name sig) 160 | (match sig 161 | [(sum$ cases) (append-map (compose (curry get-constructors name) 162 | sum-case$-type) 163 | cases)] 164 | [(product$ name^ fields) 165 | (list (format-symbol "make-~a" name^) 166 | (function$ (map product-field$-type fields) name #t))] 167 | [(cons$ a d) 168 | (list 'cons 169 | (function$ (list a d) name #t))] 170 | [_ '()])) 171 | 172 | (for/fold ([env (hash)]) 173 | ([defn (in-list system)]) 174 | (apply hash-set* env 175 | (get-constructors (defn$-name defn) 176 | (defn$-type defn))))) 177 | 178 | #;(module+ test 179 | (require rackunit) 180 | 181 | (define mad-lib-system 182 | (list 183 | (defn$ "Seeker" 184 | (sum$ (list 185 | (sum-case$ (singleton-atom$ "finder")) 186 | (sum-case$ (singleton-atom$ "gadabout")) 187 | (sum-case$ (singleton-atom$ "hunter"))))) 188 | (defn$ "Topspin" (string-atom$)) 189 | (defn$ "Tokamak" (string-atom$)) 190 | (defn$ "FishtailPalm" 191 | (product$ "fishtail-palm" 192 | (list 193 | (product-field$ "sapwood" "Seeker") 194 | (product-field$ "duramen" "Tokamak") 195 | (product-field$ "stump" "Topspin")))))) 196 | 197 | (check-equal? 198 | (resolve-system mad-lib-system) 199 | (hash 200 | "FishtailPalm" (product$ 201 | "fishtail-palm" 202 | (list 203 | (product-field$ 204 | "sapwood" 205 | (sum$ 206 | (list 207 | (sum-case$ (singleton-atom$ "finder")) 208 | (sum-case$ (singleton-atom$ "gadabout")) 209 | (sum-case$ (singleton-atom$ "hunter"))))) 210 | (product-field$ "duramen" (string-atom$)) 211 | (product-field$ "stump" (string-atom$)))) 212 | "Seeker" (sum$ 213 | (list 214 | (sum-case$ (singleton-atom$ "finder")) 215 | (sum-case$ (singleton-atom$ "gadabout")) 216 | (sum-case$ (singleton-atom$ "hunter")))) 217 | "Tokamak" (string-atom$) 218 | "Topspin" (string-atom$))) 219 | 220 | (parameterize ([current-resolved-system (resolve-system mad-lib-system)]) 221 | (check-equal? 222 | (generate-sum-template "Seeker" 223 | #:var-name 's 224 | #:cenv (hash) 225 | #:signature (number-atom$) 226 | #:checks '()) 227 | (cond^ 228 | (list 229 | (cond-case^ (app^ 'string=? '(s "finder")) (hole^ #t '#hash() (number-atom$) '())) 230 | (cond-case^ (app^ 'string=? '(s "gadabout")) (hole^ #t '#hash() (number-atom$) '())) 231 | (cond-case^ (app^ 'string=? '(s "hunter")) (hole^ #t '#hash() (number-atom$) '())))))) 232 | 233 | (define bon-system 234 | (list 235 | (defn$ "BunchOfNumbers" 236 | (sum$ (list (sum-case$ (product$ "none" '())) 237 | (sum-case$ (product$ "some" 238 | (list 239 | (product-field$ "first" (number-atom$)) 240 | (product-field$ "rest" "BunchOfNumbers"))))))))) 241 | 242 | (check-equal? 243 | (resolve-system bon-system) 244 | (hash 245 | "BunchOfNumbers" 246 | (sum$ 247 | (list 248 | (sum-case$ (product$ "none" '())) 249 | (sum-case$ 250 | (product$ "some" (list (product-field$ "first" (number-atom$)) 251 | (product-field$ "rest" (recur$ "BunchOfNumbers"))))))))) 252 | 253 | (parameterize ([current-resolved-system (resolve-system bon-system)] 254 | [current-function-name 'func] 255 | [current-function-type (function$ (list "BunchOfNumbers") (number-atom$))]) 256 | (check-equal? 257 | (generate-sum-template "BunchOfNumbers" 258 | #:var-name 'bon 259 | #:cenv (hash) 260 | #:signature (number-atom$) 261 | #:checks '()) 262 | (cond^ 263 | (list 264 | (cond-case^ (app^ 'none? '(bon)) (hole^ #t '#hash() (number-atom$) '())) 265 | (cond-case^ (app^ 'some? '(bon)) 266 | (hole^ 267 | #t 268 | (hash (app^ 'some-first '(bon)) (number-atom$) 269 | (app^ 'func (list (app^ 'some-rest '(bon)))) (number-atom$) 270 | (app^ 'some-rest '(bon)) "BunchOfNumbers") 271 | (number-atom$) 272 | '()))))))) 273 | -------------------------------------------------------------------------------- /bingus-lib/parser/from-checkers/datadef.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require rackunit) 3 | (require (only-in racket/list filter-map)) 4 | (require (only-in racket/sandbox sandbox-memory-limit make-evaluator)) 5 | (require (only-in lang/htdp-beginner struct?)) 6 | (require "grouped.rkt" 7 | "err-msg.rkt" 8 | "permute.rkt") 9 | (provide list=-no-order? 10 | (struct-out data-id) 11 | (struct-out data-app) 12 | (struct-out data-literal) 13 | (struct-out data-make) 14 | pattern-subst pattern-has? pattern-alpha=? pattern-rename infer-univs 15 | parse-data-pattern 16 | (struct-out datadef) 17 | datadef=? 18 | parse-datadefs reduce-patterns reduce-to-pattern reduce-to-patterns 19 | (struct-out polysig) 20 | parse-polysig parse-polysigs 21 | reduce-polysig polysig=? 22 | absent-polysig? lookup-polysig) 23 | 24 | ; list=-no-order? : [ListOf X] [ListOf X] -> Boolean 25 | ; Compare two lists for element equal?-ity without regard for order 26 | (define (list=-no-order? lst1 lst2) 27 | (define (histogram seq) 28 | (define h (make-hash)) 29 | (for ([k seq]) (hash-update! h k add1 0)) 30 | h) 31 | (equal? (histogram (in-list lst1)) (histogram (in-list lst2)))) 32 | 33 | ; A DataPattern is one of: ; *Interpretation*: 34 | ; - (data-id Symbol) ; type name (such as image or temperature) or type variable (such as x or y) 35 | ; - (data-app Symbol [NEListOf DataPattern]) ; type application (such as [listof number]) 36 | ; - (data-literal Anything) ; a fixed constant (such as in an enumeration) 37 | ; - (data-make Symbol [ListOf DataPattern]) ; a named function (such as make-posn or +) applied 38 | ; - String ; uninterpreted/uninterpretable 39 | (struct data-id [name] #:transparent) 40 | (struct data-app [rator rands] #:transparent) 41 | (struct data-literal [value] #:transparent) 42 | (struct data-make [rator rands] #:transparent) 43 | 44 | ; pattern-subst : [Symbol -> DataPattern] -> [DataPattern -> DataPattern] 45 | (define (pattern-subst env) 46 | (define f (match-lambda 47 | [(data-id s) (env s)] 48 | [(data-app rator rands) (data-app rator (map f rands))] 49 | [(data-make rator rands) (data-make rator (map f rands))] 50 | [p p])) 51 | f) 52 | 53 | (module+ test 54 | (check-equal? ((pattern-subst data-literal) 55 | (data-make 'bar (list (data-app 'foo (list (data-id 'x) 56 | (data-id 'y))) 57 | (data-literal 3)))) 58 | (data-make 'bar (list (data-app 'foo (list (data-literal 'x) 59 | (data-literal 'y))) 60 | (data-literal 3))))) 61 | 62 | ; pattern-has? : [Symbol -> Boolean] -> [DataPattern -> Boolean] 63 | (define (pattern-has? pred) 64 | (define f (match-lambda 65 | [(data-id s) (pred s)] 66 | [(data-app rator rands) (ormap f rands)] 67 | [(data-make rator rands) (ormap f rands)] 68 | [_ #f])) 69 | f) 70 | 71 | (module+ test 72 | (check-true ((pattern-has? (lambda (s) (symbol=? s 'x))) 73 | (data-app 'foo (list (data-id 'x) (data-id 'y))))) 74 | (check-false ((pattern-has? (lambda (s) (symbol=? s 'z))) 75 | (data-app 'foo (list (data-id 'x) (data-id 'y)))))) 76 | 77 | ; pattern-alpha=? : [ListOf [Pair Symbol Symbol]] DataPattern DataPattern -> Boolean 78 | (define (pattern-alpha=? bindings p1 p2) 79 | (match* (p1 p2) 80 | [((data-id s1) (data-id s2)) 81 | (and (member (cons s1 s2) bindings) ; `bindings` relates bound type variables 82 | #t)] 83 | [((data-app rator1 rands1) (data-app rator2 rands2)) 84 | (and (symbol=? rator1 rator2) ; `bindings` does not relate type constructors 85 | (= (length rands1) (length rands2)) 86 | (for/and ([rand1 rands1] [rand2 rands2]) 87 | (pattern-alpha=? bindings rand1 rand2)))] 88 | [((data-literal v1) (data-literal v2)) 89 | (equal? v1 v2)] 90 | [((data-make rator1 rands1) (data-make rator2 rands2)) 91 | (and (symbol=? rator1 rator2) ; `bindings` does not relate term variables 92 | (= (length rands1) (length rands2)) 93 | (for/and ([rand1 rands1] [rand2 rands2]) 94 | (pattern-alpha=? bindings rand1 rand2)))] 95 | [((? string?) (? string?)) 96 | (string=? p1 p2)] 97 | [(_ _) #f])) 98 | 99 | (module+ test 100 | (check-true (pattern-alpha=? '((x . y) (y . z)) 101 | (data-id 'x) 102 | (data-id 'y))) 103 | (check-true (pattern-alpha=? 104 | '((x . y) (y . z)) 105 | (data-app 'foo (list (data-id 'x) (data-id 'y))) 106 | (data-app 'foo (list (data-id 'y) (data-id 'z))))) 107 | (check-true (pattern-alpha=? 108 | '((x . y) (y . z)) 109 | (data-app 'foo (list (data-id 'y) (data-id 'y))) 110 | (data-app 'foo (list (data-id 'z) (data-id 'z))))) 111 | (check-false (pattern-alpha=? '((x . y) (y . z)) 112 | (data-literal 'x) 113 | (data-literal 'y))) 114 | (check-false (pattern-alpha=? 115 | '((x . y) (y . z)) 116 | (data-app 'foo (list (data-id 'x) (data-id 'y))) 117 | (data-app 'foo (list (data-id 'y) (data-id 'x))))) 118 | (check-false (pattern-alpha=? 119 | '((x . y) (y . z)) 120 | (data-app 'foo (list (data-id 'x) (data-id 'x))) 121 | (data-app 'foo (list (data-id 'z) (data-id 'z)))))) 122 | 123 | ; pattern-rename : [ListOf [Pair Symbol Symbol]] DataPattern -> [Maybe DataPattern] 124 | (define (pattern-rename src-dst p) 125 | (define to-be-bound 126 | (set-subtract (for/set ([s-d src-dst]) (cdr s-d)) 127 | (for/set ([s-d src-dst]) (car s-d)))) 128 | (and (not ((pattern-has? (lambda (s) (set-member? to-be-bound s))) p)) 129 | ((pattern-subst (lambda (s) 130 | (data-id (cond [(assoc s src-dst) => cdr] 131 | [else s])))) 132 | p))) 133 | 134 | (module+ test 135 | (check-equal? (pattern-rename '((x . y) (y . z)) 136 | (data-app 'foo (list (data-id 'x) (data-id 'y)))) 137 | (data-app 'foo (list (data-id 'y) (data-id 'z)))) 138 | (check-equal? (pattern-rename '((x . y) (y . z)) 139 | (data-app 'foo (list (data-id 'x) (data-id 'z)))) 140 | #f) 141 | (check-equal? (pattern-rename '((x . y) (y . x)) 142 | (data-app 'foo (list (data-id 'x) (data-id 'y)))) 143 | (data-app 'foo (list (data-id 'y) (data-id 'x))))) 144 | 145 | (define well-known-atomic-data-ids 146 | (set 'number 'string 'image 'color 'mode)) 147 | (define probable-data-ids 148 | (set-union well-known-atomic-data-ids 149 | (set 'boolean 'naturalnumber 'listofnumbers 150 | 'temperature 151 | 'year 'month 'day 'dateorder 'monthformat 152 | 'x 'y 'z))) 153 | 154 | ; read-single : String -> Datum 155 | ; Read a single datum from the given string. If the given string does not 156 | ; contain exactly one datum, throw an exception. 157 | (define (read-single s) 158 | (define p (open-input-string s)) 159 | (define d (read p)) 160 | (cond [(eof-object? d) (error "No datum found in" s)] 161 | [(eof-object? (read p)) d] 162 | [else (error "Multiple data found in" s)])) 163 | 164 | (module+ test 165 | (check-exn #px"^No datum found in \\\"\\\"$" 166 | (lambda () (read-single ""))) 167 | (check-exn #px"^Multiple data found in \\\"\\(\\+ 2 3\\) 4\\\"$" 168 | (lambda () (read-single "(+ 2 3) 4"))) 169 | (check-equal? (read-single "(+ 2 3)") '(+ 2 3))) 170 | 171 | ; literal-ok? : Anything -> Boolean 172 | ; Check if the given value is free of procedures and BSL structures. This 173 | ; disallows signature-name (like Person) and parametric-signature-name (like 174 | ; PersonOf) created by do-define-struct in htdp-lib/lang/private/teach.rkt, 175 | ; because both Person and PersonOf satisfy procedure? 176 | (define (literal-ok? v) 177 | (cond [(procedure? v) #f] 178 | [(struct? v) #f] 179 | [(void? v) #f] 180 | [(pair? v) (and (literal-ok? (car v)) (literal-ok? (cdr v)))] 181 | [else #t])) 182 | 183 | (module+ test 184 | (check-true (literal-ok? 0)) 185 | (check-true (literal-ok? 1)) 186 | (check-true (literal-ok? "hi")) 187 | (check-true (literal-ok? (list 0 1 "hi"))) 188 | (check-false (literal-ok? (void))) 189 | (check-false 190 | (literal-ok? 191 | ((make-evaluator 'lang/htdp-beginner 192 | "(define-struct person [name age])") 193 | 'Person))) 194 | (check-false 195 | (literal-ok? 196 | ((make-evaluator 'lang/htdp-beginner 197 | "(define-struct person [name age])") 198 | 'PersonOf))) 199 | (check-false 200 | (literal-ok? 201 | ((make-evaluator 'lang/htdp-beginner 202 | "(define-struct person [name age])") 203 | '(list Person Person)))) 204 | (check-false 205 | (literal-ok? 206 | ((make-evaluator 'lang/htdp-beginner 207 | "(define-struct person [name age])") 208 | '(list 0 (make-posn Person Person))))) 209 | (check-false 210 | (literal-ok? 211 | ((make-evaluator 'lang/htdp-beginner 212 | "(define-struct person [name age])") 213 | '(make-posn "" 0))))) 214 | 215 | ; infer-univs : DataPattern -> [Set Symbol] 216 | ; Look for stuff like (data-id 'x) 217 | (define infer-univs 218 | (match-lambda 219 | [(data-id (and (or 'x 'y 'z) s)) (set s)] 220 | [(data-app _ ps) (apply set-union (map infer-univs ps))] 221 | [(data-make _ ps) (apply set-union (set) (map infer-univs ps))] 222 | [_ (set)])) 223 | 224 | ; arrow? : String -> Boolean 225 | (define (arrow? str) (regexp-match? #px"^-+>$" str)) 226 | 227 | ; not-arrow? : String -> Boolean 228 | (define (not-arrow? str) (not (arrow? str))) 229 | 230 | ; normalize-data-name : String -> Symbol 231 | ; Used for the Symbol in data-id (such as 'number) and data-app (such as 'listof) 232 | ; but not data-make (such as 'make-posn, because that's case-sensitive) 233 | (define (normalize-data-name s) 234 | (string->symbol (regexp-replace* #rx"(?:^|-)(?:(?:ne)?lists?-?of(?:-|$))+" 235 | (string-downcase s) 236 | (lambda (m) (string-replace m "-" ""))))) 237 | 238 | (module+ test 239 | (check-equal? (normalize-data-name "List-of-lists-Of-Numbers") 'listoflistsofnumbers) 240 | (check-equal? (normalize-data-name "list-of-ne-lists-of-numbers") 'listofnelistsofnumbers) 241 | (check-equal? (normalize-data-name "nelist-of-lists-ofnumbers") 'nelistoflists-ofnumbers) 242 | (check-equal? (normalize-data-name "nelist-of-listof-numbers") 'nelistoflistofnumbers) 243 | (check-equal? (normalize-data-name "listof-string") 'listofstring) 244 | (check-equal? (normalize-data-name "iMaGe") 'image)) 245 | 246 | ; parse-data-pattern : String [Datum -> Anything] -> DataPattern 247 | ; Try to interpret the given string as a data pattern. 248 | ; If the given evaluator throws an exception, we don't make a data-literal 249 | (define (parse-data-pattern str eval) 250 | (define (loop s) (parse-data-pattern s eval)) 251 | (define trimmed-str (string-trim str)) 252 | (define normalized-name (normalize-data-name trimmed-str)) 253 | (define (handler . _) 254 | (cond 255 | [(regexp-match? #px"^[^][(){}\",.'`|;:#\\s]+$" trimmed-str) 256 | (data-id normalized-name)] 257 | [(regexp-match #px"^\\[\\s*(\\S.*)\\]$" trimmed-str) 258 | => (lambda (m) 259 | (match (grouped-string-split (cadr m)) 260 | [(list (? not-arrow? args) ..1 261 | (? arrow?) 262 | (? not-arrow? return-type) ..1) 263 | (data-app '-> (append (map loop args) 264 | (list (loop (string-join return-type)))))] 265 | [(list (? not-arrow? rator) 266 | (? not-arrow? rands) ..1) 267 | #:when (regexp-match? #px"^[^][(){}\",.'`|;:#\\s]+$" rator) 268 | (data-app (normalize-data-name rator) (map loop rands))] 269 | [_ trimmed-str]))] 270 | [(regexp-match #px"^\\(\\s*([^][(){}\",'`|;#\\s]+)(.*)\\)$" trimmed-str) 271 | => (lambda (m) 272 | (define rands (map loop (grouped-string-split (caddr m)))) 273 | (data-make (string->symbol (cadr m)) rands))] 274 | [else trimmed-str])) 275 | (cond 276 | [(set-member? probable-data-ids normalized-name) 277 | (data-id normalized-name)] 278 | [else (with-handlers ([exn:fail? handler]) 279 | (let ([val (eval (datum->syntax #f (read-single str)))]) 280 | (if (literal-ok? val) (data-literal val) (handler))))])) 281 | (define (base-eval x) (eval x (make-base-namespace))) 282 | 283 | (module+ test 284 | (check-equal? (parse-data-pattern " (+ 1 Nat) " base-eval) 285 | (data-make '+ (list (data-literal 1) 286 | (data-id 'nat)))) 287 | (check-equal? (parse-data-pattern "(make-point Number Number)" base-eval) 288 | (data-make 'make-point (list (data-id 'number) 289 | (data-id 'number)))) 290 | (check-equal? (parse-data-pattern " #true " base-eval) 291 | (data-literal true)) 292 | (check-equal? (parse-data-pattern " \"red\" " base-eval) 293 | (data-literal "red")) 294 | (check-equal? (parse-data-pattern "number less than 100 " base-eval) 295 | "number less than 100") 296 | (check-equal? (parse-data-pattern " [List-of Number] " base-eval) 297 | (data-app 'listof (list (data-id 'number)))) 298 | (check-equal? (parse-data-pattern " [List] " base-eval) 299 | "[List]") 300 | (check-equal? 301 | (parameterize ([sandbox-memory-limit 100]) 302 | (parse-data-pattern "[Pair Person PersonOf]" 303 | (make-evaluator 'lang/htdp-beginner 304 | "(define-struct person [name age])"))) 305 | (data-app 'pair (list (data-id 'person) (data-id 'personof))))) 306 | 307 | ; parse-data-cases : [ListOf String] -> [Pair [ListOf String] [ListOf String]] 308 | ; Split the given list of lines into a list of commented indented bullet items 309 | ; at the beginning and the list of remaining lines 310 | (define (parse-data-cases lines) 311 | (cond 312 | [(and (pair? lines) 313 | (regexp-match? #px"^[\\s;]*$" (car lines))) 314 | (parse-data-cases (cdr lines))] 315 | [(and (pair? lines) 316 | (regexp-match #px"^(\\s*;[\\s;]*-\\s*)(\\S.*?)\\s*$" (car lines))) 317 | => (lambda (m) 318 | (define indent (pregexp (format "^[\\s;]{~a,}(\\S.*?)\\s*$" 319 | (string-length (cadr m))))) 320 | (let accum ([rest (cdr lines)] [seen (caddr m)]) 321 | (cond 322 | [(null? rest) 323 | (cons (list seen) '())] 324 | [(regexp-match? #px"^[\\s;]*$" (car rest)) 325 | (accum (cdr rest) (string-append seen "\n"))] 326 | [(regexp-match indent (car rest)) 327 | => (lambda (m) (accum (cdr rest) 328 | (string-append seen "\n" (cadr m))))] 329 | [else 330 | (define res (parse-data-cases rest)) 331 | (cons (cons seen (car res)) (cdr res))])))] 332 | [else (cons '() lines)])) 333 | 334 | (module+ test 335 | (check-equal? (parse-data-cases (list "; - foo" 336 | "; bar" 337 | "; - baz" 338 | "blah")) 339 | (cons (list "foo\nbar" "baz") (list "blah"))) 340 | (check-equal? (parse-data-cases (list "; - foo" 341 | ";" 342 | "; bar" 343 | "" 344 | "; - baz" 345 | "blah")) 346 | (cons (list "foo\n\nbar\n" "baz") (list "blah"))) 347 | (check-equal? (parse-data-cases (list "; - foo " 348 | " ; bar" 349 | "" 350 | ";;;;BAR " 351 | ";" 352 | "; - baz" 353 | "; blah")) 354 | (cons (list "foo\nbar\n\nBAR\n" "baz") (list "; blah"))) 355 | (check-equal? (parse-data-cases (list "; - foo " 356 | " ; bar" 357 | ";;;;BAR " 358 | "; - baz")) 359 | (cons (list "foo\nbar\nBAR" "baz") (list))) 360 | (check-equal? (parse-data-cases (list "; - foo " 361 | " ; bar" 362 | ";;;;BAR ")) 363 | (cons (list "foo\nbar\nBAR") (list))) 364 | (check-equal? (parse-data-cases (list "; - foo ")) 365 | (cons (list "foo") (list)))) 366 | 367 | ; A DataDefinition is (datadef [ListOf String] [ListOf Symbol] [NEListOf DataPattern]) 368 | (struct datadef [error arglist body] #:transparent) 369 | 370 | ; datadef=? : DataDefinition DataDefinition -> Boolean 371 | (define (datadef=? datadef1 datadef2) 372 | (and (equal? (datadef-error datadef1) 373 | (datadef-error datadef2)) 374 | (= (length (datadef-arglist datadef1)) 375 | (length (datadef-arglist datadef2))) 376 | (list=-no-order? 377 | (datadef-body datadef1) 378 | (let ([src-dst (map cons (datadef-arglist datadef2) 379 | (datadef-arglist datadef1))]) 380 | (for/list ([p (datadef-body datadef2)]) 381 | (pattern-rename src-dst p)))))) 382 | 383 | (module+ test 384 | (check-true (datadef=? 385 | (datadef '() '(x) 386 | (list (data-literal '()) 387 | (data-make 'cons (list (data-id 'x) 388 | (data-app 'listof (list (data-id 'x))))))) 389 | (datadef '() '(number) 390 | (list (data-literal '()) 391 | (data-make 'cons (list (data-id 'number) 392 | (data-app 'listof (list (data-id 'number)))))))))) 393 | 394 | ; parse-dds! : [MutableHash Symbol DataDefinition] [ListOf String] [Datum -> Anything] -> Void 395 | ; Extract data definitions from comments in the given lines. 396 | ; Use the given evaluator to interpret data literals. 397 | (define (hash-add! h key new) 398 | (hash-update! h key 399 | (lambda (old) 400 | (cond 401 | [(not old) new] 402 | [(datadef=? old new) old] 403 | [else 404 | (datadef (cons "Multiple inconsistent definitions" (datadef-error old)) 405 | (datadef-arglist old) 406 | (datadef-body old))])) 407 | #f)) 408 | (define (parse-dds! h lines eval) 409 | (cond 410 | [(null? lines) (void)] 411 | [(regexp-match #px"(?i:^\\s*;[\\s;]*an?\\s+(?:([^][(){}\",'`|;#\\s]+)|\\[\\s*([^][(){}\",'`|;#\\s]+(?:\\s+[^][(){}\",'`|;#\\s]+)+)\\s*\\])\\s+is\\s+(?:an?\\s+)?(.*)$)" 412 | (car lines)) 413 | => (lambda (m) 414 | (define head-strings (string-split (or (cadr m) (caddr m)))) 415 | (match-define (cons head arglist) (map normalize-data-name head-strings)) 416 | (when (member head '(x y z)) 417 | (error (format "You made a data definition named \"~a\". Usually \"~a\" only names a data definition that is an input to another data definition or to a signature. Your data definition is not an input, but rather takes effect throughout the entire program, so it is likely to be confusing, and you should rename it." (car head-strings) (car head-strings)))) 418 | (define err 419 | (cond [(check-duplicates arglist) 420 | => (lambda (dup) 421 | (list (format "Found a data definition variable that is used more than once: ~a" dup)))] 422 | [else '()])) 423 | (define rhs (cadddr m)) 424 | (define (non-itemization) 425 | (hash-add! h head (datadef err arglist (list (parse-data-pattern rhs eval)))) 426 | (parse-dds! h (cdr lines) eval)) 427 | (cond 428 | [(regexp-match? #px"(?i:^\\W*one\\s+of\\W*$)" rhs) 429 | (match-let ([(cons cases rest) (parse-data-cases (cdr lines))]) 430 | (if (pair? cases) 431 | (begin (hash-add! h head 432 | (datadef err arglist 433 | (for/list ([c (in-list cases)]) 434 | (parse-data-pattern 435 | (regexp-replace #px"(?i:^\\s*an?\\s)" c "") 436 | eval)))) 437 | (parse-dds! h rest eval)) 438 | (non-itemization)))] 439 | [(and (not (null? (cdr lines))) 440 | (regexp-match? #px"(?i:^\\W*structure\\W*$)" rhs) 441 | (regexp-match #px"(?i:^\\s*;[\\s;]*(\\(.*\\))\\s*$)" (cadr lines))) 442 | ; An Editor is a structure: 443 | ; (make-editor String String) 444 | => (lambda (ms) 445 | (hash-add! h head 446 | (datadef err arglist (list (parse-data-pattern (cadr ms) eval)))) 447 | (parse-dds! h (cddr lines) eval))] 448 | [(regexp-match #px"(?i:^\\W*structure\\b[\\s:;.,]*(.*\\w.*)$)" rhs) 449 | ; An Editor is a structure: (make-editor String String) 450 | => (lambda (ms) 451 | (hash-add! h head 452 | (datadef err arglist (list (parse-data-pattern (cadr ms) eval)))) 453 | (parse-dds! h (cdr lines) eval))] 454 | [else (non-itemization)]))] 455 | [else (parse-dds! h (cdr lines) eval)])) 456 | 457 | ; make-datadef-hash : [ListOf Symbol] -> [MutableHash Symbol DataDefinition] 458 | ; Initialize the mutable hash table of parsed data definitions using the given 459 | ; list of built-in data definitions ('(boolean) at the start of the semester, 460 | ; '(boolean listofnumbers) after lecture18) 461 | (define built-in-datadefs 462 | (hash 'boolean (datadef '() '() (list (data-literal #t) 463 | (data-literal #f))) 464 | 'listofnumbers (datadef '() '() (list (data-app 'listof (list (data-id 'number))))))) 465 | (define (make-datadef-hash built-in) 466 | (make-hash (for/list ([k (in-list built-in)]) 467 | (cons k (hash-ref built-in-datadefs k))))) 468 | 469 | ; parse-dds : [ListOf String] [Datum -> Anything] -> [Hash Symbol [NEListOf DataPattern]] 470 | ; Extract data definitions from comments in the given lines. 471 | ; Use the given evaluator to interpret data literals. 472 | ; If a name is redefined differently, omit it from the hash. 473 | (define (parse-dds lines eval) 474 | (define h (make-datadef-hash '(boolean))) 475 | (parse-dds! h lines eval) 476 | (for/hash ([(k datadef) (in-hash h)] 477 | #:when (and (null? (datadef-error datadef)) 478 | ; Throw away parametric data definitions 479 | (null? (datadef-arglist datadef)))) 480 | (values k (datadef-body datadef)))) 481 | 482 | (module+ test 483 | (check-equal? (parse-dds (list "" 484 | "; A Time is one of:" 485 | "; - a number less than 100" 486 | "; - a number at least 100" 487 | "" 488 | "; A Boolean is one of:" 489 | "; - #false" 490 | "; - #true" 491 | "" 492 | "; launch-rocket : Time -> Image") 493 | base-eval) 494 | (hash 'time (list "number less than 100" 495 | "number at least 100") 496 | 'boolean (list (data-literal true) 497 | (data-literal false)))) 498 | (check-equal? (parse-dds (list "; A Time is one of:" 499 | "; - a number at least 100" 500 | "; - a number less than 100" 501 | "; A Time is one of:" 502 | "; - a number less than 100" 503 | "; - a number at least 100") 504 | base-eval) 505 | (hash 'boolean (list (data-literal true) 506 | (data-literal false)) 507 | 'time (list "number at least 100" 508 | "number less than 100"))) 509 | (check-equal? (parse-dds (list "; A Time is one of:" 510 | "; - a number less than 100" 511 | "; - a number at least 100" 512 | "; A Time is one of:" 513 | "; - a number at least 200" 514 | "; - a number less than 200") 515 | base-eval) 516 | (hash 'boolean (list (data-literal true) 517 | (data-literal false)))) 518 | (check-equal? (parse-dds (list "; An Editor is a structure:" 519 | "; (make-editor String String)" 520 | "; interpretation (make-editor s t) describes an editor" 521 | "; whose visible text is (string-append s t) with" 522 | "; the cursor displayed between s and t") 523 | base-eval) 524 | (hash 'boolean (list (data-literal true) 525 | (data-literal false)) 526 | 'editor (list (data-make 'make-editor 527 | (list (data-id 'string) 528 | (data-id 'string)))))) 529 | (check-equal? (parse-dds (list "; An Editor is a structure: (make-editor String String)" 530 | "; interpretation (make-editor s t) describes an editor" 531 | "; whose visible text is (string-append s t) with" 532 | "; the cursor displayed between s and t") 533 | base-eval) 534 | (hash 'boolean (list (data-literal true) 535 | (data-literal false)) 536 | 'editor (list (data-make 'make-editor 537 | (list (data-id 'string) 538 | (data-id 'string)))))) 539 | (check-equal? (parse-dds (list "; An Editor is a structure:") 540 | base-eval) 541 | (hash 'boolean (list (data-literal true) 542 | (data-literal false)) 543 | 'editor (list "structure:"))) 544 | (check-equal? (parse-dds (list "; A CoupleOfPoints is one of:" 545 | "; - (make-none)" 546 | "; - (make-one Point)" 547 | "; - (make-two Point Point)") 548 | base-eval) 549 | (hash 'boolean (list (data-literal true) 550 | (data-literal false)) 551 | 'coupleofpoints (list (data-make 'make-none empty) 552 | (data-make 'make-one (list (data-id 'point))) 553 | (data-make 'make-two (list (data-id 'point) 554 | (data-id 'point))))))) 555 | 556 | ; parse-datadefs : [ListOf String] [Datum -> Anything] -> [Hash Symbol DataDefinition] 557 | ; Extract data definitions (possibly polymorphic) from comments in the given lines. 558 | ; Use the given evaluator to interpret data literals. 559 | (define (parse-datadefs lines eval #:built-in [built-in '(boolean)]) 560 | (define h (make-datadef-hash built-in)) 561 | (parse-dds! h lines eval) 562 | (for/hash 563 | ([(k datadef) (in-hash h)] 564 | #:when (or (null? (datadef-error datadef)) 565 | (begin 566 | (error 567 | (string-join (cons (format "For the data definition \"~a\":" k) 568 | (datadef-error datadef)) 569 | "\n")) 570 | #f))) 571 | (values k datadef))) 572 | 573 | (module+ test 574 | (define sample-datadefs 575 | (hash 'boolean (datadef '() '() 576 | (list (data-literal true) 577 | (data-literal false))) 578 | 'listofnumbers (datadef '() '() (list (data-app 'listof (list (data-id 'number))))) 579 | 'listof (datadef '() '(x) 580 | (list (data-literal '()) 581 | (data-make 'cons (list (data-id 'x) 582 | (data-app 'listof (list (data-id 'x))))))) 583 | 'maybe (datadef '() '(x) 584 | (list (data-make 'make-none '()) 585 | (data-id 'x))) 586 | 'nelistof (datadef '() '(x) 587 | (list (data-make 'cons (list (data-id 'x) 588 | (data-literal '()))) 589 | (data-make 'cons (list (data-id 'x) 590 | (data-app 'nelistof (list (data-id 'x))))))) 591 | 'frame (datadef '() '() (list (data-id 'time))) 592 | 'green (datadef '() '() (list (data-literal "green"))) 593 | 'trafficlight (datadef '() '() 594 | (list (data-literal "red") 595 | (data-id 'green) 596 | (data-literal "yellow"))))) 597 | (check-equal? (parse-datadefs #:built-in '(boolean listofnumbers) 598 | (list "; A [ListOf X] is one of:" 599 | "; - empty" 600 | "; - (cons X [ListOf X])" 601 | "; A [ListOf Number] is one of:" 602 | "; - empty" 603 | "; - (cons Number [ListOf Number])" 604 | "; A [Maybe X] is one of:" 605 | "; - (make-none)" 606 | "; - X" 607 | ";; A [NEListOf X] is one of:" 608 | ";; - (cons X empty)" 609 | ";; - (cons X [NEListOf X])" 610 | "; A [Foo X X] is one of:" 611 | "; - \"pink\"" 612 | "; - \"purple\"" 613 | "; A Time is one of:" 614 | "; - a number less than 100" 615 | "; - a number at least 100" 616 | "; A Frame is Time" 617 | "; A Time is one of:" 618 | "; - a number at least 200" 619 | "; - a number less than 200" 620 | "; A Green is \"green\"" 621 | "; A TrafficLight is one of:" 622 | "; - \"red\"" 623 | "; - Green" 624 | "; - \"yellow\"") 625 | (make-evaluator 'lang/htdp-beginner "(define-struct none [])")) 626 | sample-datadefs) 627 | (check-equal? (parse-datadefs #:built-in '(boolean listofnumbers) 628 | (list "; A List-Of-Numbers is a [List-of Number]" 629 | "; A Listof-Lists-oF-Numbers is a [List-of Listofnumbers]") 630 | base-eval) 631 | (hash 'boolean 632 | (datadef '() '() 633 | (list (data-literal true) 634 | (data-literal false))) 635 | 'listofnumbers 636 | (datadef '() '() 637 | (list (data-app 'listof (list (data-id 'number))))) 638 | 'listoflistsofnumbers 639 | (datadef '() '() 640 | (list (data-app 'listof (list (data-id 'listofnumbers)))))))) 641 | 642 | ; reduce-type : [Hash Symbol [NEListOf DataPattern]] Symbol -> [NEListOf DataPattern] 643 | ; Loop up the meaning of a data definition name, following data-id chains 644 | (define (reduce-type dds t) 645 | (let loop ([t t] [seen (set)]) 646 | (cond [(or (set-member? seen t) 647 | (set-member? well-known-atomic-data-ids t)) 648 | (list (data-id t))] 649 | [(hash-ref dds t #f) 650 | => (lambda (patterns) 651 | (for*/list ([pattern (in-list patterns)] 652 | [pattern^ (match pattern 653 | [(data-id t^) 654 | (in-list (loop t^ (set-add seen t)))] 655 | [_ (in-value pattern)])]) 656 | pattern^))] 657 | [else (list (data-id t))]))) 658 | 659 | (module+ test 660 | (define sample-dds 661 | (parse-dds (list "; A TrafficLight is one of:" 662 | "; - \"red\"" 663 | "; - Green" 664 | "; - \"yellow\"" 665 | "; A Green is \"green\"" 666 | "; A Time is one of:" 667 | "; - a number less than 100" 668 | "; - a number at least 100" 669 | "; A Frame is Time" 670 | "; A Foo is Bar" 671 | "; A Bar is a Foo" 672 | "; A Time is one of:" 673 | "; - a number at least 200" 674 | "; - a number less than 200" 675 | "; A TrafficLight is one of:" 676 | "; - \"red\"" 677 | "; - Green" 678 | "; - \"yellow\"") 679 | base-eval)) 680 | (check-equal? (reduce-type sample-dds 'frame) 681 | (list (data-id 'time))) 682 | (check-equal? (reduce-type sample-dds 'trafficlight) 683 | (list (data-literal "red") 684 | (data-literal "green") 685 | (data-literal "yellow"))) 686 | (check-equal? (reduce-type sample-dds 'foo) 687 | (list (data-id 'foo)))) 688 | 689 | ; extend-env : [ListOf X] [ListOf Y] [X -> Y] -> [X -> Y] 690 | (define (extend-env arglist rands default) 691 | (define h (for/hash ([arg arglist] [rand rands]) (values arg rand))) 692 | (lambda (x) (hash-ref h x (lambda () (default x))))) 693 | 694 | ; reduce-patterns : [Hash Symbol DataDefinition] [NEListOf DataPattern] -> [NEListOf DataPattern] 695 | (define (reduce-patterns datadefs ps [seen (set)]) 696 | (for*/list ([p ps] 697 | [p^ (reduce-to-patterns datadefs p seen)]) 698 | p^)) 699 | 700 | ; reduce-to-pattern : [Hash Symbol DataDefinition] DataPattern -> DataPattern 701 | (define (reduce-to-pattern datadefs p [seen (set)]) 702 | (match p 703 | [(data-id s) 704 | (match (or (set-member? seen s) 705 | (set-member? well-known-atomic-data-ids s) 706 | (hash-ref datadefs s #f)) 707 | [(datadef _ '() (list p)) 708 | (reduce-to-pattern datadefs p (set-add seen s)) ] 709 | [_ p])] 710 | [(data-app s rands) 711 | (match (or (set-member? seen s) 712 | (set-member? well-known-atomic-data-ids s) 713 | (hash-ref datadefs s #f)) 714 | [(datadef _ arglist (list p)) 715 | #:when (= (length arglist) (length rands)) 716 | (define subst (pattern-subst (extend-env arglist rands data-id))) 717 | (reduce-to-pattern datadefs (subst p) (set-add seen s))] 718 | [_ (data-app s (for/list ([rand rands]) 719 | (reduce-to-pattern datadefs rand seen)))])] 720 | [(data-make s rands) 721 | (data-make s (for/list ([rand rands]) 722 | (reduce-to-pattern datadefs rand seen)))] 723 | [_ p])) 724 | 725 | ; reduce-to-patterns : [Hash Symbol DataDefinition] DataPattern -> [NEListOf DataPattern] 726 | (define (reduce-to-patterns datadefs p [seen (set)]) 727 | (match p 728 | [(data-id s) 729 | (match (or (set-member? seen s) 730 | (set-member? well-known-atomic-data-ids s) 731 | (hash-ref datadefs s #f)) 732 | [(datadef _ '() body) 733 | (reduce-patterns datadefs body (set-add seen s))] 734 | [_ (list p)])] 735 | [(data-app s rands) 736 | (match (or (set-member? seen s) 737 | (set-member? well-known-atomic-data-ids s) 738 | (hash-ref datadefs s #f)) 739 | [(datadef _ arglist body) 740 | #:when (= (length arglist) (length rands)) 741 | (define subst (pattern-subst (extend-env arglist rands data-id))) 742 | (reduce-patterns datadefs (map subst body) (set-add seen s))] 743 | [_ (list (data-app s (for/list ([rand rands]) 744 | (reduce-to-pattern datadefs rand seen))))])] 745 | [(data-make s rands) 746 | (list (data-make s (for/list ([rand rands]) 747 | (reduce-to-pattern datadefs rand seen))))] 748 | [_ (list p)])) 749 | 750 | (module+ test 751 | (check-equal? (reduce-to-patterns sample-datadefs 752 | (data-app 'listof (list (data-id 'string)))) 753 | (list 754 | (data-literal '()) 755 | (data-make 'cons (list (data-id 'string) 756 | (data-app 'listof (list (data-id 'string)))))))) 757 | 758 | ; A Signature is (signature Symbol [ListOf [NEListOf DataPattern]] [NEListOf DataPattern]) 759 | (struct signature [name args return-type] #:transparent) 760 | 761 | ; A PolySig is (polysig Symbol [Set Symbol] [ListOf [NEListOf DataPattern]] [NEListOf DataPattern]) 762 | (struct polysig [name univs args return-type] #:transparent) 763 | 764 | ; parse-signature : String [Datum -> Anything] -> [Maybe Signature] 765 | (define (parse-signature line eval) 766 | (define m (regexp-match #px"^[\\s;]*([^][(){}\",'`|;#\\s]+)\\s*:\\s*(\\S.*?)\\s*--*>\\s*(\\S.*?)\\s*$" line)) 767 | (and m 768 | (signature (string->symbol (cadr m)) 769 | (map (lambda (s) (list (parse-data-pattern s eval))) 770 | (grouped-string-split (caddr m))) 771 | (list (parse-data-pattern (cadddr m) eval))))) 772 | 773 | ; parse-polysig : String [Datum -> Anything] -> [Maybe PolySig] 774 | (define (parse-polysig line eval) 775 | ; Square-bracketed univ names can only have uppercase letters 776 | (match (regexp-match #px"^[\\s;]*([^][(){}\",'`|;#\\s]+)\\s*:\\s*((?:\\[[[:upper:]\\s]*\\]\\s*|\\{[^][(){}\",'`|;#]*\\}\\s*)*)(\\S.*->.*\\S)\\s*$" line) 777 | [(list _ name univs (app grouped-string-split 778 | (list (? not-arrow? args) ..1 779 | (? arrow?) 780 | (? not-arrow? return-type) ..1))) 781 | (define parsed-args (for/list ([arg args]) (parse-data-pattern arg eval))) 782 | (define parsed-return-type (parse-data-pattern (string-join return-type) eval)) 783 | (define parsed-univs 784 | (if (string=? "" univs) 785 | (apply set-union 786 | (infer-univs parsed-return-type) 787 | (map infer-univs parsed-args)) 788 | (for/set ([univ (string-split (string-downcase univs) #px"[][{}\\s]+")]) 789 | (string->symbol univ)))) 790 | (polysig (string->symbol name) 791 | parsed-univs 792 | (map list parsed-args) 793 | (list parsed-return-type))] 794 | [#f #f])) 795 | 796 | ; parse-signatures : [ListOf String] [Datum -> Anything] -> [ListOf Signature] 797 | (define (parse-signatures lines eval) 798 | (for*/list ([line lines] 799 | #:when (regexp-match? #px"^\\s*;" line) 800 | [s (in-value (parse-signature line eval))] 801 | #:when s) 802 | s)) 803 | (define sample-signatures 804 | (parse-signatures (list "; launch-rocket : Time -> Image" 805 | "; take : NaturalNumber [ListOf X] -> [ListOf X]" 806 | "; draw-tl : TrafficLight -> Image" 807 | "") 808 | base-eval)) 809 | 810 | (module+ test 811 | (check-equal? sample-signatures 812 | (list (signature 'launch-rocket 813 | (list (list (data-id 'time))) 814 | (list (data-id 'image))) 815 | (signature 'take 816 | (list (list (data-id 'naturalnumber)) 817 | (list (data-app 'listof (list (data-id 'x))))) 818 | (list (data-app 'listof (list (data-id 'x))))) 819 | (signature 'draw-tl 820 | (list (list (data-id 'trafficlight))) 821 | (list (data-id 'image)))))) 822 | 823 | ; parse-polysigs : [ListOf String] [Datum -> Anything] -> [ListOf PolySig] 824 | (define (parse-polysigs lines eval) 825 | (for*/list ([line lines] 826 | #:when (regexp-match? #px"^\\s*;" line) 827 | [s (in-value (parse-polysig line eval))] 828 | #:when s) 829 | s)) 830 | (define sample-polysigs 831 | (parse-polysigs (list "; launch-rocket : Time -> Image" 832 | "; take : NaturalNumber [ListOf X] -> [ListOf X]" 833 | "; draw-tl : TrafficLight -> Image" 834 | "; filter : [X] [X -> Boolean] [ListOf X] -> [ListOf X]" 835 | "; map : {X Y} [X -> Y] [ListOf X] -> [ListOf Y]" 836 | "") 837 | base-eval)) 838 | 839 | (module+ test 840 | (check-equal? sample-polysigs 841 | (list (polysig 'launch-rocket (set) 842 | (list (list (data-id 'time))) 843 | (list (data-id 'image))) 844 | (polysig 'take (set 'x) 845 | (list (list (data-id 'naturalnumber)) 846 | (list (data-app 'listof (list (data-id 'x))))) 847 | (list (data-app 'listof (list (data-id 'x))))) 848 | (polysig 'draw-tl (set) 849 | (list (list (data-id 'trafficlight))) 850 | (list (data-id 'image))) 851 | (polysig 'filter (set 'x) 852 | (list (list (data-app '-> (list (data-id 'x) (data-id 'boolean)))) 853 | (list (data-app 'listof (list (data-id 'x))))) 854 | (list (data-app 'listof (list (data-id 'x))))) 855 | (polysig 'map (set 'x 'y) 856 | (list (list (data-app '-> (list (data-id 'x) (data-id 'y)))) 857 | (list (data-app 'listof (list (data-id 'x))))) 858 | (list (data-app 'listof (list (data-id 'y))))))) 859 | (check-equal? 860 | (parse-polysigs (list "; launch-rocket : Time -> Image" 861 | "; take : { x } [ X ] NaturalNumber [ ListOf X]->[ListOf X ]" 862 | "; draw-tl : TrafficLight->Image" 863 | "; filter : [X][X->Boolean][ListOf X]---->[ListOf X]" 864 | "; map : {X}{Y}[X->Y][ListOf X]->[ListOf Y]" 865 | "") 866 | base-eval) 867 | sample-polysigs)) 868 | 869 | ; reduce-signature : [Hash Symbol [NEListOf DataPattern]] Signature -> Signature 870 | (define (reduce-signature dds s) 871 | (define reduce (match-lambda [(list (data-id t)) 872 | (reduce-type dds t)] 873 | [v v])) 874 | (signature (signature-name s) 875 | (map reduce (signature-args s)) 876 | (reduce (signature-return-type s)))) 877 | 878 | ; reduce-polysig : [Hash Symbol DataDefinition] PolySig -> PolySig 879 | (define (reduce-polysig datadefs sig) 880 | (define univs (polysig-univs sig)) 881 | (define src-dst ; rename all type variables, in case they are used free in datadefs 882 | (for/list ([src univs]) (cons src (gensym src)))) ; maybe use string->uninterned-symbol instead of gensym? 883 | (define univs^ (for/set ([s-d src-dst]) (cdr s-d))) 884 | (define (reduce ps) 885 | (define ps^ (for/list ([p ps]) (pattern-rename src-dst p))) 886 | (reduce-patterns datadefs ps^ univs^)) 887 | (polysig (polysig-name sig) 888 | univs^ 889 | (map reduce (polysig-args sig)) 890 | (reduce (polysig-return-type sig)))) 891 | 892 | ; signature=? : Signature Signature -> Boolean 893 | (define (signature=? s t) 894 | (and (symbol=? (signature-name s) (signature-name t)) 895 | (= (length (signature-args s)) (length (signature-args t))) 896 | (for/and ([arg1 (in-list (signature-args s))] 897 | [arg2 (in-list (signature-args t))]) 898 | (list=-no-order? arg1 arg2)) 899 | (list=-no-order? (signature-return-type s) (signature-return-type t)))) 900 | 901 | ; polysig=? : PolySig PolySig -> Boolean 902 | (define (polysig=? sig1 sig2 #:permute [perm #f]) 903 | (and (symbol=? (polysig-name sig1) 904 | (polysig-name sig2)) 905 | (= (set-count (polysig-univs sig1)) 906 | (set-count (polysig-univs sig2))) 907 | (= (length (polysig-args sig1)) 908 | (length (polysig-args sig2))) 909 | (let ([univs1 (set->list (polysig-univs sig1))] 910 | [args2 (permute-list perm (polysig-args sig2))]) 911 | (for/or ([univs2 (in-permutations (set->list (polysig-univs sig2)))]) 912 | (define src-dst (map cons univs2 univs1)) 913 | (define (rename p) (pattern-rename src-dst p)) 914 | (and (for/and ([arg1 (in-list (polysig-args sig1))] 915 | [arg2 (in-list args2)]) 916 | (list=-no-order? arg1 (map rename arg2))) 917 | (list=-no-order? (polysig-return-type sig1) 918 | (map rename (polysig-return-type sig2)))))))) 919 | 920 | (module+ test 921 | (check-true 922 | (polysig=? (polysig 'map (set 'x 'y) 923 | (list (list (data-app '-> (list (data-id 'x) (data-id 'y)))) 924 | (list (data-app 'listof (list (data-id 'x))))) 925 | (list (data-app 'listof (list (data-id 'y))))) 926 | (polysig 'map (set 'y 'z) 927 | (list (list (data-app '-> (list (data-id 'z) (data-id 'y)))) 928 | (list (data-app 'listof (list (data-id 'z))))) 929 | (list (data-app 'listof (list (data-id 'y))))))) 930 | (check-true 931 | (polysig=? (polysig 'map (set 'x 'y) 932 | (list (list (data-app '-> (list (data-id 'x) (data-id 'y)))) 933 | (list (data-app 'listof (list (data-id 'x))))) 934 | (list (data-app 'listof (list (data-id 'y))))) 935 | (polysig 'map (set 'y 'z) 936 | (list (list (data-app '-> (list (data-id 'y) (data-id 'z)))) 937 | (list (data-app 'listof (list (data-id 'y))))) 938 | (list (data-app 'listof (list (data-id 'z))))))) 939 | (check-false 940 | (polysig=? (polysig 'map (set 'x 'y) 941 | (list (list (data-app '-> (list (data-id 'x) (data-id 'y)))) 942 | (list (data-app 'listof (list (data-id 'x))))) 943 | (list (data-app 'listof (list (data-id 'y))))) 944 | (polysig 'map (set 'y 'z) 945 | (list (list (data-app '-> (list (data-id 'y) (data-id 'z)))) 946 | (list (data-app 'listof (list (data-id 'z))))) 947 | (list (data-app 'listof (list (data-id 'y)))))))) 948 | 949 | ; absent-signature? : [ListOf Signature] Symbol -> Boolean 950 | (define (absent-signature? sigs unwanted) 951 | (not (for/or ([s (in-list sigs)]) 952 | (symbol=? unwanted (signature-name s))))) 953 | 954 | ; absent-polysig? : [ListOf PolySig] Symbol -> Boolean 955 | (define (absent-polysig? sigs unwanted) 956 | (not (for/or ([s (in-list sigs)]) 957 | (symbol=? unwanted (polysig-name s))))) 958 | 959 | ; permute-polysig : Permutation PolySig -> PolySig 960 | (define (permute-polysig perm sig) 961 | (if perm 962 | (polysig (polysig-name sig) 963 | (polysig-univs sig) 964 | (permute-list perm (polysig-args sig)) 965 | (polysig-return-type sig)) 966 | sig)) 967 | 968 | ; lookup-signature : [Hash Symbol [NEListOf DataPattern]] [ListOf Signature] 969 | ; [Either Symbol Signature] -> Signature 970 | (define (lookup-signature dds sigs wanted) 971 | (define name 972 | (cond [(signature? wanted) (signature-name wanted)] 973 | [(symbol? wanted) wanted])) 974 | (define results 975 | (for/list ([s (in-list sigs)] 976 | #:when (symbol=? name (signature-name s))) 977 | (reduce-signature dds s))) 978 | (cond 979 | [(null? results) 980 | (error (err-msg-signature-nonexistent name))] 981 | [(for/and ([result (in-list (cdr results))]) 982 | (signature=? result (car results))) 983 | (when (and (signature? wanted) 984 | (not (signature=? (car results) (reduce-signature dds wanted)))) 985 | (error (err-msg-signature-incorrect name))) 986 | (car results)] 987 | [else 988 | (error (err-msg-signature-multiple name))])) 989 | 990 | (module+ test 991 | (check-equal? (lookup-signature sample-dds sample-signatures 'draw-tl) 992 | (signature 'draw-tl 993 | (list (list (data-literal "red") 994 | (data-literal "green") 995 | (data-literal "yellow"))) 996 | (list (data-id 'image)))) 997 | (check-exn #px"missing.*signature.*next-tl" (lambda () 998 | (lookup-signature sample-dds sample-signatures 'next-tl))) 999 | (check-exn #px"signature.*draw-tl.*incorrect" (lambda () 1000 | (lookup-signature sample-dds sample-signatures 1001 | (signature 'draw-tl 1002 | (list (list (data-literal "red") 1003 | (data-literal "green") 1004 | (data-literal "yellow"))) 1005 | (list (data-id 'string)))))) 1006 | (check-exn #px"missing.*signature.*next-tl" (lambda () 1007 | (lookup-signature sample-dds sample-signatures 1008 | (signature 'next-tl 1009 | (list (list (data-literal "red") 1010 | (data-literal "green") 1011 | (data-literal "yellow"))) 1012 | (list (data-id 'string)))))) 1013 | (check-not-exn (lambda () 1014 | (lookup-signature sample-dds sample-signatures 1015 | (signature 'launch-rocket 1016 | (list (list (data-id 'time))) 1017 | (list (data-id 'image)))))) 1018 | (check-not-exn (lambda () 1019 | (lookup-signature sample-dds sample-signatures 1020 | (signature 'launch-rocket 1021 | (list (list (data-id 'frame))) 1022 | (list (data-id 'image))))))) 1023 | 1024 | ; lookup-polysig : [Hash Symbol DataDefinition] [ListOf PolySig] 1025 | ; [Either Symbol PolySig] -> PolySig 1026 | (define (lookup-polysig datadefs sigs wanted #:permute [perm #f]) 1027 | (define name 1028 | (cond [(polysig? wanted) (polysig-name wanted)] 1029 | [(symbol? wanted) wanted])) 1030 | (define results 1031 | (for/list ([s (in-list sigs)] 1032 | #:when (symbol=? name (polysig-name s))) 1033 | (reduce-polysig datadefs s))) 1034 | (cond 1035 | [(null? results) 1036 | (error (err-msg-signature-nonexistent name))] 1037 | [(for/and ([result (in-list (cdr results))]) 1038 | (polysig=? result (car results))) 1039 | ; FIXME: What if people write a polymorphic signature and instances of it? 1040 | (when (and (polysig? wanted) 1041 | (not (polysig=? (car results) 1042 | (reduce-polysig datadefs wanted) 1043 | #:permute perm))) 1044 | (error (err-msg-signature-incorrect name))) 1045 | (permute-polysig (inverse-permutation perm) (car results))] 1046 | [else 1047 | (error (err-msg-signature-multiple name))])) 1048 | 1049 | (module+ test 1050 | (check-equal? (lookup-polysig sample-datadefs sample-polysigs 'draw-tl) 1051 | (polysig 'draw-tl (set) 1052 | (list (list (data-literal "red") 1053 | (data-literal "green") 1054 | (data-literal "yellow"))) 1055 | (list (data-id 'image)))) 1056 | (check-exn #px"missing.*signature.*next-tl" (lambda () 1057 | (lookup-polysig sample-datadefs sample-polysigs 'next-tl))) 1058 | (check-exn #px"signature.*draw-tl.*incorrect" (lambda () 1059 | (lookup-polysig sample-datadefs sample-polysigs 1060 | (polysig 'draw-tl (set) 1061 | (list (list (data-literal "red") 1062 | (data-literal "green") 1063 | (data-literal "yellow"))) 1064 | (list (data-id 'string)))))) 1065 | (check-exn #px"missing.*signature.*next-tl" (lambda () 1066 | (lookup-polysig sample-datadefs sample-polysigs 1067 | (polysig 'next-tl (set) 1068 | (list (list (data-literal "red") 1069 | (data-literal "green") 1070 | (data-literal "yellow"))) 1071 | (list (data-id 'string)))))) 1072 | (check-not-exn (lambda () 1073 | (lookup-polysig sample-datadefs sample-polysigs 1074 | (polysig 'launch-rocket (set) 1075 | (list (list (data-id 'time))) 1076 | (list (data-id 'image)))))) 1077 | (check-not-exn (lambda () 1078 | (lookup-polysig sample-datadefs sample-polysigs 1079 | (polysig 'launch-rocket (set) 1080 | (list (list (data-id 'frame))) 1081 | (list (data-id 'image)))))) 1082 | (check-equal? 1083 | (let ([lines (list ";An Invader is a Posn" 1084 | ";draw-invaders: [ListOf Invader] -> Image")]) 1085 | (lookup-polysig (parse-datadefs lines base-eval) 1086 | (parse-polysigs lines base-eval) 1087 | 'draw-invaders)) 1088 | (parse-polysig "draw-invaders : [ListOf Posn] -> Image" 1089 | base-eval))) 1090 | --------------------------------------------------------------------------------