examples/defstruct.scm
;; -*- scheme -*-
;; LIPS macro to create structures
;;
;; Copyright (c) 2019 Jakub T. Jankiewicz <https://jcubic.pl/me>
;; Released under MIT license
;;
;; the macro defstruct generates a bunch of helper functions
;; to work with single type of structures like in Common Lisp
;; original macro was created for Guile Scheme
;; at the beginning there are functions that were missing in LIPS
;;
;; when you call macro and if name is `point` and
;; arguments are `x` and `y` it will create these functions:
;;
;; make-point
;; point-x
;; point-y
;; set-point-x!
;; set-point-y!
;; point?
;;
;; example usage:
;;
;; (defstruct user first-name last-name age)
;; (let ((user (make-user "John" "Doe" 26)))
;; (display (concat "name: " (user-first-name user) " " (user-last-name user)))
;; (display (concat "age: " (user-age user)))
;; (set-user-last-name! user "Smith")
;; (display (concat "set!: " (set-user-age! user (+ (user-age user) 1))))
;; (display (concat "happy birthday you're now " (user-age user) " old"))
;; (display user))
;;
(define (defstruct:alist->object arg)
"Function creates JavaScript object from AList"
(typecheck "defstruct:every" arg "pair")
(--> arg (to_object)))
(define (defstruct:every fn list)
"return true if every element returns true for a function applied to every element"
(typecheck "defstruct:every" fn "function")
(typecheck "defstruct:every" list "pair")
(== (length list) (length (filter fn list))))
(define (defstruct:error symbol message)
"show error on terminal and console"
(nop (let ((msg (concat (symbol->string symbol) ": " message)))
((. console "error") msg)
(let (($ (. window "jQuery")))
(if (not (or (null? $) (null? (. jQuery "terminal"))))
(let ((term ((.. jQuery.terminal.active))))
(--> term (error msg))))))))
(define string-append concat)
;; updated original code
(define (defstruct:make-name name)
"create struct constructor name."
(typecheck "defstruct:make-name" name "symbol")
(string->symbol (string-append "make-" (symbol->string name))))
(define (defstruct:make-getter name field)
"create filed access function name."
(typecheck "defstruct:make-getter" name "symbol")
(typecheck "defstruct:make-getter" field "symbol")
(string->symbol (string-append (symbol->string name) "-"
(symbol->string field))))
(define (defstruct:make-setter name field)
"create field setter function name."
(typecheck "defstruct:make-setter" name "symbol")
(typecheck "defstruct:make-setter" field "symbol")
(string->symbol (string-append "set-"
(symbol->string name) "-"
(symbol->string field) "!")))
(define (defstruct:make-predicate name)
"create predicate function name."
(typecheck "defstruct:make-predicate" name "symbol")
(string->symbol (string-append (symbol->string name) "?")))
(define-macro (defstruct name . fields)
"Macro implementing structures in guile based on assoc list."
(let ((names (map gensym fields))
(struct (gensym))
(field-arg (gensym)))
`(if (not (defstruct:every-unique ',fields))
(error 'defstruct "Fields must be unique")
(begin
(define (,(defstruct:make-name name) ,@names)
(map cons ',fields (list ,@names)))
,@(map (lambda (field)
`(define (,(defstruct:make-getter name field) ,struct)
(cdr (assoc ',field ,struct)))) fields)
,@(map (lambda (field)
`(define (,(defstruct:make-setter name field) ,struct ,field-arg)
(set-cdr! (assoc ',field ,struct) ,field-arg)
,field-arg)) fields)
(define (,(defstruct:make-predicate name) ,struct)
(and (struct? ,struct)
(let ((result true))
(for-each (lambda (x y)
(if (not (eq? x y)) (set! result true)))
',fields
(map car ,struct))
result)))))))
(define (defstruct:unique item lst)
"check if item occurs only once."
(typecheck "last" lst "pair" 2)
(== (length (filter (lambda (i) (eq? item i)) lst)) 1))
(define (defstruct:every-unique lst)
"check if every element occurs only once."
(typecheck "last" lst "pair")
(defstruct:every (lambda (item) (defstruct:unique item lst)) lst))
(define (struct? struct)
"check if argument is structure (not that structures are AList)."
(and (pair? struct) (defstruct:every pair? struct)))
(define (defstruct:last lst)
"return last element of the list."
(typecheck "last" lst "pair")
(if (null? lst)
'()
(if (null? (cdr lst))
(car lst)
(defstruct:last (cdr lst)))))
(define (write-struct struct)
"print structure."
(if (struct? struct)
(begin
(display "#<")
(let ((last (defstruct:last struct)))
(for-each (lambda (field)
(let ((first (car field)))
(if (struct? first)
(write-struct first)
(display first)))
(display ":")
(let ((rest (cdr field)))
(if (struct? rest)
(write-struct rest)
(write rest)))
(if (not (eq? field last))
(display " ")))
struct)
(display ">")))))
(define (print-struct struct)
(write-struct struct)
(newline))