ADDED lib/fn-struct.scm
Index: lib/fn-struct.scm
==================================================================
--- lib/fn-struct.scm
+++ lib/fn-struct.scm
@@ -0,0 +1,77 @@
+; [ʞ] fn-struct.scm
+; ~ lexi hale <lexi@hale.su>
+; © affero general public license
+; > (load "lib/struct.scm")
+;
+; generates immutable, relatively efficient structs. declare
+; a struct type x with
+; (define x (struct 'field1 'field2)
+; create a record y of that type with
+; (define y (x 123 456))
+; access field1 of record y with
+; (y 'field1)
+; update field2 of record y with
+; (y 'field2 123) → new record (field1 = 123; field2 = 123)
+;
+; this unit also includes a few utility function that
+; chicken scheme conveniently "forgot." i apologize for
+; the implementation of (list-head). i was very tired.
+
+; return a sub-list of lst up to ct (inverse of list-tail)
+(define (list-head lst ct)
+ (let* ([reverse-lst (reverse lst)]
+ [idx (- (length lst) (+ 1 ct))])
+ (reverse (list-tail reverse-lst idx))))
+ ; i'm not proud of this
+
+; search for the first occurence of `term` in list lst.
+; equal? is used by default; an alternate predicate may
+; be passed after `term`
+(define (member-index lst term . opt)
+ (let ([predicate (if (eq? '() opt) equal?
+ (car opt))])
+ (define (search idx l)
+ (if (eq? l '()) #f
+ (if (predicate (car l) term) idx
+ (search (+ 1 idx) (cdr l)))))
+ (search 0 lst)))
+
+; generate a new struct type and return it as a function
+; that may be called to instantiate that type.
+(define (struct . keys)
+ (define (generate-record . vals)
+ ; the function returned by a (struct) call and called
+ ; to generate a new struct by functional-update syntax
+ (define (struct-ref key)
+ ; searches the struct for the named key and if found
+ ; return its index, otherwise return #f
+ (let ([query-idx (member-index keys key)])
+ (if (eq? #f query-idx) #f
+ (list-ref vals query-idx))))
+ (define (update-record key val)
+ ; return a new version of this construct with the same
+ ; field names and values except for { key = val }
+ (let* ([field-idx (member-index keys key)]
+ [new-tail (list-tail vals (+ 1 field-idx))]
+ [new-head (list-head vals (- field-idx 1))])
+ (apply generate-record (append new-head (list val) new-tail))))
+
+ ; are values specified for every field and no more?
+ ; TODO: consider loosening the restriction - could
+ ; there be some use to allowing the used to add fields
+ ; only accessible through the record->list facility?
+ (if (not (= (length vals) (length keys))) #f
+ (lambda access
+ ; returned by generate-record, this function is called
+ ; whenever a struct is accessed
+ (case (length access)
+ ;determine operation to perform
+ ((0) vals) ; return list of values
+ ((1) (struct-ref (car access))); search for value
+ ((2) (update-record (car access) (cadr access)))
+ (else #f))))) ; no other functions currently available
+
+ ; keys are now stored in the closure; return the
+ ; (generate-record) function to the user so she can
+ ; call it to instantiate the defined struct.
+ generate-record)
ADDED lib/select.scm
Index: lib/select.scm
==================================================================
--- lib/select.scm
+++ lib/select.scm
@@ -0,0 +1,33 @@
+; [ʞ] select.scm
+; ~ lexi hale <lexi@hale.su>
+; © CC0 / public domain
+; > (include "lisp-macro.scm")
+; (include "select.scm")
+; ? a reimplementation of (case) that lets you
+; specify your own evaluator function. same syntax,
+; except the expression to evaluate is preceeded by
+; a predicate function
+; = (select equal? "weed"
+; ("weed" 420)
+; ("sex" 69)
+; (else 42069)
+
+(define-macro (select . body)
+ (let* ([eqfn (list-ref body 0)]
+ [expr (list-ref body 1)]
+ [cases (cddr body)]
+ [result (gensym)])
+ (define (make-cond-entry case)
+ (let ([case-expr (car case)]
+ [func (cdr case)])
+ (if (eqv? case-expr 'else) (cons #t func)
+ (cons (list eqfn result case-expr) func))))
+ (define cond-entries (map make-cond-entry cases))
+ `(let ([,result ,expr]) (cond ,@cond-entries))))
+
+(define-macro (maybe . body)
+ (let (( result (gensym) ))
+ `(let (( ,result ,(cadr body) ))
+ (if ,result (let (( ,(car body) ,result ))
+ ,(cddr body))
+ #f))))
Index: lib/struct.scm
==================================================================
--- lib/struct.scm
+++ lib/struct.scm
@@ -1,77 +1,100 @@
; [ʞ] struct.scm
; ~ lexi hale <lexi@hale.su>
-; © affero general public license
-; > (load "lib/struct.scm")
-;
-; generates immutable, relatively efficient structs. declare
-; a struct type x with
-; (define x (struct 'field1 'field2)
-; create a record y of that type with
-; (define y (x 123 456))
-; access field1 of record y with
-; (y 'field1)
-; update field2 of record y with
-; (y 'field2 123) → new record (field1 = 123; field2 = 123)
-;
-; this unit also includes a few utility function that
-; chicken scheme conveniently "forgot." i apologize for
-; the implementation of (list-head). i was very tired.
+; $ csc -X fail.scm …
+; © affero gpl v3
+; > (include "lisp-macro.scm")
+; ? a typed struct mechanism for scheme, because the
+; srfi ones suck ass and don't support FRU syntax.
+; X (structure user (name . string)
+; (age . integer)
+; (pw . string)
+; gecos)
+; (define stacy (user name: "stacy"
+; age: 26
+; pw: "swordfish"))
+; (if (user? stacy) (user.name stacy))
+; (define oldstacy (user stacy age: 69))
+; (user.name oldstacy)
+; (user.age oldstacy)
+
+(include "lisp-macro.scm")
+
+(import (chicken pretty-print)
+ (chicken keyword))
+
+(begin-for-syntax (import (chicken keyword)))
+ ; i cannot believe this worked
+
+(define-macro (structure . body)
+ (define (uniq lst)
+ (define (in? x l)
+ (if (null? l) #f
+ (if (eqv? x (car l)) #t
+ (in? x (cdr l)))))
+ (define (loop acc hd)
+ (if (null? hd) acc
+ (if (in? (car hd) acc) (loop acc (cdr hd))
+ (loop (cons (car hd) acc) (cdr hd)))))
+ (loop '() lst))
+
+ (define (symsuf sym . suffix)
+ (string->symbol (apply string-append (cons (symbol->string sym) suffix))))
+
+ (define (emit-field sname idx f)
+ (let* ([prop (cond ((symbol? f) (cons f 'any))
+ ((pair? f) f))]
+ [name (car prop)]
+ [type (cdr prop)]
+ [fn (symsuf sname "." (symbol->string name))])
+ `(begin
+ (: ,fn ((pair symbol vector) --> ,type))
+ (define (,fn struct)
+ (if (,(symsuf sname "?") struct) (vector-ref (cdr struct) ,idx)
+ (error ,(string-append "argument is not of type " (symbol->string sname))))))))
+
+ (define (reduce-fields sname idx fields)
+ (if (null? fields) '()
+ (cons (emit-field sname idx (car fields))
+ (reduce-fields sname (+ 1 idx) (cdr fields)))))
+
+ (define (emit-pred name typesym)
+ (let ([fn (symsuf name "?")])
+ `(begin (: ,fn (any --> boolean))
+ (define (,fn candidate) (and (pair? candidate)
+ (eq? (quote ,typesym) (car candidate))
+ (vector? (cdr candidate)))))))
+ (define (extract-type field)
+ (cond ((symbol? field) 'any)
+ ((pair? field) (cdr field))))
-; return a sub-list of lst up to ct (inverse of list-tail)
-(define (list-head lst ct)
- (let* ([reverse-lst (reverse lst)]
- [idx (- (length lst) (+ 1 ct))])
- (reverse (list-tail reverse-lst idx))))
- ; i'm not proud of this
+ (define (emit-def name types)
+ `((define-type ,name (pair symbol (vector ,@types)))))
-; search for the first occurence of `term` in list lst.
-; equal? is used by default; an alternate predicate may
-; be passed after `term`
-(define (member-index lst term . opt)
- (let ([predicate (if (eq? '() opt) equal?
- (car opt))])
- (define (search idx l)
- (if (eq? l '()) #f
- (if (predicate (car l) term) idx
- (search (+ 1 idx) (cdr l)))))
- (search 0 lst)))
+ (define (emit-gen name types typesym fields)
+ (define (fld-get idx fld)
+ (let ([name (if (symbol? fld) fld (car fld))])
+ `(get-keyword ,(string->keyword (symbol->string name)) spec
+ (lambda() (safe-vector-ref basis ,idx)))))
+ (define (reduce-flds idx flds)
+ (if (null? flds) '()
+ (cons (fld-get idx (car flds))
+ (reduce-flds (+ 1 idx) (cdr flds)))))
+ `((: ,name (#!rest (or symbol ,@(uniq types)) --> ,name ))
+ (define (,name . args)
+ (define (safe-vector-ref v i) (if (null? v) (error "all struct fields need to be specified unless functional record update syntax is in use")
+ (vector-ref v i)))
+ (let* ([basis (if (,(symsuf name "?") (car args)) (cdar args) '())]
+ [spec (if (null? basis) args (cdr args))])
+ (cons (quote ,typesym)
+ (vector ,@(reduce-flds 0 fields)
-; generate a new struct type and return it as a function
-; that may be called to instantiate that type.
-(define (struct . keys)
- (define (generate-record . vals)
- ; the function returned by a (struct) call and called
- ; to generate a new struct by functional-update syntax
- (define (struct-ref key)
- ; searches the struct for the named key and if found
- ; return its index, otherwise return #f
- (let ([query-idx (member-index keys key)])
- (if (eq? #f query-idx) #f
- (list-ref vals query-idx))))
- (define (update-record key val)
- ; return a new version of this construct with the same
- ; field names and values except for { key = val }
- (let* ([field-idx (member-index keys key)]
- [new-tail (list-tail vals (+ 1 field-idx))]
- [new-head (list-head vals (- field-idx 1))])
- (apply generate-record (append new-head (list val) new-tail))))
+ ))))))
- ; are values specified for every field and no more?
- ; TODO: consider loosening the restriction - could
- ; there be some use to allowing the used to add fields
- ; only accessible through the record->list facility?
- (if (not (= (length vals) (length keys))) #f
- (lambda access
- ; returned by generate-record, this function is called
- ; whenever a struct is accessed
- (case (length access)
- ;determine operation to perform
- ((0) vals) ; return list of values
- ((1) (struct-ref (car access))); search for value
- ((2) (update-record (car access) (cadr access)))
- (else #f))))) ; no other functions currently available
-
- ; keys are now stored in the closure; return the
- ; (generate-record) function to the user so she can
- ; call it to instantiate the defined struct.
- generate-record)
+ (let* ([name (car body)]
+ [fields (cdr body)]
+ [typesym (gensym)]
+ [types (map extract-type fields)])
+ (append (emit-pred name typesym)
+ (emit-def name types)
+ (emit-gen name types typesym fields)
+ (reduce-fields name 0 fields))))