; Module header is generated automatically
#cs(module xlink-parser mzscheme
(require "common.ss")
(require "myenv.ss")
(require "util.ss")
(require "srfi-13-local.ss")
(require "access-remote.ss")
(require "sxpathlib.ss")

;; Parser for XML documents that contain XLink elements
;
; This software is in Public Domain.
; IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.
;
; Please send bug reports and comments to:
;   lisovsky@acm.org      Kirill Lisovsky
;   lizorkin@hotbox.ru    Dmitry Lizorkin
;
; Returns an SXML presentation for a document plus additional information
; extracted from XLink markup (described below)
;
; 'SSAX:XML->SXML+xlink' function is the core of the programme. This funcion
; is a modified Oleg Kiselyov's 'SSAX:XML->SXML' function.
; 'SSAX:XML->SXML+xlink' has a complicated seed which consists of ten elements:
;  xlink:seed = (list  mode  sxlink-arcs  sxpointer  stack
;                      locators+resources  arcs  declared-labels)
;
; 1. mode = 'general, 'extended or 'none. They have the following meaning:
;  - 'general - there are no XLink elements among current element's ancestors.
; So, 'extended' or 'simple' elements are expected (others don't have any XLink
; semantical meaning)
;  - 'extended - for elements that are direct children of an extended link
; element, i.e. 'locator', 'resource' or 'arc'
;  - 'none - no XLink elements are expected niether in the current element
; nor in any of its descendants
;
; 2. sxlink-arcs - contains information extracted from XLink elements.
;  sxlink-arcs = (list  sxlink-arc
;                          sxlink-arc
;                          ...)
;  sxlink-arc - as defined in the SXLink Specification
;
; 3. Reverse S-expression representation for XPointer ChildSeq for a currently
; processed element
;  sxpointer ::= (listof number)
; For example, '(5 4 1) corresponds to "/1/4/5" 
;
; 4. stack - a list of stack-elements. This list has the following semantics:
; - new stack-element is added when the beginning of each element is processed
; - the stack-element is consumed at the finish-element (of the same element)
;  stack = (list  stack-element
;                 stack-element
;                 ...)
;  stack-element = (list  position  xlink-values)
;  position - a position within a file
;  xlink-values = (list  type  href  role  arcrole  show  actuate  label  from  to)
; where, for example, 'type' is the value of xlink:type attribute or #f if
; there is no such attribute
;
; The other parameters of the seed are presented when an extended link is
; processed
;
; 5. locators+resources - locator and resource elements defined within an
; extended link. They are temporarily stored in this parameter. This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  locators+resources = (list  locator-or-resource
;                              locator-or-resource
;                              ...)
;  locator-or-resource = (list  uri  fragment  role  label
;                               position  element)
;  label - a string representing the value of xlink:label attribute, or #f if
; this attribute was omitted
;
; 6. arcs - information about arce defined within an extended link. This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  arcs = (list  arc-info
;                arc-info
;                ...)
;  arc-info = (list  arcrole  show  actuate  from  to
;                    position  element)
;  from - a string representing the value of xlink:from attribute, or #f if
; this attribute was omitted
;  to - the same for an xlink:to attribute
;
; 7. declared-labels - labels declared within an extended link. This parameter
; is used for constraint checking
;  declared-labels = (list  label  label ...)
;  label - a string

