procgen  Diff

; [ʞ] 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)

; [ʞ] 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))))