;;;; procedure-introspection.scm  -*- Hen -*-
;;;; Kon Lovett, Oct '09

;; Issues
;;
;; - The pulling of procedure arity & name from lambda-info is a hack.
;;
;; - The ''lambda-information'' type is grotesque; as is the ''bucket'' type.
;; These bits are too precious to waste on situations where the reference context
;; can provide disambiguation.
;;
;; - Introspection is a poorly explored area of Scheme programming. At least
;; '''R6RS''' made the distinction between ''procedure'' and ''closure'';
;; distinguishing ''named'' & ''anonymous'' lambda. The author however does not
;; support the enforced ''static'' nature of procedure identifier bindings in
;; '''R6RS'''.


(module procedure-introspection

  (;export
    ;;
    list-length.+
    list-uniq
    ;;
    procedure-lambda-info
    procedure-name
    procedure-arity
    procedure-documentation
    procedure-source-file
    procedure-source-position
    procedure-source-line
    procedure-source-column
    procedure-expression
    procedure-environment
    procedure-signature
    procedure-metadata
    ;;
    procedure-name-set!
    procedure-arity-set!
    append-procedure-arity!
    procedure-documentation-set!
    procedure-source-info-set!
    procedure-metadata-set!
    ;;
    procedure-arity-available?
    procedure-fixed-arity?
    procedure-arity-at-least?
    procedure-minimum-arity
    procedure-arity-includes?
    ;;
    *append-procedure-arity!
    *lambda-infos-append!
    ;;
    check-scalar-arity
    *lambda-infos-set!
    *source-info-set!
    *procedure-arity-available?
    *procedure-arity)

  (import scheme
          chicken
          (only data-structures identity sort)
          (only posix set-file-position!)
          (only srfi-1 any every delete-duplicates))

  (require-library data-structures posix srfi-1)

  (declare
    (bound-to-procedure
      ##sys#slot ##sys#setslot
      ##sys#lambda-decoration ##sys#decorate-lambda
      ##sys#lambda-info->string ##sys#make-lambda-info ##sys#lambda-info
      ##sys#hash-table-ref ##sys#hash-table-set!
      ##sys#check-symbol ##sys#check-string ##sys#check-closure
      ##sys#check-integer ##sys#check-exact ##sys#check-range) )

;;;

;;

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

;; count of top-level pairs
;;
;; > 0 : proper-list length
;; < 0 : circular-list length
;; #.0 : dotted-list length

(define (list-length.+ ls)
  (if (null? ls) 0
      (let loop ((ls (cdr ls)) (seen ls) (len 1))
        (cond ((null? ls)       len )
              ((not (pair? ls)) (exact->inexact len) )
              ((eq? ls seen)    (- len) )
              (else
                (loop (cdr ls) (cdr seen) (fx+ len 1)) ) ) ) ) )

(define list-uniq delete-duplicates)

;; Arity Object

; the limit

(define-constant ARGUMENT-COUNT-LIMIT most-positive-fixnum)

; definition

#| ;UNUSED
(define (fixed-arity-object? obj) (and (##sys#exact? obj) (<= 0 obj)))
(define (arity-at-least-object? obj) (and (##sys#inexact? obj) (<= 0 obj)))
(define (scalar-arity-object? obj) (or (fixed-arity-object? obj) (arity-at-least-object? obj)))
(define (arity-object? obj)
  (or (scalar-arity-object? obj)
      (and (pair? obj) (every (cut scalar-arity-object? <>)))) )
|#

;; Lambda Info Coding

(define (decode-lambda-info lambdainfo)
  (read (open-input-string (##sys#lambda-info->string lambdainfo))) )

(define (encode-lambda-info info)
  (##sys#make-lambda-info
    (let ((o (open-output-string)))
      (write info o)
      (get-output-string o))) )

;; Tagged Lambda Decoration

(define (update-lambda-decoration proc pred decr)
  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
  (##sys#decorate-lambda proc pred setter) )

(define make-decoration cons)
(define decoration? pair?)
(define decoration-tag-ref car)
(define decoration-value-ref cdr)

(define ((tagged-lambda-decoration-predicate tag) obj)
  (and (decoration? obj)
       (eq? tag (decoration-tag-ref obj))) )

(define ((tagged-lambda-decoration-setter tag pred) proc obj)
  (update-lambda-decoration proc pred (lambda (old) (make-decoration tag obj))) )

(define ((lambda-decoration-getter pred) proc)
  (and-let* ((decor (##sys#lambda-decoration proc pred)))
    (decoration-value-ref decor) ) )

(define-syntax define-tagged-lambda-decoration
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_define (rnm 'define))
            (_let (rnm 'let))
            (_set! (rnm 'set!))
            (_tagged-lambda-decoration-predicate (rnm 'tagged-lambda-decoration-predicate))
            (_tagged-lambda-decoration-setter (rnm 'tagged-lambda-decoration-setter))
            (_lambda-decoration-getter (rnm 'lambda-decoration-getter)) )
        (let* ((nam (cadr frm))
               (strnam (symbol->string nam)) )
          (let ((tagnam (string->symbol (string-append "+" strnam "-tag+")))
                (prdnam (string->symbol (string-append strnam "?")))
                (setnam (string->symbol (string-append strnam "-set!")))
                (getnam nam) )
            `(begin
              (,_define ,getnam)
              (,_define ,setnam)
              (,_let ((,tagnam '#(,nam)))
                (,_define ,prdnam (,_tagged-lambda-decoration-predicate ,tagnam))
                (,_set! ,setnam (,_tagged-lambda-decoration-setter ,tagnam ,prdnam))
                (,_set! ,getnam (,_lambda-decoration-getter ,prdnam)) ) ) ) ) ) ) ) )

;; Main lambda-info

; returns <scalar-arity>

(define (lambda-info-arity lambdainfo)
  (define (get-arity info)
    (if (pair? info) (list-length.+ (cdr info))         ; info should never be a circular list!
        (##sys#exact->inexact ARGUMENT-COUNT-LIMIT) ) ) ; nothing but a name - assume infinity
  (and lambdainfo
       (get-arity (decode-lambda-info lambdainfo))) )

; returns symbol or #f where |?| -> #f

(define (lambda-info-name lambdainfo)
  (define (get-name info) (if (pair? info) (car info) info))
  (and lambdainfo
       (let ((nm (get-name lambdainfo)))
         (and (not (eq? '? nm)) nm) ) ) )

; returns <symbol> or #f

(define (procedure-info-name proc) (lambda-info-name (##sys#lambda-info proc)))

; returns <scalar-arity> or #f
;
; <scalar-arity>      :: <arity-at-least> | <fixed-arity>
; <arity-at-least>    :: <inexact-integer>
; <fixed-arity>       :: <exact-integer>

(define (*procedure-info-arity proc) (lambda-info-arity (##sys#lambda-info proc)))

;; Multiple lambda-info

(define-tagged-lambda-decoration lambda-infos)

(define (*lambda-infos-arity proc)
  (and-let* ((infos (lambda-infos proc)))
    (map lambda-info-arity infos) ) )

(define (*lambda-infos-set! proc . defns)
  (lambda-infos-set! proc (map encode-lambda-info defns)) )

(define (*lambda-infos-append! proc defn)
  (let ((ls (or (lambda-infos proc) '())))
    (lambda-infos-set! proc (##sys#append ls (list (encode-lambda-info defn)))) ) )

;; Procedure Name Cache

(define-tagged-lambda-decoration lambda-name)

(define (*procedure-name proc)
  (or (lambda-name proc)
      (and-let* ((nm (procedure-info-name proc)))
        (lambda-name-set! proc nm)
        nm ) ) )

(define (*procedure-name-set! proc nm) (lambda-name-set! proc nm))

;; Procedure Arity Cache

(define-tagged-lambda-decoration lambda-arity)

; returns <arity-object>
;
; <arity-object>      :: <scalar-arity> | ( <scalar-arity> ... )

(define (*procedure-arity proc)
  (let ((arity (lambda-arity proc)))
    (or arity
        (let ((arities (*lambda-infos-arity proc)))
          (if arities
              (begin
                (lambda-arity-set! proc arities)
                arities )
              (and-let* ((arity (*procedure-info-arity proc)))
                (lambda-arity-set! proc arity)
                arity ) ) ) ) ) )

(define (*procedure-arity-set! proc ks) (lambda-arity-set! proc ks))

(define (*append-procedure-arity! proc k)
  (let ((ls (or (lambda-arity proc) '())))
    (lambda-arity-set! proc (##sys#append ls (list k))) ) )

(define (*procedure-arity-available? proc) (->boolean (*procedure-arity proc)))

;; Procedure Docstring

(define-tagged-lambda-decoration docstring-info)

(define *procedure-docstring docstring-info)
(define *procedure-docstring-set! docstring-info-set!)

;; Procedure Source Info

(define-tagged-lambda-decoration source-info)

(define (make-source-info f p l c) (vector f p l c))

(define (*source-info-set! proc f p l c) (source-info-set! proc (make-source-info f p l c)))

(define (source-info-file si) (and si (vector-ref si 0)))
(define (source-info-position si) (and si (vector-ref si 1)))
(define (source-info-line si) (and si (vector-ref si 2)))
(define (source-info-column si) (and si (vector-ref si 3)))

(define (*procedure-source-file proc) (source-info-file (source-info proc)))
(define (*procedure-source-position proc) (source-info-position (source-info proc)))
(define (*procedure-source-line proc) (source-info-line (source-info proc)))
(define (*procedure-source-column proc) (source-info-column (source-info proc)))

;sort-of
(define (*procedure-expression proc)
  (and-let* ((info (source-info proc)))
    (let ((inp (open-input-file (source-info-file info) #:text)))
      (set-file-position! inp (source-info-position info))
      (let ((exp (read inp)))
        (close-input-port inp)
        exp ) ) ) )


;; Procedure Metadata Decorator Cache

(define procedure-metadata-getter)
(define procedure-metadata-setter)
(let ((+procedure-metadata-decorators+ (make-vector 301 '())))

  (define (procedure-metadata-decorator key)
    (let ((decorator (##sys#hash-table-ref +procedure-metadata-decorators+ key)))
      (or decorator
          (begin
            (let* ((pred (tagged-lambda-decoration-predicate key))
                   (getter (lambda-decoration-getter pred))
                   (setter (tagged-lambda-decoration-setter key pred))
                   (decorator (cons getter setter)) )
              (##sys#hash-table-set! +procedure-metadata-decorators+ key decorator)
              decorator ) ) ) ) )

  (set! procedure-metadata-getter (lambda (key) (car (procedure-metadata-decorator key))))

  (set! procedure-metadata-setter (lambda (key) (cdr (procedure-metadata-decorator key)))) )

(define (*procedure-metadata proc key) ((procedure-metadata-getter key) proc))

(define (*procedure-metadata-set! proc key value)
  ((procedure-metadata-setter key) proc value) )

;; Procedure Environment

(define (*procedure-environment proc)
  #f )

;; Procedure Signature

(define (*procedure-signature proc)
  #f )

;; Arity Support

(define-inline (arity-has? proc k tst)
  (let ((arity (*procedure-arity proc)))
    (if (pair? arity) (any tst arity) (tst arity)) ) )

;used for file-position & line/column - not the best!

(define (*check-cardinal-integer obj loc)
  (##sys#check-integer obj loc)
  (##sys#check-range obj 0 most-positive-fixnum loc) )

(define (check-scalar-arity obj loc)
  (##sys#check-integer obj loc)
  (##sys#check-range obj 0 ARGUMENT-COUNT-LIMIT loc) )

#; ;UNUSED
(define (check-arity-object obj loc)
  (if (list? obj) (every (cut check-scalar-arity <> loc) obj)
      (check-scalar-arity obj loc) ) )

;;; Public API

;; Procedure Lambda-Info

; Return list of decoded lambda-info or lambda-info or #f

(define (procedure-lambda-info proc)
  (##sys#check-closure proc 'procedure-lambda-info)
  (let ((infos (lambda-infos proc)))
    (if infos (map decode-lambda-info infos)
        (and-let* ((info (##sys#lambda-info proc)))
          (decode-lambda-info info) ) ) ) )

;; Procedure Name

; Return symbol or #f

(define (procedure-name proc)
  (##sys#check-closure proc 'procedure-name)
  (*procedure-name proc) )

(define (procedure-name-set! proc nm)
  (##sys#check-closure proc 'procedure-name-set!)
  (##sys#check-symbol nm 'procedure-name-set!)
  (*procedure-name-set! proc nm) )

;; Procedure Arity

; Is arity information available for this procedure?

(define (procedure-arity-available? proc)
  (##sys#check-closure proc 'procedure-arity-available?)
  (*procedure-arity-available? proc) )

; Return least `integer' arity
; It is an error to call this if `arity-available?' would return #f.

(define (procedure-minimum-arity proc)
  (##sys#check-closure proc procedure-minimum-arity)
  (let ((arity (*procedure-arity proc)))
    (if (not (pair? arity)) (##sys#inexact->exact arity)
        (apply min (map ##sys#inexact->exact arity)) ) ) )

; Return #t iff a fixed arity
; It is an error to call this if `arity-available?' would return #f.

(define (procedure-fixed-arity? proc)
  (##sys#check-closure proc 'procedure-fixed-arity?)
  (let ((arity (*procedure-arity proc)))
    (if (not (pair? arity)) (##sys#exact? arity)
        (every ##sys#exact? arity) ) ) )

; Return #t iff `procedure' would accept `integer' arguments.
; It is an error to call this if `arity-available?' would return #f.

(define (procedure-arity-includes? proc k)
  (##sys#check-closure proc 'procedure-arity-includes?)
  (check-scalar-arity k 'procedure-arity-includes?)
  (arity-has? proc k (lambda (a) (if (##sys#exact? a) (= a k) (<= a k)))) )

; Return #t iff procedure accepts k or more arguments.
; It is an error to call this if `arity-available?' would return #f.

(define (procedure-arity-at-least? proc k)
  (##sys#check-closure proc 'procedure-arity-at-least?)
  (check-scalar-arity k 'procedure-arity-at-least?)
  (arity-has? proc k =) )

; Return all possible arities for this procedure as a list of
; integers.  If rest arguments are supported, the last number is the
; number of arguments above which all possible arities are allowed.
; In other words, if a procedure accepts either 1 or 5 or more
; arguments, return the list (1 5).  The caller can tell that more
; than 5 arguments would be accepted by calling `(arity-at-least?
; procedure 5)'.
; It is an error to call this if `arity-available?'  would return
; #f.

(define (procedure-arity proc)
  (##sys#check-closure proc 'procedure-arities)
  (let ((arity (*procedure-arity proc)))
    (cond ((list? arity)  (sort (list-uniq (map ##sys#inexact->exact arity) =) <))
          (else           (list (##sys#inexact->exact arity)) ) ) ) )

; Sets from a list of arities (used for case-lambda)

(define (procedure-arity-set! proc . ks)
  (##sys#check-closure proc 'procedure-arity-set!)
  (every check-scalar-arity ks 'procedure-arity-set!)
  (*procedure-arity-set! proc ks) )

; Adds an arity (used for case-lambda)

(define (append-procedure-arity! proc k)
  (##sys#check-closure proc 'append-procedure-arity!)
  (check-scalar-arity k 'append-procedure-arity!)
  (*append-procedure-arity! proc k) )

;; Procedure Documentation

; Return string or #f

(define (procedure-documentation proc)
  (##sys#check-closure proc 'procedure-documentation)
  (*procedure-docstring proc) )

(define (procedure-documentation-set! proc s)
  (##sys#check-closure proc 'procedure-docstring-set!)
  (##sys#check-string s 'procedure-docstring-set!)
  (*procedure-docstring-set! proc s) )

;; Procedure Source Information

; Return string or #f

(define (procedure-source-file proc)
  (##sys#check-closure proc 'procedure-source-file)
  (*procedure-source-file proc) )

; Return integer or #f

(define (procedure-source-position proc)
  (##sys#check-closure proc 'procedure-source-position)
  (*procedure-source-position proc) )

; Return integer or #f

(define (procedure-source-line proc)
  (##sys#check-closure proc 'procedure-source-line)
  (*procedure-source-line proc) )

; Return integer or #f

(define (procedure-source-column proc)
  (##sys#check-closure proc 'procedure-source-column)
  (*procedure-source-column proc) )

; Sets the source information for procedure

(define (procedure-source-info-set! proc f p #!optional l c)
  (##sys#check-closure proc 'procedure-source-info-set!)
  (##sys#check-string f 'procedure-source-info-set!)
  (*check-cardinal-integer p 'procedure-source-info-set!)
  (when l (*check-cardinal-integer l 'procedure-source-info-set!))
  (when c (*check-cardinal-integer c 'procedure-source-info-set!))
  (*source-info-set! proc f p l c) )

; Return expression or #f

(define (procedure-expression proc)
  (##sys#check-closure proc 'procedure-expression)
  (*procedure-expression proc) )

;; Procedure Evaluation Environment

; Return environment or #f
; the closed-over bindings as a 1st-class 'environment'

(define (procedure-environment proc)
  (##sys#check-closure proc 'procedure-environment)
  (*procedure-environment proc) )

#;
(define (procedure-environment-set! proc sig)
  (##sys#check-closure proc 'procedure-environment-set!)
  (*procedure-environment-set! proc sig) )

;; Procedure Signature

; Return signature or #f
; the signature as defined or inferred

(define (procedure-signature proc)
  (##sys#check-closure proc 'procedure-signature)
  (*procedure-signature proc) )

#;
(define (procedure-signature-set! proc sig)
  (##sys#check-closure proc 'procedure-signature-set!)
  (*procedure-signature-set! proc sig) )

;; Procedrue Metadata

; Return #f or not-false-object

(define (procedure-metadata proc key)
  (case key
    ((#:name)         (procedure-name proc))
    ((#:arity)        (procedure-arity proc))
    ((#:file)         (procedure-source-file proc))
    ((#:position)     (procedure-source-position proc))
    ((#:line)         (procedure-source-line proc))
    ((#:column)       (procedure-source-column proc))
    ((#:expression)   (procedure-expression proc))
    ((#:signature)    (procedure-signature proc))
    ((#:environment)  (procedure-environment proc))
    (else             (*procedure-metadata proc key)) ) )

(define (procedure-metadata-set! proc key value)
  (case key
    ((#:name)         (procedure-name-set! proc value))
    ((#:arity)        (procedure-arity-set! proc value))
#|
    ((#:file)         (procedure-source-file-set! proc value))
    ((#:position)     (procedure-source-position-set! proc value))
    ((#:line)         (procedure-source-line-set! proc value))
    ((#:column)       (procedure-source-column-set! proc value))
    ((#:expression)   (procedure-expression-set! proc value))
    ((#:signature)    (procedure-signature-set! proc value))
    ((#:environment)  (procedure-environment-set! proc value))
|#
    (else             (*procedure-metadata-set! proc key value)) ) )

) ;module procedure-introspection