; Some global constants
(define xlink:namespace-uri 'http://www.w3.org/1999/xlink)
(define xlink:linkbase-uri "http://www.w3.org/1999/xlink/properties/linkbase")

;=========================================================================
; A 'seed' datatype
;  xlink:seed = (list  mode  sxlink-arcs  sxpointer  stack
;                      locators+resources  arcs  declared-labels)
; The last three parameters are optional. See a head comment for details

;------------------------------------------------
; Two constructors for a seed
; They are introducted in order to control (possible) future modifications of
; a 'seed' list

; This function constructs a seed consisting only of six compulsory elements
(define (xlink:make-small-seed mode sxlink-arcs sxpointer stack)
  (list mode sxlink-arcs sxpointer stack))

; The similar function which makes a full-length seed
(define (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)
  (list mode sxlink-arcs sxpointer stack
        locators+resources arcs declared-labels))

;------------------------------------------------
; Accessor functions

(define (xlink:seed-mode seed)
  (car seed))
(define (xlink:seed-sxlink-arcs seed)
  (cadr seed))
(define (xlink:seed-sxpointer seed)
  (list-ref seed 2))
(define (xlink:seed-stack seed)
  (list-ref seed 3))

; We assume that the seed has the full length for the latter four functions
(define (xlink:seed-locators+resources seed)
  (list-ref seed 4))
(define (xlink:seed-arcs seed)
  (list-ref seed 5))
(define (xlink:seed-declared-labels seed)
  (list-ref seed 6))


;=========================================================================
; Here basic functions for special datatypes are collected

;------------------------------------------------
; 2. 'sxlink-arcs' datatype

; Adds the arc defined by the XLink simple link to 'sxlink-arcs'
(define (xlink:add-simple
         xlink-values element position sxpointer sxlink-arcs)
  (let ((href (xlink:values-href xlink-values))
        (role (xlink:values-role xlink-values))
        (arcrole (xlink:values-arcrole xlink-values))
        (title (xlink:values-title xlink-values))
        (show (xlink:values-show xlink-values))
        (actuate (xlink:values-actuate xlink-values)))
    (if
     (not href)   ; the link is untraversable
     sxlink-arcs  ; no arc added
     (call-with-values
      (lambda ()
        (let ((lst (string-split href (list #\#) 2)))
          (cond
            ((= (length lst) 1)  ; no XPointer fragment identifier
             (values (car lst) #f))
            ((= (string-length (car lst)) 0)  ; addresses the same document
             (values #f (cadr lst)))
            (else
             (values (car lst) (cadr lst))))))
      (lambda (uri-ending fragment)
        (cons
         `(,(if (equal? arcrole xlink:linkbase-uri)
                'linkbase 'simple)
           (from
            (uri)  ; goes from this document
            (nodes ,element)
            (xpointer ,(xlink:sxpointer->childseq sxpointer)))
           (to
            (uri ,@(if uri-ending (list uri-ending) '()))
            ,@(if fragment `((xpointer ,fragment)) '())
            ,@(if role `((role ,role)) '())
            ,@(if title `((title ,title)) '()))
           ,@(if arcrole `((arcrole ,arcrole)) '())
           ,@(if show `((show ,show)) '())
           ,@(if actuate `((actuate ,actuate)) '())
           (declaration
            (uri)  ; in this document
            (nodes ,element)
            (xpointer ,(xlink:sxpointer->childseq sxpointer))
            (position ,position)))
         sxlink-arcs))))))

; This function appends information to 'sxlink-arcs' according to
; 'locators+resources' and 'arcs' parameters.
; The function is called at the end-tag of an extended link element.
(define (xlink:add-extended
         locators+resources arcs sxlink-arcs declaration)
  (let (; like map, but applies the function to each pair of the arguments
        (map-join
         (lambda (func arg-lst1 arg-lst2)
           (let ((arg-lst1 (reverse arg-lst1)))
             (let iterate-second ((lst2 (reverse arg-lst2))
                                  (res '()))
               (if
                (null? lst2)  ; everyone processed
                res
                (let iterate-first ((lst1 arg-lst1)
                                    (res res))
                  (if
                   (null? lst1)  ; the iteration loop finished
                   (iterate-second (cdr lst2) res)
                   (iterate-first
                    (cdr lst1)
                    (cons (func (car lst1) (car lst2)) res)))))))))
        ; a stub for determining whether a locator-or-resouces is a local
        ; or remote one
        (resource?
         (lambda (locator-or-resource)
           ; Resource iff info contains subelement 'nodes
           (assq 'nodes (xlink:resource-data locator-or-resource)))))    
    (let loop ((arcs arcs)
               (sxlink-arcs sxlink-arcs))
      (if
       (null? arcs)  ; all arcs processed
       sxlink-arcs
       (loop
        (cdr arcs)
        (let ((arc-info (car arcs)))
          (append
           (map-join
            (lambda (starting ending)
              `(,(cond  ; determining arc name
                   ((xlink:arc-info-linkbase arc-info)                    
                    'linkbase)
                   ((and (resource? starting)
                         (not (resource? ending)))
                    'outbound)
                   ((and (not (resource? starting))
                         (resource? ending))
                    'inbound)
                   ((and (resource? starting) (resource? ending))
                    'local-to-local)
                   (else
                    'third-party))
                (from ,@(xlink:resource-data starting))
                (to ,@(xlink:resource-data ending))
                ,@(xlink:arc-info-data arc-info)
                ,declaration))
            (let ((from (xlink:arc-info-from arc-info)))
              (if
               (not from)  ; arc outgoes from every resource
               locators+resources
               (filter
                (lambda (locator-or-resource)
                  (equal? from
                          (xlink:resource-label locator-or-resource)))
                locators+resources)))
            (let ((to (xlink:arc-info-to arc-info)))
              (if
               (not to)  ; arc comes to every resource
               locators+resources
               (filter
                (lambda (locator-or-resource)
                  (equal? to
                          (xlink:resource-label locator-or-resource)))
                locators+resources))))
           sxlink-arcs)))))))

;------------------------------------------------
; 3. 'sxpointer' datatype
; Reverse S-expression representation for XPointer ChildSeq for a currently
; processed element
;  sxpointer ::= (listof number)
; For example, '(5 4 1) corresponds to "/1/4/5" 

(define (xlink:sxpointer->childseq sxpointer)
  (apply
   string-append
   (map
    (lambda (num) (string-append "/" (number->string num)))
    (reverse sxpointer))))

; Forms sxpointer for the following sibling element of the current element
(define (xlink:sxpointer4sibling sxpointer)
  (cons (+ 1 (car sxpointer)) (cdr sxpointer)))

;------------------------------------------------
; 5. 'locators+resources' datatype
; locators+resources - locator and resource elements defined within an
; extended link. They are temporarily stored in this parameter. This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  locators+resources = (list  locator-or-resource
;                              locator-or-resource
;                              ...)
;  locator-or-resource = (list  label  resource-data)
;  resource-data - whatever required to describe the resource in terms of
; the SXLink Specification

; Constructor
(define (xlink:make-locator-or-resource label resource-info)
  (list label resource-info))

; Accessors
; NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:resource-label locator-or-resource)
  (car locator-or-resource))
(define (xlink:resource-data locator-or-resource)
  (cadr locator-or-resource))

; If the following XLink constraint is fulfilled, adds information about the
; XLink locator element to 'locators+resources'. Otherwise, displays an error
; message and doesn't add anything.
;  Constraint: Attributes on Locator Element
;  The locator-type element must have the locator attribute (see 5.4 Locator
;  Attribute (href)). The locator attribute (href) must have a value supplied.
(define (xlink:add-locator xlink-values position element locators+resources)
  (let ((href (xlink:values-href xlink-values))
        (role (xlink:values-role xlink-values))
        (title (xlink:values-title xlink-values))
        (label (xlink:values-label xlink-values)))
    (cond
      ((not href)
       (xlink:parser-error
        position "locator element doesn't have an xlink:href attribute")
       locators+resources)
      (else
       (let ((lst (string-split href (list #\#) 2)))
         (call-with-values
          (lambda ()
            (cond
              ((= (length lst) 1) (values (car lst) #f))
              ((= (string-length (car lst)) 0) (values #f (cadr lst)))
              (else (values (car lst) (cadr lst)))))
          (lambda (uri fragment)
            (cons
             (xlink:make-locator-or-resource
              label
              `((uri ,@(if uri (list uri) '()))
                ,@(if fragment `((xpointer ,fragment)) '())
                ,@(if role `((role ,role)) '())
                ,@(if title `((title ,title)) '())))
             locators+resources))))))))

; Adds information concerning XLink resource element to 'locators+resources'
(define (xlink:add-resource xlink-values element sxpointer locators+resources)
  (let ((role (xlink:values-role xlink-values))
        (label (xlink:values-label xlink-values))
        (title (xlink:values-title xlink-values)))
    (cons
     (xlink:make-locator-or-resource
      label
      `((uri)
        (nodes ,element)
        (xpointer ,(xlink:sxpointer->childseq sxpointer))
        ,@(if role `((role ,role)) '())
        ,@(if title `((title ,title)) '())))
     locators+resources)))

;------------------------------------------------
; 6. 'arcs' datatype
; arcs - information about arce defined within an extended link. This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  arcs = (list  arc-info
;                arc-info
;                ...)
;  arc-info = (list  from  to  linkbase  position  data)
;  linkbase - a boolean: whether a linkbase arc
;  arc-data - whatever required to describe the arc in terms of the SXLink
; Specification

; Constructor
(define (xlink:make-arc-info from to linkbase position data)
  (list from to linkbase position data))

; Accessors
; NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:arc-info-from arc-info)
  (car arc-info))
(define (xlink:arc-info-to arc-info)
  (cadr arc-info))
(define (xlink:arc-info-linkbase arc-info)
  (list-ref arc-info 2))
(define (xlink:arc-info-position arc-info)
  (list-ref arc-info 3))
(define (xlink:arc-info-data arc-info)
  (list-ref arc-info 4))

; Adds arc information to 'arcs' datatype. A side effect - checks the following
; XLink constraint:
;  Constraint: No Arc Duplication
;  Each arc-type element must have a pair of from and to xlink-values that does
;  not  repeat the from and to xlink-values (respectively) for any other
;  arc-type element in the same extended link; that is, each pair in a link
;  must be unique.
(define (xlink:add-arc xlink-values position element arcs)
  (let ((arcrole (xlink:values-arcrole xlink-values))
        (title (xlink:values-title xlink-values))
        (show (xlink:values-show xlink-values))
        (actuate (xlink:values-actuate xlink-values))
        (from (xlink:values-from xlink-values))
        (to (xlink:values-to xlink-values)))
    (let loop ((as arcs))
      (if
       (null? as)
       (cons
        (xlink:make-arc-info
         from to
         (equal? arcrole xlink:linkbase-uri)
         position
         `(,@(if arcrole `((arcrole ,arcrole)) '())
           ,@(if title `((title ,title)) '())
           ,@(if show `((show ,show)) '())
           ,@(if actuate `((actuate ,actuate)) '())))
        arcs)
       (let ((from2 (xlink:arc-info-from (car as)))
             (to2 (xlink:arc-info-to (car as))))
         (when
             (and (or (not from) (not from2) (equal? from from2))
                  (or (not to) (not to2) (equal? to to2)))
           (xlink:parser-error position "duplicate arcs - xlink:from"
                        (if from (string-append "=" from) " - omitted")
                        ", xlink:to"
                        (if to (string-append "=" to) " - omitted")))
         (loop (cdr as)))))))

; XLink specification, 5.1.3:
;  If no arc-type elements are provided in an extended link, then by extension
;  the missing from and to xlink-values are interpreted as standing for all the
;  labels in that link.
; Inserts such a default arc if 'arcs' are empty
(define (xlink:add-default-arc element arcs)
  (if (null? arcs)
      (list (xlink:make-arc-info
             #f #f #f
             0  ; position is dummy here, since it will never be used
             '()  ; none of the attributes arcrole, title, show, actuate
             ))
      arcs))

;------------------------------------------------
; 7. 'declared-labels' datatype
; declared-labels - labels declared within an extended link. This parameter
; is used for constraint checking
;  declared-labels = (list  label  label ...)
;  label - a string

; If an xlink:label attribute is presented in 'xlink-values', it's value is added
; to 'declared-labels'. Otherwise, 'declared-labels' remain unchainged
(define (xlink:add-declared-label xlink-values declared-labels)
  (let((label (xlink:values-label xlink-values)))
    (if(not label)
       declared-labels
       (cons label declared-labels))))

; The function checks the following XLink constraint
;  Constraint: label, from, and to xlink-values
;  The value of a label, from, or to attribute must be an NCName. If a value
;  is supplied for a from or to attribute, it must correspond to the same value
;  for some label attribute on a locator- or resource-type element that appears
;  as a direct child inside the same extended-type element as does the arc-type
;  element.
; Error message is displayed if some label was undeclared.
; The function always returns #t.
; It is called at the end-tag of an extended link element
(define (xlink:all-labels-declared arcs declared-labels)
  (let loop ((arcs arcs))
    (if
     (null? arcs)
     #t
     (let((arc-info (car arcs)))
       (let((from (xlink:arc-info-from arc-info))
            (to (xlink:arc-info-to arc-info))
            (position (xlink:arc-info-position arc-info)))       
         (when (and from (not (member from declared-labels)))
           (xlink:parser-error position "label not defined - xlink:from=" from))
         (when (and to (not (member to declared-labels)))
           (xlink:parser-error position "label not defined - xlink:to=" to))
         (loop (cdr arcs)))))))


;=========================================================================
; Some simple functions working with attributes
;  xlink-values = (list
;                   type href role arcrole title show actuate label from to)

;------------------------------------------------
; Trivial constructor and accessor functions
; These functions are used as a level of abstraction

; Constructs a datatype (just a list in a current implementation) which
; contains xlink-values of all xlink-related attributes. For example, 'type'
; is the value of xlink:type attribute or #f if there is no such attribute.
; This datatype will be called 'xlink-values' in the latter text
(define (xlink:construct-xlink-values
         type href role arcrole title show actuate label from to)
  (list type href role arcrole title show actuate label from to))

; Accessors
; NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:values-type xlink-values)
  (car xlink-values))
(define (xlink:values-href xlink-values)
  (cadr xlink-values))
(define (xlink:values-role xlink-values)
  (list-ref xlink-values 2))
(define (xlink:values-arcrole xlink-values)
  (list-ref xlink-values 3))
(define (xlink:values-title xlink-values)
  (list-ref xlink-values 4))
(define (xlink:values-show xlink-values)
  (list-ref xlink-values 5))
(define (xlink:values-actuate xlink-values)
  (list-ref xlink-values 6))
(define (xlink:values-label xlink-values)
  (list-ref xlink-values 7))
(define (xlink:values-from xlink-values)
  (list-ref xlink-values 8))
(define (xlink:values-to xlink-values)
  (list-ref xlink-values 9))

;------------------------------------------------
; Functions which read attributes

; The function is given a list called 'attributes' (in SSAX parser). This list
; has the form
;  attributes = (list  attribute 
;                      attribute
;                      ...)
;  attribute = (cons  (cons  namespace-prefix  attribute-name)
;                     attribute-value )
;           or (cons  attribute-name  attribute-value )
;  namespaces - defined in "ssax.scm"
; reads XLink attributes' values and returns a 'xlink-values' datatype
; (the result of 'xlink:construct-xlink-values' function)
(define (xlink:read-attributes attributes namespaces)
  (let loop ((attributes attributes)
             (type #f) (href #f) (role #f) (arcrole #f) (title #f) (show #f)
             (actuate #f) (label #f) (from #f) (to #f))
    (if(null? attributes)  ; the attribute list is over
       (xlink:construct-xlink-values
        type href role arcrole title show actuate label from to)
       (let ((attribute (car attributes)))                  
         (if
          (not (pair? (car attribute)))  ; attribute doesn't have namespace
          (loop (cdr attributes) 
                type href role arcrole title show actuate label from to)
          (let ((namespace-prefix (caar attribute))
                (attribute-name (cdar attribute))
                (attribute-value (cdr attribute)))
            (let ((namespace-uri
                   (let rpt ((ns namespaces))
                     (cond
                       ((null? ns) namespace-prefix)
                       ((equal? (cadar ns) namespace-prefix) (cddar ns))
                       (else (rpt (cdr ns)))))))
              (if
               (not (equal? namespace-uri xlink:namespace-uri))
               (loop (cdr attributes)
                     type href role arcrole title show actuate label from to)
               (case attribute-name
                 ((type) (loop (cdr attributes) attribute-value href role 
                               arcrole title show actuate label from to))
                 ((href) (loop (cdr attributes) type attribute-value role
                               arcrole title show actuate label from to))
                 ((role) (loop (cdr attributes) type href attribute-value 
                               arcrole title show actuate label from to))
                 ((arcrole)
                  (loop (cdr attributes) type href role attribute-value title
                        show actuate label from to))
                 ((title) (loop (cdr attributes) type href role arcrole
                                attribute-value show actuate label from to))
                 ((show) (loop (cdr attributes) type href role arcrole title
                               attribute-value actuate label from to))
                 ((actuate) (loop (cdr attributes) type href role arcrole
                                  title show attribute-value label from to))
                 ((label) (loop (cdr attributes) type href role arcrole title
                                show actuate attribute-value from to))
                 ((from) (loop (cdr attributes) type href role arcrole title
                               show actuate label attribute-value to))
                 ((to) (loop (cdr attributes) type href role arcrole title
                             show actuate label from attribute-value))
                 (else (loop (cdr attributes) type href role arcrole title
                             show actuate label from to)))))))))))

; Reads SXML element's attributes
;  element - an SXML node representing an element
;  ns-prefixes = (list  (list  prefix  namespace-uri)
;                       (list  prefix  namespace-uri)
;                       ...)
;  prefix - a symbol
;  namespace-uri - a string
; An 'xlink-values' datatype is returned
(define (xlink:read-SXML-attributes element ns-prefixes)
  (let ((attr-node ((select-kids (ntype?? '@)) element)))
    (if
     (null? attr-node)  ; no attributes
     (xlink:construct-xlink-values #f #f #f #f #f #f #f #f #f #f)
     (let loop ((attr-list (cdar attr-node))
                (type #f) (href #f) (role #f) (arcrole #f) (title #f)
                (show #f) (actuate #f) (label #f) (from #f) (to #f))
       (if
        (null? attr-list)
        (xlink:construct-xlink-values
         type href role arcrole title show actuate label from to)
        (let ((attribute-name (symbol->string (caar attr-list)))
              (attribute-value (cadar attr-list)))
          (call-with-values
           (lambda ()
             (cond
               ((string-rindex attribute-name #\:)
                => (lambda (pos)
                     (values
                      (string->symbol (substring attribute-name 0 pos))
                      (string->symbol
                       (substring attribute-name (+ pos 1)
                                  (string-length attribute-name))))))
               (else
                (values #f attribute-name))))
           (lambda (prefix local)
             (if
              (not prefix)   ; this is a non-qualified name
              (loop (cdr attr-list)
                    type href role arcrole title show actuate label from to)
              (let ((namespace-uri
                     (cond
                       ((assoc prefix ns-prefixes)
                        => (lambda (pair)
                             (string->symbol (cadr pair))))
                       (else
                        prefix))))
                (if
                 (not (equal? namespace-uri xlink:namespace-uri))
                 (loop (cdr attr-list)
                       type href role arcrole title show actuate label from to)
                 (case local
                   ((type) (loop (cdr attr-list) attribute-value href role 
                                 arcrole title show actuate label from to))
                   ((href) (loop (cdr attr-list) type attribute-value role
                                 arcrole title show actuate label from to))
                   ((role) (loop (cdr attr-list) type href attribute-value
                                 arcrole title show actuate label from to))
                   ((arcrole)
                    (loop (cdr attr-list) type href role attribute-value title
                          show actuate label from to))
                   ((title) (loop (cdr attr-list) type href role arcrole
                                  attribute-value show actuate label from to))
                   ((show) (loop (cdr attr-list) type href role arcrole title
                                 attribute-value actuate label from to))
                   ((actuate) (loop (cdr attr-list) type href role arcrole title
                                    show attribute-value label from to))
                   ((label) (loop (cdr attr-list) type href role arcrole title
                                  show actuate attribute-value from to))
                   ((from) (loop (cdr attr-list) type href role arcrole title
                                 show actuate label attribute-value to))
                   ((to) (loop (cdr attr-list) type href role arcrole title show 
                               actuate label from attribute-value))
                   (else (loop (cdr attr-list) type href role arcrole title show 
                               actuate label from to))))))))))))))

;------------------------------------------------
; These functions check XLink constrains which limit some attributes' xlink-values

; A helper function which is used by the next one
;  value - a value of an attribute (#f if there is no such attribute)
;  valid-xlink-values - a list of xlink-values which are allowed for this attribute
;  attr-name - a string denotating a name of an attribute (for a message)
;  position - position within a file
; Function always returns #t.
; Side effects: function "cerr"s a message if 'value' is not #f and not within
; 'valid-xlink-values'
(define (xlink:check-helper value valid-xlink-values attr-name position)
  (cond
    ((not value) )  ; a value is #f - a correct situation
    ((not (member value valid-xlink-values))
     (xlink:parser-error position "unexpected attribute value - " 
                  attr-name "=" value))
    (else #t)))

;  xlink-values = (type href role arcrole show actuate label from to)
; where, for example, 'type' is the value of xlink:type attribute or #f if
; there is no such attribute (this datatype is a result
; of 'read-xlink-attributes' function)
;  position - position within a file
;
; The function checks the three similar XLink constraints:
;  1. Constraint: type Value
;  The value of the type attribute must be supplied. The value must be one of
;  "simple", "extended", "locator", "arc", "resource", "title", or "none".
;  2. Constraint: show Value
;  If a value is supplied for a show attribute, it must be one of the xlink-values
;  "new", "replace", "embed", "other", and "none".
;  3. Constraint: actuate Value
;  If a value is supplied for an actuate attribute, it must be be one of the
;  xlink-values "onLoad", "onRequest", "other", and "none".
;
; The result is always #t
; Side effects - error messages (printed by
; an 'xlink:check-helper' function above)
(define (xlink:check-type-show-actuate-constraints xlink-values position)
  (xlink:check-helper (xlink:values-type xlink-values)
                      '("simple" "extended" "locator" "arc" "resource"
                        "title" "none")
                      "xlink:type"
                      position)
  (xlink:check-helper (xlink:values-show xlink-values)
                      '("new" "replace" "embed" "other" "none")
                      "xlink:show"
                      position)
  (xlink:check-helper (xlink:values-actuate xlink-values)
                      '("onLoad" "onRequest" "other" "none")
                      "xlink:actuate"
                      position))
    

;=========================================================================
; Functions which perform starting and ending actions for XLink elements
; All these functions have the same signature:
;
; (smth-start position xlink-values xlink:seed)
;  position - position within a file
;  xlink-values = (list  type  href  role  arcrole  show  actuate  label  from  to)
; where, for example, 'type' is the value of xlink:type attribute or #f if
; there is no such attribute
;  xlink:seed = (list  mode  sxlink-arcs  sxpointer  stack
;                      locators+resources  arcs  declared-labels)
; See a head comment for details
;
; (smth-end xlink:parent-seed xlink:seed element)
; element - the SXML presentation of the current element
;
; All the functions return a new 'xlink:seed'

;------------------------------------------------
; A general element
; It is the element which doesn't have any XLink meaning, but its descendants
; might have such a meaning

(define (xlink:general-start position xlink-values seed)
  (let((sxlink-arcs (xlink:seed-sxlink-arcs seed))       
       (sxpointer (xlink:seed-sxpointer seed))
       (stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed
     'general sxlink-arcs (cons 1 sxpointer) stack)))

(define (xlink:general-end parent-seed seed element)
  (let ((mode (xlink:seed-mode parent-seed))
        (sxlink-arcs (xlink:seed-sxlink-arcs seed))
        (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
        (stack (xlink:seed-stack parent-seed)))
    (xlink:make-small-seed mode sxlink-arcs sxpointer stack)))

;------------------------------------------------
; An element and all its descendants don't have any XLink meaning

(define (xlink:none-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:none-end parent-seed seed element)
  parent-seed)
  
;------------------------------------------------
; A simple-link element

(define (xlink:simple-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:simple-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:add-simple 
                             xlink-values element position
                             (xlink:seed-sxpointer parent-seed)
                             (xlink:seed-sxlink-arcs parent-seed)))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed)))
        (xlink:make-small-seed
         mode sxlink-arcs sxpointer stack)))))          

;------------------------------------------------
; An extended-link element

(define (xlink:extended-start position xlink-values seed)
  (let ((sxlink-arcs (xlink:seed-sxlink-arcs seed))
        (sxpointer (cons 1 (xlink:seed-sxpointer seed)))
        (stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-full-seed 'extended sxlink-arcs sxpointer stack
                          '() '() '())))

(define (xlink:extended-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((locators+resources (xlink:seed-locators+resources seed))
            (arcs (xlink:add-default-arc element (xlink:seed-arcs seed)))
            (declared-labels (xlink:seed-declared-labels seed)))           
        (xlink:all-labels-declared arcs declared-labels)      
        (let ((mode (xlink:seed-mode parent-seed))
              (sxlink-arcs
               (xlink:add-extended
                locators+resources arcs (xlink:seed-sxlink-arcs seed)
                `(declaration
                  (uri)  ; declared in this document
                  (nodes ,element)
                  (xpointer ,(xlink:sxpointer->childseq
                              (xlink:seed-sxpointer parent-seed)))
                  (position ,position))))
              (sxpointer
               (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
              (stack (xlink:seed-stack parent-seed)))
          (xlink:make-small-seed mode sxlink-arcs sxpointer stack))))))

;------------------------------------------------
; A locator element

(define (xlink:locator-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))  

(define (xlink:locator-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed))
            (locators+resources 
             (xlink:add-locator xlink-values position element
                                (xlink:seed-locators+resources parent-seed)))
            (arcs (xlink:seed-arcs parent-seed))
            (declared-labels 
             (xlink:add-declared-label 
              xlink-values (xlink:seed-declared-labels parent-seed))))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))

;------------------------------------------------
; A resource element

(define (xlink:resource-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:resource-end parent-seed seed element)
  (let((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let* ((mode (xlink:seed-mode parent-seed))
             (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
             (sxpointer
              (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
             (stack (xlink:seed-stack parent-seed))
             (locators+resources 
              (xlink:add-resource xlink-values element sxpointer
                                  (xlink:seed-locators+resources parent-seed)))
             (arcs (xlink:seed-arcs parent-seed))
             (declared-labels
              (xlink:add-declared-label
               xlink-values (xlink:seed-declared-labels parent-seed))))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))

;------------------------------------------------
; An arc element

(define (xlink:arc-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:arc-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed))
            (locators+resources (xlink:seed-locators+resources parent-seed))           
            (arcs (xlink:add-arc xlink-values position element
                                 (xlink:seed-arcs parent-seed)))
            (declared-labels
             (xlink:seed-declared-labels parent-seed)))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))


;=========================================================================
; Miscellaneous utility functions

;------------------------------------------------
; Functions dealing with position

; Returns posiotion of a port
; NOTE: Specific for different Scheme implementations
(define (xlink:get-port-position port)
  (cond-expand         
   (bigloo
    (string-append "position " (number->string (input-port-position port))))
   (chicken
    (string-append
     "line " (number->string (receive (row col) (port-position port) row))))
   (gambit
    ; DL: was
    ;(string-append "line " (number->string (port-input-line-count port)))
    (string-append "position "
                   (number->string (input-port-byte-position port))))
   (guile
    (string-append "line " (number->string (port-line port))))
   (plt
    (string-append "position " (number->string (file-position port))))
   (else "unknown")))

; This function displays an error message. #t is returned
;  position - position within a file
;  text - a message to display
(define (xlink:parser-error position . text)
  (apply
   cerr
   (if
    (string=? position "unknown")
    (append (list nl "XLink error:" nl) text (list nl))
    (append (list nl "XLink error in " position ":" nl) text (list nl)))))

;------------------------------------------------
; Functions working on branches of an SXML tree

; Helper is used by the following functions in this section
;  action-on-branch ::= (lambda (elem content-nodeset) ...)
;  elem - SXML element that corresponds to the branch
;  content-nodeset - new content
; The lambda should return the new elem
(define (xlink:branch-helper action-on-branch)
  (lambda (document branch-lpath content-nodeset)
    (letrec
        (; Constructs a new branch if it doesn't exist in a document
         (make-new-branch
          (lambda (lpath)
            (if (null? (cdr lpath))  ; lpath consists of a single member
                (cons (car lpath) content-nodeset)
                (list (car lpath) (make-new-branch (cdr lpath))))))
         ; Walks a document
         (tree-walk
          (lambda (elem lpath)
            (if
             (null? lpath)  ; we have reached the desired node
             (action-on-branch elem content-nodeset)
             (let loop ((foll-siblings elem)
                        (prec-siblings '()))
               (cond
                 ((null? foll-siblings)  ; no such branch
                  (cons*
                   (car elem)
                   (make-new-branch lpath)
                   (cdr elem)))
                 ((and (pair? (car foll-siblings))
                       (eq? (caar foll-siblings) (car lpath)))
                  ; match found
                  (append
                   (reverse prec-siblings)
                   (list
                    (tree-walk (car foll-siblings) (cdr lpath)))
                   (cdr foll-siblings)))
                 (else
                  (loop (cdr foll-siblings)
                        (cons (car foll-siblings) prec-siblings)))))))))
      (tree-walk document branch-lpath))))

; Replaces the content of the branch with a new content
;  document - SXML document
;  branch-lpath ::= (listof symbol)
;  branch-lpath - is like an sxpath location path. There must be no more than
; one branch in an SXML tree with this location path. If this branch doesn't
; exist, it will be created as the first branch in a document
;  content-nodeset ::= (listof node)
;  content-nodeset - defines the content of the branch
(define xlink:replace-branch
  (xlink:branch-helper
   (lambda (elem content-nodeset) (cons (car elem) content-nodeset))))

; Appends 'content-nodeset' to the content of the given branch
(define xlink:append-branch
  (xlink:branch-helper
   (lambda (elem content-nodeset) (append elem content-nodeset))))

;------------------------------------------------
; Processing the document URI
; (borrowed from "xlink.scm")

; Given a document, returns its URI (a string)
; #f is returned if there is no "@@/uri" subtree in the document
(define (xlink:get-uri doc)
  (let ((nodeset ((select-kids (ntype?? 'uri))
                  ((select-kids (ntype?? '@@)) doc))))
    (if (null? nodeset)  ; there is no "@@/uri" subtree
        #f
        (cadar nodeset))))

; Adds the URI of the document where the arcs were declared, to sxlink-arcs
; Returns modified sxlink-arcs
(define (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
  (letrec
      ((process-arc
        ; uri-alist ::= (listof (cons uri resolved-uri))
        ; association between the URI and the corresponding resolved one
        ; Returns: (values new-node new-uri-alist)
        (lambda (node uri-alist)
          (case (car node)  ; a node is always an SXML element
            ((linkbase simple inbound outbound third-party local-to-local
              from to declaration)
             ; Recursive application to children
             (call-with-values
              (lambda () (process-nodeset (cdr node) uri-alist))
              (lambda (new-children new-uri-alist)
                (values (cons (car node) new-children)
                        new-uri-alist))))
            ((uri)
             (cond
               ((null? (cdr node))  ; no URI is set
                (values `(uri ,uri) uri-alist))
               ((assoc (cadr node) uri-alist)
                => (lambda (pair)
                     (values `(uri ,(cdr pair)) uri-alist)))
               (else
                (let ((resolved-uri
                       (ar:resolve-uri-according-base uri (cadr node))))
                  (values `(uri ,resolved-uri)
                          (cons
                           (cons (cadr node) resolved-uri)
                           uri-alist))))))
            (else
             (values node uri-alist)))))
       ; Applies the previous function to a nodeset
       (process-nodeset
        (lambda (nodeset uri-alist)
          (let loop ((nset nodeset)
                     (res '())
                     (uri-alist uri-alist))
            (if
             (null? nset)
             (values (reverse res) uri-alist)
             (call-with-values
              (lambda () (process-arc (car nset) uri-alist))
              (lambda (new-node new-uri-alist)
                (loop (cdr nset)
                      (cons new-node res)
                      new-uri-alist))))))))
    (call-with-values
     (lambda () (process-nodeset sxlink-arcs '()))
     (lambda (new-sxlink-arcs dummy)
       new-sxlink-arcs))))
                 

;=========================================================================
; Core features of the parser

;------------------------------------------------
; Handler units for SSAX multi-parser
              
; This function is called by the NEW-LEVEL-SEED handler
; A new 'xlink:seed' is returned
(define (xlink:new-level-seed-handler port attributes namespaces seed)
  (let ((position (xlink:get-port-position port))
        (xlink-values (xlink:read-attributes attributes namespaces)))
    (xlink:check-type-show-actuate-constraints xlink-values position)
    (let((mode (xlink:seed-mode seed))
         (type (xlink:values-type xlink-values)))
      (case mode
        ((general)
         (case (if type (string->symbol type) type)
           ((simple) (xlink:simple-start position xlink-values seed))
           ((extended) (xlink:extended-start position xlink-values seed))
           ((none) (xlink:none-start position xlink-values seed))
           (else (xlink:general-start position xlink-values seed))))
        ((extended)
         (case (if type (string->symbol type) type)
           ((locator) (xlink:locator-start position xlink-values seed))
           ((resource) (xlink:resource-start position xlink-values seed))
           ((arc) (xlink:arc-start position xlink-values seed))
           (else (xlink:none-start position xlink-values seed))))
        ((none) (xlink:none-start position xlink-values seed))
        (else 
         (xlink:parser-error position "internal processor error - mode=" 
                      mode)
         (xlink:none-start position xlink-values seed))))))
  
; This function is called by the FINISH-ELEMENT handler
; A new 'xlink:seed' is returned
(define (xlink:finish-element-handler parent-seed seed element)
  (let((xlink-values (cadar (xlink:seed-stack seed))))
    (let((mode (xlink:seed-mode parent-seed))
         (type (xlink:values-type xlink-values)))
      (case mode
        ((general)
         (case (if type (string->symbol type) type)
           ((simple) (xlink:simple-end parent-seed seed element))
           ((extended) (xlink:extended-end parent-seed 
                                           seed element))
           ((none) (xlink:none-end parent-seed seed element))
           (else (xlink:general-end parent-seed seed element))))
        ((extended)
         (case (if type (string->symbol type) type)
           ((locator) (xlink:locator-end parent-seed 
                                         seed element))
           ((resource) (xlink:resource-end parent-seed 
                                           seed element))
           ((arc) (xlink:arc-end parent-seed seed element))
           (else (xlink:none-end parent-seed seed element))))
        ((none) (xlink:none-end parent-seed seed element))
        (else 
         (xlink:parser-error 0 "internal processor error - mode=" 
                      mode)
         (xlink:none-end parent-seed seed element))))))

; Constructs the member of an axuiliary list
(define (xlink:ending-action xlink:seed)
  (let ((sxlink-arcs (reverse (xlink:seed-sxlink-arcs xlink:seed))))    
    `(sxlink
      (declared-here ,@sxlink-arcs))))

;-------------------------------------------------
; The function which adds XLink-related information to the SXML document

;  document - an SXML document
; The function emulates a 'fold-ts' operation.
; A new SXML document is returned. It contains an auxiliary list with an
; 'sxlink' subtree. If the source document already contains such a
; subtree, it will be replaced. Other subtrees in an auxiliary list will
; remain unchanged.
(define (SXML->SXML+xlink document)
  (letrec
      ((fold-ts
        (lambda (node ns-prefixes seed)
          (let ((xlink-values (xlink:read-SXML-attributes node ns-prefixes)))
            (let ((mode (xlink:seed-mode seed))
                  (type (xlink:values-type xlink-values))
                  (pos "unknown"))
              (let rpt
                ((kids ((select-kids (ntype?? '*)) node))
                 (new-seed
                  (case mode
                    ((general)
                     (case (if type (string->symbol type) type)
                       ((simple)
                        (xlink:simple-start pos xlink-values seed))
                       ((extended)
                        (xlink:extended-start pos xlink-values seed))
                       ((none)
                        (xlink:none-start pos xlink-values seed))
                       (else
                        (xlink:general-start pos xlink-values seed))))
                    ((extended)
                     (case (if type (string->symbol type) type)
                       ((locator)
                        (xlink:locator-start pos xlink-values seed))
                       ((resource)
                        (xlink:resource-start pos xlink-values seed))
                       ((arc)
                        (xlink:arc-start pos xlink-values seed))
                       (else
                        (xlink:none-start pos xlink-values seed))))
                    ((none)
                     (xlink:none-start pos xlink-values seed))
                    (else
                     (xlink:parser-error pos "internal processor error - mode=" mode)
                     (xlink:none-start pos xlink-values seed)))))
                (if
                 (not (null? kids))
                 (rpt (cdr kids)
                      (fold-ts (car kids) ns-prefixes new-seed))
                 (case mode
                   ((general)
                    (case (if type (string->symbol type) type)
                      ((simple) (xlink:simple-end seed new-seed node))
                      ((extended) (xlink:extended-end seed new-seed node))
                      ((none) (xlink:none-end seed new-seed node))
                      (else (xlink:general-end seed new-seed node))))
                   ((extended)
                    (case (if type (string->symbol type) type)
                      ((locator) (xlink:locator-end seed new-seed node))
                      ((resource) (xlink:resource-end seed new-seed node))
                      ((arc) (xlink:arc-end seed new-seed node))
                      (else (xlink:none-end seed new-seed node))))
                   ((none) (xlink:none-end seed new-seed node))
                   (else
                    (xlink:parser-error pos
                     "internal processor error - mode=" mode)
                    (xlink:none-end seed new-seed node))))))))))
  (let* ((ns-prefixes
          (let ((ns-node ((select-kids (ntype?? '*NAMESPACES*))
                          ((select-kids (ntype?? '@@)) document))))
            (if (null? ns-node)
                '()
                (cdar ns-node))))
         (sxlink-arcs
          (xlink:seed-sxlink-arcs
           (fold-ts ((select-kids (ntype?? '*)) document)
                    ns-prefixes
                    (xlink:make-small-seed 'general '() '(1) '()))))
         (uri (xlink:get-uri document)))
    (xlink:append-branch
     document
     '(@@ sxlink declared-here)
     (if uri  ; URI for the document supplied
         (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
         sxlink-arcs)))))

;-------------------------------------------------
; Adds SXLink arc information to SHTML document

(define (SHTML->SHTML+xlink document)
  (letrec
      ((tree-walk
        ; Returns (listof sxlink-arc)
        (lambda (node sxpointer)          
          (let loop
            ((sxlink-arcs
              (if
               (not (and (pair? node) (eq? (car node) 'a)))
               '()  ; it is not an <A> element
               (let ((href ((select-kids (ntype?? '*text*))
                            ((select-kids (ntype?? 'href))
                             ((select-kids (ntype?? '@)) node)))))
                 (if
                  (null? href)  ; <A> doesn't contain href attribute
                  '()
                  (call-with-values
                   (lambda ()
                     (let ((lst (string-split (car href) (list #\#) 2)))
                       (cond
                         ((null? lst)  ; (car href)=""  - the real situation
                          (values (car href) #f))
                         ((= (length lst) 1)  ; no anchor
                          (values (car lst) #f))
                         ((= (string-length (car lst)) 0)
                          (values #f (cadr lst)))
                         (else
                          (values (car lst) (cadr lst))))))
                   (lambda (uri-ending fragment)
                     `((simple
                        (from
                         (uri)  ; from this document
                         (nodes ,node)
                         (xpointer ,(xlink:sxpointer->childseq sxpointer)))
                        (to
                         (uri ,@(if uri-ending (list uri-ending) '()))
                         ,@(if fragment
                               `((xpointer
                                  ,(string-append
                                    "xpointer(descendant::*[a/@name='"
                                    fragment "'])")))
                               '()))
                        (declaration
                         (uri)
                         (nodes ,node)
                         (xpointer
                          ,(xlink:sxpointer->childseq sxpointer))))))
                   )))))
             (kids ((select-kids (ntype?? '*)) node))
             (kid-pos 1))
            (if (null? kids)  ; every child node processed
                sxlink-arcs
                (loop
                 (append sxlink-arcs
                         (tree-walk (car kids) (cons kid-pos sxpointer)))
                 (cdr kids)
                 (+ kid-pos 1)))))))
    (let ((sxlink-arcs (tree-walk document '()))
          (uri (xlink:get-uri document)))
      (xlink:append-branch
       document
       '(@@ sxlink declared-here)
       (if uri  ; URI for the document supplied
           (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
           sxlink-arcs)))))

(provide (all-defined)))