;;;; type-coerce.scm
;;;; Kon Lovett, Sep '09

;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
; Copyright (C) 1995, 2001 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;; Issues
;;
;; - Cannot know before attempt if coercion possible.
;;
;; - The coercion of a composite object to a scalar often makes little sense.
;;
;; - The coercion of a scalar object to a composite is usually just to
;; box the object with the specified composite.

(module type-coerce

(;export
  make-case-coerce
  (case-coerce *make-case-coerce) *make-case-coerce
  coerce
  coerce-all)

#|
(cond-expand
  (full-numeric-tower
    (import
      (except scheme
        + - * / = > < >= <=
        number->string string->number
        eqv? equal?
        exp log sin cos tan atan acos asin expt sqrt
        quotient modulo remainder
        numerator denominator
        abs max min gcd lcm
        positive? negative? odd? even? zero?
        exact? inexact?
        rationalize
        floor ceiling truncate round
        inexact->exact exact->inexact
        number? complex? real? rational? integer?
        make-rectangular make-polar real-part imag-part magnitude angle)
      (except chicken
        add1 sub1 random randomize conj signum
        force-finalizers
        bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift)
      numbers)
    (require-library numbers) )
  (else
      (import scheme chicken) ) )
|#

(import scheme)

(import chicken)

(import
  (only data-structures alist-ref)
  (only srfi-1 every reverse!)
  (only miscmacros if*)
  (only type-checks check-procedure check-symbol check-list check-alist)
  (only type-errors signal-type-error)
  type-of
  coerce-extend)

(require-library
  data-structures srfi-1
  miscmacros type-checks type-errors
  type-of coerce-extend)

;;;

(define (->boolean obj) (and obj #t))

(define (string->vector x) (list->vector (string->list x)))
(define (vector->string x) (list->string (vector->list x)))

;;; Extension

(define ((*make-case-coerce func al) obj typ err)
  (func obj typ (lambda () (if* (alist-ref typ al eq?) (it obj) (err)))) )

;;

(define (make-case-coerce func #!optional (al '()))
  (check-procedure 'make-case-coerce func 'func)
  (check-alist 'make-case-coerce al 'alist)
  (*make-case-coerce func al) )

;;

(define-syntax case-coerce
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_lambda (rnm 'lambda))
            (_case (rnm 'case))
            (_else (rnm 'else))
            (_*make-case-coerce (rnm '*make-case-coerce))
            (_typ (rnm 'typ)) )
        (let ((else-clause `(,_else (on-error))))
          (let loop ((clauses (cdr frm)) (sym-clauses '()))
            (if (null? clauses)
                `(,_*make-case-coerce
                   (,_lambda (object ,_typ on-error)
                     (,_case ,_typ ,@(reverse! sym-clauses) ,else-clause))
                   '())
                (let* ((clause (car clauses))
                       (rest (cdr clauses))
                       (tst (car clause))
                       (bdy (cdr clause)) )
                  (##sys#check-syntax 'case-coerce bdy '#(_ 1))
                  (cond ((and (symbol? tst) (cmp tst _else))
                          (set! else-clause clause)
                          (loop rest sym-clauses) )
                        (else
                          (##sys#check-syntax 'case-coerce tst '#(symbol 1))
                          (loop rest (cons clause sym-clauses)) ) ) ) ) ) ) ) ) ) )

;;@body
;;Converts and returns @1 of type @code{char}, @code{number},
;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
;;@2 (which must be one of these symbols).

(define (error-coerce obj restyp) (error 'coerce "cannot coerce" obj restyp))

(define (coerce obj restyp #!optional (default-proc error-coerce))
  (define (other->other) (other-coerce obj restyp default-proc))
  (check-symbol 'coerce restyp 'result-type)
  (when default-proc (check-procedure 'coerce default-proc 'default-proc))
  (let ((objtyp (extended-type-of obj)))
    (cond
      ((eq? objtyp restyp)    obj )
      ((eq? 'boolean restyp)  (->boolean obj) )
      (else
        (case objtyp
          ((boolean)
            (case restyp
              ((atom)     obj )
              ((number integer)
                (if obj 1 0) )
              ((string)   (if obj "true" "false") )
              ((keyword)  (string->keyword (if obj "true" "false")) )
              ((symbol)   (string->symbol (if obj "true" "false")) )
              ((list)     (list obj) )
              ((vector)   (vector obj) )
              (else       (other->other) ) ) )
          ((char)
            (case restyp
              ((atom)     obj )
              ((number integer)
                          (char->integer obj) )
              ((string)   (string obj) )
              ((keyword)  (string->keyword (number->string obj)) )
              ((symbol)   (string->symbol (number->string obj)) )
              ((list)     (list obj) )
              ((vector)   (vector obj) )
              (else       (other->other) ) ) )
          ((number fixnum flonum) ;bignum ratnum compnum
            (case restyp
              ((atom)     obj )
              ((char)     (integer->char obj) )
              ((integer)  (inexact->exact obj) )
              ((string)   (number->string obj) )
              ((keyword)  (string->keyword (number->string obj)) )
              ((symbol)   (string->symbol (number->string obj)) )
              ((list)     (string->list (number->string obj)) )
              ((vector)   (string->vector (number->string obj)) )
              (else       (other->other) ) ) )
          ((keyword)
            (case restyp
              ((atom)     obj )
              ((char)     (coerce (keyword->string obj) 'char) )
              ((number integer)
                          (coerce (keyword->string obj) restyp) )
              ((string)   (keyword->string obj) )
              ((symbol)   (string->symbol (keyword->string obj)) )
              ((list)     (string->list (keyword->string obj)) )
              ((vector)   (string->vector (keyword->string obj)) )
              (else       (other->other) ) ) )
          ((symbol)
            (case restyp
              ((atom)     obj )
              ((char)     (coerce (symbol->string obj) 'char) )
              ((number integer)
                          (coerce (symbol->string obj) restyp) )
              ((string)   (symbol->string obj) )
              ((keyword)  (string->keyword (symbol->string obj)) )
              ((list)     (string->list (symbol->string obj)) )
              ((vector)   (string->vector (symbol->string obj)) )
              (else       (other->other) ) ) )
          ((string)
            (case restyp
              ((atom)     (or (string->number obj) (string->symbol obj)) )
              ((char)
                          (if (= 1 (string-length obj)) (string-ref obj 0)
                              (other->other)))
              ((number integer)
                          (or (string->number obj)
                              (other->other)) )
              ((keyword)  (string->keyword obj) )
              ((symbol)   (string->symbol obj) )
              ((list)     (string->list obj) )
              ((vector)   (string->vector obj) )
              ((blob)     (string->blob obj) )
              (else       (other->other) ) ) )
          ((list null pair)
            (case restyp
              ((atom)     (coerce (list->string obj) 'atom) )
              ((char)
                          (if (and (= 1 (length obj)) (char? (car obj)))
                              (car obj)
                              (other->other)) )
              ((number integer)
                           (or (string->number (list->string obj))
                               (other->other)) )
              ((string)   (list->string obj) )
              ((keyword)  (string->keyword (list->string obj)) )
              ((symbol)   (string->symbol (list->string obj)) )
              ((vector)   (list->vector obj) )
              (else       (other->other) ) ) )
          ((vector)
            (case restyp
              ((atom)     (coerce (vector->string obj) 'atom) )
              ((char)
                          (if (and (= 1 (vector-length obj)) (char? (vector-ref obj 0)))
                              (vector-ref obj 0)
                              (other->other)) )
              ((number integer)
                          (or (string->number (coerce obj 'string))
                              (other->other)) )
              ((string)   (vector->string obj) )
              ((keyword)  (string->keyword (vector->string obj)) )
              ((symbol)   (string->symbol (vector->string obj)) )
              ((list)     (vector->list obj) )
              (else       (other->other) ) ) )
          ((blob)
            (case restyp
              ((string)   (blob->string obj))
              (else       (other->other) ) ) )
          (else
            (other->other) ) ) ) ) ) )

;;

(define (coerce-all flst tlst #!optional default-proc)
  (check-list 'coerce-all flst "objects")
  (check-list 'coerce-all tlst "types")
  #; ;NOT NEEDED
  (unless (= (length flst) (length tlst))
    (signal-type-error 'coerce-all "list length mismatch" flst tlst) )
  (map (cut coerce <> <> default-proc) flst tlst) )

) ;module type-coerce