;; foolproofscheme.ss ;; ;; @author Morgan McGuire, morgan@cs.brown.edu ;; ;; @created 2002-01-14 ;; @edited 2002-01-17 ;; ;; Module for turning Scheme into a variant which ;; includes some imperative programming tools and type ;; checking for procedure arguments. (module foolproofscheme (file "typedproc.ss") (require (lib "unitsig.ss") (lib "url.ss" "net") (lib "xml.ss" "xml") (lib "string.ss") (lib "list.ss") (lib "etc.ss") (lib "base64.ss" "net") (lib "file.ss")) (require-for-syntax (lib "list.ss") (file "typedproc.ss")) (provide (all-from (file "typedproc.ss")) (all-from (lib "xml.ss" "xml")) define-typed-tuple define-typed-set define-typed-struct table-get table-set-with-mutation _make-html-table table-of1 alist1? while pow inc dec _make-set-html ->boolean list-of1 ->html register-html-converter) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Table lookup. table must be an alist where the keys are symbols. ;; (define-proc (table-get table:list? key:symbol?) (cond [(assq key table) => second] [else (error (format "Key not found. Key = ~s Table = ~v" key table))])) ;; ;; Given a table, returns a new table which is the old table ;; with a new entry (possibly replacing the old entry). ;; ;; NOTE: the new table shares ;; elements with the old table; always use this as: ;; (set! t (table-set-with-mutation t k v)) ;; (define-proc (table-set-with-mutation table:list? key:symbol? value):list? (if (empty? table) ;; If the table is empty, just create a table with one element. (list (list key value)) ;; See if the first element is what we want (if (eq? (first (first table)) key) ;; mutate the existing entry and return the table (begin (set-car! (rest (first table)) value) table) ;; Recurse (cons (first table) (table-set-with-mutation (rest table) key value))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Computes a^b for non-negative integers. (define-proc (pow a:integer? b:integer?):integer? (cond [(= b 0) 1] [(= b 1) a] [(> b 1) (* a (pow a (- b 1)))] [else (error "pow cannot compute negative powers")])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;(while test-expr body-expr...) ;; ;; Evaluates the test expression. If true, ;; the body-expressions are evaluated and the ;; test re-applied until the test returns false. ;; The return value is the last result from the ;; last body-expr, or nil if the body-exprs are ;; never evaluated because the test returns false ;; on the first iteration. (define-syntax while (syntax-rules () [(while test body1 body2 ...) (letrec ([p (lambda (last-val) (if test (p (begin body1 body2 ...)) last-val))]) (p null))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (inc x) => (set! x (+ x 1)) ;; (define-syntax inc (syntax-rules () [(_ var) (set! var (+ var 1))])) (define-syntax dec (syntax-rules () [(_ var) (set! var (- var 1))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (define-typed-set name type-pred? =?) ;; ;; Creates procedures with the following names and syntaxes: ;; (insert does not insert if already in the set) ;; ;; (name? s) ;; (name-insert! s:name? x:type-pred?):void ;; (name-member? s:name? x:type-pred?):boolean? ;; (name-remove! s:name? x:type-pred?):void ;; (name-empty? s:name?):boolean? ;; (name-size? s:name?):integer? ;; (name->list s:name):list? ;; (name->vector s:name):vector? ;; (make-name a . b):name? ;; (name-random-member s:name):type-pred? (define-macro (define-typed-set expr) (if (not (= (length expr) 3)) (error "Wrong number of arguments to define-typed-set")) (let* ([name (first expr)] [type-pred? (second expr)] [=? (third expr)] [internal (symbol-append name (symbol-append '- (gensym)))] [internal? (symbol-append internal '?)] [internal-data (symbol-append internal '-data)] [set-internal-data! (symbol-append (symbol-append 'set- internal-data) '!)] [make-internal (symbol-append 'make- internal)] [name? (symbol-append name '?)] [make-name (symbol-append 'make- name)] [name-insert! (symbol-append name '-insert!)] [name-remove! (symbol-append name '-remove!)] [name-member? (symbol-append name '-member?)] [name-empty? (symbol-append name '-empty?)] [name-size (symbol-append name '-size)] [name->list (symbol-append name '->list)] [name->vector (symbol-append name '->vector)] [name-random-member (symbol-append name '-random-member)] ) `(begin ;; data is a list; OPT: could use a vector for better ;; performance. (define-struct ,internal (data)) (define ,name? ,internal?) (define (,make-name . args) (let ([s (,make-internal '())]) (map (proc (x) (,name-insert! s x)) args) s)) (define-proc (,name-member? s:,name? x:,type-pred?):boolean? (mem? x (,internal-data s) ,=?)) (define-proc (,name-insert! s:,name? x:,type-pred?):void (if (not (,name-member? s x)) (,set-internal-data! s (cons x (,internal-data s))))) (define-proc (,name-remove! s:,name? x:,type-pred?):void (if (not (,name-member? s x)) (error (format "~s is not a member of ~s" x s))) (,set-internal-data! s (remove x (,internal-data s) ,=?))) (define-proc (,name-empty? s:,name?):boolean? (empty? (,internal-data s))) (define-proc (,name-size s:,name?):integer? (length (,internal-data s))) (define-proc (,name->list s:,name?):list? (list-copy (,internal-data s))) (define-proc (,name->vector s:,name?):vector? (apply vector (,internal-data s))) (define-proc (,name-random-member s:,name?):,type-pred? (let ([data (,internal-data s)]) (list-ref data (random (length data))))) (register-html-converter ,name? (proc (set:,name?) (_make-set-html (,internal-data set)))) ) ; begin )) (define-proc (_make-set-html elt:list?) `(TABLE ([BORDER "1"] [CELLSPACING "1"] [CELLPADDING "1"]) ,@(map (proc (e) `(TR (TD ,(->html e)))) elt))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (define-typed-struct name (field1:type1 ...)) ;; ;; Creates a struct data type, with the following ;; functions defined: ;; ;; (make-name val1 ...) ;; (name? t) ;; (name-field1 t) ;; (set-name-field1! t val) ;; ;; It also creates the following macro: ;; ;; (with-name struct expr1 ...) ;; ;; This macro binds variables with all of the names of the fields from ;; the corresponding values in the struct then evaluates the body ;; expressions. ;; ;; Current implementation doesn't actually do type checking! (define-macro (define-typed-struct expr) (let* ( ;; Some symbols we'll use in the generated code [name (first expr)] [name- (symbol-append name '-)] [set-name- (symbol-append 'set- name-)] [make-name (symbol-append 'make- name)] [name? (symbol-append name '?)] ;; Extract the field list [raw-field-list (second expr)] ;; Reparse the field list so that colons are handled [field-list (reparse-for-colons (retokenize-for-colons raw-field-list))] ;; Extract just the field names [fields (map (proc (binding) (if (list? binding) (second binding) binding)) field-list)] ;; Some symbols we'll use in the generated code [internal (symbol-append name (symbol-append '- (gensym)))] [internal- (symbol-append internal '-)] [set-internal- (symbol-append 'set- internal-)] [internal? (symbol-append internal '?)] [make-internal (symbol-append 'make- internal)] [get-fields (map (proc (f) `(,(symbol-append internal- f) struct)) fields)] ;; the name-field procs [getters (map (proc (binding) (let ([field (if (list? binding) (second binding) binding)]) `(define-proc (,(symbol-append name- field) s:,name?) (,(symbol-append internal- field) s)))) field-list)] ;; the set-name-field! procs [setters (map (proc (binding) (let* ([typed (list? binding)] [field (if typed (second binding) binding)] [t? (if typed (third binding) void)]) (if typed `(define-proc (,(symbol-append (symbol-append set-name- field) '!) s:,name? x:,t?) (,(symbol-append (symbol-append set-internal- field) '!) s x)) `(define-proc (,(symbol-append (symbol-append set-name- field) '!) s:,name? x) (,(symbol-append (symbol-append set-internal- field) '!) s x))))) field-list)] ;; Make a list of bindings that with will use in the corresponding let statement. ;[with-bindings ;(map (proc (field) ; `(,field (,(symbol-append name- field) struct))) ; field-list)] ) `(begin ;; define the internal structure (define-struct ,internal ,fields) (define ,name? ,internal?) (define-proc (,make-name ,@raw-field-list):,name? (,make-internal ,@fields)) ,@getters ,@setters (register-html-converter ,name? (proc (struct:,name?) (_make-html-table ,(symbol->string name) '(,@fields) (list ,@get-fields)))) ; (define-syntax (,(symbol-append 'with- name) stx) ; (syntax-case stx () ; [(_ struct body1 body2 ...) ; (let ,with-bindings body1 body2 ...)])) ); begin )) ;; ;; Used by structs to build tables. ;; (define-proc (_make-html-table table-caption:string? title-list:(list-of1 symbol?) value-list:list?) `(TABLE ([BORDER "1"] [CELLSPACING "0"] [CELLPADDING "0"]) (TR (TD (FONT ([SIZE "+1"]) (CENTER ,table-caption)))) (TR (TD (TABLE ([BORDER "0"] [CELLSPACING "1"]) ,@(map (proc (title:symbol? value) `(TR (TD ([VALIGN "TOP"] [BGCOLOR "#DDDDDD"]) (I ,(symbol->string title) ) ) (TD ([VALIGN "TOP"]) ,(->html value)))) title-list value-list)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Scheme defines everything except false to be true ;; for purposes of if, and, or, etc. so we sometimes ;; need to explicitly convert. (define-proc (->boolean x):boolean? (if x #t #f)) ;; ;; Creates a type checking predicate that verifies its argument is a ;; list and at least the first element of the list has the right type. ;; (define-proc (list-of1 type?:proc?):proc? (proc (value):boolean? (->boolean (or (empty? value) (and (list? value) (type? (first value))))))) ;; ;; Type predicate verifying that at least the ;; first element is a list of lists. ;; (define alist1? (list-of1 list?)) ;; ;; meta-type predicate ;; ;; Verifies that at least the first element of the list corresponds to ;; a table from symbols to type. ;; (define-proc (table-of1 type?:proc?):proc? (proc (value):boolean? (->boolean (or (empty? value) (and (list? value) (list? (first value)) (symbol? (first (first value))) (type? (second (first value)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (define-typed-tuple name type-predicate) ;; ;; Creates an immutable tuple data type, with the following ;; functions defined: ;; ;; (make-name v1 ...) ;; (name? t) ;; (name-ref t index) ;; (name-length t) ;; (name->vector t) ;; (name->list t) ;; ;; Also registers an ->html proc for the type. ;; (define-macro (define-typed-tuple expr) (let* ([symbol-append (lambda (a b) (string->symbol (string-append (symbol->string a) (symbol->string b))))] [name (first expr)] [pred? (cadr expr)] [constructor (symbol-append 'make- name)] [selector (symbol-append name '-ref)] [name? (symbol-append name '?)] [name->vector (symbol-append name '->vector)] [name->list (symbol-append name '->list)] [length (symbol-append name '-length)] [internal (symbol-append name (symbol-append '- (gensym)))] [internal? (symbol-append internal '?)] [make-internal (symbol-append 'make- internal)] [internal-data (symbol-append internal '-data)]) `(begin (define-struct ,internal (data)) (define (,constructor a . b) (letrec ([args (cons a b)] ;; Perform type checking. We don't use fold because ;; a) it isn't defined here and b) the error message ;; would make no sense. [check (lambda (count lst) (if (eq? lst '()) void (if (not (,pred? (first lst))) (error (format "~s (constructor argument ~s) is not of type ~s" (first lst) count ,(format "~s" pred?))) (check (+ 1 count) (cdr lst)))))]) ;; Type check (check 0 args) (,make-internal (apply vector (cons a b))))) (define (,length tuple) (if (not (,name? tuple)) (error "Argument must be a " ,(format "~s" name)) (vector-length (,internal-data tuple)))) (define (,selector tuple index) (if (not (,name? tuple)) (error "First argument must be a " ,(format "~s" name))) (if (not (integer? index)) (error "Second argument must be an integer")) (let ([data (,internal-data tuple)]) ;; Don't need to type-check; we check when elements are inserted (if (or (< index 0) (>= index (vector-length data))) (error (format "Tuple index exceeds bounds (index = s, length = ~s)" index (vector-length data))) (vector-ref data index)))) (define (,name->vector tuple) (if (not (,name? tuple)) (error "Argument must be a " ,(format "~s" name)) (apply vector (vector->list (,internal-data tuple))))) (define (,name->list tuple) (if (not (,name? tuple)) (error "Argument must be a " ,(format "~s" name)) (vector->list (,internal-data tuple)))) (define ,name? ,internal?) (register-html-converter ,name? (proc (tuple:,name?) (->html (,internal-data tuple)))) ))) ;; ;; An extensible pretty printer that converts Scheme objects into ;; HTML (i.e. xexprs for HTML). Call register-html-converter ;; to add more types. define-typed-set, tuple, and struct ;; automatically register themselves. Unregistered types fall ;; through to (format "~s" x) ;; (define-proc (->html x) (->html-helper x html-converter-table)) (define-proc (->html-helper x table) (cond ;; base case; use format [(empty? table) (format "~s" x)] [((first (first table)) x) ((second (first table)) x)] [else (->html-helper x (rest table))])) (define-proc (register-html-converter type:proc? converter:proc?):void ;; We choose the order such that subsequent rules override (set! html-converter-table (cons (list type converter) html-converter-table))) (define html-converter-table (list (list list? (proc (x:list?) `(SPAN "(" ,@(map ->html x) ")"))) (list vector? (proc (x:vector?) `(SPAN "[" ,@(map ->html (vector->list x)) "]"))) (list boolean? (proc (x:boolean?) (if x "true" "false"))))) ) ; Module