generics.scm

;; Generics with return types

#| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  $ petite --script generics.scm

|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (gen-id template-id . args)
  (datum->syntax template-id
    (string->symbol
     (apply string-append
            (map (lambda (x)
                   (if (string? x)
                       x
                       (symbol->string (syntax->datum x))))
                 args)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (param-sig-matches-arg-sig? a b)
  
  (cond ((and (null? a)
              (null? b))
         #t)
        
        ((equal? (car a)
                 (car b))
         (param-sig-matches-arg-sig? (cdr a) (cdr b)))

        ((eq? (car a) #f)
         (param-sig-matches-arg-sig? (cdr a) (cdr b)))

        (else #f)))

(define-record-type entry
  (fields signature return name))

(define (show obj)
  (display "show: ")
  (display obj)
  (newline)
  obj)

(define (make-generic)
  (lambda (stx)
    (lambda (lookup)
      (expand-generic-form lookup stx))))

(define (get-tbl lookup form)
  (syntax-case form ()
    ((g par ...)
     (with-syntax
         ((res
           (lookup (syntax g)
                   (syntax tbl))))
       (syntax res)))))

(define (expand-generic-form lookup stx)
  (syntax-case stx ()
    ((k param ...)
     (let ((signature (map (lambda (p)
                             (cond ((integer? (syntax->datum p)) 'integer)
                                   ;; ((vector?  (syntax->datum p)) 'vector)
                                   ((string? (syntax->datum p)) 'string)
                                   ((char? (syntax->datum p)) 'char)
                                   ((identifier? p)
                                    (lookup p (syntax type)))

                                   ((and (list? (syntax->datum p))
                                         (get-tbl lookup p))

                                    (let ((inner-form-table (get-tbl lookup p)))

                                      (let ((name
                                             (car
                                              (syntax->datum
                                               (expand-generic-form lookup p)))))
                                        
                                        (entry-return
                                         (find (lambda (entry)
                                                 (equal? (entry-name entry) name))
                                               (unbox inner-form-table))))))
                                   
                                   (else #f)))
                           (syntax (param ...)))))

       (let ((table (get-tbl lookup (syntax (k)))))

         (let ((proc-name

                (cond ((find (lambda (entry)
                               (equal? (entry-signature entry) signature))
                             (unbox table))
                       => entry-name)
                      
                      ((find (lambda (entry)
                               (param-sig-matches-arg-sig? (entry-signature entry)
                                                           signature))
                             (unbox table))
                       => entry-name)

                      (else
                       
                       (display "signature of argument list:\n")
                       (display signature)
                       (newline)

                       (display "argument list:\n")
                       ;; (display (syntax '(param ...)))
                       (display (syntax (param ...)))
                       (newline)

                       (display "table:\n") (display table) (newline)

                       (error #f "no entry in table")))))

           (with-syntax ((proc-syntax
                          (datum->syntax (syntax list) proc-name)))
             (syntax
              (proc-syntax param ...)))))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (join-strings ls elt)
  (if (null? (cdr ls))
      (car ls)
      (string-append (car ls) elt (join-strings (cdr ls) elt))))

(define (join-symbols ls elt)
  (string->symbol
   (join-strings (map symbol->string ls) (symbol->string elt))))

(define (ensure-symbol obj)
  (if (eq? obj #f)
      'false
      obj))

(define-syntax define-method
  (lambda (stx)
    (lambda (lookup)
      (syntax-case stx ()
        ((_ name ((param type) ...) return-type
            expr
            ...)
         (with-syntax
             ((proc-name (datum->syntax (syntax name)
                           (join-symbols
                            (map ensure-symbol
                                 (map syntax->datum
                                      (syntax (name type ...))))
                            '-))))

           (set-box! (lookup (syntax name) (syntax tbl))
                     (cons (make-entry (syntax->datum (syntax (type ...)))
                                       (syntax->datum (syntax return-type))
                                       (syntax->datum (syntax proc-name)))
                           (unbox
                            (lookup (syntax name) (syntax tbl)))))

           (syntax
            (begin
              (define (proc-name param ...)
                expr
                ...)
              
              ))))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax add (make-generic))

(define-property add tbl (box '()))

(define-method add ((a integer) (b integer)) integer
  (+ a b))

(assert (=

         (add 1 2)

         3))

(let ((i 10)
      (j 20))

  (define-property i type 'integer)
  (define-property j type 'integer)

  (add i j))

(let ((var-a 10)
      (var-b 20))

  (define-property var-a type 'integer)
  (define-property var-b type 'integer)

  (add 30 (add var-a var-b)))

(assert (=

         (add (add 1 2)
              (add 3 4))

         10))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax nth (make-generic))

(define-property nth tbl (box '()))

(define-method nth ((v vector) (i #f)) #f
  (vector-ref v i))

(define-method nth ((s string) (i #f)) #f
  (string-ref s i))

(define-method nth ((l list) (i #f)) #f
  (list-ref l i))

(define-method nth ((bv u8) (i #f)) #f
  (bytevector-u8-ref bv i))

(define-method nth ((v vector-of-integer) (i #f)) integer
  (vector-ref v i))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (eq? 

         (let ((v0 '#(a b c)) (a 0))
           (define-property v0 type 'vector)
           (define-property a  type 'integer)
           (nth v0 a))

         'a))

(assert (eq?

         (let ((s0 "abc") (a 0))
           (define-property s0 type 'string)
           (define-property a  type 'integer)
           (nth s0 a))

         #\a))

;; second paramater is not typed:

;; (assert (eq? 

;;          (let ((v0 '#(a b c)) (a 0))
;;            (define-property v0 type 'vector)
;;            (nth v0 a))

;;          'a))

;; second parameter is a literal integer:

(assert (eq? 

         (let ((v0 '#(a b c)))
           (define-property v0 type 'vector)
           (nth v0 0))

         'a))

;; first parameter is a literal string:

(assert (eq?

         (nth "abc" 0)

         #\a))

(assert (eq?
         
         (let ((l0 '(a b c)))
           (define-property l0 type 'list)
           (nth l0 0))

         'a))

(assert (eq?
         
         (let ((bv0 (bytevector 1 2 3)))
           (define-property bv0 type 'u8)
           (nth bv0 0))

         1))

(assert (char=?

         (nth "abc" (add 0 1))

         #\b))

(assert (=

         (let ((v0 (vector 10 20 30)))

           (define-property v0 type 'vector-of-integer)

           (add 10 (nth v0 0)))

         20))

(assert (=

         (let ((v0 (vector 10 20 30)))

           (define-property v0 type 'vector)

           (nth v0 (add 1 1)))

         30))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax nth! (make-generic))

(define-property nth! tbl (box '()))

(define-method nth! ((v vector) (i integer) (val #f)) #f
  (vector-set! v i val))

;; (define-method nth! ((s string) (i integer) (c char))
;;   (string-set! s i c))

(define-method nth! ((s string) (i integer) (c #f)) #f
  (string-set! s i c))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (eq? 

         (let ((v0 '#(a b c)))
           (define-property v0 type 'vector)
           (nth! v0 0 'x)
           (nth  v0 0))

         'x))

(assert (eq?

         (let ((s0 "abc"))
           (define-property s0 type 'string)
           (nth! s0 0 #\x)
           (nth  s0 0))

         #\x))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax size (make-generic))

(define-property size tbl (box '()))

(define-method size ((v vector)) integer
  (vector-length v))

(define-method size ((s string)) integer
  (string-length s))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (=
         
         (let ((v0 '#(a b c)))
           (define-property v0 type 'vector)
           (size v0))

         3))

(assert (=
         
         (size "abc")

         3))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax new-of-size (make-generic))

(define-property new-of-size tbl (box '()))

(define-method new-of-size ((obj vector) (n integer)) vector
  (make-vector n))

(define-method new-of-size ((obj string) (n integer)) string
  (make-string n))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax indexable-fold-left
  (syntax-rules ()
    ((indexable-fold-left seq ival proc)
     (let ((n (size seq)))
       (let loop ((i 0) (val ival))
         (define-property i type 'integer)
         (if (>= i n)
             val
             (loop (+ i 1) (proc val (nth seq i)))))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax fold-left (make-generic))

(define-property fold-left tbl (box '()))

(define-method fold-left ((v vector) (ival #f) (proc #f)) #f
  (define-property v type 'vector)
  (indexable-fold-left v ival proc))

(define-method fold-left ((s string) (ival #f) (proc #f)) #f
  (define-property s type 'string)
  (indexable-fold-left s ival proc))

(define-method fold-left ((l list) (ival #f) (proc #f)) #f
  (let loop ((l l) (val ival))
    (if (null? l)
        val
        (loop (cdr l)
              (proc val (car l))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (= 

         (let ((v0 '#(10 20 30)))
           (define-property v0 type 'vector)
           (fold-left v0 0 +))

         60))

(assert (string=?

         (fold-left "abc"
                    ""
                    (lambda (s c)
                      (string-append (string c) s)))

         "cba"))

(assert (= 

         (let ((l0 '(10 20 30)))
           (define-property l0 type 'list)
           (fold-left l0 0 +))

         60))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (define-syntax for-each
;;   (syntax-rules ()
;;     ((for-each seq proc)
;;      (let ((ival #f)
;;            (proc2 (lambda (val elt)
;;                     (proc elt))))
;;        (fold-left seq
;;                   ival
;;                   proc2)))))

(define-syntax for-each
  (syntax-rules ()
    ((for-each seq proc)
     (fold-left seq
                #f
                (lambda (val elt)
                  (proc elt))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (= 

         (let ((v0 '#(1 2 3))
               (sum 0))
           (define-property v0 type 'vector)
           (for-each v0
                     (lambda (n)
                       (set! sum (+ sum n))))
           sum)

         6))

(assert (string=?

         (let ((accum ""))
           (for-each "abc"
                     (lambda (c)
                       (set! accum
                             (string-append (string c) accum))))
           accum)

         "cba"))

(assert (= 

         (let ((l0 '(1 2 3))
               (sum 0))
           (define-property l0 type 'list)
           (for-each l0
                     (lambda (n)
                       (set! sum (+ sum n))))
           sum)

         6))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax for-each-with-index
  (syntax-rules ()
    ((_ seq proc)
     (fold-left seq
                0
                (lambda (i elt)
                  (proc i elt)
                  (+ i 1))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (equal?

         (let ((v0 '#(10 20 30))
               (accum '()))

           (define-property v0 type 'vector)
           
           (for-each-with-index v0
                                (lambda (i elt)
                                  (set! accum (cons (cons i elt) accum))))

           accum)

         '((2 . 30) (1 . 20) (0 . 10))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax lookup-type
  (lambda (stx)
    (lambda (lookup)
      (syntax-case stx ()
        ((_ param)
         (with-syntax ((result
                        (datum->syntax
                            (syntax list)
                            (let ((p (syntax param)))
                              (cond ((integer? (syntax->datum p)) 'integer)
                                    ;; ((vector?  (syntax->datum p)) 'vector)
                                    ((string? (syntax->datum p)) 'string)
                                    ((char? (syntax->datum p)) 'char)
                                    ((identifier? p)
                                     (lookup p (syntax type)))
                                    (else #f))))))
           (syntax 'result)))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax indexable-subseq
  (syntax-rules ()
    ((_ seq start end)
     (let ((n (- end start)))
       (define-property n type 'integer)
       (let ((new (new-of-size seq n)))
         (define-property new type (lookup-type seq))
         (for-each-with-index new
                              (lambda (i elt)
                                (define-property i type 'integer)
                                (nth! new i (nth seq (+ start i)))))
         new)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax subseq (make-generic))

(define-property subseq tbl (box '()))

(define-method subseq ((v vector) (start integer) (end integer)) vector
  (define-property v type 'vector)
  (indexable-subseq v start end))

(define-method subseq ((s string) (start integer) (end integer)) string
  (define-property s type 'string)
  (indexable-subseq s start end))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(assert (equal?

         (let ((v0 '#(a b c d e f)))

           (define-property v0 type 'vector)

           (subseq v0 1 4))

         '#(b c d)))

(assert (string=?
 
         (subseq "abcdef" 1 (add 3 1))

         "bcd"))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;