#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2014, Juergen Lorenz
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

Neither the name of the author nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
]|#

(require-library datatype)

(module typed-lists (define-list-type)

(import scheme
        (only chicken error define-record-printer
              receive case-lambda)
        (only data-structures list-of? o)
        (only extras sprintf)
        datatype)

(import-for-syntax (only data-structures chop))

;;; (define-list-type name
;;;                   [documentation: docu]
;;;                   item-predicate: type?
;;;                   item-equality: equ?)
;;; ----------------------------------------
(define-syntax define-list-type
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let (
        (name (cadr form))
        (pairs (chop (cddr form) 2))
        (pre (let loop (
               (str (symbol->string (inject (cadr form))))
               (result '())
               )
               (if (or (zero? (string-length str))
                       (string=? str "list"))
                 (list->string (reverse result))
                 (loop (substring str 1)
                       (cons (string-ref str 0) result)))))
        (append-syms
          (lambda syms
            (string->symbol
              (apply string-append
                     (map symbol->string syms)))))
        )
        (let (
          (type? (cadr (assq item-predicate: pairs)))
          (equ? (cadr (assq item-equality: pairs)))
          (docu (cond
                  ((assq documentation: pairs) => cadr)
                  (else (append-syms (inject name) 's))))
          (prepend-prefix
            (lambda (sym)
              (string->symbol
                (string-append
                  pre
                  (substring (symbol->string sym) 1)))))
          )
          (let (
            (name? (append-syms (inject name) '?))
            (list->name (append-syms 'list-> (inject name)))
            (name->list (append-syms (inject name) '->list))
            (make-name (append-syms 'make- (inject name)))
            (gapply (prepend-prefix 'gapply))
            (gnull (prepend-prefix 'gnull))
            (gnull? (prepend-prefix 'gnull?))
            (gcons (prepend-prefix 'gcons))
            (gcar (prepend-prefix 'gcar))
            (gcdr (prepend-prefix 'gcdr))
            (gcadr (prepend-prefix 'gcadr))
            (gcddr (prepend-prefix 'gcddr))
            (gcaddr (prepend-prefix 'gcaddr))
            (gcdddr (prepend-prefix 'gcdddr))
            (gcadddr (prepend-prefix 'gcadddr))
            (gcddddr (prepend-prefix 'gcddddr))
            (greverse (prepend-prefix 'greverse))
            (greverse* (prepend-prefix 'greverse*))
            (glength (prepend-prefix 'glength))
            (gref (prepend-prefix 'gref))
            (gmap (prepend-prefix 'gmap))
            (gfor-each (prepend-prefix 'gfor-each))
            (gappend (prepend-prefix 'gappend))
            (gmappend (prepend-prefix 'gmappend))
            (gsublist (prepend-prefix 'gsublist))
            (gsplit-at (prepend-prefix 'gsplit-at))
            (gsplit-with (prepend-prefix 'gsplit-with))
            ;(gequ? (prepend-prefix 'gequ?))
            (gequal? (prepend-prefix 'gequal?))
            (gmember (prepend-prefix 'gmember))
            (gmemp (prepend-prefix 'gmemp))
            (gremp (prepend-prefix 'gremp))
            (gremove (prepend-prefix 'gremove))
            (gremove-dups (prepend-prefix 'gremove-dups))
            (gassp (prepend-prefix 'gassp))
            ;(gassq (prepend-prefix 'gassq))
            ;(gassv (prepend-prefix 'gassv))
            (gassoc (prepend-prefix 'gassoc))
            (gfilter (prepend-prefix 'gfilter))
            (gfold-left (prepend-prefix 'gfold-left))
            (gfold-right (prepend-prefix 'gfold-right))
            (gmerge (prepend-prefix 'gmerge))
            (gsort (prepend-prefix 'gsort))
            (gsorted? (prepend-prefix 'gsorted?))
            (gdrop (prepend-prefix 'gdrop))
            (gdrop-while (prepend-prefix 'gdrop-while))
            (gtake (prepend-prefix 'gtake))
            (gtake-while (prepend-prefix 'gtake-while))
            (glist-ref (prepend-prefix 'glist-ref))
            (glist-head (prepend-prefix 'glist-head))
            (glist-tail (prepend-prefix 'glist-tail))
            (grepeat (prepend-prefix 'grepeat))
            (giterate-times (prepend-prefix 'giterate-times))
            (giterate-while (prepend-prefix 'giterate-while))
            (giterate-until (prepend-prefix 'giterate-until))
            (gzip (prepend-prefix 'gzip))
            (ginterpose (prepend-prefix 'ginterpose))
            (gevery? (prepend-prefix 'gevery?))
            (gsome (prepend-prefix 'gsome))
            (gnot-every? (prepend-prefix 'gnot-every?))
            (gnot-any? (prepend-prefix 'gnot-any?))
            ;;; sets
            (name->set (append-syms (inject name) '->set))
            (gset (prepend-prefix 'gset))
            (gset-add (prepend-prefix 'gset-add))
            (gset? (prepend-prefix 'gset?))
            (gsubset? (prepend-prefix 'gsubset?))
            (gset->list (prepend-prefix 'gset->list))
            (gset-in? (prepend-prefix 'gset-in?))
            (gset-cardinality (prepend-prefix 'gset-cardinality))
            (gsubset (prepend-prefix 'gsubset))
            (gset-equal? (prepend-prefix 'gset-equal?))
            (gset-null? (prepend-prefix 'gset-null?))
            (gadjoin (prepend-prefix 'gadjoin))
            (gset-difference (prepend-prefix 'gset-difference))
            (gset-union (prepend-prefix 'gset-union))
            (gset-intersection (prepend-prefix 'gset-intersection))
            )
            `(begin

               (define-datatype 
                 ,name
                 ,name?
                 (,gnull)
                 (,gcons
                   (first ,type?)
                   (rest ,name?)))

               (define-record-printer (,name glst out)
                 (display (,name->list glst) out))

               (define (,gnull? xpr)
                 (and (,name? xpr)
                      (cases ,name xpr
                        (,gnull () #t)
                        (,gcons (first rest) #f))))

               (define (,gcar glst)
                 (cases ,name glst
                   (,gnull () (error ',gcar "list empty" glst))
                   (,gcons (first rest) first)))
  
               (define (,gcdr glst)
                 (cases ,name glst
                   (,gnull () (error ',gcdr "list empty" glst))
                   (,gcons (first rest) rest)))
  
               (define (,gcadr glst)
                 (,gcar (,gcdr glst)))

               (define (,gcddr glst)
                 (,gcdr (,gcdr glst)))

               (define (,gcaddr glst)
                 (,gcar (,gcddr glst)))

               (define (,gcdddr glst)
                 (,gcdr (,gcddr glst)))

               (define (,gcadddr glst)
                 (,gcar (,gcdddr glst)))

               (define (,gcddddr glst)
                 (,gcdr (,gcdddr glst)))

               ;; one-list version of ,greverse*
               ;; defined separately for performance reasons
               (define (,greverse glst)
                 (let loop ((ls glst) (result (,gnull)))
                   (cases ,name ls
                     (,gnull () result)
                     (,gcons (first rest)
                        (loop rest (,gcons first result))))))

               ;; checks for equal length
               (define (,greverse* . glsts)
                 (if (null? glsts)
                   (,gnull)
                   (let loop (
                     (lsts glsts)
                     (results (make-list (length glsts) (,gnull)))
                     )
                     (cond
                       (((list-of? ,gnull?) lsts)
                        (apply values results))
                       (((list-of? (o not ,gnull?)) lsts)
                        (loop (map ,gcdr lsts)
                              (map (lambda (l ll) (,gcons l ll))
                                   (map ,gcar lsts) results)))
                       (else (error ',greverse* "lists not of equal length"))))))
  
               (define (,name . args)
                 (let loop ((args args) (result (,gnull)))
                   (if (null? args)
                     (,greverse result)
                     (loop (cdr args) (,gcons (car args) result)))))
  
               (define (,make-name len fill)
                 (let loop ((k 0) (result (,gnull)))
                   (if (= k len)
                     result
                     (loop (+ k 1) (,gcons fill result)))))

               (define (,grepeat n x)
                 (,make-name n x))

               (define (,giterate-times n fn x)
                 (let loop ((k 0) (val x) (result (,gnull)))
                   (if (= k n)
                     (,greverse result)
                     (loop (+ k 1) (fn val) (,gcons val result)))))

               (define (,giterate-while ok? fn x)
                 (let loop ((val x) (result (,gnull)))
                   (if (ok? val)
                     (loop (fn val) (,gcons val result))
                     (,greverse result))))

               (define (,giterate-until ok? fn x)
                 (let loop ((val x) (result (,gnull)))
                   (if (ok? val)
                     (,greverse result)
                     (loop (fn val) (,gcons val result)))))

               (define (,name->list glst)
                 (let loop ((ls glst) (result '()))
                   (cases ,name ls
                     (,gnull () (reverse result))
                     (,gcons (first rest)
                      (loop rest (cons first result))))))
  
               (define (,gapply fn . args)
                 (let ((len (length args)))
                   (apply fn
                     (let loop ((k 0) (result '()))
                       (cond
                         ((= k len) (reverse result))
                         ((= k (- len 1))
                          (let ((tail (list-ref args k)))
                            (if (,name? tail)
                              (loop (+ k 1)
                                    (append
                                      (reverse
                                        (,name->list tail))
                                      result))
                              (error ',gapply
                                     (string-append
                                       "not a "
                                       (symbol->string
                                         ',name))
                                     tail))))
                         (else
                           (let ((item (list-ref args k)))
                             (if (,type? item)
                               (loop (+ k 1)
                                     (cons item result))
                               (error 'gapply
                                      "wrong type"
                                      `(,',type? ,item))))))))))

               (define (,list->name lst)
                 (apply ,name lst))

               (define (,glength glst)
                 (let loop ((ls glst) (k 0))
                   (cases ,name ls
                     (,gnull () k)
                     (,gcons (first rest)
                       (loop rest (+ k 1))))))

               (define (,gref k glst)
                 (let loop ((ls glst) (n 0))
                   (cases ,name ls
                     (,gnull () (error ',gref "range error"))
                     (,gcons (first rest)
                       (if (= n k)
                         first
                         (loop rest (+ n 1)))))))

               (define (,gsublist from upto glst)
                 (let loop ((ls glst) (k 0) (result (,gnull)))
                   (cases ,name ls
                     (,gnull () (,greverse result))
                     (,gcons (first rest)
                       (cond
                         ((= k upto)
                          (,greverse result))
                         ((< k from)
                          (loop rest (+ k 1) result))
                         (else
                           (loop rest (+ k 1) (,gcons first result))))))))

               (define (,gsplit-at k glst)
                 (let loop ((ls glst) (n 0) (head (,gnull)))
                   (cases ,name ls
                     (,gnull () (values (,greverse head) ls))
                     (,gcons (first rest)
                       (if (= n k)
                        (values (,greverse head) ls)
                        (loop rest (+ n 1) (,gcons first head)))))))

               (define (,gsplit-with ok? glst)
                 (let loop ((ls glst) (head (,gnull)))
                   (cases ,name ls
                     (,gnull () (values (,greverse head) ls))
                     (,gcons (first rest)
                       (if (ok? first)
                         (values (,greverse head) ls)
                         (loop rest (,gcons first head)))))))

               (define (,gtake k glst)
                 (call-with-values
                   (lambda () (,gsplit-at k glst))
                   (lambda (head tail) head)))

               (define (,gtake-while ok? glst)
                 (call-with-values
                   (lambda () (,gsplit-with (o not ok?) glst))
                   (lambda (head tail) head)))

               (define (,gdrop k glst)
                 (call-with-values
                   (lambda () (,gsplit-at k glst))
                   (lambda (head tail) tail)))

               (define (,gdrop-while ok? glst)
                 (call-with-values
                   (lambda () (,gsplit-with (o not ok?) glst))
                   (lambda (head tail) tail)))

               (define (,gappend . glsts)
                 (cond
                   ((null? glsts)
                    (,gnull))
                   ((null? (cdr glsts))
                    (car glsts))
                   ((null? (cddr glsts))
                    (let loop ((ls0 (,greverse (car glsts)))
                               (result (cadr glsts)))
                      (cases ,name ls0
                        (,gnull () result)
                        (,gcons (first rest)
                                (loop rest (,gcons first result))))))
                   (else
                     (,gappend (car glsts)
                               (apply ,gappend (cdr glsts))))))

               (define (,gmappend fn . glsts)
                 (apply ,gappend
                        (apply map fn
                               (map ,name->list glsts))))

               (define (,gmap fn . glsts)
                 (if (null? glsts)
                   (,gnull)
                   (let loop ((lsts glsts) (result (,gnull)))
                     (if (memq #t (map ,gnull? lsts))
                       (,greverse result)
                       (loop (map ,gcdr lsts)
                             (,gcons (apply fn (map ,gcar lsts))
                                     result))))))

               (define (,gfor-each fn . glsts)
                 (unless (null? glsts)
                   (do ((lsts glsts (map ,gcdr lsts)))
                     ((memq #t (map ,gnull? lsts)))
                     (apply fn (map ,gcar lsts)))))

               (define (,gfilter ok? glst)
                 (let loop ((ls glst) (yes (,gnull)) (no (,gnull)))
                   (cases ,name ls
                     (,gnull ()
                       (values (,greverse yes) (,greverse no)))
                     (,gcons (first rest)
                        (if (ok? first)
                          (loop rest (,gcons first yes) no)
                          (loop rest yes (,gcons first no)))))))

               (define (,gequal? glst0 glst1)
                 (let loop ((ls0 glst0) (ls1 glst1))
                   (cond
                     ((,gnull? ls0)
                      (,gnull? ls1))
                     ((,gnull? ls1)
                      (,gnull? ls0))
                     (else
                       (and (,equ? (,gcar ls0)
                                   (,gcar ls1))
                            (loop (,gcdr ls0)
                                  (,gcdr ls1)))))))

               (define (,gmemp ok? glst)
                 (let loop ((ls glst))
                   (cases ,name ls
                     (,gnull () #f)
                     (,gcons (first rest)
                        (if (ok? first)
                          ls
                          (loop rest))))))

               (define (,gmember item glst)
                 (,gmemp (lambda (x) (,equ? x item)) glst))

               (define (,gremp ok? glst)
                 (call-with-values (lambda () (,gfilter ok? glst))
                                   (lambda (a b) b)))

               (define (,gremove item glst)
                 (,gremp (lambda (x) (,equ? item x)) glst))

               (define (,gadjoin item glst)
                 (if (,gmember item glst)
                   glst
                   (,gcons item glst)))

               (define (,gremove-dups glst)
                 (let loop ((ls glst) (result (,gnull)))
                   (cases ,name ls
                     (,gnull () result)
                     (,gcons (first rest)
                             (loop rest (,gadjoin first result))))))

               (define (,gassp ok? glst)
                 (let loop ((ls glst))
                   (cases ,name ls
                     (,gnull () #f)
                     (,gcons (first rest)
                       (if (ok? (car first))
                         first
                         (loop rest))))))

               (define (,gassoc item glst)
                 (,gassp (lambda (x) (,equ? item x)) glst))

               (define (,gfold-left op base . glsts)
                 (if (null? glsts)
                   base
                   (let loop ((lsts glsts) (result base))
                     (cond
                       (((list-of? ,gnull?) lsts)
                        result)
                       (((list-of? (o not ,gnull?)) lsts)
                        (loop (map ,gcdr lsts)
                              (apply op result (map ,gcar lsts))))
                       (else
                         (error ',gfold-left "lists not of equal length"))))))

               (define (,gfold-right op base . glsts)
                 (if (null? glsts)
                   base
                   (let loop (
                     ;; checking for equal length is done by greverse*
                     (lsts (call-with-values
                             (lambda () (apply ,greverse* glsts))
                             list))
                     (result base)
                     )
                     (if ((list-of? ,gnull?) lsts)
                       result
                       (loop (map ,gcdr lsts)
                             (apply op
                                    (append (map ,gcar lsts)
                                            (list result))))))))
               (define (,gmerge <? glst0 glst1)
                 ;; without sorted checks, not tail recursive
                 ;(let loop ((ls0 glst0) (ls1 glst1))
                 ;  (cond
                 ;    ((,gnull? ls0) ls1)
                 ;    ((,gnull? ls1) ls0)
                 ;    ((<? (,gcar ls0) (,gcar ls1))
                 ;     (,gcons (,gcar ls0)
                 ;             (loop (,gcdr ls0) ls1)))
                 ;    (else
                 ;     (,gcons (,gcar ls1)
                 ;             (loop ls0 (,gcdr ls1)))))))
                 ;; tail recursive, with sorted checks
                 (let loop ((ls0 glst0) (ls1 glst1) (result (,gnull)))
                   (cond
                     ((and (,gnull? ls0) (,gnull? ls1))
                      (,greverse result))
                     ((,gnull? ls0)
                      (if (or (,gnull? (,gcdr ls1))
                              (<? (,gcar ls1) (,gcar (,gcdr ls1))))
                        (loop ls0 (,gcdr ls1) (,gcons (,gcar ls1) result))
                        (error ',gmerge "not sorted" glst1)))
                     ((,gnull? ls1)
                      (if (or (,gnull? (,gcdr ls0))
                              (<? (,gcar ls0) (,gcar (,gcdr ls0))))
                        (loop (,gcdr ls0) ls1 (,gcons (,gcar ls0) result))
                        (error ',gmerge "not sorted" glst1)))
                     ((not (or (,gnull? (,gcdr ls0))
                               (<? (,gcar ls0) (,gcar (,gcdr ls0)))))
                      (error ',gmerge "not sorted" glst0))
                     ((not (or (,gnull? (,gcdr ls1))
                               (<? (,gcar ls1) (,gcar (,gcdr ls1)))))
                      (error ',gmerge "not sorted" glst1))
                     (else
                       (if (<? (,gcar ls0) (,gcar ls1))
                         (loop (,gcdr ls0) ls1 (,gcons (,gcar ls0) result))
                         (loop ls0 (,gcdr ls1) (,gcons (,gcar ls1) result))))
                     )))
               (define (,gsort <? glst)
                 (let loop ((ls glst))
                   (let ((len (,glength ls)))
                     (if (< len 2)
                       ls
                       (receive (head tail)
                         (,gsplit-at (quotient len 2) ls)
                         (,gmerge <?
                                  (loop head)
                                  (loop tail)))))))
               (define (,gsorted? <? glst)
                 (let loop ((ls glst))
                   (cases ,name ls
                     (,gnull () #t)
                     (,gcons (first rest)
                       (cond
                         ((,gnull? rest) #t)
                         ((<? first (,gcar rest))
                          (loop rest))
                         (else #f))))))

               (define (,gzip glst0 glst1)
                 (cond
                   ((,gnull? glst0)
                    glst1)
                   (else
                     (,gcons (,gcar glst0)
                             (,gzip glst1 (,gcdr glst0))))))

               (define (,ginterpose sep glst)
                 (,gcdr
                   (let loop ((ls glst) (result (,gnull)))
                     (cases ,name ls
                       (,gnull () (,greverse result))
                       (,gcons (first rest)
                         (loop rest
                               (,gcons first (,gcons sep result))))))))
                               ;(,gapply ,name first sep result)))))))

               (define (,gevery? ok? glst)
                 (not (,gmemp (o not ok?) glst)))

               (define (,gnot-every? ok? glst)
                 (if (,gmemp (o not ok?) glst) #t #f))

               (define (,gnot-any? ok? glst)
                 (if (,gmemp ok? glst)
                   #f
                   #t))

               (define (,gsome ok? glst)
                 (let loop ((ls glst))
                   (cases ,name ls
                     (,gnull () #f)
                     (,gcons (first rest)
                        (if (ok? first)
                          first
                          (loop rest))))))

               (define (,glist-ref glst k)
                 (let loop ((ls glst) (n 0))
                   (cases ,name ls
                     (,gnull () (error ',glist-ref "range error"))
                     (,gcons (first rest)
                             (if (= n k)
                               first
                               (loop rest (+ n 1)))))))

               (define (,glist-head glst k)
                 (call-with-values
                   (lambda () (,gsplit-at k glst))
                   (lambda (head tail) head)))


               (define (,glist-tail glst k)
                 (call-with-values
                   (lambda () (,gsplit-at k glst))
                   (lambda (head tail) tail)))

               ;;; sets
               (define-datatype ,gset ,gset?
                 (,name->set (set ,name?)))

               (define (,gset-add item set)
                 (,name->set
                   (cases ,gset set
                     (,name->set (ls)
                        ;(,gremove-dups (,gcons item ls))))))
                        (,gcons item ls)))))
                 
               ;(set! ,name->set
               ;      (o ,name->set ,gremove-dups))

               (define (,gset->list set)
                 (cases ,gset set
                   (,name->set (set) set)))
               
               (define-record-printer (,gset set out)
                 (let ((str (sprintf "~s"
                              (,name->list
                                (cases ,gset set
                                  (,name->set (ls)
                                    (,gremove-dups ls)))))))
                   (string-set! str 0 #\{)
                   (string-set! str (- (string-length str) 1) #\})
                   (display str out)))

               (define (,gset . args)
                 (,name->set (apply ,name args)))

               (define (,gset-cardinality set)
                 (cases ,gset set
                   (,name->set (ls)
                      (,glength (,gremove-dups ls)))))

               (define (,gset-in? item set)
                 (cases ,gset set
                   (,name->set (ls)
                     (if (,gmember item ls) #t #f))))

               (define (,gsubset? set0 set1)
                 (cases ,gset set0
                   (,name->set (ls0)
                     (,gevery?
                       (lambda (item)
                         (,gmember
                           item
                           (cases ,gset set1
                             (,name->set (ls1)
                                         ls1))))
                       ls0))))

               (define (,gset-equal? set0 set1)
                 (and (,gsubset? set0 set1)
                      (,gsubset? set1 set0)))

               ;; gfilter not used, to avoid unnessecary reversing
               (define (,gsubset ok? set)
                 (cases ,gset set
                   (,name->set (ls)
                     (let loop ((ls ls) (yes (,gnull)) (no (,gnull)))
                       (cases ,name ls
                         (,gnull ()
                           (values (,name->set yes) (,name->set no)))
                         (,gcons (first rest)
                           (if (ok? first)
                             (loop rest (,gcons first yes) no)
                             (loop rest yes (,gcons first no)))))))))

               (define (,gset-null? xpr)
                 (and (,gset? xpr)
                      (cases ,gset xpr
                        (,name->set (ls) (,gnull? ls)))))

               (define (,gset-difference set0 set1)
                 (let loop ((ls1 (,gset->list  set1))
                            (ls0 (,gset->list set0)))
                   (cases ,name ls1
                     (,gnull () (,name->set ls0))
                     (,gcons (first rest)
                       (loop rest (,gremove first ls0))))))

               ;; gappend not used, to avoid unnessecary reversing
               (define (,gset-union . sets)
                 (cond
                   ((null? sets) (,name->set (,gnull)))
                   ((null? (cdr sets)) (car sets))
                   ((null? (cddr sets))
                    (cases ,gset (car sets)
                      (,name->set (ls)
                        (let loop ((ls ls) (result (cadr sets)))
                          (cases ,name ls
                            (,gnull () result)
                            (,gcons (first rest)
                              (loop rest
                                    (,gset-add first result))))))))
                   (else
                     (,gset-union (car sets)
                                  (apply ,gset-union (cdr sets))))))

               (define (,gset-intersection . sets)
                   (cond
                     ((null? sets)
                      (,name->set (,gnull)))
                     ((null? (cdr sets))
                      (car sets))
                     ((null? (cddr sets))
                      (let ((set1 (cadr sets)))
                        (cases ,gset (car sets)
                          (,name->set (ls)
                            (let loop ((ls ls)
                                       (result (,gnull)))
                              (cases ,name ls
                                (,gnull () (,name->set result))
                                (,gcons (first rest)
                                  (if (,gset-in? first set1)
                                    (loop rest
                                          (,gcons first result))
                                    (loop rest result)))))))))
                     (else
                       (,gset-intersection (car sets)
                                           (apply ,gset-intersection (cdr sets))))))

               ;; documentation procedure
               (define ,docu
                 (let (
                   (signatures '(
                     (,name? xpr)
                     (,name . args)
                     ;(,glist . args)
                     (,grepeat n x)
                     (,giterate-times n fn x)
                     (,giterate-while ok? fn x)
                     (,giterate-until ok? fn x)
                     (,name->list glst)
                     (,list->name lst)
                     (,gapply fn . args)
                     (,gnull? xpr)
                     (,gcar glst)
                     (,gcdr glst)
                     (,gcadr glst)
                     (,gcddr glst)
                     (,gcaddr glst)
                     (,gcdddr glst)
                     (,gcadddr glst)
                     (,gcddddr glst)
                     (,greverse glst)
                     (,greverse* . glsts)
                     (,glength glst)
                     (,gsublist from upto glst)
                     (,gref k glst)
                     (,gsplit-at k glst)
                     (,gsplit-with ok? glst)
                     (,gdrop k glst)
                     (,gdrop-while ok? glst)
                     (,gtake k glst)
                     (,gtake-while ok? glst)
                     (,gappend . glsts)
                     (,gmap fn . glsts)
                     (,gmappend fn . glsts)
                     (,gfor-each fn . glsts)
                     (,gfilter ok? glst)
                     (,gadjoin item glst)
                     (,gequal? glst0 glst1)
                     (,gmemp ok? glst)
                     (,gmember item glst)
                     (,gremp ok? glst)
                     (,gremove item glst)
                     (,gremove-dups glst)
                     (,gassp ok? glst)
                     (,gassoc item glst)
                     (,gfold-left op base . glsts)
                     (,gfold-right op base . glsts)
                     (,gmerge <? glst0 glst1)
                     (,gsort <? glst)
                     (,gsorted? <? glst)
                     (,gzip glst0 glst1)
                     (,ginterpose sep glst)
                     (,gevery? ok? glst)
                     (,gsome ok? glst)
                     (,gnot-every? ok? glst)
                     (,gnot-any? ok? glst)
                     (,make-name len fill)
                     (,glist-ref glst k)
                     (,glist-head glst k)
                     (,glist-tail glst k)
                     ;;; sets
                     (,name->set glst)
                     (,gset? xpr)
                     (,gset->list set)
                     (,gset-in? item set)
                     (,gsubset? set0 set1)
                     (,gsubset ok? set)
                     (,gset-equal? set0 set1)
                     (,gset-null? xpr)
                     (,gset-add item set)
                     (,gset-cardinality set)
                     (,gset . args)
                     (,gset-difference set0 set1)
                     (,gset-union . sets)
                     (,gset-intersection . sets)
                     ))
                   )
                   (case-lambda
                     (() (map car signatures))
                     ((sym) (assq sym signatures)))))

               )))))))

) ; tyed-lists