ybot_parser_xml.xtm

;; (if (and (defined? '*xtmlib-ybot-parser-xml-loaded*) *xtmlib-ybot-parser-xml-loaded*)
;;     (sys:load-escape "ybot_parser_xml library already loaded"))
;; (define *xtmlib-ybot-parser-xml-loaded* #f)

;; (define *ybot-lib-dir* "/Users/s2805534/Dropbox/ybot/src/extempore_libs")
;; (if (not (defined? '*ybot-lib-dir*))
;;     (sys:load-escape "Set the *ybot-lib-dir* variable before loading this library"))
;; (sys:load (string-append *ybot-lib-dir* "/ybot_parser.xtm"))


(sys:load-preload-check 'ybot_parser_xml)
(define *xtmlib-ybot_parser_xml-loaded* #f)

(impc:aot:suppress-aot-do
 (sys:load "libs/contrib/ybot/ybot_parser.xtm"))
(impc:aot:insert-forms
 (sys:load "libs/contrib/ybot/ybot_parser.xtm" 'quiet))



;; XML Tag: label, parent, children, attributes, contents, _properties
;; use 'opaque' i8* for List{XMLTag*}*
(bind-type XMLTag <String*,XMLTag*,i8*,List{Pair{String*,String*}*}*,String*,i8> (constructor? . #f) (printer? . #f))

;; provide our own constructor - hide i8* with 'hidden' cast from List{XMLTag*}* 
(bind-func XMLTag:[XMLTag*,String*,XMLTag*,List{XMLTag*}*,List{Pair{String*,String*}*}*,String*,i8]*
  (lambda (label parent children attributes contents properties)
    (let ((tag:XMLTag* (alloc)))
      (tfill! tag label parent (cast children i8*) attributes contents properties)
      tag)))

;; getters and setters 
(bind-func label (lambda (tag:XMLTag*) (tref tag 0)))
(bind-func label (lambda (tag:XMLTag* label_in:String*) (tset! tag 0 label_in)))
(bind-func parent (lambda (tag:XMLTag*) (tref tag 1)))
(bind-func parent (lambda (tag:XMLTag* parent_in:XMLTag*) (tset! tag 1 parent_in)))
(bind-func children (lambda (tag:XMLTag*) (cast (tref tag 2) List{XMLTag*}*)))
(bind-func children (lambda (tag:XMLTag* children_in:List{XMLTag*}*) (cast (tset! tag 2 (cast children_in i8*)) List{XMLTag*}*)))
(bind-func attributes (lambda (tag:XMLTag*) (tref tag 3)))
(bind-func attributes (lambda (tag:XMLTag* attrs_in:List{Pair{String*,String*}*}*) (tset! tag 3 attrs_in)))
(bind-func contents (lambda (tag:XMLTag*) (tref tag 4)))
(bind-func contents (lambda (tag:XMLTag* contents_in:String*) (tset! tag 4 contents_in)))
(bind-func properties (lambda (tag:XMLTag*) (tref tag 5)))
(bind-func properties (lambda (tag:XMLTag* properties_in:i8) (tset! tag 5 properties_in)))

;; helpers
(bind-func void_element (lambda (tag:XMLTag*) (= (& (properties tag) #x1) #x1)))
(bind-func set_void_element (lambda (tag:XMLTag*) (properties tag (bor (properties tag) #x1))))
(bind-func no_self_nesting_element (lambda (tag:XMLTag*) (= (& (properties tag) #x2) #x2)))
(bind-func set_no_self_nesting_element (lambda (tag:XMLTag*) (properties tag (bor (properties tag) #x2))))
(bind-func push_attribute (lambda (tag:XMLTag* attr:Pair{String*,String*}*) (attributes tag (cons attr (attributes tag)))))
(bind-func pop_attribute (lambda (tag:XMLTag*) (let ((attr (car (attributes tag)))) (attributes tag (cdr (attributes tag))) attr)))
(bind-func add_child (lambda (tag:XMLTag* child:XMLTag*) (children tag (cons child (children tag)))))

(bind-val xmlOpenAngleBracket i8 (i64toi8 60))
(bind-val xmlCloseAngleBracket i8 (i64toi8 62))
(bind-val xmlBackSlash i8 (i64toi8 92))
(bind-val xmlForwardSlash i8 (i64toi8 47))
(bind-val xmlSpace i8 (i64toi8 32))
(bind-val xmlEquals i8 (i64toi8 61))
(bind-val xmlDoubleQuote i8 (i64toi8 34))
(bind-val xmlTab i8 (i64toi8 9))
(bind-val xmlCarriageReturn i8 (i64toi8 13))
(bind-val xmlLineFeed i8 (i64toi8 10))
(bind-val xmlQuestionMark i8 (i64toi8 63))
(bind-val ybotXmlPlaceHolder i8 (i64toi8 26))


(bind-func print_shallow:[void,XMLTag*,i64]*
  (lambda (tag depth)
    (if (non-null tag)
        (let* ((name:String* (label tag))
               (attr:List{Pair{String*,String*}*}*  (attributes tag))
               (cntnts:String* (contents tag)))
          (doloop (i depth)
            (printf "  "))
          (if (non-null name) (printf "<%s" (cstring name)) (printf "<%s" "unknown"))
          (let ((attr_printer:[void,Pair{String*,String*}*]*
                 (lambda (a:Pair{String*,String*}*)
                   (cond
                    ((non-null a)
                     (if (non-null (first a)) (begin (printf " %s" (cstring (first a))) void) void)
                     (if (non-null (second a)) (begin (printf "=%c%s%c" xmlDoubleQuote (cstring (second a)) xmlDoubleQuote) void) void))
                    (else void)))))
            (for-each attr_printer (reverse attr)))
          (printf ">")
          (if (not (void_element tag))
              (begin
                (highlighter "black")
                (print_sanitised cntnts)
                (highlighter "normal")
                void)
              void))
        (begin
          (printf "<NULL TAG>")
          void))
      void))
      
(bind-func print_deep:[void,XMLTag*,i64]*
  (lambda (tag depth)
    (cond
     ((non-null tag)
      (print_shallow tag depth)
      (printf "\n")
      (for-each (lambda (child) (print_deep child (+ depth 1))) (reverse (children tag)))
      (if (not (void_element tag))
          (let ((i:i64 0))
            (dotimes (i depth)
              (printf "  "))))
      (if (and (non-null (label tag)) (not (void_element tag)))
          (printf "</%s>\n" (cstring (label tag))))
      void)
     (else void))))


(bind-func print:[void,XMLTag*]*
  (lambda (tag) (cond ((non-null tag) (print_deep tag 0)) (else void))))
      

(bind-func attribute_matching:[Pair{String*,String*}*,XMLTag*,String*]*
  (lambda (tag name)
    (cond
     ((and (non-null tag) (non-empty (attributes tag)))
      (let ((cmp:[bool,String*,String*]*
             (lambda (a b)
               (equal (lower a) (lower b)))))
        (hash_find:[Pair{String*,String*}*,List{Pair{String*,String*}*}*,String*,[bool,String*,String*]*]*
         (attributes tag) name cmp)))
     (else null))))


;; Working with the XML document object
(bind-func elements_matching:[List{XMLTag*}*,XMLTag*,[bool,XMLTag*]*]*
  (lambda (tag:XMLTag* predicate:[bool,XMLTag*]*)
    (let ((output:List{XMLTag*}* null))
      (let ((loop:[List{XMLTag*}*,XMLTag*]*
             (lambda (aTag)
               (cond
                ((non-null aTag)
                 (if (predicate aTag) (set! output (cons aTag output)))
                 (for-each loop (children aTag))
                 output)
                (else null)))))
        (loop tag)))))


(bind-func first_element_matching:[XMLTag*,XMLTag*,[bool,XMLTag*]*]*
  (lambda (tag predicate)
    (let ((lst:List{XMLTag*}* (elements_matching tag predicate)))
      (cond
       ((non-null lst)
        (car lst))
       (else null)))))
        

(bind-func elements_by_label:[List{XMLTag*}*,XMLTag*,String*]*
  (lambda (tag:XMLTag* name:String*)
    (let ((predicate:[bool,XMLTag*]*
           (lambda (aTag)
             (and (non-null aTag) (equal (label aTag) name)))))
      (elements_matching tag predicate))))
           

(bind-func elements_by_id:[List{XMLTag*}*,XMLTag*,String*]*
  (lambda (tag id)
    (let ((predicate:[bool,XMLTag*]*
           (lambda (aTag:XMLTag*)
             (let ((match:Pair{String*,String*}* (attribute_matching aTag (String "id"))))
                (and (non-null match) (equal (second match) id))))))
      (elements_matching tag predicate))))
               

(bind-func element_by_label_and_id:[XMLTag*,XMLTag*,String*,String*]*
  (lambda (tag name id)
    (let ((predicate:[bool,XMLTag*]*
           (lambda (aTag:XMLTag*)
             (let ((match:Pair{String*,String*}* (attribute_matching aTag (String "id"))))
                 (and (non-null match) (equal (second match) id) (non-null aTag) (equal (label aTag) name))))))
      (let ((suspects:List{XMLTag*}* (elements_matching tag predicate)))
        (cond
         ((non-empty suspects)
          (car suspects))
         (else null))))))



;; Contexts - We are always inside some element
;; Inside tag 
;; -- in label
;;    -- in literal
;;    -- else
;; -- in attributes
;;    -- in literal
;;    -- else
;; -- else

;; Context encoding
(bind-val XML_TAG_CONTENT i8                       (binary "00000000"))
(bind-val XML_TAG_LABEL i8                             (binary "00000001"))
(bind-val XML_TAG_ATTRIBUTE_NAME i8        (binary "00000010"))
(bind-val XML_TAG_ATTRIBUTE_VALUE i8       (binary "00000100"))
(bind-val XML_TAG_LITERAL i8                          (binary "00001000"))
(bind-val XML_TAG_ESCAPE i8                          (binary "00010000"))
(bind-val XML_TAG_END_LABEL i8                    (binary "00100000"))
(bind-val XML_TAG_FRESH i8                             (binary "01000000"))
(bind-val XML_DEFAULT i8                                  (binary "10000000"))

(bind-func name_of_state:[String*,i8]*
  (lambda (state:i8)
    (cond
     ((= state (binary "00000000")) (String "CONTENT"))
     ((= state (binary "00000001")) (String "LABEL"))
     ((= state (binary "00000010")) (String "ATTRIBUTE_NAME"))
     ((= state (binary "00000100")) (String "ATTRIBUTE_VALUE"))
     ((= state (binary "00001000")) (String "LITERAL"))
     ((= state (binary "00010000")) (String "ESCAPE"))
     ((= state (binary "00100000")) (String "END_LABEL"))
     ((= state (binary "01000000")) (String "FRESH"))
     ((= state (binary "10000000")) (String "DEFAULT"))
     (else (String "UNKNOWN")))))
     

(bind-func xml_default_cond:halting_cond_t
 (lambda (c)
   (contains c (list xmlOpenAngleBracket))))

(bind-func xml_literal_cond:halting_cond_t
 (lambda (c)
   (contains c (list xmlDoubleQuote))))
           
(bind-func xml_content_cond:[bool,i8]*
 (lambda (c)
   (contains c (list xmlOpenAngleBracket xmlDoubleQuote))))

(bind-func xml_label_cond:[bool,i8]*
 (lambda (c)
   (contains c (list xmlCloseAngleBracket xmlForwardSlash xmlSpace xmlDoubleQuote))))

(bind-func xml_end_label_cond:[bool,i8]*
 (lambda (c)
   (contains c (list xmlCloseAngleBracket))))

(bind-func xml_attribute_value_cond:[bool,i8]*
 (lambda (c)
   (contains c (list xmlCloseAngleBracket xmlForwardSlash xmlDoubleQuote xmlSpace))))

(bind-func xml_attribute_name_cond:[bool,i8]*
 (lambda (c)
   (contains c (list xmlCloseAngleBracket xmlForwardSlash xmlDoubleQuote xmlSpace xmlEquals))))

(bind-func xml_contents_cond:[bool,i8]*
 (lambda (c)
   (contains c (list xmlOpenAngleBracket xmlForwardSlash))))




(bind-type XMLParseContext <XMLTag*,StringStreamBuffer*,halting_cond_t,i8> (constructor? . #f) (printer? . #f))

;; provide our own constructor
(bind-func XMLParseContext:[XMLParseContext*,XMLTag*,halting_cond_t,i8]*
  (lambda (tag condition state)
    (let ((context:XMLParseContext* (alloc)))
      (tset! context 0 tag)
      (tset! context 1 (StringStreamBuffer_c 256))
      (tset! context 2 condition)
      (tset! context 3 state)
      context)))


;; getters and setters 
(bind-func tag (lambda (context:XMLParseContext*) (tref context 0)))
(bind-func tag (lambda (context:XMLParseContext* tag_in:XMLTag*) (tset! context 0 tag_in)))
(bind-func buffer (lambda (context:XMLParseContext*) (tref context 1)))
(bind-func buffer (lambda (context:XMLParseContext* buffer_in:StringStreamBuffer*) (tset! context 1 buffer_in)))
(bind-func condition (lambda (context:XMLParseContext*) (tref context 2)))
(bind-func condition (lambda (context:XMLParseContext* condition_in:halting_cond_t) (tset! context 2 condition_in)))
(bind-func state (lambda (context:XMLParseContext*) (tref context 3)))
(bind-func state (lambda (context:XMLParseContext* state_in:i8) (tset! context 3 state_in)))

(bind-func replicate:[XMLParseContext*,XMLParseContext*]*
  (lambda (context)
    (let ((new_context:XMLParseContext* (alloc)))
      (tset! new_context 0 (tag context))
      (tset! new_context 1 (buffer context))
      (tset! new_context 2 (condition context))
      (tset! new_context 3 (state context))
      new_context)))


(bind-func replicate_into_literal:[XMLParseContext*,XMLParseContext*]*
  (lambda (context)
    (let ((new_context:XMLParseContext* (alloc)))
      (tset! new_context 0 (tag context))
      (tset! new_context 1 (buffer context))
      (tset! new_context 2 xml_literal_cond)
      (tset! new_context 3 XML_TAG_LITERAL)
      new_context)))



(bind-func XMLParseContext_default:[XMLParseContext*]*
  (lambda ()
    (let* ((context:XMLParseContext* (alloc))
           (tag:XMLTag* (XMLTag (String "Document") null null null (String "") (binary "00000000")))
           (buffer:StringStreamBuffer* (StringStreamBuffer_c 256))
           (state XML_DEFAULT))
      (tfill! context tag buffer xml_default_cond state)
      context)))
      

(bind-func print_context:[void,XMLParseContext*]*
  (lambda (ctxt)
    (cond
     ((non-null ctxt)
      (printf "State: %s \tTag: " (cstring (name_of_state (state ctxt))))
      (print_shallow (tag ctxt) 0)
      (cond
       ((non-null (buffer ctxt))
        (print_sanitised (toString (buffer ctxt)))))
      (printf "\n")
      void)
    (else void))))

(bind-func print_context_brief:[void,XMLParseContext*]*
  (lambda (ctxt)
    (cond
     ((non-null ctxt)
      (printf "State: %s \tTag: " (cstring (name_of_state (state ctxt))))
      (print_shallow (tag ctxt) 0)
      (printf "\n")
      void)
    (else void))))


(bind-type XMLParseContextStack <List{XMLParseContext*}*> (constructor? . #f) (printer? . #f))

(bind-func XMLParseContextStack:[XMLParseContextStack*]*
  (lambda ()
    (let* ((stack:XMLParseContextStack* (alloc))
           (context_list:List{XMLParseContext*}* (list (XMLParseContext_default))))
      (tfill! stack context_list)
      stack)))

(bind-func head:[List{XMLParseContext*}*,XMLParseContextStack*]* (lambda (stack:XMLParseContextStack*) (tref stack 0)))
(bind-func head (lambda (stack:XMLParseContextStack* head_in:List{XMLParseContext*}*) (tset! stack 0 head_in)))

(bind-func print_context_stack:[void,XMLParseContextStack*]*
  (lambda (stack)
    (for-each print_context:[void,XMLParseContext*]* (head stack))))

(bind-func print_context_stack_brief:[void,XMLParseContextStack*]*
  (lambda (stack)
    (for-each print_context_brief:[void,XMLParseContext*]* (head stack))))


(bind-func pop:[XMLParseContext*,XMLParseContextStack*]*
  (lambda (stack)
    (cond
     ((non-null stack)
      ;;(printf "Popping stack\n")
      ;;(print_context_stack stack)
      (let ((lst (head stack)))
        (cond
         ((non-null lst)
          (cond
           ((< 0 (length lst))
            (cond
             ((< 1 (length lst))
              (let ((top_context:XMLParseContext* (car lst)))
                (head stack (cdr lst))
                top_context))
             (else
              (car lst))))
            (else
             (printf "Stack has no elements!\n")
             (XMLParseContext_default))))
          (else
           (printf "List of contexts is null!\n")
           (XMLParseContext_default)))))
     (else
      (printf "Stack is null!\n")
      (XMLParseContext_default)))))


(bind-func push:[XMLParseContextStack*,XMLParseContextStack*,XMLParseContext*]*
  (lambda (stack context)
    ;;(printf "Pushing context:\n")
    ;;(print_context context)
    (cond
     ((non-null stack)
      ;;(printf "onto stack:\n")
      ;;(print_context_stack stack)
      (head stack (cons context (head stack)))
      stack)
     (else
      (let ((output:XMLParseContextStack* (XMLParseContextStack)))
        (head output (cons context (head output)))
        (set! stack output)
        stack)))))


(bind-func bottom:[XMLParseContext*,XMLParseContextStack*]*
  (lambda (stack:XMLParseContextStack*)
    (cond
     ((non-null stack)
      (car (last (head stack))))
     (else null))))


(bind-func top:[XMLParseContext*,XMLParseContextStack*]*
  (lambda (stack)
    (car (head stack))))


(bind-func tag:[XMLTag*,XMLParseContextStack*]*
  (lambda (stack)
    (tag:[XMLTag*,XMLParseContext*]* (top stack))))

(bind-func buffer:[StringStreamBuffer*,XMLParseContextStack*]*
  (lambda (stack)
    (buffer:[StringStreamBuffer*,XMLParseContext*]* (top stack))))

(bind-func condition:[halting_cond_t,XMLParseContextStack*]*
  (lambda (stack)
    (condition:[halting_cond_t,XMLParseContext*]* (top stack))))

(bind-func state:[i8,XMLParseContextStack*]*
  (lambda (stack)
    (state:[i8,XMLParseContext*]* (top stack))))



(bind-func parser_c:[parser_t,XMLParseContext*]*
  (lambda (context)
    (letrec
        ((parser:parser_t
          (lambda (stream)
            (cond
             ((not (end_of_stream stream))
              (let* ((c:i8 (next stream)))
                (highlighter "red") (printf "%c" c) (highlighter "normal")
                (cond
                 (((condition context) c)
                  ;;(printf "\n --- Encountered %c --- stopped parsing in context " c)
                  ;;(print_context_brief context)
                  (step_back stream)
                  #t)
                 (else
                  (buffer context (write (buffer context) c))
                  (parser stream)))))
             (else #f)))))
      parser)))


;; (keep_parsing:[bool]*
;;  (lambda ()
;;    (printf "... resuming parsing of tag %s in state %s ... \n" (cstring (label (current_tag))) (cstring (name_of_state (current_state))))
;;    (char_reader stream (current_tag) (current_buffer) (current_condition))))

(bind-func collapse:[XMLTag*,XMLParseContextStack*]*
  (lambda (stack)
    (let ((doc_context:XMLParseContext* (bottom stack)))
      (cond
       ((and (non-null doc_context) (nontrivial (buffer doc_context)) (non-null (tag doc_context)))
        (contents (tag doc_context) (toString (buffer doc_context))) #t)
       (else #f))
      (tag doc_context))))


(bind-func tail_matching_label:[List{XMLParseContext*}*,XMLParseContextStack*,String*]*
  (lambda (stack name)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              ((equal (label (tag (car lst))) name) lst)
              (else (loop (cdr lst)))))))
      (loop (head stack)))))
     

(bind-func tail_not_matching_label:[List{XMLParseContext*}*,XMLParseContextStack*,String*]*
  (lambda (stack name)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              ((not (equal (label (tag (car lst))) name)) lst)
              (else (loop (cdr lst)))))))
      (loop (head stack)))))


(bind-func tail_matching_tag:[List{XMLParseContext*}*,XMLParseContextStack*,XMLTag*]*
  (lambda (stack:XMLParseContextStack* aTag:XMLTag*)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              (else
               (let* ((ctxt:XMLParseContext* (car lst))
                      (tg:XMLTag* (tag ctxt)))
                 (cond 
                  ((= (cast tg i8*) (cast aTag i8*)) lst)
                  (else (loop (cdr lst))))))))))
      (loop (head stack)))))


(bind-func tail_not_matching_tag:[List{XMLParseContext*}*,XMLParseContextStack*,XMLTag*]*
  (lambda (stack:XMLParseContextStack* aTag:XMLTag*)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              (else
               (let* ((ctxt:XMLParseContext* (car lst))
                      (tg:XMLTag* (tag ctxt)))
                 (cond 
                  ((not (= (cast tg i8*) (cast aTag i8*))) lst)
                  (else (loop (cdr lst))))))))))
      (loop (head stack)))))


(bind-func pop_before_tail:[XMLParseContextStack*,XMLParseContextStack*,List{XMLParseContext*}*]*
  (lambda (stack tail)
    (head stack tail)
    stack))
  

(bind-func pop_before_matching_label:[XMLParseContextStack*,XMLParseContextStack*,String*]*
  (lambda (stack name)
    ;;(printf "Popping all tags until first tag labelled %s\n" (cstring name))
    (pop_before_tail stack (tail_matching_label stack name))))


(bind-func pop_while_matching_label:[XMLParseContextStack*,XMLParseContextStack*,String*]*
  (lambda (stack name)
    ;;(printf "Popping all tags until first not labelled %s\n" (cstring name))
    (pop_before_tail stack (tail_not_matching_label stack name))))


(bind-func pop_before_matching_tag:[XMLParseContextStack*,XMLParseContextStack*,XMLTag*]*
  (lambda (stack tag)
    ;;(printf "Popping all tags until %p: " (cast tag i8*)) (print_shallow tag 0) (printf "\n")
    (pop_before_tail stack (tail_matching_tag stack tag))))


(bind-func pop_while_matching_tag:[XMLParseContextStack*,XMLParseContextStack*,XMLTag*]*
  (lambda (stack tag)
    ;;(printf "Popping all tags matching %p: " (cast tag i8*)) (print_shallow tag 0) (printf "\n")
    (pop_before_tail stack (tail_not_matching_tag stack tag))))


(bind-func pop_before_match:[XMLParseContextStack*,XMLParseContextStack*,[bool,XMLParseContext*]*]*
  (lambda (stack predicate)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              ((predicate (car lst)) lst)
              (else (loop (cdr lst)))))))
      (loop (head stack)))))
    

(bind-func pop_while_matching:[XMLParseContextStack*,XMLParseContextStack*,[bool,XMLParseContext*]*]*
  (lambda (stack predicate)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              ((not (predicate (car lst))) lst)
              (else (loop (cdr lst)))))))
      (loop (head stack)))))


(bind-func process_while_not_matching_label:[List{XMLParseContext*}*,XMLParseContextStack*,String*,[bool,XMLParseContext*]*]*
  (lambda (stack name proc)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              ((equal (label (tag (car lst))) name) lst)
              (else
               (proc (car lst))
               (loop (cdr lst)))))))
      (loop (head stack)))))


(bind-func process_while_matching_tag:[List{XMLParseContext*}*,XMLParseContextStack*,XMLTag*,[bool,XMLParseContext*]*]*
  (lambda (stack:XMLParseContextStack* aTag:XMLTag* proc:[bool,XMLParseContext*]*)
    (let ((loop:[List{XMLParseContext*}*,List{XMLParseContext*}*]*
           (lambda (lst)
             (cond
              ((null? lst) null)
              (else
               (let* ((ctxt:XMLParseContext* (car lst))
                      (tg:XMLTag* (tag ctxt)))
                 (cond 
                  ((not (= (cast tg i8*) (cast aTag i8*)))
                   lst)
                  (else
                   (proc ctxt)
                   (loop (cdr lst))))))))))
      (loop (head stack)))))


(bind-func parse_xml_stream:[XMLTag*,CharStream*,XMLParseContextStack*]*
  (lambda (stream:CharStream* stack:XMLParseContextStack*)
    (cond
     ((end_of_stream stream)
      (collapse stack))
     (else
      (let ((parse:parser_t (parser_c (top stack))))
        (cond ;; 1a

         ((= (state stack) XML_TAG_LITERAL)
          (cond
           ((parse stream)
            (pop stack)
            (next stream)
            (parse_xml_stream stream stack))
           (else (collapse stack))))

         ((= (state stack) XML_DEFAULT)
          (cond
           ((parse stream)
            (let ((d (peek stream)))
              (cond
               ((= d xmlQuestionMark)
                (next stream)
                (parse_xml_stream stream stack))
               (else
                (let* ((child:XMLTag* (XMLTag (String "TBC") null null null (String "") (binary "00000000")))
                       (new_context:XMLParseContext*  (XMLParseContext child xml_label_cond XML_TAG_LABEL)))
                  (add_child (tag stack) child)
                  (push stack new_context))
                (parse_xml_stream stream stack)))))
           (else (collapse stack))))

         ((= (state stack) XML_TAG_LABEL)
          (cond
           ((parse stream)
            (cond
             ((= (peek stream) xmlDoubleQuote)
              (push stack (replicate_into_literal (top stack)))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlSpace)
              (label (tag stack) (toString (buffer stack)))
              ;;(printf "Tag label identified as %s\n" (cstring (label (tag stack))))
              (cond
               ((contains (lower (label (tag stack))) (list (Str "link") (Str "br") (Str "img") (Str "image")))
                ;;(printf "Marking tag %s as void\n" (cstring (label (tag stack))))
                (set_void_element (tag stack))))
              (cond
               ((contains (lower (label (tag stack))) (list (String "li")))
                ;;(printf "Marking tag %s as not allowing self-nesting\n" (cstring (label (tag stack))))
                (set_no_self_nesting_element (tag stack))))
              (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_attribute_name_cond XML_TAG_ATTRIBUTE_NAME)))
                (pop stack)
                (push stack new_context))
              (skip_whitespace stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlCloseAngleBracket)
              (label (tag stack) (toString (buffer stack)))
              ;;(printf "Tag label identified as %s\n" (cstring (label (tag stack))))
              (cond
               ((contains (lower (label (tag stack))) (list (String "li")))
                ;;(printf "Marking tag %s as not allowing self-nesting\n" (cstring (label (tag stack))))
                (set_no_self_nesting_element (tag stack))))
              (cond
               ((contains (lower (label (tag stack))) (list (Str "link") (Str "br") (Str "img") (Str "image")))
                ;;(printf "Marking tag %s as void\n" (cstring (label (tag stack))))
                (set_void_element (tag stack))
                (pop_while_matching_tag stack (tag stack))
                (next stream)
                (parse_xml_stream stream stack))
               (else
                (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_content_cond XML_TAG_CONTENT)))
                  (pop stack)
                  (push stack new_context))
                (next stream)
                (parse_xml_stream stream stack))))
             (else
              (next stream)
              (parse_xml_stream stream stack))))
           (else (collapse stack))))

         
         ((= (state stack) XML_TAG_ATTRIBUTE_NAME)
          (cond
           ((parse stream)
            (cond
             ((= (peek stream) xmlDoubleQuote)
              (push stack (replicate_into_literal (top stack)))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlCloseAngleBracket)
              (cond
               ((nontrivial (buffer stack))
                (let ((attr:Pair{String*,String*}* (Pair (toString (buffer stack)) null)))
                (push_attribute (tag stack) attr))))
              (if (void_element (tag stack)) (pop_while_matching_tag stack (tag stack)))
              (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_content_cond XML_TAG_CONTENT)))
                (pop stack)
                (push stack new_context))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlEquals)
              (let ((attr:Pair{String*,String*}* (Pair (toString (buffer stack)) null)))
                (push_attribute (tag stack) attr))
              (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_attribute_value_cond XML_TAG_ATTRIBUTE_VALUE)))
                (pop stack)
                (push stack new_context))
              (next stream)
              (parse_xml_stream stream stack))
             (else
               (next stream)
               (parse_xml_stream stream stack))))
           (else (collapse stack))))


         ((= (state stack) XML_TAG_ATTRIBUTE_VALUE)
          (cond
           ((parse stream)
            (let ((attr:Pair{String*,String*}* (pop_attribute (tag stack))))
              (cond
               ((non-null attr)
                (push_attribute (tag stack) (Pair (first attr) (toString (buffer stack)))))))
            (cond
             ((= (peek stream) xmlDoubleQuote)
              (push stack (replicate_into_literal (top stack)))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlCloseAngleBracket)
              (if (void_element (tag stack)) (pop_while_matching_tag stack (tag stack)))
              (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_content_cond XML_TAG_CONTENT)))
                (pop stack)
                (push stack new_context))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlSpace)
              (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_attribute_name_cond XML_TAG_ATTRIBUTE_NAME)))
                (pop stack)
                (push stack new_context))
              (skip_whitespace stream)
              (parse_xml_stream stream stack))
             (else
               (next stream)
               (parse_xml_stream stream stack))))
           (else (collapse stack))))

         
         ((= (state stack) XML_TAG_CONTENT)
          (cond
           ((parse stream)
            (cond
             ((= (peek stream) xmlDoubleQuote)
              (push stack (replicate_into_literal (top stack)))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlOpenAngleBracket)
              (next stream)
              (cond
               ((= (peek stream) xmlForwardSlash)
                (contents (tag stack) (toString (buffer stack)))
                (let ((new_context:XMLParseContext* (XMLParseContext (tag stack) xml_end_label_cond XML_TAG_END_LABEL)))
                  (state new_context XML_TAG_END_LABEL)
                  (pop stack)
                  (push stack new_context))
                (next stream)
                (parse_xml_stream stream stack))
               (else 
                (cond
                 ((no_self_nesting_element (tag stack))
                  ;;(printf "Element %s does not allow self-nesting ... " (cstring (label (tag stack))))
                  (let ((str:String* (look_ahead stream 2)))
                    ;;(printf "next two characters are %s\n" (cstring str))
                    (cond
                     ((equal str (label (tag stack)))
                      ;;(printf "found %s attempting to self-nest. Popping back up to parent\n" (cstring (label (tag stack))))
                      (contents (tag stack) (toString (buffer stack)))
                      (pop stack) void)
                     (else
                      ;;(printf "luckily the next tag is %s\n" (cstring str))
                      void))))
                 (else void))
                ;;(printf "A child is born!\n")
                (let* ((child:XMLTag* (XMLTag (String "TBC") null null null (String "") (binary "00000000")))
                       (new_context:XMLParseContext*  (XMLParseContext child xml_label_cond XML_TAG_LABEL)))
                    (add_child (tag stack) child)
                    ;;(printf "Added child tag %s to parent tag %s.\n" (cstring (label child)) (cstring (label (tag stack))))
                    ;;(printf "Added child tag %s to parent tag %s. Parent now:\n" (cstring (label child)) (cstring (label (tag stack))))
                    ;;(print (tag stack))
                    (push stack new_context))
                  (parse_xml_stream stream stack))))
             (else
              (next stream)
              (parse_xml_stream stream stack))))
           (else (collapse stack))))

         ((= (state stack) XML_TAG_END_LABEL)
          (cond
           ((parse stream)
            (cond
             ((= (peek stream) xmlDoubleQuote)
              (push stack (replicate_into_literal (top stack)))
              (next stream)
              (parse_xml_stream stream stack))
             ((= (peek stream) xmlCloseAngleBracket)
              (let ((closing_label:String* (toString (buffer stack))))
                (highlighter "white")
                ;;(printf "Found closing label %s\n" (cstring closing_label))
                (highlighter "normal")
                (let ((finaliser:[bool,XMLParseContext*]*
                       (lambda (context:XMLParseContext*)
                         (cond
                          ((and (non-null context) (non-null (tag context)) (nontrivial (buffer context)))
                           ;;(printf "Processing context: ") (print_context context) (printf "\n")
                           (cond
                            ((= (state context) XML_TAG_CONTENT)
                             ;;(printf "Setting contents of %s to %s\n" (cstring (label (tag context))) (cstring (buffer context)))
                             (contents (tag context) (toString (buffer context))) #t)
                            (else #f)))
                          (else #f)))))
                  (let ((first_tail (process_while_not_matching_label stack closing_label finaliser)))
                    (if (non-null first_tail) (head stack first_tail)))
                  ;;(printf "Should have skipped over any non-matching labelled contexts.\n Stack is now\n")
                  ;;(print_context_stack stack)
                  (let ((second_tail (process_while_matching_tag stack (tag stack) finaliser)))
                    (if (non-null second_tail) (head stack second_tail)))))
               (next stream)
              (parse_xml_stream stream stack))
             (else
              (next stream)
              (parse_xml_stream stream stack))))
           (else (collapse stack))))

         (else
          (printf "Shouldn't have gotten into this state %s\n" (name_of_state (state stack)))
          (collapse stack))))))))


(bind-func parse_xml_file:[XMLTag*,i8*]*
  (lambda (path)
    (let ((file (yfs_open path)))
      (if (non-null file)
          (let* ((eof:bool* (zalloc))
                 (stream:CharStream* (CharStream file eof))
                 (stack:XMLParseContextStack* (XMLParseContextStack)))
            (let ((output:XMLTag* (parse_xml_stream stream stack)))
              (yfs_close file)
              output))
          null))))

                            
(define *xtmlib-ybot_parser_xml-loaded* #t)