;*=====================================================================*/
;*    serrano/prgm/project/skribe/src/bigloo/resolve.scm               */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Fri Jul 25 09:31:18 2003                          */
;*    Last change :  Sun Jul 11 09:17:52 2004 (serrano)                */
;*    Copyright   :  2003-04 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    The Skribe resolve stage                                         */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module skribe_resolve
   
   (include "debug.sch")
   
   (import  skribe_types
	    skribe_lib
	    skribe_bib
	    skribe_eval)
   
   (import  skribe_index)
   
   (export  (resolve! ::obj ::%engine ::pair-nil)
	    (resolve-children ::obj)
	    (resolve-children* ::obj)
	    (resolve-parent ::%ast ::pair-nil)
	    (resolve-search-parent ::%ast ::pair-nil ::procedure)
	    (resolve-counter ::%ast ::pair-nil ::symbol ::obj . o)
	    (resolve-ident ::bstring ::obj ::%ast ::obj)))

;*---------------------------------------------------------------------*/
;*    *unresolved* ...                                                 */
;*---------------------------------------------------------------------*/
(define *unresolved* #f)

;*---------------------------------------------------------------------*/
;*    resolve! ...                                                     */
;*    -------------------------------------------------------------    */
;*    This function iterates over an ast until all unresolved          */
;*    references are resolved.                                         */
;*---------------------------------------------------------------------*/
(define (resolve! ast engine env)
   (with-debug 3 'resolve
      (debug-item "ast=" ast)
      (let ((old *unresolved*))
	 (let loop ((ast ast))
	    (set! *unresolved* #f)
	    (let ((ast (do-resolve! ast engine env)))
	       (if *unresolved*
		   (loop ast)
		   (begin
		      (set! *unresolved* old)
		      ast)))))))

;*---------------------------------------------------------------------*/
;*    do-resolve!  ...                                                 */
;*---------------------------------------------------------------------*/
(define-generic (do-resolve! ast engine env)
   (if (pair? ast)
       (do-resolve*! ast engine env)
       ast))

;*---------------------------------------------------------------------*/
;*    do-resolve! ::%node ...                                          */
;*---------------------------------------------------------------------*/
(define-method (do-resolve! node::%node engine env)
   (with-access::%node node (body options parent)
      (with-debug 5 'do-resolve::body 
	 (debug-item "node=" (if (markup? node)
				 (markup-markup node)
				 (find-runtime-type node)))
	 (debug-item "body=" (find-runtime-type body))
	 (if (not (eq? parent #unspecified))
	     node
	     (let ((p (assq 'parent env)))
		(set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))
		(if (pair? options)
		    (begin
		       (debug-item "unresolved options=" options)
		       (for-each (lambda (o)
				    (set-car! (cdr o)
					      (do-resolve! (cadr o) engine env)))
				 options)
		       (debug-item "resolved options=" options)))))
	 (set! body (do-resolve! body engine env))
	 node)))

;*---------------------------------------------------------------------*/
;*    do-resolve! ::%container ...                                     */
;*---------------------------------------------------------------------*/
(define-method (do-resolve! node::%container engine env0)
   (with-access::%container node (body options env parent)
      (with-debug 5 'do-resolve::%container
	 (debug-item "markup=" (markup-markup node))
	 (debug-item "body=" (find-runtime-type body))
	 (debug-item "env0=" env0)
	 (debug-item "env=" env)
	 (if (not (eq? parent #unspecified))
	     (let ((e `((parent ,node) ,@env ,@env0)))
		(set! body (do-resolve! body engine e))
		node)
	     (let ((p (assq 'parent env0)))
		(set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))
		(if (pair? options)
		    (let ((e (append `((parent ,node)) env0)))
		       (debug-item "unresolved options=" options)
		       (for-each (lambda (o)
				    (set-car! (cdr o)
					      (do-resolve! (cadr o) engine e)))
				 options)
		       (debug-item "resolved options=" options)))
		(let ((e `((parent ,node) ,@env ,@env0)))
		   (set! body (do-resolve! body engine e))
		   node))))
      ;; return the container
      node))

;*---------------------------------------------------------------------*/
;*    do-resolve! ::%document ...                                      */
;*---------------------------------------------------------------------*/
(define-method (do-resolve! node::%document engine env0)
   (with-access::%document node (env)
      (call-next-method)
      ;; resolve the engine custom
      (let ((env (append `((parent ,node)) env0)))
	 (for-each (lambda (c)
		      (let ((i (car c))
			    (a (cadr c)))
			 (debug-item "custom=" i " " a)
			 (set-car! (cdr c) (do-resolve! a engine env))))
		   (%engine-customs engine)))
      ;; return the container
      node))

;*---------------------------------------------------------------------*/
;*    do-resolve! ::%unresolved ...                                    */
;*---------------------------------------------------------------------*/
(define-method (do-resolve! node::%unresolved engine env)
   (with-debug 5 'do-resolve::%unresolved
      (debug-item "node=" node)
      (with-access::%unresolved node (proc parent loc)
	 (let ((p (assq 'parent env)))
	    (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))))
	 (let ((res (proc node engine env)))
	    (if (ast? res) (%ast-loc-set! res loc))
	    (debug-item "res=" res)
	    (set! *unresolved* #t)
	    res))))

;*---------------------------------------------------------------------*/
;*    do-resolve! ::handle ...                                         */
;*---------------------------------------------------------------------*/
(define-method (do-resolve! node::%handle engine env)
   node)

;*---------------------------------------------------------------------*/
;*    do-resolve*! ...                                                 */
;*---------------------------------------------------------------------*/
(define (do-resolve*! n+ engine env)
   (let loop ((n* n+))
      (cond
	 ((pair? n*)
	  (set-car! n* (do-resolve! (car n*) engine env))
	  (loop (cdr n*)))
	 ((not (null? n*))
	  (skribe-error 'do-resolve "Illegal argument" n*))
	 (else
	  n+))))

;*---------------------------------------------------------------------*/
;*    resolve-children ...                                             */
;*---------------------------------------------------------------------*/
(define (resolve-children n)
   (if (pair? n)
       n
       (list n)))

;*---------------------------------------------------------------------*/
;*    resolve-children* ...                                            */
;*---------------------------------------------------------------------*/
(define (resolve-children* n)
   (cond
      ((pair? n)
       (map resolve-children* n))
      ((%container? n)
       (cons n (resolve-children* (%container-body n))))
      (else
       (list n))))

;*---------------------------------------------------------------------*/
;*    resolve-parent ...                                               */
;*---------------------------------------------------------------------*/
(define (resolve-parent n e)
   (with-debug 5 'resolve-parent
      (debug-item "n=" n)
      (cond
	 ((not (%ast? n))
	  (let ((c (assq 'parent e)))
	     (if (pair? c)
		 (cadr c)
		 n)))
	 ((eq? (%ast-parent n) #unspecified)
	  (skribe-error 'resolve-parent "Orphan node" n))
	 (else
	  (%ast-parent n)))))

;*---------------------------------------------------------------------*/
;*    resolve-search-parent ...                                        */
;*---------------------------------------------------------------------*/
(define (resolve-search-parent n e pred)
   (with-debug 5 'resolve-search-parent
      (debug-item "node=" (find-runtime-type n))
      (debug-item "searching=" pred)
      (let ((p (resolve-parent n e)))
	 (debug-item "parent=" (find-runtime-type p) " "
		     (if (markup? p) (markup-markup p) "???"))
	 (cond
	    ((pred p)
	     p)
	    ((%unresolved? p)
	     p)
	    ((not p)
	     #f)
	    (else
	     (resolve-search-parent p e pred))))))

;*---------------------------------------------------------------------*/
;*    resolve-counter ...                                              */
;*---------------------------------------------------------------------*/
(define (resolve-counter n e cnt val . opt)
   (let ((c (assq (symbol-append cnt '-counter) e)))
      (if (not (pair? c))
	  (if (or (null? opt) (not (car opt)) (null? e))
	      (skribe-error cnt "Orphan node" n)
	      (begin
		 (set-cdr! (last-pair e)
			   (list (list (symbol-append cnt '-counter) 0)
				 (list (symbol-append cnt '-env) '())))
		 (resolve-counter n e cnt val)))
	  (let* ((num (cadr c))
		 (nval (if (integer? val)
			   val
			   (+ 1 num))))
	     (let ((c2 (assq (symbol-append cnt '-env) e)))
		(set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2))))
	     (cond
		((integer? val)
		 (set-car! (cdr c) val)
		 (car val))
		((not val)
		 val)
		(else
		 (set-car! (cdr c) (+ 1 num))
		 (+ 1 num)))))))

;*---------------------------------------------------------------------*/
;*    resolve-ident ...                                                */
;*---------------------------------------------------------------------*/
(define (resolve-ident ident markup n e)
   (with-debug 4 'resolve-ident
      (debug-item "ident=" ident)
      (debug-item "markup=" markup)
      (debug-item "n=" (if (markup? n) (markup-markup n) n))
      (if (not (string? ident))
	  (skribe-type-error 'resolve-ident
			     "Illegal ident"
			     ident
			     "string")
	  (let ((mks (find-markups ident)))
	     (and mks
		  (if (not markup)
		      (car mks)
		      (let loop ((mks mks))
			 (cond
			    ((null? mks)
			     #f)
			    ((is-markup? (car mks) markup)
			     (car mks))
			    (else
			     (loop (cdr mks)))))))))))