; [ʞ] struct.scm
; ~ lexi hale <lexi@hale.su>
; $ 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))))
(define (emit-def name types)
`((define-type ,name (pair symbol (vector ,@types)))))
(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)))))))
(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))))