; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Interfaces
;
; An interface has four fields:
;   - A procedure for looking up names in the interface.  The procedure
;     accepts a name and a phase, and returns a base name and a type.  
;     If the name is not exported the base name is #F.
;   - A procedure for walking over the declarations in the interfaces.
;     The name, base-name, phase, and type of each exported name are passed
;     to the action procedure.
;   - A procedure for walking over all phases of a given name.  It
;     accepts an action procedure and a name.  The base-name, phase
;     and type of each export of that name are passed to the action
;     procedure.
;   - A population containing the structures that export this interface and
;     any compound or modified interfaces that build on it.  This population
;     is used for propogating changes when an interface or structure is
;     redefined.
;   - A name for debugging.

(define-record-type interface :interface
  (really-make-interface ref walk walk-phases clients name)
  interface?
  (ref ref-method)
  (walk walk-method)
  (walk-phases walk-phases-method)
  (clients interface-clients)
  (name interface-name set-interface-name!))

(define-record-discloser :interface
  (lambda (int)
    (list 'interface (interface-name int))))

(define (make-interface ref walk walk-phases name)
  (really-make-interface ref
			 walk
			 walk-phases
			 (make-population)
			 name))

; The generic lookup function, and a simplified version for use when the
; base name and type are not needed.

(define (interface-ref int name phase)
  ((ref-method int) name phase))

(define (interface-member? int name phase)
  (receive (base-name type)
      (interface-ref int name phase)
    base-name))

; The generic walk function.

(define (for-each-declaration proc int)
  ((walk-method int) proc))

; Walking over all phases

(define (for-each-phase proc int name)
  ((walk-phases-method int) proc name))

; Adding to the client population.

(define (note-reference-to-interface! int thing)
  (let ((pop (interface-clients int)))
    (if pop
	(add-to-population! thing pop))))

; Adding a late name.

(define (note-interface-name! int name)
  (if (and name (not (interface-name int)))
      (set-interface-name! int name)))

;----------------
; Simple interfaces.  ITEMS is a list of items of the form:
;  - <name>			   ; use the default type, phase 0
;  - (<name> <type>)		   ; use <type>, phase 0
;  - (<name> <phase> <type>)       ; use <phase> and <type>
;  - ((<name> ...) <type>)	   ; use <type> for each <name>, phase 0
;  - ((<name> ...) <phase> <type>) ; use <type> for each <name>
;
; We make a table of the names and use it appropriately.

(define (make-simple-interface name items)
  (let ((table (make-simple-interface-table items)))
    (make-interface (lambda (name phase)
		      (receive (type token) (name+phase-table-ref table name phase)
			(if type
			    (values name type)
			    (values #f #f))))
		    (lambda (proc)
		      (name+phase-table-walk (lambda (name phase type)
					       (proc name name phase type))
					     table))
		    (lambda (proc name)
		      (name+phase-table-walk-phases (lambda (phase type)
						      (proc name phase type))
						    table name))
		    name)))

; The table maps a name to one of the following:
; - a type (meaning a phase-0 export)
; - a table mapping phases to types

(define (make-simple-interface-table items)
  (let ((table (make-name+phase-table)))
    (for-each (lambda (item)
		(receive (names phase type)
		    (parse-simple-interface-item item)
		  (for-each (lambda (name)
			      (name+phase-table-set! table name phase #f type))
			    names)))
	      items)
    (make-name+phase-table-immutable! table)
    table))

; returns names phase type
(define (parse-simple-interface-item item)
  (if (pair? item)
      (let* ((names (car item))
	     (names (if (pair? names)
			names
			(list names)))
	     (rest (cdr item)))
	(if (integer? (car rest))
	    (values names
		    (car rest)
		    (if (pair? (cdr rest))
			(cadr rest)
			undeclared-type))
	    (values names 
		    0
		    (car rest))))
      (values (list item) 0 undeclared-type)))
	
	    

;----------------
; Compound interfaces
;
; A compound interface is the union of a set of existing interfaces.
; To do lookups or walks we walk down the list of included interfaces.

(define (make-compound-interface name . ints)
  (let ((int (make-interface (lambda (name phase)
			       (let loop ((ints ints))
				 (if (null? ints)
				     (values #f #f)
				     (receive (new-name type)
					 (interface-ref (car ints) name phase)
				       (if new-name
					   (values new-name type)
					   (loop (cdr ints)))))))
			     (lambda (proc)
			       (for-each (lambda (int)
					   (for-each-declaration proc int))
					 ints))
			     (lambda (proc name)
			       (for-each (lambda (int)
					   (for-each-phase proc int name))
					 ints))
			     name)))
    (for-each (lambda (i)
		(note-reference-to-interface! i int))
	      ints)
    int))

;----------------
; Modified interfaces.
;
; We return a procedure that uses COMMANDS to modify any interface it is
; passed.  We parse the commands first so that errors are detected before
; the structure that exports the modified interace is installed anywhere.
;
; Commands are:
;  (prefix <symbol>)
;      Add <symbol> to the beginning of every name in INTERFACE.
;  (expose <symbol> ...)
;      Export only those names in INTERFACE that are listed.
;  (hide <symbol> ...)
;      Do not export any of the names listed.
;  (alias (<old> <new>) ...)
;      Make name <old> also visible as <new>.
;  (rename (<old> <new>) ...)
;      Make name <old> visible as <new> but not as <old>.
; The commands are interpreted last-to-first.  Thus
;  ((expose foo:bar) (prefix foo:))
; and
;  ((prefix foo:) (expose bar))
; both make BAR visible as FOO:BAR but
;  ((expose bar) (prefix foo:))
; does not allow any names to be seen.

(define (make-modified-interface-maker commands)
  (if (and (list? commands)
	   (every okay-command? commands))
      (receive (alist hidden default)
	  (process-commands commands)
	(lambda (interface)
	  (let ((lookup (make-lookup alist hidden default interface))
		(walker (make-interface-walker alist hidden default interface))
		(phase-walker (make-phase-walker alist hidden default interface)))
	    (let ((int (make-interface lookup walker phase-walker #f)))
	      (note-reference-to-interface! interface int)
	      int))))
      (assertion-violation 'make-modified-interface-maker
			   "badly-formed structure modifiers" commands)))

; We process COMMANDS and compute three values:
;   - an alist mapping visible names to their real names in the package
;   - a list of names that are hidden (these may also appear in the alist;
;     the hiding overrides the alist).      
;   - a default, which applies to all other names:
;         = #f, there are no other visible names
;         = #t, all other names are visible
;         = <symbol>, names beginning with this prefix are visible
;
; We just loop over the commands, dispatching on the type of command.

(define (process-commands commands)
  (let loop ((alist '())
	     (hidden '())
	     (default #t)
	     (commands (reverse commands)))
    (if (null? commands)
	(values (filter (lambda (pair)
			  (not (memq (car pair) hidden)))
			alist)
		hidden
		default)
	(receive (alist hidden default)
	    (let ((proc (case (caar commands)
			  ((prefix) process-prefix)
			  ((expose) process-expose)
			  ((hide)   process-hide)
			  ((alias)  process-alias)
			  ((rename) process-rename))))
	      (proc (cdar commands) alist hidden default))
	  (loop alist hidden default (cdr commands))))))

; Checks that COMMAND is properly formed.

(define (okay-command? command)
  (and (list? command)
       (pair? command)
       (symbol? (car command))
       (pair? (cdr command))
       (let ((args (cdr command)))
	 (case (car command)
	   ((prefix)
	    (and (symbol? (car args))
		 (null? (cdr args))))
	   ((expose hide)
	    (every symbol? args))
	   ((alias rename)
	    (every (lambda (spec)
		     (and (list? spec)
			  (= 2 (length spec))
			  (symbol? (car spec))
			  (symbol? (cadr spec))))
		   args))
	   (else
	    #f)))))

; We add the prefix to the names in ALIST and HIDDEN.  If DEFAULT is already
; a prefix we add this one to it, otherwise the prefix is the new default.

(define (process-prefix args alist hidden default)	     
  (let ((prefix (car args)))
    (values (map (lambda (pair)
		   (cons (symbol-append prefix (car pair))
			 (cdr pair)))
		 alist)
	    (map (lambda (name)
		   (symbol-append prefix name))
		 hidden)
	    (cond ((symbol? default)
		   (symbol-append default prefix))
		  ((not default)
		   #f)
		  (else
		   prefix)))))

; We make a new ALIST with the exposed names and with package names are looked
; up in the current state.  Then we start again with no hidden names and no
; default.

(define (process-expose args alist hidden default)	     
  (values (let loop ((args args) (new-alist '()))
	    (if (null? args)
		(reverse new-alist)
		(let* ((name (car args))
		       (pname (interface-lookup name alist hidden default)))
		  (loop (cdr args)
			(if pname
			    (cons (cons name pname)
				  new-alist)
			    new-alist)))))
	  '()		    
	  #f))

; Just add the names to the hidden list.

(define (process-hide args alist hidden default)
  (values alist
	  (append args hidden)
	  default))

; Add the new aliases to ALIST.

(define (process-alias args alist hidden default)
  (values (append (map (lambda (spec)
			 (cons (cadr spec)
			       (interface-lookup (car spec) alist hidden default)))
		       args)
		  alist)
	  hidden
	  default))

; Add the new aliases to ALIST and add the old names to HIDDEN.

(define (process-rename args alist hidden default)
  (values (append (map (lambda (spec)
			 (cons (cadr spec)
			       (interface-lookup (car spec) alist hidden default)))
		       args)
		  alist)
	  (append (map car args) hidden)
	  default))

;----------------
; Look up a name, returning the name by which it is known in the base structure.
;   - If it is in HIDDEN then it is not exported.
;   - If there is an alias, then return the alias.
;   - If there is no default the name is not exported.
;   - A default of #T means every name is passed through.
;   - Otherwise, check that NAME begins with the default and return the
;     suffix after the default.

(define (interface-lookup name alist hidden default)
  (cond ((memq name hidden)
	 #f)
	((assq name alist)
	 => cdr)
	((not default)
	 #f)
	((eq? default #t)
	 name)
	((prefix-match? (symbol->string name)
			(symbol->string default))
	 (remove-prefix (symbol->string name)
			(symbol->string default)))
	(else
	 #f)))

; Curried version of INTERFACE-LOOKUP for making the INTERFACE-REF method for
; modified structures.

(define (make-lookup alist hidden default interface)
  (lambda (name phase)
    (let ((alias (interface-lookup name alist hidden default)))
      (if alias
	  (interface-ref interface alias phase)
	  (values #f #f)))))

; True if NAME begins with PREFIX (and is not just PREFIX).

(define (prefix-match? name prefix)
  (and (< (string-length prefix)
	  (string-length name))
       (let loop ((i 0))
	 (cond ((= i (string-length prefix))
		#t)
	       ((char=? (string-ref name i)
			(string-ref prefix i))
		(loop (+ i 1)))
	       (else
		#f)))))

; Return the portion of NAME that follows PREFIX.

(define (remove-prefix name prefix)
  (string->symbol (substring name
			     (string-length prefix)
			     (string-length name))))

;----------------
; Return a procedure for walking over the declarations in a modified interface.
; There are two helpers, depending on whether names are passed on by default.

(define (make-interface-walker alist hidden default interface)
  (lambda (proc)
    (if default
	(walk-default proc alist hidden default interface))
    (walk-alist proc alist hidden interface)))

; If there is a default we need to walk over the declarations in the base
; interface and pass on the ones that are not hidden.

(define (walk-default proc alist hidden default interface)
  (for-each-declaration
   (lambda (name base-name phase type)
     (let ((new-name
	    (cond ((symbol? default)
		   (symbol-append default name))
		  (else name))))
       (if (not (memq new-name hidden))
	   (proc new-name
		 base-name
		 phase
		 type))))
   interface))
	 
; With no default, all of the names are in the ALIST and we do not need to
; walk over the declarations in the base interface.

(define (walk-alist proc alist hidden interface)
  (for-each (lambda (pair)
	      (let ((new-name (car pair)))
		(if (not (memq new-name hidden))
		    (for-each-phase (lambda (base-name phase type)
				      (proc new-name base-name phase type))
				    interface (cdr pair)))))
	    alist))

;----------------
; Return a procedure for walking over the phases of an export in a modified interface.

(define (make-phase-walker alist hidden default interface)
  (lambda (proc name)
    (cond
     ((interface-lookup name alist hidden default)
      => (lambda (alias)
	   (for-each-phase proc interface alias))))))
