(defun company-blueprint-backend (command &optional arg &rest ignored)
  (cl-case command
    (interactive (company-begin-backend 'company-blueprint-backend))
;    (prefix (and (bound-and-true-p dojo-minor-mode)           ; This line would test for dojo-minor-mode
    (prefix (and (eq major-mode 'blueprint-mode)
		 (blueprint-get-current-completion-prefix)))
    (candidates (blueprint-get-completion-candidates arg))
    (annotation (blueprint-get-completion-annotation arg))
    (meta (blueprint-get-completion-doc arg))
  )
)



(defun blueprint-get-current-completion-prefix ()
  ; < > <!-- --> " space

  (let* ((prev-open-pos (blueprint-get-prefix-start "<"))
         (prev-close-pos (blueprint-get-prefix-start ">"))
         (prev-quotation-pos (blueprint-get-prefix-start "\""))
         (prev-eq-pos (blueprint-get-prefix-start "="))
         (prev-comment-start-pos (blueprint-get-prefix-start "<!--"))
         (prev-comment-end-pos (blueprint-get-prefix-start "-->"))
         (prev-space-pos (blueprint-get-prefix-start "[[:space:]]"))
         (next-comment-end-pos (save-excursion (search-forward "-->" nil t)))
         (max-delimiter-pos (dojo-common-math-nil-aware-max prev-open-pos prev-close-pos prev-quotation-pos prev-eq-pos prev-space-pos)))

    (log-blueprint-completion (format "open-pos [%s], close-pos [%s], comment-start [%s], comment-end [%s], space [%s], next-comment-end [%s]"
                                      prev-open-pos prev-close-pos prev-comment-start-pos prev-comment-end-pos prev-space-pos next-comment-end-pos))

    (cond ((and (not (null prev-comment-start-pos)) (<= prev-comment-start-pos (point))          ; Previous comment start before point
                (or (null prev-comment-end-pos) (< prev-comment-end-pos prev-comment-start-pos)) ; Previous comment end not after previous comment start
                (not (null next-comment-end-pos)) (>= next-comment-end-pos (point)))             ; Next comment end after point
           (log-blueprint-completion (format "Inside comment, will not return any prefix."))
           nil)
          ((null max-delimiter-pos)
           (log-blueprint-completion (format "No useful delimiter before point."))
           nil)
          ((eq max-delimiter-pos prev-open-pos)
           (log-blueprint-completion (format "After tag start, will return [%s]" (buffer-substring prev-open-pos (point))))
           (buffer-substring (1- prev-open-pos) (point)))
          ((eq max-delimiter-pos prev-space-pos)
           (log-blueprint-completion (format "After space, will return [%s]" (buffer-substring prev-space-pos (point))))
           (buffer-substring prev-space-pos (point)))
          ((eq max-delimiter-pos prev-eq-pos)
           (log-blueprint-completion (format "After equal sign, will return [%s]" (buffer-substring prev-eq-pos (point))))
           (buffer-substring prev-eq-pos (point)))
          ((eq max-delimiter-pos prev-quotation-pos)
           (save-excursion
             (let ((old-point (point)))
               (goto-char (1- prev-quotation-pos))
               (let* ((prev-prev-quotation-pos (blueprint-get-prefix-start "\""))
                      (prev-prev-eq-pos (blueprint-get-prefix-start "="))
                      (prev-max-delimiter-pos (dojo-common-math-nil-aware-max prev-prev-quotation-pos prev-prev-eq-pos)))
                 (log-blueprint-completion (format "prev-prev-quotation-pos [%s], prev-prev-eq-pos [%s], prev-max-delimiter-pos [%s]"
                                                   prev-prev-quotation-pos prev-prev-eq-pos prev-max-delimiter-pos))
                 (cond ((or (null prev-max-delimiter-pos)
                            (eq prev-prev-eq-pos prev-max-delimiter-pos))
                        (log-blueprint-completion (format "After quotation, will return [%s]" (buffer-substring (1- prev-quotation-pos) old-point)))
                        (buffer-substring (1- prev-quotation-pos) old-point))
                       (t
                        (log-blueprint-completion (format "Probably after closing quotation, will return nil."))
                        nil))))))
          (t
           (log-blueprint-completion (format "None of the above cases matched."))
           nil))))

(defun blueprint-get-prefix-start (regexp)
  (save-excursion
    (let ((result (re-search-backward regexp nil t)))
      (if result
          (1+ result)
        nil))))

(defun blueprint-get-token (regexp)
  (save-excursion
    (let ((result (re-search-forward regexp nil t)))
      (if result
          result
        nil))))

(defun blueprint-get-token-backwards (regexp)
  (save-excursion
    (re-search-backward regexp nil t)))

(defun blueprint-get-completion-candidates (prefix)
;  (log-blueprint-completion (format "Called get-completion-candidates with prefix [%s]" prefix))

  (let* ((ancestor-path (blueprint-get-ancestor-path))
         (type (nth (1- (length ancestor-path)) ancestor-path))
         (candidates (cond ((string= type "---")
;                            (log-blueprint-completion (format "Outside node name / attribute name / attribute value, will return nothing."))
                            ())
                           ((string= type "node-name")
                            (blueprint-get-node-name-candidates prefix ancestor-path))
                           ((string= type "attribute-name")
                            (blueprint-get-attribute-name-candidates prefix ancestor-path))
                           ((string= type "attribute-value")
                            (blueprint-get-attribute-value-candidates prefix ancestor-path))
                           (t
                            (log-blueprint-completion (format "Unknown completion case [%s]" type))
                            ()))))
    candidates))
  

(defun blueprint-get-candidates-if-prefix (prefix candidates)
  (let ((completions ()))
    (dolist (candidate candidates)
      (if (string-prefix-p prefix candidate)
          (progn
            (push candidate completions))))
    completions))
    

(defun blueprint-get-ancestor-path ()
  (save-excursion
    (let* ((orig-point (point))
           (prev-point (point))
           (within-comment nil)
           (last-comment-close-pos (blueprint-get-token-backwards "-->"))
           (last-empty-tag-close-pos (blueprint-get-token-backwards "*/>"))
           (last-tag-close-pos (blueprint-get-token-backwards "[^-][^-/]>"))
           (last-tag-open-pos (blueprint-get-token-backwards "<[^/]"))
           (last-empty-tag-open-pos (blueprint-get-token-backwards "</"))
           (last-close (dojo-common-math-nil-aware-max last-tag-close-pos last-empty-tag-close-pos))
           (last-open (dojo-common-math-nil-aware-max last-empty-tag-open-pos last-tag-open-pos))
           (last-pos (dojo-common-math-nil-aware-max last-close last-open))
           (level 0)
           (abort-malformed nil)
           (tag-start-without-comments nil))
      (while (and (>= level 0) (null abort-malformed))
;        (log-blueprint-completion (format "Positions: [%s], --> [%s], /> [%s], > [%s], < [%s], </ [%s], last-close [%s], last-open [%s], last-pos [%s]"
;                                          (point) last-comment-close-pos last-empty-tag-close-pos
;                                          last-tag-close-pos last-tag-open-pos
;                                          last-empty-tag-open-pos last-close last-open last-pos))
;        (log-blueprint-completion (format "Level / point: level [%s], orig-point [%s], prev-point [%s]" level orig-point prev-point))
        
        (cond ((null last-pos)
;               (log-blueprint-completion "No further interesting tokens, aborting.")
               (setq abort-malformed t))
              ((and (not (null last-comment-close-pos)) (< last-pos last-comment-close-pos))
;               (log-blueprint-completion "Skipping comment.")
               (goto-char last-comment-close-pos)
               (let* ((last-comment-open-pos (blueprint-get-token-backwards "<!--")))
                 (if (null last-comment-open-pos)
                     (setq abort-malformed t)
                   (setq tag-start-without-comments (concat (buffer-substring-no-properties (+ last-comment-close-pos 3) prev-point) tag-start-without-comments))
                   (goto-char last-comment-open-pos)
                   (setq prev-point last-comment-open-pos)
                   (setq last-comment-close-pos (blueprint-get-token-backwards "-->"))
                   (setq last-empty-tag-close-pos (blueprint-get-token-backwards "*/>"))
                   (setq last-tag-close-pos (blueprint-get-token-backwards "[^-][^-/]>"))
                   (setq last-tag-open-pos (blueprint-get-token-backwards "<[^/]"))
                   (setq last-empty-tag-open-pos (blueprint-get-token-backwards "</"))
                   (setq last-close (dojo-common-math-nil-aware-max last-tag-close-pos last-empty-tag-close-pos))
                   (setq last-open (dojo-common-math-nil-aware-max last-empty-tag-open-pos last-tag-open-pos))
                   (setq last-pos (dojo-common-math-nil-aware-max last-close last-open)))))
              (t
               (decf level)
;               (log-blueprint-completion (format "Getting back to last open / close tag."))
               (cond ((eq last-pos last-close)
                      (goto-char (+ last-close 3)))
                     (t
                      (goto-char last-open))))))
      (setq tag-start-without-comments (dojo-common-strings-trim
                                        (concat (buffer-substring-no-properties (point) prev-point) tag-start-without-comments)))
      
;      (log-blueprint-completion (format "After loop: point is [%s], tag-start-without-comments is [%s]" (point) tag-start-without-comments))
      
      (let* ((assign-index (last-index-of tag-start-without-comments "="))
             (space-index (last-index-of tag-start-without-comments "[[:space:]]"))
             (max-index (dojo-common-math-nil-aware-max assign-index space-index))
             (type nil)
             (node-name nil)
             (attribute-name nil)
             (path nil))
        (cond ((null max-index)
               (setq type "node-name"))
              ((eq max-index space-index)
               (setq type "attribute-name"))
              ((eq max-index assign-index)
               (setq type "attribute-value")
               (setq attribute-name (substring tag-start-without-comments (1+ space-index) assign-index))))
        
        (if (and (not (null max-index)) (or (eq max-index space-index) (eq max-index assign-index)))
            (let* ((first-space-index (string-match "[[:space:]]" tag-start-without-comments))
                   (first-identifier-index (string-match "[[:alnum:]]" tag-start-without-comments)))
              (setq node-name (substring tag-start-without-comments first-identifier-index first-space-index))))
        
;        (log-blueprint-completion (format "... space-index [%s], assign-index [%s]" space-index assign-index))
;        (log-blueprint-completion (format "After inspecting final open tag: type [%s], node-name [%s], attribute-name [%s]"
;                                          type node-name attribute-name))
        
        (setq path (cons type path))
        (if (string= type "attribute-value")
            (setq path (cons attribute-name path)))
        (if (or (string= type "attribute-name") (string= type "attribute-value"))
            (setq path (cons node-name path)))
        
        ; Before, we were at the starting < of the node, now we want to step backwards, to certainly arrive in correct xml
        ; But don't do this if the char before is '>', as this might lead to a wrong ancestor-path; the code below
        ; might erroneously assume that we are *inside* the tag which ends there.
        (if (and (> (point) 0) (not (eq (char-after (1- (point))) ?\>)))
            (backward-char))

        (log-blueprint-completion (format "Starting backward-up loop at position [%s]" (point)))

        (while (and (< (point-min) (point)) ;; Doesn't error if point is at beginning of buffer
                    (condition-case nil
                        (progn
                          (nxml-backward-up-element) ; always returns nil
                          t)
                      (error nil)))
          
          (let* ((prefix (xmltok-start-tag-prefix))
                 (local-name (xmltok-start-tag-local-name))
                 (qualified-name (concat prefix ":" local-name)))
            (setq path (cons (blueprint-get-start-tag-qualified-name) path))))
        
;        (log-blueprint-completion (format "Returning ancestor-path [%s]" path))
        
        path))))

(defun blueprint-get-start-tag-qualified-name ()
  (let* ((prefix (xmltok-start-tag-prefix))
         (local-name (xmltok-start-tag-local-name))
         (qualified-name (concat prefix ":" local-name)))
    qualified-name))

(defun blueprint-get-node-name-candidates (prefix ancestor-path)
  (log-blueprint-completion (format "Retrieving node-name candidates for prefix [%s]" prefix))
  (log-blueprint-completion (format "... ancestor-path is [%s]" ancestor-path))

  (let* ((parent-node (nth (- (length ancestor-path) 2) ancestor-path))
         (starts-with-bracket (starts-with prefix "<"))
         (colon-pos (string-match ":" prefix))
         ; Unify prefix to the form '<bp:foo', in order to make prefix check below easier
         (prefix-for-check (cond (starts-with-bracket         
                                  (cond ((null colon-pos)           ; <foo
                                         (concat "<bp:" (substring prefix 1)))
                                        (t                          ; <bp:foo
                                         prefix)))
                                 (t
                                  (cond ((null colon-pos)           ; foo
                                         (concat "<bp:" prefix))
                                        (t                          ; bp:foo
                                         (concat "<" prefix)))))))

    (log-blueprint-completion (format "Using prefix [%s] for check" prefix-for-check))

    (cond ((string= parent-node "bp:bean")
           (blueprint-get-candidates-if-prefix prefix-for-check (list "<bp:property" "<bp:argument")))
          ((string= parent-node "bp:blueprint")
           (blueprint-get-candidates-if-prefix prefix-for-check (list "<bp:bean" "<bp:service" "<bp:reference"))) ; bp:type-converters
          (t
           (log-blueprint-completion (format "Unknown parent node name [%s]" parent-node))))))

(defun blueprint-get-attribute-name-candidates (prefix ancestor-path)
  (log-blueprint-completion (format "Retrieving attribute-name candidates for prefix [%s]" prefix))
  (log-blueprint-completion (format "... ancestor-path is [%s]" ancestor-path))

  (let* ((parent-node (nth (- (length ancestor-path) 2) ancestor-path)))
    (cond ((string= parent-node "bp:bean")
           (blueprint-get-candidates-if-prefix prefix (list "id" "class" "factory-method" "factory-ref" "init-method")))
          ((string= parent-node "bp:property")
           (blueprint-get-candidates-if-prefix prefix (list "name" "ref" "value-ref" "value")))
          ((string= parent-node "bp:reference")
           (blueprint-get-candidates-if-prefix prefix (list "id" "interface")))
          ((string= parent-node "bp:service")
           (blueprint-get-candidates-if-prefix prefix (list "id" "interface" "ref")))
          (t
           (log-blueprint-completion (format "Unknown parent node name [%s]" parent-node))))))

(defun blueprint-get-attribute-value-candidates (prefix ancestor-path)
  (log-blueprint-completion (format "Retrieving attribute-value candidates for prefix [%s]" prefix))
  (log-blueprint-completion (format "... ancestor-path is [%s]" ancestor-path))

  (let* ((prefix-without-quotation (if (starts-with prefix "\"") (substring prefix 1) prefix))
         (attribute-name (nth (- (length ancestor-path) 2) ancestor-path))
         (project-and-path (dojo-get-current-project-and-path))
         (project (nth 0 project-and-path))
         (blueprint (dojo-core-workspace-get-blueprint-file-by-project project)))

; Probably pretty useless, as when typing the xml in general is not syntactically correct,

;    (if (and project (null blueprint))
;        (progn
;          (log-blueprint-completion (format "Blueprint not yet parsed, will parse it now."))
;          (setq blueprint (blueprint-parse-parse-current-services-xml))))

    (if (null blueprint)
        (log-blueprint-completion (format "[WARNING] No blueprint-file data exists, completion of blueprint ids will not work.")))

    (cond ((and (or (string= attribute-name "ref")
                    (string= attribute-name "factory-ref"))
                blueprint)

           (log-blueprint-completion (format "Will complete blueprint-internal reference."))
           (let* ((id-to-instance (blueprint-file-id-to-instance blueprint))
                  (ids (hash-table-get-all-keys id-to-instance))
                  (completions (blueprint-get-candidates-if-prefix prefix-without-quotation ids))
                  (completions-with-quotations ()))
             (dolist (completion completions)
               (push (concat "\"" completion "\"") completions-with-quotations))
             completions-with-quotations))
          ((or (string= attribute-name "class") (string= attribute-name "interface"))
           (log-blueprint-completion (format "Will complete qualified java class name."))
           (dojo-core-workspace-derive-java-names-if-necessary)
           (let* ((case-fold-search nil)
                  (package-prefix (string-match-p "^[[:lower:]]" prefix-without-quotation))
                  (classes-sorted (if package-prefix
                                      (dojo-workspace-java-classes-sorted-by-qualified-name dojo-current-workspace)
                                    (dojo-workspace-java-classes-sorted-by-name dojo-current-workspace)))
                  (accessor-fct (if package-prefix
                                    (lambda (java-class) (dojo-java-class-qualified-name java-class))
                                  (lambda (java-class) (dojo-java-class-name java-class))))
                  (curr-index (dojo-common-containers-binary-search classes-sorted prefix-without-quotation 'string< accessor-fct))
                  (candidates ())
                  (max-count 10))

             (while (let* ((candidate-class (seq-elt classes-sorted curr-index))
                           (prefix-to-check (funcall accessor-fct candidate-class)))
                      (and (< curr-index (length classes-sorted))
                           (< (length candidates) max-count)
                           (starts-with prefix-to-check prefix-without-quotation)))
               (push (concat "\"" (dojo-java-class-qualified-name (seq-elt classes-sorted curr-index)) "\"") candidates)
               (incf curr-index))
             candidates))
          (t
           ()))))

(defun blueprint-get-completion-annotation (arg)
;  (format "Beschreibung: %s" arg)
  "")

(defun blueprint-get-completion-doc (arg)
  (format "Documentation for %s" arg))

(provide 'blueprint-completion)

;    (dolist (attribute attributes)
;      (let* ((name-start (xmltok-attribute-name-start attribute))
;             (name-colon (xmltok-attribute-name-colon attribute))
;             (name-end (xmltok-attribute-name-end attribute))
;             (value-start (xmltok-attribute-value-start attribute))
;             (value-end (xmltok-attribute-value-end attribute))
;             (raw-normalized-value (xmltok-attribute-raw-normalized-value attribute))
;             (attribute-refs (xmltok-attribute-refs attribute)))
;        (log-blueprint-completion (format "... attribute: name-start [%s], name-colon [%s], name-end [%s], value-start [%s], value-end [%s]"
;                                          name-start name-colon name-end value-start value-end))
;        (log-blueprint-completion (format "...... raw-normalized-value [%s], attribute-refs [%s]" raw-normalized-value attribute-refs))))