;;; annotate.el --- annotate files without changing them  -*- lexical-binding: t; -*-
;; Copyright © 2015 Bastian Bechtold and contributors:
;; Naoya Yamashita (2018)
;; Università degli Studi di Palermo (2019)

;; Author: Bastian Bechtold
;; Maintainer: Bastian Bechtold <bastibe.dev@mailbox.org>, cage <cage-dev@twistfold.it>
;; URL: https://github.com/bastibe/annotate.el
;; Created: 2015-06-10
;; Package-Version: 20260514.1320
;; Package-Revision: 347525024f31
;; Package-Requires: ((emacs "27.1"))

;; This file is NOT part of GNU Emacs.

;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;;; Commentary:

;; This package provides the minor mode annotate-mode, which can add
;; annotations to arbitrary files without changing the files
;; themselves.  Annotations are saved in the annotate-file
;; (~/.annotations by default).
;;
;; To add annotations to a file, select a region and hit C-c C-a.  The
;; region will be underlined, and the annotation will be displayed in
;; the right margin.  Annotations are saved whenever the file is saved.
;;
;; Use C-c ] to jump to the next annotation and C-c [ to jump to
;; the previous annotation.  Use M-x annotate-export-annotations to
;; save annotations as a no-difference diff file.

;; Important note for developers: annotation can not overlaps and newline character
;; can not be annotated.

;;; Code:

(require 'info)

(require 'cl-lib)

;;;###autoload
(defgroup annotate nil
  "Annotate files without changing them."
  :version "2.5.0"
  :group 'text)

(defvar annotate-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-a") #'annotate-annotate)
    (define-key map (kbd "C-c C-d") #'annotate-delete-annotation)
    (define-key map (kbd "C-c C-r") #'annotate-reply-to)
    (define-key map (kbd "C-c C-t") #'annotate-show-thread-at-point)
    (define-key map (kbd "C-c C-p") #'annotate-change-annotation-text-position)
    (define-key map (kbd "C-c C-c") #'annotate-change-annotation-colors)
    (define-key map (kbd "C-c C-s") #'annotate-show-annotation-summary)
    (define-key map (kbd "C-c ]")   #'annotate-goto-next-annotation)
    (define-key map (kbd "C-c [")   #'annotate-goto-previous-annotation)
    map))

;;;###autoload
(define-minor-mode annotate-mode
  "Toggle Annotate mode.
See https://github.com/bastibe/annotate.el/ for documentation."
  :lighter " Ann"
  :group 'annotate
  (annotate-initialize-maybe))

(defcustom annotate-file (locate-user-emacs-file "annotations" ".annotations")
  "File where annotations are stored."
  :type 'file)

(defcustom annotate-file-buffer-local nil
  "If non nil (default `nil'), for each annotated file \"filename\", a database
\"filename.notes\", containing the annotations, is generated in the
same directory that contains \"filename\"."
  :type 'string)

(defcustom annotate-buffer-local-database-extension "notes"
  "The extension appended to the annotated filename to get the
name of the local database annotation"
  :type 'string)

(defcustom annotate-highlight-faces '((:underline "#EEF192")
                                      (:underline "#92EEF1")
                                      (:underline "#F192EE"))
  "List of faces for annotated text."
  :type '(repeat (plist)))

(defcustom annotate-annotation-text-faces '((:background "#EEF192"  :foreground "black")
                                            (:background "#92EEF1"  :foreground "black")
                                            (:background "#F192EE"  :foreground "black"))
  "List of faces for annotation's text."
  :type '(repeat (plist)))

(defface annotate-prefix
  '((t (:inherit default)))
  "Face for character used to pad annotation.
This is the fill space between text lines and annotation text.")

(defcustom annotate-annotation-column 85
  "Where annotations appear."
  :type 'number)

(defcustom annotate-diff-export-options ""
  "Options passed to \"diff\" in `annotate-export-annotations'.
This is used when diffing between a buffer with and without
integrated annotations.
Note that there is an implicit \"-u\" at the end of default options
that Emacs passes to the diff program."
  :type 'string)

(defcustom annotate-use-messages t
  "Whether status messages may appear in the minibuffer."
  :type 'boolean)

(defcustom annotate-popup-warning-indirect-buffer t
  "Whether an information popup message is shown when killing an
annotated indirect buffer."
  :type 'boolean)

(defcustom annotate-integrate-marker " ANNOTATION: "
  "Marker that is written before every integrated annotation."
  :type 'string)

(defcustom annotate-integrate-highlight ?~
  "Character used to underline an annotated text."
  :type 'character)

(defcustom annotate-fallback-comment "#"
  "When variable `comment-start' is nil use this string instead."
  :type 'string)

(defcustom annotate-blacklist-major-mode '()
  "Major modes in which to prevent auto-activation of command `annotate-mode'.
This is consulted when visiting a file.
It can be useful when some mode does not work well with
annotate (like source blocks in `org-mode') as this ensure that it
will be never loaded, see `annotate-initialize-maybe'."
  :type  '(repeat symbol))

(defcustom annotate-summary-ask-query t
  "If non nil a prompt asking for a query to filter the database
before showing it in a summary window is used. If nil the
database is not filtered at all."
  :type 'boolean)

(defcustom annotate-database-confirm-deletion t
  "If non nil a prompt asking confirmation before deleting a
database file that is going to be empty after saving an annotated
file will be shown."
  :type 'boolean)

(defcustom annotate-annotation-confirm-deletion nil
  "If non nil a prompt asking confirmation before deleting an
annotation file will be shown."
  :type 'boolean)

(defcustom annotate-database-confirm-import t
  "If non nil a prompt asking confirmation before importing a
database file will be shown."
  :type 'boolean)

(defcustom annotate-annotation-max-size-not-place-new-line 15
  "The maximum \"string-width\" allowed for an annotation to be
placed on the right margin of the window instead of its own line
 after the annotated text."
  :type  'number)

(defconst annotate-allowed-positioning-policy
  '(:by-length :margin :new-line)
  "The allowed values for annotation positioning.")

(defcustom annotate-annotation-position-policy :by-length
  "Policy for annotation's position:
- :new-line
  always in a new-line
- :margin
  always on right margin
- :by-length
  decide by text's length

if the length is more than the value of
`annotate-annotation-max-size-not-place-new-line' place the
annotation on a new line, place on the right margin
otherwise."
  :type  'symbol)

(defcustom annotate-use-echo-area nil
  "Whether annotation text should appear in the echo area only when mouse
id positioned over the annotated text instead of positioning them in
the the buffer (the default)."
  :type 'boolean)

(defcustom annotate-print-annotation-under-cursor nil
  "Whether annotation text should appear in the minibuffer when
the cursor is positioned over an annotated text (default: nil).

Important note: for this changes to take effect also
annotate-use-echo-area must be non nil"
  :type 'boolean)

(defcustom annotate-print-annotation-under-cursor-prefix "ANNOTATION: "
  "Prefix that is printed before annotation in the minibuffer when
annotate-print-annotation-under-cursor is non nil"
  :type 'string)

(defcustom annotate-print-annotation-under-cursor-delay 0.5
  "The delay (in seconds) after an annotation id printed in the
minibuffer, when the pursor is placed over an annotated text.

This variable works only if `annotate-print-annotation-under-cursor' is non nil"
  :type 'float)

(defcustom annotate-warn-if-hash-mismatch t
  "Whether a warning message should be printed if a mismatch
occurs, for an annotated file, between the hash stored in the
database annotations and the hash calculated from the actual
file.

This usually happens if an annotated file (a file with an entry in the
database) is saved with annotated-mode *not* active or the file
has been modified outside Emacs."
  :type 'boolean)

(defcustom annotate-endline-annotate-whole-line t
  "Whether trying to annotate the end of line character will
annotate the whole line before (or after if the line is composed
by the newline character only) instead."
  :type 'boolean)

(defcustom annotate-search-region-lines-delta 2
  "When the annotated file is out of sync with its annotation
database the software looks for annotated text in the region with
delta equals to the value of this variable. Units are in number
of lines. The center of the region is the position of the
annotation as defined in the database."
  :type 'number)

(defcustom annotate-autosave t
  "Whether annotations should be saved after each user action,
e.g. new annotation created, existing one amended or deleted."
  :type 'boolean)

(defcustom annotate-annotation-expansion-map '()

  "The expansion map for the annotation text. If a substring in the
annotation text matches the string in the first item of each element of
this list, it is expanded with the results of passing the second item —
as a command — to a system shell, if the third item is not null, the
output string of the command's results are trimmed (spaces or some
others non printable characters are removed from both ends, see:
`string-trim'). Example below.

The expression:

\(setf annotate-annotation-expansion-map
      \\='((\"%d\" \"date +%Y-%m-%d\" t)))

Will expand any occurrence of \"%d\" in the annotation's text with the
current date (format: \"YYYY-MM-DD\"), moreover the results will be
trimmed"
  :type '(repeat (list string string boolean)))

(defconst annotate-prop-chain-position
  'position)

(defconst annotate-prop-chain-pos-marker-first
  0)

(defconst annotate-prop-chain-pos-marker-last
  -1)

(defconst annotate-warn-file-changed-control-string
  (concat "The file '%s' has changed on disk "
          "from the last time the annotations were saved.\n"
          "Chances are that they will not be displayed correctly.")
  "The message to warn the user that file has been modified and
annotations positions could be outdated.")

(defconst annotate-warn-file-searching-annotation-failed-control-string
  (concat "The file '%s' has changed on disk "
          "from the last time the annotations were saved and "
          "Unfortunately was not possible to show annotation %S "
          "because i failed looking for test %S.")
  "The message to warn the user that file has been modified and
an annotations could not be restored.")

(defconst annotate-warn-buffer-has-no-valid-file
  "Annotations can not be saved: unable to find a file for buffer %S"
  "The message to warn the user that a buffer it is not visiting
a valid file to be annotated.")

(defconst annotate-popup-warn-killing-an-indirect-buffer
  (concat "You killed an indirect buffer that contains annotation.\n"
          "Annotate mode can not save annotation in an indirect buffer.\n"
          "The buffer's content has been saved in a regular buffer "
          "(together with its annotations) named:\n\n%S\n\n"
          "If you want you can save that buffer in a file and "
          "the annotations will be saved as well.")
  "The message to warn the user that an annotated indirect buffer
has been killed.")

(defconst annotate-error-summary-win-filename-invalid
  "Error: File not found or in an unsupported format"
  "The message to warn the user that file can not be show in
summary window because does not exist or is in an unsupported
 format.")

(defconst annotate-info-valid-file-extensions
  '(".info" ".info.gz" ".gz")
  "The valid extension for files that contains info document.")

(defconst annotate-summary-list-prefix "    "
  "The string used as prefix for each text annotation item in summary window.")

(defconst annotate-summary-list-prefix-file "* File: "
  "The string used as prefix for each annotated file item in summary window.")

(defconst annotate-summary-list-prefix-snippet "** Annotated text: "
  "The string used as prefix for each annotation snippet item in summary window.")

(defconst annotate-summary-list-prefix-reply "*** Reply to: "
  "The string used as prefix for each annotation snippet item in summary window.")

(defconst annotate-ellipse-text-marker "…"
  "The string used when a string is truncated with an ellipse.")

(defconst annotate-info-root-name "dir"
  "The pseudo-filename of info root.")

(defconst annotate-summary-buffer-name "*annotations*"
  "The name of the buffer for summary window.")

(defconst annotate-thread-buffer-name "*annotation thread*"
  "The name of the buffer for thread window.")

(defconst annotate-dump-from-indirect-bugger-suffix "-was-annotated-indirect-buffer"
  "Append this suffix to a buffer generated from an annotated indirect buffer.")

(defconst annotate-annotation-prompt "Annotation: "
  "The prompt when asking user for annotation modification.")

(defconst annotate-summary-delete-button-label "❌delete"
  "The label for the button, in summary window, to delete an annotation.")

(defconst annotate-summary-replace-button-label "📝replace"
  "The label for the button, in summary window, to replace an annotation.")

(defconst annotate-summary-show-thread-button-label "🧵show thread"
  "The label for the button, in summary window, to show the annotation's thread.")

(defconst annotate-confirm-deleting-annotation-prompt  "Delete this annotation? "
  "Prompt to be shown when asking for annotation deletion confirm.")

(defconst annotate-confirm-appending-newline-prompt "No newline character at the end of the buffer %S, annotation will not be displayed properly: append one? "
  "Prompt to be shown when asking for appending a newline at the end of the buffer.")

(defconst annotate-message-annotation-loaded "Annotations loaded."
  "The message shown when annotations has been loaded.")

(defconst annotate-message-annotations-not-found "No annotations found."
  "The message shown when no annotations has been loaded from the database.")

(defconst annotate-thread-delete-button-label "❌delete"
  "The label for the button, in thread window, to delete an annotation.")

(defconst annotate-thread-reply-button-label "✏️add reply"
  "The label for the button, in thread window, to delete an annotation.")

(defconst annotate-thread-branch-string "├▶")

(defconst annotate-thread-leaf-string "╰▶")

(defconst annotate-thread-trunk-string "│")

(defconst annotate-thread-trunk-stretch-string "┆")

(defcustom annotate-thread-header-face 'font-lock-doc-face
  "Face for header text (the annotated text) in the thread window."
  :type '(repeat (plist)))

(defcustom annotate-thread-author-face 'font-lock-doc-face
  "Face for author field in the thread window."
  :type '(repeat (plist)))

(defcustom annotate-thread-tree-arrow-face 'font-lock-warning-face
  "Face for arrow in the tree of a thread window."
  :type '(repeat (plist)))

(defcustom annotate-thread-tree-face 'font-lock-function-name-face
  "Face for arrow in the tree of a thread window."
  :type '(repeat (plist)))

(defcustom annotate-thread-action-face 'font-lock-comment-face
  "Face for arrow that prefixes actions button in thread window."
  :type '(repeat (plist)))

;;;; buffer locals variables

(defvar-local annotate-echo-annotation-timer nil
  "The buffer local variable bound to a timer that is in charge to print
the annotation under cursor on the echo area.")

(defvar-local annotate-colors-index-counter 0
  "An always increasing value to address annotation colors
in the customizable colors lists:

- annotate-highlight-faces
- annotate-annotation-text-faces.")

;;;; custom errors

(define-error 'annotate-error "Annotation error")

(define-error 'annotate-empty-annotation-text-error
              "Empty annotation text"
              'annotate-error)

(define-error 'annotate-no-new-line-at-end-file-error
              "No newline found at the end of the buffer"
              'annotate-error)

(define-error 'annotate-db-file-not-found
              "Annotations database file not found"
              'annotate-error)

(define-error 'annotate-annotate-region-overlaps
              "Error: the region overlaps with at least an already existing annotation"
              'annotate-error)

(define-error 'annotate-query-parsing-error
              "Parsing failed:"
              'annotate-error)

(cl-defmacro annotate-with-disable-read-only (&body body)
  "Run BODY with `read-only-mode' temporary disabled."
  (let ((read-mode-p (gensym)))
    `(let ((,read-mode-p (if buffer-read-only
                             1
                           -1)))
       (when (= ,read-mode-p 1)
         (read-only-mode -1))
       ,@body
       (when (= ,read-mode-p 1)
         (read-only-mode 1)))))

(defun annotate-file-exists-p (filepath)
  "Returns nil if the file pointed by `FILEPATH' does not exists
or an error occurs during the test
\(e.g TRAMP mode fails to connect to remote server)."
  (with-demoted-errors "Error: %S"
    (file-exists-p filepath)))

(defun annotate-annotations-exist-p ()
  "Does this buffer contains at least one or more annotations?"
  (cl-find-if 'annotationp
              (overlays-in 0 (buffer-size))))

(defun annotate-initialize-maybe ()
  "Initialize annotate mode only if buffer's major mode is not in the blacklist.
See `annotate-blacklist-major-mode'."
  (cl-flet ((shutdown ()
              (setq annotate-mode t)
              (annotate-shutdown)
              (setq annotate-mode nil)))
    (let ((annotate-allowed-p (with-current-buffer (current-buffer)
                                (not (apply #'derived-mode-p annotate-blacklist-major-mode)))))
      (cond
       ((not annotate-allowed-p)
        (shutdown))
       (annotate-mode
        (when (not (annotate-annotations-exist-p))
          (annotate-initialize)))
       (t
        (shutdown))))))

(cl-defun annotate-buffer-checksum (&optional (object (current-buffer)))
  "Calculate an hash for the argument OBJECT."
  (secure-hash 'md5 object))

(defun annotate-end-of-line-pos ()
  "Get the position of the end of line and rewind the point's
position (so that it is unchanged after this function is called)."
  (line-end-position))

(defun annotate-beginning-of-line-pos ()
  "Get the position of the beginning of line and rewind the point's
position (so that it is unchanged after this function is called)."
  (save-excursion
    (beginning-of-line)
    (point)))

(defun annotate-annotated-text-empty-p (annotation)
  "Does this ANNOTATION contains annotated text?"
  (and (overlay-start annotation)
       (overlay-end   annotation)
       (= (overlay-start annotation)
          (overlay-end   annotation))))

(cl-defun annotate-annotation-set-id (annotation &optional (id (annotate--generate-unique-id)))
  "Set property id to ID for ANNOTATION."
  (overlay-put annotation 'id id))

(cl-defgeneric annotate-annotation-id (object)
    "Get property id from annotation overlay: OBJECT.")

(cl-defmethod annotate-annotation-id ((object overlay))
  "Get property id from annotation overlay: OBJECT."
  (overlay-get object 'id))

(cl-defmethod annotate-annotation-id ((object list))
  "Get property id from annotation serialized: OBJECT."
  (annotate-id-from-dump object))

(cl-defun annotate-annotation-set-reply-to (annotation in-reply-to-id)
  "Set property reply-to IN-REPLY-TO-ID for ANNOTATION."
  (overlay-put annotation 'reply-to in-reply-to-id))

(cl-defgeneric annotate-annotation-reply-to (object)
  "Get the id of object OBJECT is the reply of.")

(cl-defmethod annotate-annotation-reply-to ((object overlay))
  "Get the id of object OBJECT is the reply of."
  (overlay-get object 'reply-to))

(cl-defmethod annotate-annotation-reply-to ((object list))
  "Get the id of object OBJECT is the reply of."
  (annotate-reply-to-from-dump object))

(cl-defgeneric annotate-annotation-replace-reply-to (object)
"Replace the id of the annotation OBJECT is replying.")

(cl-defmethod annotate-annotation-replace-reply-to ((object list) new-id)
"Replace the id of the annotation OBJECT is replying."
  (setf (elt object 7)
        new-id)
  object)

(cl-defmethod annotate-annotation-replace-reply-to ((object overlay) new-id)
  "Replace the id of the annotation OBJECT is replying."
  (overlay-put object 'reply-to new-id)
  object)

(defun annotate-annotation-reply-p (annotation)
  "Returns true if ANNOTATION is a reply"
  (annotate-annotation-reply-to annotation))

(defun annotate-annotation-set-face (annotation face)
  "Set property face to FACE for ANNOTATION."
  (overlay-put annotation 'face face))

(defun annotate-annotation-face (annotation)
  "Get property face from ANNOTATION."
  (overlay-get annotation 'face))

(defun annotate-annotation-set-annotation-face (annotation face)
  "Set property annotation-face to FACE for ANNOTATION."
  (overlay-put annotation 'annotation-face face))

(defun annotate-annotation-property-annotation-face (annotation)
  "Get property annotation-face from ANNOTATION."
  (overlay-get annotation 'annotation-face))

(defun annotate-annotation-set-annotation-text (annotation annotation-text)
  "Set the annotation's content for ANNOTATION to ANNOTATION-TEXT."
  (overlay-put annotation 'annotation annotation-text))

(defun annotate-annotation-get-annotation-text (annotation)
  "Get the annotation's content for ANNOTATION."
  (overlay-get annotation 'annotation))

(defun annotate-annotation-set-position (annotation position)
  "Set the annotation's position policy for ANNOTATION
to the value bound to POSITION."
  (overlay-put annotation 'annotate-position position))

(defun annotate-annotation-get-position (annotation)
  "Get the annotation's position policy for ANNOTATION."
  (overlay-get annotation 'annotate-position))

(defun annotate-overlay-maybe-set-position (overlay position)
  "Set the annotation's position policy for OVERLAY to the value bound
to POSITION,but only if the value of the property `position' is not null."
  (when position
    (annotate-annotation-set-position overlay position)))

(defun annotate-chain-last-ring (chain)
  "Get the last ring of CHAIN."
  (car (last chain)))

(defun annotate--remap-chain-pos (annotations)
  "Remap ANNOTATIONS as an annotation \"chain\".

An annotation is a collection of one or more overlays that
contains the property `annotate-prop-chain-position'.

The value of `annotate-prop-chain-position' in each chain is an
integer starting from:

`annotate-prop-chain-pos-marker-first' and *always* ending with

`annotate-prop-chain-pos-marker-last'

This means that a value of said property for a chain that
contains only an element is equal to
`annotate-prop-chain-pos-marker-last'.

This function ensure this constrains for the chain ANNOTATION
belong."
  (cond
   ((< (length annotations)
       1)
    annotations)
   ((= (length annotations)
       1)
    (annotate-annotation-set-chain-last (cl-first annotations)))
   (t
    (let ((all-but-last (butlast annotations))
          (last-element (car (last annotations))))
      (cl-loop for annotation in all-but-last
               for i from annotate-prop-chain-pos-marker-first
               do
               (annotate-annotation-chain-position annotation i))
      (when last-element
        (annotate-annotation-set-chain-last last-element))))))

(defun annotate-before-change-fn (a _b)
  "This function is added to \"before-change-functions\" hook and
it is called any time the buffer content is changed (so, for
example, text is added or deleted). In particular, it will
rearrange the overlays bounds when an annotated text is
modified (for example a newline is inserted)."
  (with-silent-modifications
    (save-excursion
      (let* ((bol (annotate-beginning-of-line-pos))
             (eol (annotate-end-of-line-pos))
             (ov  (cl-remove-if-not #'annotationp
                                    (overlays-in bol eol))))
        (dolist (overlay ov)
          (annotate--remove-annotation-property (overlay-start overlay)
                                                (overlay-end   overlay))
          ;; check if we are breaking the overlay
          (when (<= (overlay-start overlay)
                    a
                    (overlay-end overlay))
            (let ((start-overlay (overlay-start overlay)))
              ;; delete overlay if there is no more annotated text
              (when (<= a start-overlay)
                (let ((chain (cl-remove overlay (annotate-find-chain overlay))))
                  (delete-overlay overlay)
                  (annotate--remap-chain-pos chain))))))))))

(defun annotate-info-select-fn ()
  "The function to be called when an info buffer is updated."
  (annotate-clear-annotations)
  (annotate-load-annotations)
  (font-lock-flush))

(defun on-window-size-change (_frame)
  "The function to call when window-size-change-functions is called,
note that the argument _FRAME is ignored"
  (font-lock-flush))

(defun annotate--filepath->local-database-name (filepath)
  "Generates the file path of the local database form FILEPATH."
  (concat (file-name-nondirectory filepath)
          "."
          annotate-buffer-local-database-extension))

(defun annotate--maybe-database-set-buffer-local ()
  "Sets, if user asked to do so, the annotation database to a
local version (i.e. a different database for each annotated file"
  (when annotate-file-buffer-local
    (make-local-variable 'annotate-file)
    (when-let* ((buffer-file-path (buffer-file-name))
                (parent-directory (file-name-directory buffer-file-path))
                (db-name (annotate--filepath->local-database-name buffer-file-path)))
      (setq-local annotate-file db-name))))

(defun annotate-timer-print-annotation-function ()
  "Print annotation under point in the minibuffer.
Used by the timer set in `annotate--maybe-make-timer-print-annotation'.

See also the customizable variables: `annotate-echo-annotation-timer' and
`annotate-print-annotation-under-cursor'."
  (with-current-buffer (current-buffer)
    (when annotate-mode
      (when-let* ((annotation (annotate-annotation-at (point))))
        (message "%s%s"
                 annotate-print-annotation-under-cursor-prefix
                 (annotate-annotation-get-annotation-text annotation))))))

(defun annotate-print-annotation-under-cursor-p ()
  "Non nil if the user configured the package to print
annotation's text in the minibuffer."
  (and annotate-use-echo-area
       annotate-print-annotation-under-cursor))

(defun annotate--maybe-make-timer-print-annotation ()
  "Set the timer to print the annotation's text in the minibuffer.
Used when the mode is activated."
  (when (annotate-print-annotation-under-cursor-p)
    (setf annotate-echo-annotation-timer
          (run-with-idle-timer annotate-print-annotation-under-cursor-delay
                               t
                               #'annotate-timer-print-annotation-function))))

(defun annotate--maybe-cancel-timer-print-annotation ()
  "Cancel the timer to print the annotations text in the minibuffer.
Used when the mode is deactivated."
  (when (and (annotate-print-annotation-under-cursor-p)
             annotate-echo-annotation-timer
             (timerp annotate-echo-annotation-timer))
    (cancel-timer annotate-echo-annotation-timer)))

(defun annotate-initialize ()
  "Load annotations and set up save and display hooks."
  (annotate--maybe-database-set-buffer-local)
  (annotate--maybe-make-timer-print-annotation)
  (annotate-load-annotations)
  (add-hook 'kill-buffer-hook                 #'annotate-save-annotations t t)
  (add-hook 'kill-emacs-hook                  #'annotate-save-all-annotated-buffers t nil)
  ;; This hook  is needed to  reorganize the layout of  the annotation
  ;; text when a window vertically resized
  (add-hook 'window-size-change-functions     #'on-window-size-change t t)
  (add-hook 'before-change-functions          #'annotate-before-change-fn t t)
  (add-hook 'Info-selection-hook              #'annotate-info-select-fn   t t)
  (if annotate-use-echo-area
      (font-lock-add-keywords
       nil
       '((annotate--font-lock-matcher (2 (annotate--annotation-builder)))))
    (font-lock-add-keywords
     nil
     '((annotate--font-lock-matcher (2 (annotate--annotation-builder))
                                    (1 (annotate--change-guard)))))))

(defun annotate-shutdown ()
  "Clear annotations and remove save and display hooks."
  (annotate-clear-annotations)
  (annotate--maybe-cancel-timer-print-annotation)
  (remove-hook 'kill-buffer-hook                 #'annotate-save-annotations t)
  (remove-hook 'kill-emacs-hook                  #'annotate-save-all-annotated-buffers nil)
  (remove-hook 'window-size-change-functions     #'on-window-size-change t)
  (remove-hook 'before-change-functions          #'annotate-before-change-fn t)
  (remove-hook 'Info-selection-hook              #'annotate-info-select-fn   t)
  (if annotate-use-echo-area
      (font-lock-remove-keywords
       nil
       '((annotate--font-lock-matcher (2 (annotate--annotation-builder)))))
    (font-lock-remove-keywords
     nil
     '((annotate--font-lock-matcher (2 (annotate--annotation-builder))
                                    (1 (annotate--change-guard)))))))

(defun annotate-overlay-filled-p (overlay)
  "Does this OVERLAY contains an `annotation' property?"
  (and overlay
       (overlayp overlay)
       (annotate-annotation-get-annotation-text overlay)))

(defun annotationp (overlay)
  "Is OVERLAY an annotation?"
  (annotate-overlay-filled-p overlay))

(cl-defmacro annotate-ensure-annotation ((overlay) &body body)
  "Runs BODY only if OVERLAY is an annotation (i.e. passes annotationp)."
  `(and (annotationp ,overlay)
        (progn ,@body)))

(defun annotate--position-on-annotated-text-p (pos)
  "Does POS (as buffer position) corresponds to a character
that belong to some annotated text?"
  (let ((annotation (annotate-annotation-at pos)))
    (if annotation
        t
      ;; there is  a chance  that a  point do not  belong to  the text
      ;; rendered as annotated but belong to a chain anyway example:
      ;;
      ;; legend:
      ;; a = annotated text
      ;; * = non annotated text
      ;; # = annotation
      ;;
      ;; Create a multiline annotation using region.
      ;;
      ;; aaaa
      ;; aaaa
      ;; aaaa
      ;;
      ;;
      ;; aaaa
      ;; aaaa
      ;; aaaa    ####
      ;;
      ;; place the cursor here:
      ;;
      ;; aaaa
      ;; aaaa
      ;; ^ cursor
      ;; aaaa    ####
      ;;
      ;; type some text
      ;;
      ;; aaaa
      ;; *****
      ;; aaaa    ####
      ;;
      ;; the text (the asterisks) is not rendered as annotated but as
      ;; annotations can not have gaps so we enforce this limitation
      ;; and consider it still parts of a chain formed by the
      ;; surrounding annotated text.
      (let* ((previous-annotation (annotate-previous-annotation-ends pos))
             (next-annotation     (annotate-next-annotation-starts   pos))
             (previous-chain      (annotate-chain-first previous-annotation))
             (next-chain          (annotate-chain-first next-annotation)))
        (if (and previous-chain
                 next-chain
                 (eq previous-chain
                     next-chain))
            t
          nil)))))

(defun annotate-delete-chains-in-region (from to)
  "Deletes all the chains enclosed in the range specified by
positions FROM and TO."
  (let* ((enclosed-chains (annotate-annotations-chain-in-range from to)))
    (dolist (chain enclosed-chains)
      (annotate--delete-annotation-chain (cl-first chain)))))

(defun annotate-count-newline-in-region (from to)
  "Counts the number of newlines character (?\n) in range
specified by FROM and TO."
  (cl-count-if (lambda (a) (char-equal a ?\n))
               (buffer-substring-no-properties from to)))

(defun annotate--expand-annotation-text (annotation-text)
  "Expand substrings of ANNOTATION-TEXT, using rules defined in the variable in
`in annotate-annotation-expansion-map'."
  (cl-flet ((regex (expansion-item)
              (cl-first expansion-item))
            (trimp (expansion-item)
              (cl-third expansion-item))
            (command (expansion-item)
              (cl-second expansion-item)))
    (cl-loop with results = annotation-text
             for expansion in annotate-annotation-expansion-map
             when (string-match-p (regex expansion) results)
             do (let ((expansion-results (shell-command-to-string (command expansion))))
                  (when (trimp expansion)
                    (setf expansion-results (string-trim expansion-results)))
                  (setf results
                        (replace-regexp-in-string (regex expansion)
                                                  expansion-results
                                                  results
                                                  t
                                                  t)))
             finally (return results))))

(defun annotate--make-reply-to (parent-annotation reply-author reply-body)
  "Attach a reply to the annotation PARENT-ANNOTATION"
  (let ((parent-id  (annotate-annotation-id parent-annotation))
        (reply-text (format "from: %s\n%s"
                            reply-author
                            reply-body)))
    (annotate--make-annotation-for-record nil
                                          nil
                                          reply-text
                                          nil
                                          nil
                                          nil
                                          (annotate--generate-unique-id)
                                          parent-id)))

(defun annotate--make-reply-annotation (parent-annotation author reply-body)
  "Makes an annotation with text equals to the concatenation
of AUTHOR and REPLY-BODY (see: `annotate--make-reply-to'.
The new annotation will be a reply to PARENT-ANNOTATION.
This new annotation will be saved in the annotations database."
  (let ((annotation-record (annotate--make-reply-to parent-annotation
                                                    author
                                                    reply-body)))
    (annotate-save-annotations :replace t)
    (annotate-save-annotations :annotations-to-save (list annotation-record)
                               :replace nil)))

(defun annotate--annotation-with-reply (chain)
  "Find the ring in annotation's chain CHAIN that could host the reply annotation."
  (annotate-chain-first (cl-first chain)))

(defun annotate-reply-to ()
  "Reply to the annotation under cursor, if such annotation exists."
  (interactive)
  (when-let* ((chain        (annotate-chain-at (point)))
              (parent       (annotate--annotation-with-reply chain))
              (reply-author (read-from-minibuffer "Author: "
                                                  (user-login-name)))
              (reply-body   (read-from-minibuffer annotate-annotation-prompt))
              (reply-text   (format "from: %s\n%s" reply-author reply-body)))
    (annotate--make-reply-annotation parent reply-author reply-body)))

(defun annotate-annotate (&optional color-index)
  "Create, modify, or delete annotation.
if COLOR-INDEX is not null must be an index that adresses an element both in
- `annotate-highlight-faces'
and
- `annotate-annotation-text-faces'"
  (interactive "P")
  (when color-index
    (setf color-index (min (max (1- color-index) 0)
                           (1- (length annotate-highlight-faces)))))
  (cl-labels ((create-new-annotation ()
                ;; create a new annotation in the region returned by `annotate-bound'
                (cl-destructuring-bind (start end)
                    (annotate-bounds)
                  (let* ((raw-text        (read-from-minibuffer annotate-annotation-prompt))
                         (annotation-text (annotate--expand-annotation-text raw-text)))
                    (condition-case nil
                        (annotate-create-annotation start end annotation-text nil color-index)
                      (annotate-no-new-line-at-end-file-error
                       (user-error "Missing newline at the end of the buffer"))
                      (annotate-empty-annotation-text-error
                       (user-error "Annotation text is empty"))))))
              (cut-right (region-beg region-stop &optional delete-enclosed)
                ;; This function  will trim on  the right one  or more
                ;; existing  chains   of  overlays  that   compose  an
                ;; annotation  (i.e.  the   overlays  applied  on  the
                ;; annotated text). After this  function is called the
                ;; text  staring  from   `region-beg'  and  ending  on
                ;; `region-stop' will be cleared of all annotations if
                ;; `delete-enclosed' is non null.
                (let* ((last-of-chain-to-cut  (annotate-chain-last-at region-beg))
                       (first-of-chain-to-cut (annotate-chain-first-at region-beg))
                       (chain-start           (overlay-start first-of-chain-to-cut))
                       (chain-end             (overlay-end   last-of-chain-to-cut))
                       (newlines-count        (annotate-count-newline-in-region region-beg
                                                                                chain-end))
                       (cut-count             (- chain-end
                                                 region-beg
                                                 newlines-count)))
                  (cl-loop repeat cut-count do
                           (when (annotate-annotation-at chain-start)
                             (annotate--cut-right-annotation first-of-chain-to-cut t)))
                  (when delete-enclosed
                    (annotate-delete-chains-in-region chain-end region-stop))))
              (cut-left (region-stop delete-enclosed)
                ;; This function  will trim  on the  left one  or more
                ;; existing  chains   of  overlays  that   compose  an
                ;; annotation  (i.e.   the  overlays  applied  on  the
                ;; annotated text). After this  function is called the
                ;; text starting from the last  char of the last chain
                ;; element   of   the   annotation   and   ending   on
                ;; `region-stop' will be cleared of all annotations if
                ;; `delete-enclosed' is non null.
                (let* ((last-of-chain-to-cut  (annotate-chain-last-at region-stop))
                       (first-of-chain-to-cut (annotate-chain-first-at region-stop))
                       (chain-start           (overlay-start first-of-chain-to-cut))
                       (chain-end             (overlay-end   last-of-chain-to-cut))
                       (newlines-count        (annotate-count-newline-in-region chain-start
                                                                                region-stop))
                       (cut-count             (- region-stop
                                                 chain-start
                                                 newlines-count)))
                  (cl-loop repeat cut-count do
                           (when (annotate-annotation-at (1- chain-end))
                             (annotate--cut-left-annotation last-of-chain-to-cut)))
                  (when delete-enclosed
                    (annotate-delete-chains-in-region chain-end region-stop))))
              (annotate-overwrite-range (start end)
                ;; annotate  text starting  from  `start'  and ending  on
                ;; `end', overwriting any other annotation existing in
                ;; that range
                (goto-char end)
                (push-mark (point) t t)
                (goto-char start)
                (annotate-annotate))
              (annotate-line (eol)
                ;; annotate a line that terminate at `eol'
                ;;
                ;; if  the line  contains no  text before  the newline
                ;; annotate the next line with text, if any.
                ;;
                ;; if the line contains a single annotation that spans
                ;; the whole line update the existing annotation
                ;;
                ;; if the  line contains  no annotation, or  more than
                ;; one  annotation,  annotate   the  whole  line  that
                ;; terminate at `eol'
                (let* ((bol                     (annotate-beginning-of-line-pos))
                       (annotations-on-the-line (annotate-annotations-overlay-in-range bol
                                                                                       eol)))
                  (if (= (length annotations-on-the-line)
                         1)
                      (let* ((annotation                    (cl-first annotations-on-the-line))
                             (start-overlay                 (overlay-start annotation))
                             (end-overlay                   (overlay-end   annotation))
                             (annotation-spans-whole-line-p (and (= start-overlay bol)
                                                                 (= end-overlay   eol))))
                        (if annotation-spans-whole-line-p
                            (progn
                              (goto-char end-overlay)
                              (push-mark start-overlay t t)
                              (annotate-change-annotation (overlay-start annotation))
                              (pop-mark))
                          (annotate-overwrite-range bol eol)))
                    (annotate-overwrite-range bol eol)))))
    (let ((annotation (annotate-annotation-at (point))))
      (cond
       ((use-region-p)
        (let* ((region-beg      (region-beginning))
               (region-stop     (region-end))
               (enclosed-chains (annotate-annotations-chain-in-range region-beg region-stop)))
          (cond
           ((and (annotate--position-on-annotated-text-p region-beg)
                 (annotate--position-on-annotated-text-p region-stop))
            ;; aaaaaaaaaaaaaaaaaa
            ;;   ^-----------^
            (let ((starting-chain-at-start (annotate-chain-first-at region-beg))
                  (starting-chain-at-end   (annotate-chain-first-at region-stop)))
              (if (eq starting-chain-at-start
                      starting-chain-at-end)
                  (signal 'annotate-annotate-region-overlaps nil)
                (cut-left region-stop nil)
                (cut-right region-beg region-stop t)
                (create-new-annotation))))
           ((annotate--position-on-annotated-text-p region-beg)
            ;; aaaabbcc**********
            ;;   ^------------^
            (cut-right region-beg region-stop t)
            (create-new-annotation))
           ((annotate--position-on-annotated-text-p region-stop)
            ;; **********cccaaaa
            ;;   ^------------^
            (cut-left region-stop t)
            (create-new-annotation))
           (enclosed-chains
            ;; ****aaaaaaaaaaaaaaa****
            ;;  ^------------------^
            (annotate-delete-chains-in-region region-beg region-stop)
            (create-new-annotation))
           (t
            (create-new-annotation)))))
       (annotation
        (annotate-change-annotation (point))
        (font-lock-flush))
       (t
        (if (annotate--position-on-annotated-text-p (point))
            (signal 'annotate-annotate-region-overlaps nil)
          (let ((char-maybe-newline (char-after)))
            (when char-maybe-newline
              (cond
               ((not (char-equal char-maybe-newline ?\n))
                (create-new-annotation))
               ((null annotate-endline-annotate-whole-line)
                (user-error "The end of line can not be annotated"))
               (t ;; annotate the whole line before or after
                (save-excursion
                  (let* ((bol (annotate-beginning-of-line-pos))
                         (eol (point)))
                    (if (/= eol bol)       ; text before the newline, annotate it
                        (annotate-line eol)
                      (progn                ; no text before  the new
                                        ; line, annotate next line
                                        ; with proper text
                        (forward-line 1)
                        (goto-char (annotate-end-of-line-pos))
                        (annotate-annotate))))))))))))
      (when annotate-autosave
        (annotate-save-annotations :replace t)))))

(defun annotate-toggle-annotation-text ()
  "Hide annotation's text at current cursor's point, if such annotation exists."
  (interactive)
  (when-let* ((chain     (annotate-chain-at (point)))
              (last-ring (annotate-chain-last-ring chain)))
    (if (annotate-tail-overlay-hide-text-p last-ring)
        (annotate-chain-show-text chain)
      (annotate-chain-hide-text chain))
    (font-lock-flush)))

(defun annotate-toggle-all-annotations-text ()
  "Hide annotation's text in the whole buffer."
  (interactive)
  (let ((chains (annotate-annotations-chain-in-range 0 (buffer-size))))
    (dolist (chain chains)
      (if (annotate-tail-overlay-hide-text-p (annotate-chain-last-ring chain))
          (annotate-chain-show-text chain)
        (annotate-chain-hide-text chain))))
  (font-lock-flush))

(cl-defun annotate-goto-next-annotation (&key (startingp t))
  "Move point to the next annotation.
STARTINGP is an internal variable."
  (interactive)
  (let ((annotation (annotate-annotation-at (point))))
    (if startingp
        (if annotation
            (let* ((chain-last          (annotate-chain-last annotation))
                   (annotation-last-end (overlay-end chain-last))
                   (look-ahead          (annotate-next-annotation-starts annotation-last-end)))
              (if look-ahead
                  (progn
                    (goto-char annotation-last-end)
                    (annotate-goto-next-annotation :startingp nil))
                (when annotate-use-messages
                  (message "This is the last annotation."))))
          (let ((next-annotation (annotate-next-annotation-starts (point))))
            (when next-annotation
              (goto-char (overlay-start next-annotation)))))
      (if annotation
          (let ((chain-first (annotate-chain-first annotation)))
            (goto-char (overlay-start chain-first)))
        (annotate-goto-next-annotation :startingp t)))))

(cl-defun annotate-goto-previous-annotation (&key (startingp t))
  "Move point to the previous annotation.  STARTINGP is an internal variable."
  (interactive)
  (let ((annotation (annotate-annotation-at (point))))
    (if startingp
        (if annotation
            (let* ((chain-first            (annotate-chain-first annotation))
                   (annotation-first-start (overlay-start chain-first))
                   (look-behind            (annotate-previous-annotation-ends annotation-first-start)))
              (if look-behind
                  (progn
                    (goto-char (1- annotation-first-start))
                    (annotate-goto-previous-annotation :startingp nil))
                (when annotate-use-messages
                  (message "This is the first annotation."))))
          (let ((previous-annotation (annotate-previous-annotation-ends (point))))
            (when previous-annotation
              (goto-char (1- (overlay-end previous-annotation))))))
      (if annotation
          (let ((chain-last (annotate-chain-last annotation)))
            (goto-char (overlay-end chain-last)))
        (annotate-goto-previous-annotation :startingp t)))))

(defun annotate-change-annotation-text-position ()
  "Change the policy positioning for the annotation under point."
  (interactive)
  (when-let* ((annotation (annotate-annotation-at (point))))
    (let ((current-position (annotate-annotation-get-position annotation)))
      (if (null current-position)
          (annotate-annotation-set-position annotation
                                            (cl-first annotate-allowed-positioning-policy))
        (when-let* ((current-position-index (cl-position current-position
                                                         annotate-allowed-positioning-policy))
                    (next-position-index    (mod (1+ current-position-index)
                                                 (length annotate-allowed-positioning-policy))))
          (annotate-annotation-set-position annotation
                                            (elt annotate-allowed-positioning-policy
                                                 next-position-index)))))
    (message "New position policy for this annotation is %s"
             (annotate-annotation-get-position annotation))
    (font-lock-flush)))

(defun annotate-change-annotation-colors ()
  "Change the colors for the annotation under point."
  (interactive)
  (cl-flet ((new-color-index (annotation)
              (let ((current-annotation-face (annotate-annotation-property-annotation-face annotation)))
                (if current-annotation-face
                    (let* ((current-color-index (cl-position-if (lambda (a)
                                                                  (cl-equalp current-annotation-face
                                                                             a))
                                                                annotate-annotation-text-faces))
                           (new-color-index     (mod (1+ current-color-index)
                                                     (length annotate-annotation-text-faces))))
                      new-color-index)
                  0))))
    (when-let* ((annotation (annotate-annotation-at (point))))
      (let ((new-color-index (new-color-index annotation)))
        (annotate-annotation-set-annotation-face annotation
                                                 (elt annotate-annotation-text-faces
                                                      new-color-index))
        (annotate-annotation-set-face annotation
                                      (elt annotate-highlight-faces
                                           new-color-index))
        (font-lock-flush)))))

(defun annotate-actual-comment-start ()
  "String for comment start related to current buffer's major mode."
  (or comment-start
      annotate-fallback-comment))

(defun annotate-actual-comment-end ()
  "String for comment ends, if any, related to current buffer's major mode."
  (or comment-end
      ""))

(defun annotate-comments-length ()
  "Total length of the comment markers (start and end) strings."
  (+ (string-width (annotate-actual-comment-start))
     (string-width (annotate-actual-comment-end))))

(defun annotate-wrap-in-comment (&rest strings)
  "Put comment markers at the start and (if it makes sense)
end of the string returned by concatenating STRINGS.
 See: annotate-actual-comment-start and annotate-actual-comment-end."
  (apply #'concat (append (list (annotate-actual-comment-start))
                          strings
                          (list (annotate-actual-comment-end)))))

(cl-defstruct annotate-overlay-lines
  overlay
  line
  relative-start
  relative-end)

(cl-defun annotate--integrate-annotations (&key (use-annotation-marker t)
                                                (as-new-buffer         t)
                                                (switch-to-new-buffer  t))
  "Export all annotations, This function is not part of the public API.
if USE-ANNOTATION-MARKER is not nill the annotation's text will be wrappend with
`annotate-integrate-marker'.
if AS-NEW-BUFFER is not nil the intergrated text will be shown in a new buffer.
If SWITCH-TO-NEW-BUFFER is not nil (and so is AS-NEW-BUFFER), the new buffer
will get the focus."
  (cl-labels ((build-input-text-line ()
                (save-excursion
                  (annotate--split-lines (buffer-substring-no-properties (point-min)
                                                                         (point-max))))))

    (let* ((filename               (annotate-actual-file-name))
           (export-buffer          (generate-new-buffer (concat filename ".annotated.diff")))
           (annotations-overlays   (sort (annotate-all-annotations)
                                         (lambda (a b)
                                           (< (overlay-start a)
                                              (overlay-start b)))))
           (lines-count            (count-lines (point-min) (point-max)))
           (buffer-lines           (build-input-text-line))
           (ov-line-pos            (mapcar (lambda (ov)
                                             (line-number-at-pos (overlay-start ov)))
                                           annotations-overlays))
           (ov-start-pos-in-line   (mapcar (lambda (ov)
                                             (save-excursion
                                               (goto-char (overlay-start ov))
                                               (let ((bol (annotate-beginning-of-line-pos)))
                                                 (- (overlay-start ov) bol))))
                                           annotations-overlays))
           (ov-end-pos-in-line     (mapcar (lambda (ov)
                                             (save-excursion
                                               (goto-char (overlay-start ov))
                                               (let ((bol (annotate-beginning-of-line-pos)))
                                                 (- (overlay-end ov) bol))))
                                           annotations-overlays))
           (overlay-relative-pos   (cl-mapcar (lambda (ov line start end)
                                                (make-annotate-overlay-lines :overlay        ov
                                                                             :line           line
                                                                             :relative-start start
                                                                             :relative-end   end))
                                              annotations-overlays
                                              ov-line-pos
                                              ov-start-pos-in-line
                                              ov-end-pos-in-line))
           (parent-buffer-mode     major-mode)
           (output-buffer          (if as-new-buffer
                                       export-buffer
                                     (current-buffer))))
      (with-current-buffer output-buffer
        (erase-buffer)
        (when as-new-buffer
          (funcall parent-buffer-mode))
        (cl-loop
         for buffer-line in buffer-lines
         for line-number from 1  do
         (let ((overlays-in-line (cl-remove-if-not (lambda (a)
                                                     (= (annotate-overlay-lines-line a)
                                                        line-number))
                                                   overlay-relative-pos)))
           (when (or (/= (1- line-number)
                         lines-count)
                     (not (annotate-string-empty-p buffer-line)))
             (insert buffer-line "\n")
             (cl-loop for ov-line-pos in overlays-in-line do
                      (let* ((overlay         (annotate-overlay-lines-overlay ov-line-pos))
                             (relative-start  (annotate-overlay-lines-relative-start ov-line-pos))
                             (relative-end    (annotate-overlay-lines-relative-end ov-line-pos))
                             (padding         (if (<= (1- relative-start) 0)
                                                  ""
                                                (make-string (1- relative-start) ? )))
                             (annotated-lines (annotate--split-lines
                                               (annotate-annotation-get-annotation-text overlay)))
                             (ov-length       (- relative-end relative-start))
                             (underline       (make-string ov-length
                                                           annotate-integrate-highlight)))
                        (insert (annotate-wrap-in-comment padding underline) "\n")
                        (when (annotate-chain-last-p overlay)
                          (when use-annotation-marker
                            (insert (annotate-wrap-in-comment annotate-integrate-marker) "\n"))
                          (cl-loop for line in annotated-lines do
                                   (insert (annotate-wrap-in-comment line) "\n")))))))))
      (when (and as-new-buffer
                 switch-to-new-buffer)
        (switch-to-buffer output-buffer))
      (when (not as-new-buffer)
        (delete-region (point) (point-max)))
      output-buffer)))

(defun annotate-integrate-annotations ()
  "Write all annotations into the file as comments below the annotated line.
An example might look like this:"
  (interactive)
  (annotate--integrate-annotations :use-annotation-marker t
                                   :as-new-buffer         nil
                                   :switch-to-new-buffer  nil)
  (annotate-clear-annotations))

(defun annotate-export-annotations ()
  "Export all annotations as a unified diff file.
An example might look like this:

--- .../annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200
+++ .../annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200
@@ -73,5 +73,5 @@
 ;;;###autoload
 (defface annotate-highlight
-  \\='((t (:underline \"coral\"))))
+  \\='((t (:underline \"coral\"))))
#        ~~~~~~~~~~~~~~~~~~
#        this doesn't work in cli
   \"Face for annotation highlights.\")

This diff does not contain any changes, but highlights the
annotation, and can be conveniently viewed in diff-mode."
  (interactive)
  (let ((buffer (annotate--integrate-annotations :switch-to-new-buffer nil)))
    (diff-buffers (current-buffer) buffer annotate-diff-export-options)))

(defun annotate--font-lock-matcher (limit)
  "Finds the next annotation before LIMIT. Matches two areas:
- the area between the overlay and the annotation
- the newline that will display the annotation

The first match will get `annotate--change-guard' as its
`insert-in-front-hook', to make sure that if a newline is inserted
between the overlay and the annotation, the \"display\" property of
the newline is properly disposed of.

The second match will get `annotate--annotation-builder' as its
`display' property, which makes the newline look like an
annotation plus the newline."
  (goto-char (next-overlay-change (point)))
  (if (>= (point) limit)
      nil ; no match found before limit
    (progn
      ;; go to the end of the longest annotation under point
      (let ((overlays (sort (cl-remove-if (lambda (a)
                                            (not (and (annotationp a)
                                                      (< (overlay-end a)
                                                         limit))))
                                          (overlays-at (point)))
                            (lambda (x y)
                              (> (overlay-end x)
                                 (overlay-end y))))))
        (when overlays
          (goto-char (overlay-end (car overlays)))))
      ;; capture the area from the overlay to EOL (regexp match #1)
      ;; for the modification guard and the newline itself (regexp
      ;; match #2) for the annotation.
      (re-search-forward "\\(.*\\(\n\\)\\)" limit t))))

(cl-defstruct annotate-group
  words
  start-word)

(defun annotate-group-by-width (text maximum-width)
  "Groups TEXT in a list formed by chunks of maximum size equal
to MAXIMUM-WIDTH."
  (cl-labels ((next-word (words)
                (or (cl-first words)
                    ""))
              (join-until-width (words &optional (word nil))
                (cond
                 ((null words)
                  (make-annotate-group :words      nil
                                       :start-word word))
                 (t
                  (let* ((next-word (next-word words))
                         (new-word  (if word
                                        (concat word " " next-word)
                                      next-word)))
                    (if (<= (string-width new-word)
                            maximum-width)
                        (join-until-width (cl-rest words) new-word)
                      (make-annotate-group :words      words
                                           :start-word (or word next-word)))))))
              (split-position (text column-max-width)
                (let ((character-width (length       text))
                      (column-width    (string-width text)))
                  (if (= character-width column-width)
                      column-max-width
                    (let* ((res    0)
                           (so-far ""))
                      (cl-loop for i from 0 below column-max-width
                               until (>= (string-width so-far)
                                         column-max-width)
                               do
                               (setf so-far (concat so-far (string (elt text i))))
                               (setf res i))
                      res))))
              (%group (words so-far)
                (cond
                 ((null words)
                  so-far)
                 ((<= (string-width (cl-first words))
                      maximum-width)
                  (let* ((potential-start (join-until-width words))
                         (word            (annotate-group-start-word potential-start))
                         (nonjoined-words (annotate-group-words potential-start))
                         (rest-words      nonjoined-words)
                         (potential-start word))
                    (%group rest-words
                            (append (list potential-start)
                                    so-far))))
                 (t
                  (let* ((word           (cl-first words))
                         (rest-words     (cl-rest words))
                         (split-position (split-position word maximum-width))
                         (prefix         (cl-subseq word 0 split-position))
                         (next-word      (if rest-words
                                             (cl-first rest-words)
                                           ""))
                         (raw-suffix     (cl-subseq word split-position))
                         (suffix         (if rest-words
                                             (concat raw-suffix " " next-word)
                                           raw-suffix)))
                    (%group (append (list suffix)
                                    (cl-rest rest-words))
                            (append (list prefix)
                                    so-far))))))
              (%split-words (text)
                (save-match-data (split-string text "[[:space:]]" t))))
    (if (< maximum-width 1)
        nil
      (let* ((words   (%split-words text))
             (grouped (reverse (%group words '()))))
        grouped))))

(cl-defun annotate-safe-subseq (seq from to &optional (value-if-limits-invalid seq))
  "Return a substring of SEQ or VALUE-IF-LIMITS-INVALID
sequence if FROM or TO are invalids."
  (cond
   ((< to from)
    value-if-limits-invalid)
   ((or (< from 0)
        (> from (length seq))
        (> to   (length seq)))
    value-if-limits-invalid)
   (t
    (cl-subseq seq from to))))

(defun annotate-lineate (text line-width)
  "Breaks TEXT into lines to fit in the annotation space with width LINE-WIDTH."
  (cl-labels ((pad (string max-width add-newline-p)
                (if (null string)
                    ""
                  (let* ((size       (string-width string))
                         (rest-width (max (- max-width
                                             size)
                                          0))
                         (padding    (make-string rest-width
                                                  ? )))
                    (if add-newline-p
                        (concat string padding "\n")
                      (concat string padding)))))
              (%subseq (seq from to)
                (if (= (length seq) 1)
                    nil
                  (annotate-safe-subseq seq from to nil))))
    (let* ((current-window             (get-buffer-window (current-buffer)))
           (theoretical-line-width     (- (window-body-width current-window)
                                          annotate-annotation-column))
           (available-width            (if (> theoretical-line-width 0)
                                           theoretical-line-width
                                         line-width))
           (lineated-list              (annotate-group-by-width text available-width))
           (max-width                  (apply #'max
                                              (mapcar #'string-width lineated-list)))
           (all-but-last-lineated-list (%subseq lineated-list 0 (1- (length lineated-list))))
           (last-line                   (if all-but-last-lineated-list
                                            (car (last lineated-list))
                                          (cl-first lineated-list)))
           (lineated                   (cl-mapcar (lambda (a)
                                                    (pad a max-width t))
                                                  all-but-last-lineated-list)))
      (apply #'concat
             (append lineated
                     (list (pad last-line max-width nil)))))))

(cl-defun annotate--split-lines (text &optional (separator "\n"))
  "Return TEXT splitted by SEPARATOR (default: \"\n\")."
  (save-match-data
    (split-string text separator)))

(defun annotate--join-with-string (strings junction)
  "Join list of string in STRINGS using string JUNCTION."
  (cl-reduce (lambda (a b) (concat a junction b))
             strings))

(defun annotate-wrap-annotation-in-box (annotation-overlay
                                        begin-of-line
                                        end-of-line
                                        annotation-on-is-own-line-p)
  "Pads or breaks annotation text (as property of
ANNOTATION-OVERLAY so that all lines have the same width.

If annotation is a placed on the margin of a window (that is
ANNOTATION-ON-IS-OWN-LINE-P is
nil) the text is broken (regardless of words) to fit on the side
of the window using BEGIN-OF-LINE END-OF-LINE.

If annotation is a note that is placed in its own line the text is padded
with spaces so that a \"box\" surround the text without seams, e.g:

aaa      aaa
aa   ->  aa*
a        a**"
  (let ((annotation-text (annotate-annotation-get-annotation-text annotation-overlay)))
    (cl-labels ((boxify-multiline (raw-annotation-text &optional add-space-at-end)
                  (let* ((lines         (annotate--split-lines raw-annotation-text))
                         (lines-widths  (mapcar #'string-width lines))
                         (max-width     (cl-reduce (lambda (a b) (if (> a b)
                                                                     a
                                                                   b))
                                                   lines-widths
                                                   :initial-value -1))
                         (padding-sizes (mapcar (lambda (a) (- max-width
                                                               (string-width a)))
                                                lines))
                         (paddings      (mapcar (lambda (a) (make-string a ? ))
                                                padding-sizes))
                         (box-lines     (cl-mapcar (lambda (a b) (concat a b))
                                                   lines paddings))
                         (almost-boxed  (annotate--join-with-string box-lines "\n")))
                    (if add-space-at-end
                        (concat almost-boxed " ")
                      almost-boxed))))
      (if annotation-on-is-own-line-p
          (list (boxify-multiline annotation-text t))
        (let* ((lineated         (annotate-lineate annotation-text
                                                   (- end-of-line begin-of-line)))
               (boxed            (boxify-multiline lineated nil)))
          (annotate--split-lines boxed))))))

(defun annotate--current-highlight-face ()
  "Reurns the current annotation color theme."
  (elt annotate-highlight-faces
       (mod annotate-colors-index-counter
            (length annotate-highlight-faces))))

(defun annotate--current-annotation-text-face ()
  "Reurns the current annotation's text color theme."
  (elt annotate-annotation-text-faces
       (mod annotate-colors-index-counter
            (length annotate-annotation-text-faces))))

(defun annotate--annotation-builder ()
  "Searches the line before point for annotations, and returns a
\"facespec\" with the annotation in its \"display\" property."
  (save-excursion
    ;; (let ((newline-position (point)))
    (goto-char (1- (point))) ; we start at the start of the previous line
    ;; find overlays in the preceding line
    (let ((prefix-first       (annotate-make-prefix)) ; white spaces
                                        ; before first
                                        ; line of
                                        ; annotation
          (prefix-rest        (make-string annotate-annotation-column ? ))
          (bol                (progn (beginning-of-line) (point)))
          (eol                (progn (end-of-line) (point)))
          (annotation-text    "")
          (overlays           nil)
          (overlays-counter   1)
          (hidden-text        nil))
      ;; include previous line if point is at bol:
      (when (null (overlays-in bol eol))
        (setq bol (1- bol)))
      (setq overlays
            (sort (cl-remove-if-not #'annotationp
                                    (overlays-in bol eol))
                  (lambda (x y)
                    (< (overlay-end x) (overlay-end y)))))
      ;; configure each annotation's properties and place it on the
      ;; the window. The default position of the annotation (newline
      ;; or right margin) is indicated by the value of the
      ;; variable: `annotate-annotation-position-policy'.
      (dolist (ov overlays)
        (let* ((last-ring-p          (annotate-chain-last-p ov))
               (annotation-face      (annotate-annotation-face ov)) ; added by annotate-create-annotation
               (annotation-text-face (annotate-annotation-property-annotation-face ov)) ; added by annotate-create-annotation
               (position             (annotate-annotation-get-position ov))
               (annotation-long-p  (> (string-width (annotate-annotation-get-annotation-text ov))
                                      annotate-annotation-max-size-not-place-new-line))
               (new-position-policy  position))
          (if (null position)
              (setf new-position-policy
                    (if (eq annotate-annotation-position-policy
                            :by-length)
                        (if annotation-long-p
                            :new-line
                          :margin)
                      annotate-annotation-position-policy))
            (setf new-position-policy
                  (if (eq position
                          :by-length)
                      (if annotation-long-p
                          :new-line
                        :margin)
                    position)))
          (let* ((wrap-in-a-new-line   (eq new-position-policy :new-line))
                 (multiline-annotation (annotate-wrap-annotation-in-box ov
                                                                        bol
                                                                        eol
                                                                        wrap-in-a-new-line))
                 (annotation-stopper   (if (not (eq new-position-policy
                                                    :margin))
                                           (if (= overlays-counter
                                                  (length overlays))
                                               "\n"
                                             "")
                                         "\n"))
                 (tail-hidden-text-p   (and last-ring-p
                                            (annotate-tail-overlay-hide-text-p ov))))
            (setf hidden-text tail-hidden-text-p)
            (cl-incf overlays-counter)
            (annotate-annotation-set-face ov annotation-face)
            (annotate-annotation-set-annotation-face ov annotation-text-face)
            (when (and (not annotate-use-echo-area)
                       (not hidden-text)
                       (annotate-chain-last-p ov))
              (when (and new-position-policy
                         (not (eq new-position-policy :margin)))
                (setf prefix-first " \n"))
              (dolist (l multiline-annotation)
                (setq annotation-text
                      (concat annotation-text
                              prefix-first
                              (propertize l 'face annotation-text-face)
                              annotation-stopper))
                ;; white space before for all but the first annotation line
                (if (eq new-position-policy
                        :new-line)
                    (setq prefix-first (concat prefix-first prefix-rest))
                  (setq prefix-first prefix-rest)))))))
      (when (not annotate-use-echo-area)
        ;; build facespec with the annotation text as display property
        (if (string= annotation-text "")
            ;; annotation has been removed: remove display prop
            (list 'face 'default 'display nil)
          ;; annotation has been changed/added: change/add display prop
          (list 'face 'default 'display annotation-text))))))

(defun annotate--remove-annotation-property (_begin end)
  "Cleans up annotation properties associated within a region
surrounded by _BEGIN and END."
  (when (and annotate-mode
             (> (buffer-size) 0))
    (with-silent-modifications
      (annotate-with-disable-read-only
        ;; copy undo list
        (let ((saved-undo-list (copy-tree buffer-undo-list t)))
          ;; inhibit property removal to the undo list (and empty it too)
          (buffer-disable-undo)
          (save-excursion
            (goto-char end)
            ;; go to the EOL where the
            ;; annotated newline used to be
            (end-of-line)
            ;; strip dangling display property
            (when (< (point)
                     (point-max))
              (remove-text-properties (point) (1+ (point)) '(display nil))))
          ;; restore undo list
          (setf buffer-undo-list saved-undo-list)
          (buffer-enable-undo))))))

(defun annotate-annotations-overlay-in-range (from-position to-position)
  "Return the annotations overlays that are enclosed in the range
defined by FROM-POSITION and TO-POSITION."
  (let ((annotations ())
        (counter (max 0 (1- from-position))))
    (catch 'scan-loop
      (while (<= counter
                 to-position)
        (cl-incf counter)
        (let ((annotation (annotate-next-annotation-starts counter)))
          (if (annotationp annotation)
              (let ((chain-end   (overlay-end   (annotate-chain-last  annotation)))
                    (chain-start (overlay-start (annotate-chain-first annotation))))
                (setf counter chain-end)
                (when (and (>= chain-start from-position)
                           (<= chain-end   to-position))
                  (cl-pushnew annotation annotations)))
            (throw 'scan-loop t)))))
    (reverse annotations)))

(defun annotate-annotations-chain-in-range (from-position to-position)
  "Return the annotations (chains) that are enclosed in the range
defined by FROM-POSITION and TO-POSITION."
  (let ((annotations (annotate-annotations-overlay-in-range from-position to-position))
        (chains      ()))
    (cl-loop for annotation in annotations do
             (let ((chain (annotate-find-chain annotation)))
               (cl-pushnew chain chains :test (lambda (a b) (eq (cl-first a) (cl-first b))))))
    (reverse chains)))

(defun annotate--change-guard ()
  "Return a `facespec' with an `insert-behind-hooks' property
that strips dangling `display' properties of text insertions if
text is inserted. This cleans up after newline insertions between
an overlay and it's annotation."
  (list 'face
        nil
        'insert-in-front-hooks
        '(annotate--remove-annotation-property)))

(defun annotate-prefix-lines (prefix text &optional omit-trailing-null)
  "Prepend PREFIX to each line in TEXT.
If OMIT-TRAILING-NULL is non null, empty line at the end of
text will be discarded."
  (let ((lines (annotate--split-lines text "\n")))
    (when omit-trailing-null
      (let ((last-not-empty (cl-position-if-not #'annotate-string-empty-p
                                                lines
                                                :from-end t)))
        (setf lines (cl-subseq lines 0 (1+ last-not-empty)))))
    (apply #'concat (mapcar (lambda (l) (concat prefix l "\n")) lines))))

;;; database related procedures

(cl-defun annotate-indirect-buffer-p (&optional (buffer (current-buffer)))
  "Returns non nil if BUFFER (default the current buffer) is an indirect buffer."
  (buffer-base-buffer buffer))

(defun annotate-indirect-buffer-current-p ()
  "Returns non nil if the current buffer is an indirect buffer."
  (annotate-indirect-buffer-p))

(cl-defun annotate-guess-filename-for-dump (filename
                                            &optional (return-filename-if-not-found-p t))
  "Guess an acceptable file name suitable for metadata database from FILENAME.
If RETURN-FILENAME-IF-NOT-FOUND-P is not nil return FILENAME even if
this file does not exists on the filesystem."
  (cond
   ((annotate-string-empty-p filename)
    nil)
   ((annotate-file-exists-p filename)
    filename)
   (t
    (let ((found (if return-filename-if-not-found-p
                     filename
                   nil)))
      (cl-block surrounding
        (dolist (extension annotate-info-valid-file-extensions)
          (let ((filename-maybe (concat filename extension)))
            (when (annotate-file-exists-p filename-maybe)
              (setf found filename-maybe)
              (cl-return-from surrounding found)))))
      found))))

(defun annotate-info-actual-filename ()
  "The info filename that feed this buffer or nil if not this
buffer is not on info-mode"
  (annotate-guess-filename-for-dump Info-current-file nil))

(defun annotate-actual-file-name ()
  "Get the actual file name of the current buffer."
  (cond
   ((annotate-indirect-buffer-current-p)
    nil)
   (t
    (let ((visited-filename (when (buffer-file-name)
                              (abbreviate-file-name (buffer-file-name)))))
      (substring-no-properties (or (annotate-info-actual-filename)
                                   visited-filename
                                   (buffer-file-name (buffer-base-buffer))
                                   ""))))))

(defun annotate--mac-address ()
  "Return the MAC address of one of the hardware network interface,
or nil if no such interface can be found."
  (when-let* ((all-interfaces-names (mapcar #'car (network-interface-list)))
              (interface-name       (cl-find-if-not (lambda (a) (string= a "lo"))
                                                    all-interfaces-names))
              (hw-address-vec       (cdr (cl-fourth (network-interface-info interface-name))))
              (hw-address           #x000000000000))
    (cl-loop for byte across hw-address-vec
             for shift from 40 downto -10 by 8
             do
             (setf hw-address
                   (logior hw-address (ash byte shift))))
    hw-address))

(defun annotate--generate-unique-id ()
  "Generate an unique string identifier
Note: implements time based  UUIDv1 (see: rfc9562)."
  (let* ((now        (+ (car (time-convert nil 10000000)) ; accuracy: 100 nanoseconds
                        #x01b21dd213814000)) ; convert unix epoch to gregorian epoch
         (time-low   (logand #xffffffff now))
         (time-mid   (logand #xffff (ash now -32)))
         (time-high  (logand #xfff (ash now -48)))
         (variant    #x02)
         (version    #x01)
         (node       (or (annotate--mac-address)
                         (random #xffffffffffff)))
         (clock      (logand #x3fff (random #xffff)))
         (uuid       #x00000000000000000000000000000000))
    (setf uuid (logior uuid (ash time-low 96)))
    (setf uuid (logior uuid (ash time-mid 80)))
    (setf uuid (logior uuid (ash version 76)))
    (setf uuid (logior uuid (ash time-high 64)))
    (setf uuid (logior uuid (ash variant 62)))
    (setf uuid (logior uuid (ash clock 48)))
    (setf uuid (logior uuid node))
    (format "%08x-%04x-%04x-%04x-%012x"
            (logand #xffffffff (ash uuid -96))
            (logand #x00ffff (ash uuid -80))
            (logand #x00ffff (ash uuid -64))
            (logand #x00ffff (ash uuid -48))
            (logand #xffffffffffff uuid))))

(defun annotate-annotation-id= (a b)
  "Returns non nil if annotations id A and B are equals."
  (string= a b))

(defun annotate-make-annotation-dump-entry (filename file-annotations checksum)
  "Make an annotation record: see `annotate-load-annotations'."
  (list filename
        file-annotations
        checksum))

(defun annotate-make-record (filename file-annotations checksum)
  "Make an annotation record: see `annotate-load-annotations'."
  (annotate-make-annotation-dump-entry filename file-annotations checksum))

(defun annotate-color-index-from-dump (annotation-serialized)
  "Get the color index from an annotation list loaded from a
file."
  (and (> (length annotation-serialized) 3)
       (nth 4 annotation-serialized)))

(defun annotate-placement-policy-from-dump (annotation-serialized)
  "Get the placement policy field from an annotation list loaded from a
file."
  (and (> (length annotation-serialized) 4)
       (nth 5 annotation-serialized)))

(defun annotate-checksum-from-dump (record)
  "Get the checksum field from an annotation list loaded from a
file."
  (and (> (length record) 2)
       (nth 2 record)))

(defun annotate-id-from-dump (annotation-serialized)
  "Get the id field from an annotation list loaded from a
file."
  (and (> (length annotation-serialized) 6)
       (nth 6 annotation-serialized)))

(defun annotate-reply-to-from-dump (annotation-serialized)
  "Get the reply-to field from an annotation list loaded from a
file."
  (and (> (length annotation-serialized) 7)
       (nth 7 annotation-serialized)))

(defun annotate-annotation-dump-reply-p (annotation-serialized)
  "Returns non nil fi ANNOTATION-SERIALIZED is a reply."
  (annotate-reply-to-from-dump annotation-serialized))

(defun annotate-annotations-from-dump (record)
  "Get the annotations field from an annotation list loaded from a
file."
  (cl-second record))

(defun annotate-filename-from-dump (record)
  "Get the filename field from an annotation list loaded from a
file."
  (cl-first record))

(defun annotate-beginning-of-annotation (annotation-serialized)
  "Get the starting point of an annotation. The arg ANNOTATION-SERIALIZED
must be a single annotation field got from a file dump of all annotated buffers,
essentially what you get from:
\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))."
  (cl-first annotation-serialized))

(defun annotate-ending-of-annotation (annotation-serialized)
  "Get the ending point of an annotation. The arg ANNOTATION-SERIALIZED
must be a single annotation field got from a file dump of all annotated buffers,
essentially what you get from:
\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))."
  (cl-second annotation-serialized))

(defun annotate--interval-left-limit (annotation-serialized)
  "Given an annotation record ANNOTATION-SERIALIZED returns
the left limit of the annotated text."
  (cl-first annotation-serialized))

(defun annotate--interval-right-limit (annotation-serialized)
  "Given an annotation record ANNOTATION-SERIALIZED returns the
right limit of the annotated text."
  (cl-second annotation-serialized))

(defun annotate--make-interval (left-limit right-limit)
  "Make an interval from LEFT-LIMIT and RIGHT-LIMIT."
  (list left-limit right-limit))

(defun annotate-annotation-interval (annotation-serialized)
  "Return the limits where ANNOTATION-SERIALIZED is applied.
The limit is a list of two numbers (LEFT RIGHT) representing of the portion
of the buffer where this annotation is applied.
Note that this function returns the character interval
yyyyyyyy ggg
  ^^^^^^^  ← Annotation interval in the database
             (extends for one more than the last character)
  |----|   ← The interval that this function returns.

In other terms the interval in the database is a closed interval while
the interval that this function return is closed on the left and open on
the right side."
  (annotate--make-interval (annotate-beginning-of-annotation annotation-serialized)
                           (1- (annotate-ending-of-annotation annotation-serialized))))

(defun annotate-annotation-string (annotation-serialized)
  "Get the text of an annotation. The arg ANNOTATION-SERIALIZED must be a single
annotation field got from a file dump of all annotated buffers,
essentially what you get from:
\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))."
  (nth 2 annotation-serialized))

(cl-defgeneric annotate-annotation-replace-annotation-text (object new-text)
  "Replace the annotation text of OBJECT with NEW-TEXT.")

(cl-defmethod annotate-annotation-replace-annotation-text ((object list) new-text)
  "Replace the annotation text of OBJECT with NEW-TEXT."
  (setf (elt object 2)
        new-text)
  object)

(cl-defmethod annotate-annotation-replace-annotation-text ((object overlay) new-text)
  "Replace the annotation text of OBJECT with NEW-TEXT."
  (overlay-put object 'annotation new-text)
  object)

(defun annotate-annotated-text (annotation-serialized)
  "Get the annotated text of an annotation. The arg ANNOTATION-SERIALIZED
must be a single annotation field got from a file dump of all
annotated buffers, essentially what you get from:
\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))."
  (and (> (length annotation-serialized) 3)
       (nth 3 annotation-serialized)))

(defun annotate-save-all-annotated-buffers ()
  "Save the annotations for all buffer where `annotate-mode' is active."
  (let ((all-annotated-buffers (annotate-buffers-annotate-mode)))
    (cl-loop for annotated-buffer in all-annotated-buffers do
             (with-current-buffer annotated-buffer
               (annotate-save-annotations :replace t)))))

(cl-defun annotate--dump-indirect-buffer (annotations &optional (indirect-buffer (current-buffer)))
  "Clone an annotated indirect buffer into a new buffer.
ANNOTATIONS containd the annotations and INDIRECT-BUFFER
\(default the current buffer) is the buffer to be cloned."
  (when annotations
    (let* ((new-buffer-name  (generate-new-buffer-name (concat (buffer-name indirect-buffer)
                                                               annotate-dump-from-indirect-bugger-suffix)))
           (new-buffer           (get-buffer-create new-buffer-name))
           (indirect-content (with-current-buffer (current-buffer)
                               (buffer-string))))
      (with-current-buffer new-buffer
        (annotate-mode -1)
        (insert indirect-content)
        ;; when launching the command `(annotate-mode 1)' annotate
        ;; mode refuses to add the hooks if annotations are already
        ;; present in the buffer.
        ;; So the right way here is: first activate the mode and then
        ;; add the annotations
        (annotate-mode 1)
        (cl-loop for annotation in annotations do
                 (let ((annotation-start (annotate-beginning-of-annotation annotation))
                       (annotation-end   (annotate-ending-of-annotation annotation))
                       (annotation-text  (annotate-annotation-string annotation)))
                   (annotate-create-annotation annotation-start
                                               annotation-end
                                               annotation-text
                                               nil)))
        (pop-to-buffer new-buffer)
        (let* ((info-message (message annotate-popup-warn-killing-an-indirect-buffer
                                      (buffer-name new-buffer)))
               (user-choice  (when annotate-popup-warning-indirect-buffer
                               (x-popup-dialog t (list info-message
                                                       (cons "OK" :ok)
                                                       (cons "Never show again" :bury))))))
          (when (eq user-choice :bury)
            (customize-save-variable 'annotate-popup-warning-indirect-buffer nil)))))))

(defun annotate--current-file-annotation ()
  "Returns all the annotation contained in the current buffer."
  (cl-remove-if (lambda (a)
                  (= (annotate-beginning-of-annotation a)
                     (annotate-ending-of-annotation    a)))
                (annotate-describe-annotations)))

(defun annotate-remove-stray-replies (annotations-db)
  "Remove any reply in ANNOTATION-DB that is a reply of a non existent parent."
  (cl-labels ((remove-stray (annotations-db)
                (let ((stray-found nil))
                  (cl-values
                   (cl-loop for record in annotations-db
                            collect
                            (let* ((annotations (annotate-annotations-from-dump record))
                                   (filtered-annotations (cl-remove-if
                                                          (lambda (a)
                                                            (when-let* ((parent-id (annotate-annotation-reply-to a)))
                                                              ;; if  parent-id is  null
                                                              ;; the  message  is  athe
                                                              ;; root of  the tread, do
                                                              ;; not remove
                                                              (let ((found (annotate--find-annotation annotations-db
                                                                                                      parent-id)))
                                                                (when (not found)
                                                                  (setf stray-found t))
                                                                (not found))))
                                                          annotations)))
                              (annotate-make-record (annotate-filename-from-dump record)
                                                    filtered-annotations
                                                    (annotate-checksum-from-dump record))))
                   stray-found))))
    (cl-multiple-value-bind (db recurse)
        (remove-stray annotations-db)
      (if recurse
          (annotate-remove-stray-replies db)
        db))))

(cl-defun annotate-save-annotations (&key
                                     (annotations-to-save (annotate--current-file-annotation))
                                     (replace t))
  "Save all ANNOTATIONS-TO-SAVE (default all valid annotation in the current
buffer) annotations to disk
ANNOTATIONS-TO-SAVE: a list of annotations to be saved in the database
REPLACE: if not nil replace all the annotations from the current file
with ANNOTATIONS-TO-SAVE, append otherwise."
  (interactive)
  (let ((all-records (annotate-load-annotation-data t))
        (filename    (annotate-guess-filename-for-dump (annotate-actual-file-name))))
    (cond
     (filename
      (let* ((existing-record      (assoc-string filename all-records))
             (existing-annotations (if existing-record
                                       (annotate-annotations-from-dump existing-record)
                                     nil))
             (all-reply (cl-remove-if-not (lambda (a)
                                            (annotate-annotation-dump-reply-p a))
                                          existing-annotations)))
        (setf annotations-to-save (append all-reply annotations-to-save))
        (cond
         (replace
          (let ((record-no-current-annotation
                 (cl-remove-if (lambda (a) (string= (annotate-filename-from-dump a)
                                                    filename))
                               all-records)))
            (setf all-records
                  (push (annotate-make-annotation-dump-entry filename
                                                             annotations-to-save
                                                             (annotate-buffer-checksum))
                        record-no-current-annotation))))
         (existing-record
          (let* ((annotations-from-dump (annotate-annotations-from-dump existing-record)))
            (cl-loop for annotation-to-save in annotations-to-save
                     when (not (cl-find-if (lambda (a)
                                             (and (not (annotate-annotation-dump-reply-p annotation-to-save))
                                                  (= (annotate-beginning-of-annotation a)
                                                     (annotate-beginning-of-annotation annotation-to-save))
                                                  (= (annotate-ending-of-annotation a)
                                                     (annotate-ending-of-annotation annotation-to-save))))
                                           annotations-from-dump))
                     do (push annotation-to-save annotations-from-dump))
            (setcdr (assoc-string filename all-records)
                    (list annotations-from-dump
                          (annotate-buffer-checksum)))))
         (t
          (setf all-records
                (push (annotate-make-annotation-dump-entry filename
                                                           annotations-to-save
                                                           (annotate-buffer-checksum))
                      all-records))))
        ;; performs some cleaning up
        ;; remove duplicate entries (a user reported seeing them)
        (dolist (entry all-records)
          (delete-dups entry))
        ;; remove all the replies that has no parents (recursively)
        ;; then remove all the records that references file that contains no annotations
        (let* ((only-valid-replies (annotate-remove-stray-replies all-records))
               (only-annotated-file (cl-remove-if (lambda (entry)
                                                    (null (annotate-annotations-from-dump entry)))
                                                  only-valid-replies)))
             (annotate-dump-annotation-data only-annotated-file))
        (when annotate-use-messages
          (message "Annotations saved."))))
     ((annotate-indirect-buffer-current-p)
      (annotate--dump-indirect-buffer annotations-to-save))
     (annotations-to-save
      (lwarn '(annotate-mode)
             :warning
             annotate-warn-buffer-has-no-valid-file
             (current-buffer))))))

(defun annotate-load-annotation-old-format ()
  "Load all annotations from disk in old format."
  (interactive)
  (let ((annotations (cdr (assoc-string (annotate-actual-file-name)
                                        (annotate-load-annotation-data t)))))
    ;; remove empty annotations created by earlier bug:
    (setq annotations (cl-remove-if (lambda (ann) (null (nth 2 ann)))
                                    annotations))
    (when (and (null annotations)
               annotate-use-messages)
      (message annotate-message-annotations-not-found))
    (when (not (null annotations))
      (save-excursion
        (dolist (annotation annotations)
          (let ((start              (annotate-beginning-of-annotation annotation))
                (end                (annotate-ending-of-annotation    annotation))
                (annotation-string  (annotate-annotation-string       annotation)))
            (annotate-create-annotation start end annotation-string nil)))))
    (font-lock-flush)
    (when annotate-use-messages
      (message annotate-message-annotation-loaded))))

(defun annotate-load-annotations ()
  "Load all annotations from disk and redraw the buffer to render the annotations.

The format of the database is:

\(RECORD-1 RECORD-2 ... RECORD-N)

Each record is:

\(FILENAME ANNOTATIONS CHECKSUM)

where:

FILENAME: a string identifying a file on the file-system, or the
string \"dir\" for top-level info file.

CHECKSUM: a string used to fingerprint the annotate file above,
used to check if a file has been modified.

annotations:

\(ANNOTATION-1 ANNOTATION-2 ... ANNOTATION-N) or nil

finally annotation is:

\(START END ANNOTATION-STRING
  ANNOTATED-TEXT COLOR-INDEX
  POSITIONING-POLICY ID REPLY-TO)

START:              the buffer position where annotated text start
END:                the buffer position where annotated text ends
ANNOTATION-STRING:  the text of annotation
ANNOTATED-TEXT:     the substring of buffer from START to END (as above)
COLOR-INDEX:        the index position in `annotate-annotation-text-faces' and
                    `annotate-highlight-faces' to chode the annotation's visual
POSITIONING-POLICY: a keyword representing the stategy for the annotation's
                    text position; the allowed values are specified in:
                    `annotate-allowed-positioning-policy'
ID:                 An unique string that identify this annotation
REPLY-TO:           The ID of an annotation this is a reply or nil
example:

\\='(\"/foo/bar\" ((0 9 \"note\" \"annotated\" 0 :margin \"ID\"
[nil or parent ID])) hash-as-hex-string)."
  (interactive)
  (cl-labels ((old-format-p (annotation)
                (not (stringp (cl-first (last annotation))))))
    (let* ((filename             (annotate-actual-file-name))
           (all-annotations-data (annotate-load-annotation-data t))
           (annotation-dump      (assoc-string filename all-annotations-data))
           (annotations          (annotate-annotations-from-dump annotation-dump))
           (old-checksum         (annotate-checksum-from-dump annotation-dump))
           (new-checksum         (annotate-buffer-checksum)))
      (if (old-format-p annotation-dump)
          (annotate-load-annotation-old-format)
        (when (and annotate-warn-if-hash-mismatch
                   (not (old-format-p annotation-dump))
                   old-checksum
                   new-checksum
                   (not (string= old-checksum new-checksum)))
          (annotate-save-annotations :replace t)
          (lwarn '(annotate-mode)
                 :warning
                 annotate-warn-file-changed-control-string
                 filename))
        (cond
         ((and (null annotations)
               annotate-use-messages)
          (message annotate-message-annotations-not-found))
         (annotations
          (save-excursion
            (dolist (annotation (cl-remove-if #'annotate-annotation-dump-reply-p
                                              annotations))
              (let* ((start             (annotate-beginning-of-annotation annotation))
                     (end               (annotate-ending-of-annotation    annotation))
                     (annotation-string (annotate-annotation-string       annotation))
                     (annotated-text    (annotate-annotated-text          annotation))
                     (dump-color-index  (annotate-color-index-from-dump   annotation))
                     (color-index       (if (and dump-color-index
                                                 (< dump-color-index
                                                    (length annotate-highlight-faces)))
                                            dump-color-index
                                          nil))
                     (position          (annotate-placement-policy-from-dump annotation))
                     (id                (annotate-id-from-dump annotation)))
                (annotate-create-annotation start
                                            end
                                            annotation-string
                                            annotated-text
                                            color-index
                                            position
                                            id))))))
        (font-lock-flush)
        (when annotate-use-messages
          (message annotate-message-annotation-loaded))))))

(defun annotate-db-clean-records (records-db)
  "Remove records from arg RECORDS-DB that have empty annotation, example:

\\='((\"/foo/bar.dat\" nil \"abababababababababababababab\")
  (\"/foo/baz.dat\" ((0 9 \"note\" \"annotated\")) \"abababababababababababababab\"))

will become:

\\='((\"/foo/baz.dat\" ((0 9 \"note\" \"annotated\")) \"abababababababababababababab\"))

i.e. the first record is removed."
  (cl-remove-if (lambda (a) (null (annotate-annotations-from-dump a)))
                records-db))

(defun annotate-db-purge ()
  "Update database *on disk* removing all the records with empty
annotation."
  (interactive)
  (annotate-db-purge* (annotate-load-annotation-data t)))

(defun annotate-db-purge* (annotations-db)
  "Update database ANNOTATIONS-DB removing all the records with empty
annotation and save to disk."
  (let ((clean-db (annotate-db-clean-records annotations-db)))
    (annotate-dump-annotation-data clean-db)))

(defun annotate--deserialize-database-file (file)
  "Return a sexp from the annotation database contained in FILE."
  (cl-flet ((deserialize-record (record)
              "deserialize `RECORD' form its sexp form."
              (let* ((filename        (annotate-filename-from-dump    record))
                     (annotations     (annotate-annotations-from-dump record))
                     (file-checksum   (annotate-checksum-from-dump    record)))
                (annotate-make-record filename
                                      annotations
                                      file-checksum))))
    (with-temp-buffer
      (let* ((annotations-file file)
             (attributes       (file-attributes annotations-file)))
        (cond
         ((not (annotate-file-exists-p annotations-file))
          (signal 'annotate-db-file-not-found (list annotations-file)))
         ((= (file-attribute-size attributes)
             0)
          nil)
         (t
          (insert-file-contents annotations-file)
          (mapcar #'deserialize-record (read (current-buffer)))))))))

(defun annotate-load-annotation-data (&optional ignore-errors)
  "Read and returns saved annotations."
  (if ignore-errors
      (ignore-errors (annotate--deserialize-database-file annotate-file))
    (annotate--deserialize-database-file annotate-file)))

(defun annotate-dump-annotation-data (data &optional save-empty-db)
  "Save DATA into annotation file."
  (cond
   ((or save-empty-db
        data)
    (with-temp-file annotate-file
      (cl-flet ((%make-record (annotation)
                  (let ((full-filename (annotate-filename-from-dump    annotation))
                        (annotations   (annotate-annotations-from-dump annotation))
                        (file-checksum (annotate-checksum-from-dump    annotation)))
                    (annotate-make-record (abbreviate-file-name full-filename)
                                          annotations
                                          file-checksum))))
      (let* ((print-length nil)
             (actual-data (mapcar #'%make-record data)))
        (prin1 actual-data (current-buffer))))))
   ((annotate-file-exists-p annotate-file)
    (let* ((confirm-message    "Delete annotations database file %S? ")
           (delete-confirmed-p (or (not annotate-database-confirm-deletion)
                                   (y-or-n-p (format confirm-message annotate-file)))))
      (if delete-confirmed-p
          (condition-case err
              (delete-file annotate-file t)
            (error (message "error removing annotation database: %S"
                            (error-message-string err))))
        (annotate-dump-annotation-data data t))))))

(cl-defmacro with-matching-annotation-fns ((filename
                                            beginning
                                            ending)
                                           &body body)
  "Anaphoric macro to build functions to find annotations."
  `(let ((filename-match-p          (lambda (record)
                                      (string= (annotate-filename-from-dump record)
                                               ,filename)))
         (annotation-limits-match-p (lambda (a)
                                      (when (not (annotate-annotation-reply-p a))
                                        (and (= (annotate-beginning-of-annotation a)
                                                ,beginning)
                                             (= (annotate-ending-of-annotation    a)
                                                ,ending))))))
     ,@body))

(defun annotate-db-remove-annotation (db-records
                                      record-filename
                                      annotation-beginning
                                      annotation-ending)
  "Remove from database DB-RECORDS the annotation identified by
the triplets RECORD-FILENAME, ANNOTATION-BEGINNING and
 ANNOTATION-ENDING; if such annotation does exists."
  (with-matching-annotation-fns
   (record-filename
    annotation-beginning
    annotation-ending)
   (let ((file-matched-record (cl-find-if filename-match-p db-records)))
     (if file-matched-record
         (let* ((rest-of-db      (cl-remove-if filename-match-p db-records))
                (new-annotations (cl-remove-if annotation-limits-match-p
                                               (annotate-annotations-from-dump file-matched-record)))
                (checksum        (annotate-checksum-from-dump file-matched-record))
                (new-record      (annotate-make-record record-filename
                                                       new-annotations
                                                       checksum)))
           (push new-record
                 rest-of-db))
       db-records))))

(defun annotate-db-replace-annotation (db-records
                                       record-filename
                                       annotation-beginning
                                       annotation-ending
                                       replacing-text)
  "Replace the text of annotation from database DB-RECORDS
identified by the triplets RECORD-FILENAME,
 ANNOTATION-BEGINNING and ANNOTATION-ENDING; if such
 annotation does exists."
  (with-matching-annotation-fns
   (record-filename
    annotation-beginning
    annotation-ending)
   (let ((file-matched-record (cl-find-if filename-match-p db-records)))
     (if file-matched-record
         (let ((old-annotation   (cl-find-if annotation-limits-match-p
                                             (annotate-annotations-from-dump file-matched-record))))
           (if old-annotation
               (let* ((rest-of-db       (cl-remove-if filename-match-p db-records))
                      (rest-annotations (cl-remove-if annotation-limits-match-p
                                                      (annotate-annotations-from-dump file-matched-record)))
                      (checksum         (annotate-checksum-from-dump file-matched-record))
                      (new-annotation   (annotate-annotation-replace-annotation-text old-annotation
                                                                                     replacing-text))
                      (new-record       (annotate-make-record record-filename
                                                              (append (list new-annotation)
                                                                      rest-annotations)
                                                              checksum)))
                 (push new-record
                       rest-of-db))
             db-records))
       db-records))))

(defun annotate-db-annotations-starts-before-p (a b)
  "Non nil if  annotation A starts before B.

In this context annotation means annotation loaded from local
database not the annotation shown in the buffer (therefore these
arguments are \"record\" as called in the other database-related
functions)."
  (< (annotate-beginning-of-annotation a)
     (annotate-beginning-of-annotation b)))

;;;; database related procedures ends here

(defun annotate-clear-annotations ()
  "Clear all current annotations."
  (interactive)
  (let ((overlays   (overlays-in 0 (buffer-size))))
    ;; only remove annotations, not all overlays
    (setq overlays (cl-remove-if
                    (lambda (ov) (not (annotationp ov)))
                    overlays))
    (dolist (ov overlays)
      (annotate--remove-annotation-property (overlay-start ov)
                                            (overlay-end ov))
      (delete-overlay ov))))

(defun annotate-string-empty-p (a)
  "Is the arg A an empty string or null?"
  (or (null a)
      (string= "" a)))

(defun annotate-annotation-prop-get (annotation property)
  "Get property PROPERTY from annotation ANNOTATION. If
ANNOTATION does not pass `annotationp' returns nil."
  (annotate-ensure-annotation (annotation)
    (overlay-get annotation property)))

(defun annotate-annotation-get-chain-position (annotation)
  "Get property's value that define position of this annotation
in a chain of annotations"
  (annotate-annotation-prop-get annotation annotate-prop-chain-position))

(defun annotate-annotation-chain-position (annotation pos)
  "Set property's value that define position of this annotation
in a chain of annotations."
  (overlay-put annotation annotate-prop-chain-position pos))

(defun annotate-chain-last-p (annotation)
  "Non nil if ANNOTATION is the last element of a chain of annotations."
  (let ((value (annotate-annotation-get-chain-position annotation)))
    (and value
         (cl-equalp value annotate-prop-chain-pos-marker-last))))

(defun annotate-chain-first-p (annotation)
  "Non nil if ANNOTATION is the first element, or the only
of a chain of annotations."
  (let* ((chain-pos           (annotate-annotation-get-chain-position annotation))
         (annotation-start    (overlay-start annotation))
         (previous-annotation (annotate-previous-annotation-ends annotation-start))
         (previous-chain-pos  (annotate-annotation-get-chain-position previous-annotation)))
    (or (= chain-pos
           annotate-prop-chain-pos-marker-first)
        (and (= chain-pos
                annotate-prop-chain-pos-marker-last)
             (or (null previous-annotation)
                 (= previous-chain-pos
                    annotate-prop-chain-pos-marker-last))))))

(defun annotate-chain-first (annotation)
  "Find first element of the chain where ANNOTATION belongs."
  (cond
   ((null annotation)
    nil)
   ((annotate-chain-first-p annotation)
    annotation)
   (t
    (let* ((annotation-start    (overlay-start annotation))
           (previous-annotation (annotate-previous-annotation-ends annotation-start)))
      (annotate-chain-first previous-annotation)))))

(defun annotate-chain-last (annotation)
  "Find last element of the chain where ANNOTATION belongs."
  (cond
   ((null annotation)
    nil)
   ((annotate-chain-last-p annotation)
    annotation)
   (t
    (let* ((annotation-end  (overlay-end annotation))
           (next-annotation (annotate-next-annotation-starts annotation-end)))
      (annotate-chain-last next-annotation)))))

(defun annotate-chain-first-at (pos)
  "Find first element of the chain of annotation that overlap point POS."
  (let ((annotation (annotate-annotation-at pos)))
    (annotate-ensure-annotation (annotation)
      (annotate-chain-first annotation))))

(defun annotate-chain-last-at (pos)
  "Find last element of the chain of annotation that overlap point POS."
  (let ((annotation (annotate-annotation-at pos)))
    (annotate-ensure-annotation (annotation)
      (annotate-chain-last annotation))))

(defun annotate-chain-at (pos)
  "Find the chain of overlays where point POS belongs."
  (let ((annotation (annotate-annotation-at pos)))
    (annotate-ensure-annotation (annotation)
      (annotate-find-chain annotation))))

(defun annotate-annotation-set-chain-first (annotation)
  "Set property's value that define position of this annotation
in a chain of annotations as first."
  (annotate-annotation-chain-position annotation annotate-prop-chain-pos-marker-first))

(defun annotate-annotation-set-chain-last (annotation)
  "Set property's value that define position of this annotation
in a chain of annotations as last."
  (annotate-annotation-chain-position annotation annotate-prop-chain-pos-marker-last))

(defun annotate-find-chain (annotation)
  "Find all ANNOTATION that are parts of the chain where ANNOTATION belongs."
  (annotate-ensure-annotation (annotation)
    (cl-labels ((find-next-annotation (pos)
                  (annotate-annotation-at (next-overlay-change pos))))
      (let* ((chain-first      (annotate-chain-first annotation))
             (results          (list chain-first))
             (chain-last       (annotate-chain-last  annotation))
             (start-pos        (overlay-end chain-first))
             (next-annotation  (find-next-annotation start-pos)))
        (if (eq chain-first
                chain-last)
            results
          (while (not (eq next-annotation
                          chain-last))
            (if next-annotation
                (progn
                  (cl-pushnew next-annotation results)
                  (setf start-pos       (overlay-end next-annotation)))
              (cl-incf start-pos))
            (setf next-annotation (find-next-annotation start-pos)))
          (push chain-last results)
          (reverse results))))))

(defun annotate-annotations-chain-at (pos)
  "Find all annotation that are parts of the chain that overlaps at POS."
  (annotate-find-chain (annotate-annotation-at pos)))

(defun annotate-chain-hide-text (chain)
  "Sets an overlay properties of the last ring of CHAIN so that
the annotation's text will not be rendered."
  (let ((last-ring (annotate-chain-last-ring chain)))
    (overlay-put last-ring 'hide-text t)))

(defun annotate-chain-show-text (chain)
  "Sets an overlay properties of the last ring of CHAIN so that
the annotation's text will be rendered."
  (let ((last-ring (annotate-chain-last-ring chain)))
    (overlay-put last-ring 'hide-text nil)))

(defun annotate-chain-hide-text-p (chain)
  "Non nil if the annotation's text contained in the last ring of CHAIN
must not be rendered."
  (let ((last-ring (annotate-chain-last (cl-first chain))))
    (annotate-tail-overlay-hide-text-p last-ring)))

(defun annotate-tail-overlay-hide-text-p (overlay)
  "Get the property for hiding the annotation text from OVERLAY."
  (overlay-get overlay 'hide-text))

(cl-defun annotate-create-annotation (start end annotation-text annotated-text
                                            &optional
                                            color-index
                                            position
                                            (annotation-id (annotate--generate-unique-id)))
  "Create a new annotation for selected region (from START to  END.

Here the argument ANNOTATION-TEXT is the string that appears
on the margin of the window and ANNOTATED-TEXT is the string
that is underlined.

If this function is called from procedure
`annotate-load-annotations' the argument ANNOTATED-TEXT
should be not null.  In this case we know that an annotation
existed in a text interval defined in the database
metadata (the database located in the file specified by the
variable `annotate-file') and should just be
restored.  Sometimes the annotated text (see above) can not be
found in said interval because the annotated file's content
changed and `annotate-mode' could not track the
changes (e.g. save the file when `annotate-mode' was not
active/loaded) in this case the matching
text (\"annotated-text\") is searched in a region surrounding the
interval and, if found, the buffer is annotated right there.

The searched interval can be customized setting the variable:
\"annotate-search-region-lines-delta\".

COLOR-INDEX, if non-null (default nil), is used as index to address
elements both in ANNOTATE-COLOR-INDEX-FROM-DUMP
and ANNOTATE-COLOR-INDEX-FROM-DUMP to specify annotation appearance.

POSITION indicates the positioning policy for the annotation,
if null the value bound to ANNOTATE-ANNOTATION-POSITION-POLICY is
used.

ANNOTATION-ID is an unique identifier for the annotation
\(by default is generated using `annotate--generate-unique-id'."
  (cl-labels ((face-annotation-shifting-point (position shifting-direction-function)
                (when-let* ((annotation       (funcall shifting-direction-function
                                                       position))
                            (annotation-face  (annotate-annotation-face annotation)))
                  (cl-find-if (lambda (a) (cl-equalp annotation-face a))
                              annotate-highlight-faces)))
              (face-annotation-before-point (position)
                (face-annotation-shifting-point position
                                                #'annotate-previous-annotation-ends))
              (face-annotation-after-point (position)
                (face-annotation-shifting-point (max (point-min)
                                                     (1- position))
                                                #'annotate-next-annotation-starts))
              (available-face-index (&rest used-faces)
                (cl-position-if-not (lambda (a)
                                      (cl-member a used-faces :test #'cl-equalp))
                                    annotate-highlight-faces))
              (create-annotation (start end annotation-text)
                (if (null color-index)
                    (when-let* ((new-face-index (available-face-index (face-annotation-before-point start)
                                                                      (face-annotation-after-point end))))
                      (setf annotate-colors-index-counter
                            new-face-index))
                  (cl-incf annotate-colors-index-counter))
                (save-excursion
                  (let ((all-overlays ()))
                    (while (< start end)
                      (goto-char start)
                      (let ((char-maybe-newline (string (char-after))))
                        (if (string= char-maybe-newline "\n")
                            (goto-char (1+ (point)))
                          (progn
                            (re-search-forward "\n" end :goto-end)
                            (when (<= (point) end)
                              (let* ((end-overlay (if (/= (point) end)
                                                      (1- (point))
                                                    (point)))
                                     (highlight (make-overlay start end-overlay))
                                     (highlight-face (if color-index
                                                         (elt annotate-highlight-faces
                                                              color-index)
                                                       (annotate--current-highlight-face)))
                                     (annotation-face (if color-index
                                                          (elt annotate-annotation-text-faces
                                                               color-index)
                                                        (annotate--current-annotation-text-face))))
                                (annotate-annotation-set-id highlight annotation-id)
                                (annotate-annotation-set-face highlight highlight-face)
                                (annotate-annotation-set-annotation-text highlight annotation-text)
                                (annotate-annotation-set-annotation-face highlight annotation-face)
                                (annotate-overlay-maybe-set-position  highlight position)
                                (annotate-overlay-maybe-set-help-echo highlight
                                                                      annotation-text)
                                (annotate-annotation-chain-position highlight
                                                                    annotate-prop-chain-pos-marker-last)
                                (push highlight all-overlays))))))
                      (setf start (point)))
                    (annotate--remap-chain-pos (reverse (mapcar #'maybe-force-newline-policy
                                                                all-overlays))))))
              (beginning-of-nth-line (start line-count)
                (save-excursion
                  (goto-char start)
                  (forward-line line-count)
                  (beginning-of-line)
                  (point)))
              (go-backward           (start)
                (beginning-of-nth-line
                 start
                 (- annotate-search-region-lines-delta)))
              (go-forward            (start)
                (beginning-of-nth-line start
                                       annotate-search-region-lines-delta))
              (guess-match-and-add   (start end annotated-text max)
                (cl-block surrounding
                  (while (< start max)
                    (let ((to-match (ignore-errors
                                      (buffer-substring-no-properties start end))))
                      (if (and to-match
                               (string= to-match annotated-text))
                          (cl-return-from surrounding start))
                      (progn
                        (setf start (1+ start)
                              end   (1+ end)))))
                  nil))
              (maybe-force-newline-policy  (annotation)
                ;; force  newline policy  if height  of any  the face  of the
                ;; overlay is different from height of default face
                (save-excursion
                  (goto-char (overlay-start annotation))
                  (let* ((bol                  (annotate-beginning-of-line-pos))
                         (eol                  (annotate-end-of-line-pos))
                         (changed-face-pos     (min bol (overlay-start annotation)))
                         (limit                (max eol (overlay-end   annotation)))
                         (all-faces            (list (get-text-property changed-face-pos 'face)))
                         (default-face-height  (face-attribute 'default :height))
                         (all-faces-height     ())
                         (force-newline-p      nil))
                    (while (< changed-face-pos limit)
                      (setf changed-face-pos
                            (next-single-property-change changed-face-pos
                                                         'face
                                                         (current-buffer)
                                                         limit))
                      (push (get-text-property changed-face-pos 'face)
                            all-faces))
                    (setf all-faces-height
                          (mapcar (lambda (face)
                                    (cond
                                     ((facep face)
                                      (face-attribute face :height nil 'default))
                                     ((and (consp face)
                                           (keywordp (cl-first face))) ; a plist
                                      (cl-getf face :height
                                               (face-attribute 'default :height)))
                                     ((consp face) ; a list of named face, first wins
                                      (face-attribute (cl-first face) :height nil 'default))
                                     (t
                                      (face-attribute 'default :height))))
                                  (remq nil all-faces)))
                    (setf force-newline-p
                          (cl-find-if (lambda (a) (/= a default-face-height))
                                      all-faces-height))
                    (when force-newline-p
                      (annotate-annotation-set-position annotation :new-line)))
                  annotation))
              (next-to-a-line-terminator-p ()
                (save-excursion
                  (goto-char end)
                  (re-search-forward "\n" nil t))))
    (cond
     ((annotate-string-empty-p annotation-text)
      (signal 'annotate-empty-annotation-text-error t))
     ((and (not (or annotate-use-echo-area
                    (next-to-a-line-terminator-p)))
           (annotate--confirm-append-newline-at-the-end-of-buffer))
      (save-excursion
        (goto-char (point-max))
        (insert "\n"))
      (annotate-create-annotation start
                                  end
                                  annotation-text
                                  annotated-text
                                  color-index
                                  position
                                  annotation-id))
     (t
      (if (not (annotate-string-empty-p annotated-text))
          (let ((text-to-match (ignore-errors
                                 (buffer-substring-no-properties start end))))
            (if (and text-to-match
                     (string= text-to-match annotated-text))
                (create-annotation start end annotation-text)
              (let* ((starting-point-matching (go-backward start))
                     (ending-point-match      (go-forward  start))
                     (length-match            (- end start))
                     (new-match               (guess-match-and-add starting-point-matching
                                                                   (+ starting-point-matching
                                                                      length-match)
                                                                   annotated-text
                                                                   ending-point-match)))
                (and new-match
                     (create-annotation new-match
                                        (+ new-match length-match)
                                        annotation-text)))
              (lwarn '(annotate-mode) ; if matches annotated text failed
                     :warning
                     annotate-warn-file-searching-annotation-failed-control-string
                     (annotate-actual-file-name)
                     annotation-text
                     text-to-match)))
        (create-annotation start end annotation-text)) ; create new annotation
      (when (use-region-p)
        (deactivate-mark))
      (save-excursion
        (goto-char end)
        (font-lock-fontify-block 1))))))

(defun annotate-overlay-put-echo-help (overlay text)
  "Set the property `help-echo' to TEXT in overlay OVERLAY."
  (overlay-put overlay 'help-echo text))

(defun annotate-overlay-get-echo-help (overlay)
  "Set the property `help-echo' from overlay OVERLAY."
  (overlay-get overlay 'help-echo))

(defun annotate-overlay-maybe-set-help-echo (overlay annotation-text)
  "Set the property `help-echo' to ANNOTATION-TEXT in overlay OVERLAY if
the annotations should be shown in a popup fashion.

See the variable: `annotate-use-echo-area'."
  (when annotate-use-echo-area
    (annotate-overlay-put-echo-help overlay annotation-text)))

(defun annotate--delete-annotation-chain (annotation)
  "Delete ANNOTATION from a buffer and the chain it belongs to.

This function is not part of the public API."
  (annotate-ensure-annotation (annotation)
    (save-excursion
      (with-current-buffer (current-buffer)
        (let* ((chain (annotate-find-chain annotation)))
          ;; (filename      (annotate-actual-file-name))
          (dolist (single-element chain)
            (goto-char (overlay-end single-element))
            (move-end-of-line nil)
            (annotate--remove-annotation-property (overlay-start single-element)
                                                  (overlay-end   single-element))
            (delete-overlay single-element)))))))

(defun annotate--delete-annotation-chain-ring (annotation-ring)
  "Delete overlay of ANNOTATION-RING from a buffer.

A ring is a single element of an annotation chain.

This function is not part of the public API."
  (annotate-ensure-annotation (annotation-ring)
    (save-excursion
      (goto-char (overlay-end annotation-ring))
      (move-end-of-line nil)
      (annotate--remove-annotation-property (overlay-start annotation-ring)
                                            (overlay-end   annotation-ring))
      (delete-overlay annotation-ring))))

(defun annotate-delete-chain-element (annotation)
  "Delete a ring (a ring is a single element of an ANNOTATION chain.)
from a chain where ANNOTATION belong."
  (annotate-ensure-annotation (annotation)
    (let* ((chain                   (annotate-find-chain    annotation))
           (first-of-chain-p        (annotate-chain-first-p annotation))
           (last-of-chain-p         (annotate-chain-last-p  annotation))
           (only-element-in-chain-p (= (length chain) 1)))
      (annotate--delete-annotation-chain-ring annotation)
      (when (not only-element-in-chain-p)
        (cond
         (first-of-chain-p
          (let ((second-annotation (cl-second chain)))
            (when (not (annotate-chain-last-p second-annotation))
              (annotate-annotation-set-chain-first second-annotation))))
         (last-of-chain-p
          (let ((annotation-before (elt chain (- (length chain) 2))))
            (annotate-annotation-set-chain-last annotation-before))))))))

(defun annotate--cut-left-annotation (annotation)
  "Trims ANNOTATION exactly one character from the start."
  (annotate-ensure-annotation (annotation)
    (let* ((chain                       (annotate-find-chain annotation))
           (first-annotation            (annotate-chain-first annotation))
           (chain-start-pos             (overlay-start first-annotation))
           (first-annotation-ending-pos (overlay-end   first-annotation))
           (new-starting-pos            (1+ chain-start-pos)))
      (cond
       ((>= new-starting-pos
            first-annotation-ending-pos) ; delete chain element or entire annotation
        (if (= (length chain)
               1)                        ; the chain is formed by just one element, delete entirely
            (annotate--delete-annotation-chain first-annotation)
          (annotate-delete-chain-element first-annotation))) ; delete just the first element of the chain
       (t
        (move-overlay first-annotation new-starting-pos first-annotation-ending-pos))))))

(defun annotate--cut-right-annotation (annotation &optional refontify-buffer)
  "Trims ANNOTATION exactly one character from the end."
  (annotate-ensure-annotation (annotation)
    (let* ((chain                        (annotate-find-chain annotation))
           (last-annotation              (annotate-chain-last annotation))
           (last-annotation-ending-pos   (overlay-end last-annotation))
           (last-annotation-starting-pos (overlay-start last-annotation))
           (new-ending-pos               (1- last-annotation-ending-pos)))
      (cond
       ((<= new-ending-pos
            last-annotation-starting-pos) ; delete chain element or entire annotation
        (if (= (length chain) 1)          ; the chain is formed by just one element, delete entirely
            (annotate--delete-annotation-chain last-annotation)
          (progn ; delete just the last element of the chain
            (annotate-delete-chain-element last-annotation)
            (when refontify-buffer
              (font-lock-flush)))))
       (t
        (move-overlay last-annotation last-annotation-starting-pos new-ending-pos))))))

(defun annotate--delete-annotation-chain-prevent-modification (annotation)
  "Delete an annotation chain backing up and restoring modification
status of the buffer before deletion occured.

This function is not part of the public API."
  (annotate-ensure-annotation (annotation)
    (with-silent-modifications
      (annotate--delete-annotation-chain annotation))))

(defun annotate--confirm-annotation-delete ()
  "Prompt user for delete confirmation.
This function is not part of the public API."
  (or (not annotate-annotation-confirm-deletion)
      (y-or-n-p annotate-confirm-deleting-annotation-prompt)))

(cl-defgeneric annotate-remove-annotation-from-dump (annotations-db object)
  "Remove the entry in ANNOTATIONS-DB that contains an object
with the id of OBJECT.")

(cl-defmethod annotate-remove-annotation-from-dump (annotations-db object)
  "Remove the entry in ANNOTATIONS-DB that contains an object with
the id of OBJECT."
  (annotate-ensure-annotation (object)
    (let ((id-to-delete (annotate-annotation-id object)))
      (annotate-remove-annotation-from-dump annotations-db id-to-delete))))

(cl-defmethod annotate-remove-annotation-from-dump (annotations-db (object string))
  "Remove the entry in ANNOTATIONS-DB that contains an annotation with the id:
OBJECT (a string)."
  (let ((id-to-delete object))
    (cl-loop for record in annotations-db
             collect
             (let* ((annotations (annotate-annotations-from-dump record))
                    (filtered-annotations (cl-remove-if
                                           (lambda (a)
                                             (annotate-annotation-id= (annotate-id-from-dump a)
                                                                      id-to-delete))
                                           annotations)))
               (annotate-make-record (annotate-filename-from-dump record)
                                     filtered-annotations
                                     (annotate-checksum-from-dump record))))))

(defun annotate--attach-annotation-to-dump (annotate-db serialized-annotation)
  "Returns a copy of ANNOTATE-DB with SERIALIZED-ANNOTATION added to
the annotations part of the record where the parent of
SERIALIZED-ANNOTATION exists."
  (let ((parent-id (annotate-annotation-reply-to serialized-annotation)))
    (cl-loop for record in annotate-db
             collect
             (let* ((annotations (annotate-annotations-from-dump record))
                    (parent (cl-find-if
                             (lambda (a)
                               (annotate-annotation-id= parent-id
                                                        (annotate-id-from-dump a)))
                             annotations)))
               (if parent
                   (annotate-make-record (annotate-filename-from-dump record)
                                         (push serialized-annotation
                                               annotations)
                                         (annotate-checksum-from-dump record))
                 record)))))

(cl-defgeneric annotate-get-annotation-children (annotate-db object)
  "Returns the replies of OBJECT in ANNOTATE-DB.")

(cl-defmethod annotate-get-annotation-children (annotate-db (object list))
  "Returns the replies of OBJECT in ANNOTATE-DB."
  (let ((id (annotate-id-from-dump object)))
    (annotate-get-annotation-children annotate-db id)))

(cl-defmethod annotate-get-annotation-children (annotate-db (object string))
  "Returns the replies of OBJECT in ANNOTATE-DB."
  (let ((id        object)
        (children '()))
    (cl-loop for record in annotate-db
             do (cl-loop for annotation in (annotate-annotations-from-dump record)
                         when (annotate-annotation-id= id
                                                       (annotate-reply-to-from-dump annotation))
                         do
                         (push annotation children)))
    children))

(cl-defgeneric annotate--find-annotation (annotations-db object)
  "Find annotation identified by OBJECT.")

(cl-defmethod annotate--find-annotation (annotations-db (object string))
  "Find annotation identified by OBJECT."
  (cl-block annotate--find-annotation
    (let ((id-to-be-found object))
      (cl-loop for record in annotations-db
               do (cl-loop for annotation in (annotate-annotations-from-dump record)
                           do (when (annotate-annotation-id= (annotate-id-from-dump annotation)
                                                             id-to-be-found)
                                (cl-return-from annotate--find-annotation annotation))))
      nil)))

(cl-defmethod annotate--find-annotation (annotations-db (object overlay))
  "Find annotation identified by OBJECT."
  (let ((id-to-be-found (annotate-annotation-id object)))
    (annotate--find-annotation annotations-db id-to-be-found)))

(cl-defmethod annotate--find-annotation (annotations-db (object list))
  "Find annotation identified by OBJECT."
  (let ((id-to-be-found (annotate-id-from-dump object)))
    (annotate--find-annotation annotations-db id-to-be-found)))

(cl-defgeneric annotate-remove-annotation-thread (annotations-db object)
  "Remove the entry in OBJECTS-DB that contains an object with the id of OBJECT
and, if exist, recursively all its children.")

(cl-defmethod annotate-remove-annotation-thread (annotations-db object)
  "Remove the entry in OBJECTS-DB that contains an object with the id of OBJECT
and, if exist, recursively all its children."
  (annotate-ensure-annotation (object)
    (let ((id-to-delete (annotate-annotation-id object)))
      (annotate-remove-annotation-thread annotations-db id-to-delete))))

(cl-defmethod annotate-remove-annotation-thread (annotations-db (object list))
  "Remove the entry in OBJECTS-DB that contains an object with the id of
serialzed annotation OBJECT and, if exist, recursively all its children."
    (let ((id-to-delete (annotate-id-from-dump object)))
      (annotate-remove-annotation-thread annotations-db id-to-delete)))

(cl-defmethod annotate-remove-annotation-thread (annotations-db (object string))
  "Remove the entry in OBJECTS-DB that contains an object with the id of OBJECT
and, if exist, recursively all its children."
  (let* ((id-to-delete object)
         (children     (annotate-get-annotation-children annotations-db id-to-delete))
         (filtered-db
          (cl-loop for record in annotations-db
                   collect
                   (let* ((annotations (annotate-annotations-from-dump record))
                          (filtered-annotations (cl-remove-if
                                                 (lambda (a)
                                                   (annotate-annotation-id= (annotate-id-from-dump a)
                                                                            id-to-delete))
                                                 annotations)))
                     (annotate-make-record (annotate-filename-from-dump record)
                                           filtered-annotations
                                           (annotate-checksum-from-dump record))))))
    (cl-loop for child in children
             do (setf filtered-db
                      (annotate-remove-annotation-thread filtered-db
                                                         child)))
    filtered-db))

(cl-defun annotate-delete-annotation (&optional (point (point)))
  "Command to delete an annotation, POINT is the buffer
position where to look for annotation (default the cursor
point)."
  (interactive)
  (when-let* ((annotation (annotate-annotation-at point)))
    (let* ((delete-confirmed-p (annotate--confirm-annotation-delete)))
      (when delete-confirmed-p
        (annotate--delete-annotation-chain annotation)
        (font-lock-flush)))
    (when annotate-autosave
      (annotate-save-annotations :replace t))))

(defun annotate--confirm-append-newline-at-the-end-of-buffer ()
  "Prompt user for appending newline confirmation.
This function is not part of the public API."
  (y-or-n-p (format annotate-confirm-appending-newline-prompt (buffer-name))))

(defun annotate-change-annotation (pos)
  "Change annotation at POS.  If empty, delete annotation."
  (let* ((highlight       (annotate-annotation-at pos))
         (annotation-text (read-from-minibuffer annotate-annotation-prompt
                                                (annotate-annotation-get-annotation-text highlight))))
    (cl-labels ((change (annotation)
                  (let ((chain (annotate-find-chain annotation)))
                    (dolist (single-element chain)
                      (annotate-overlay-maybe-set-help-echo single-element annotation-text)
                      (annotate-annotation-set-annotation-text single-element annotation-text)))))
      (save-excursion
        (cond
         ;; annotation was cancelled:
         ((null annotation-text))
         ;; annotation was erased:
         ((string= "" annotation-text)
          (let* ((delete-confirmed-p (annotate--confirm-annotation-delete)))
            (when delete-confirmed-p
              (annotate--delete-annotation-chain-prevent-modification highlight))))
         ;; annotation was changed:
         (t
          (change highlight)))))))

(defun annotate-make-prefix ()
  "An empty string from the end of the line upto the annotation."
  (save-excursion
    (let* ((line-text (buffer-substring
                       (progn (beginning-of-line) (point))
                       (progn (end-of-line) (point))))
           (prefix-length (- annotate-annotation-column (string-width line-text))))
      (if (< prefix-length 1)
          (concat " \n" (make-string annotate-annotation-column ? ))
        (make-string prefix-length ? )))))

(cl-defun annotate-annotation-at (&optional (pos (point)))
  "Return the annotations (overlay where (annotationp overlay) -> t)
at positions POS or nil if no annotations exists at pos.

NOTE this assumes that annotations never overlaps so the list of
all annotations can contains only one element maximum."
  (let ((all (cl-remove-if-not #'annotationp
                               (overlays-at pos))))
    (cl-first all)))

(defun annotate-previous-annotation-ends (pos)
  "Return the previous annotation that ends before POS or nil if no annotation
was found.
NOTE this assumes that annotations never overlaps."
  (cl-labels ((previous-annotation-ends (start)
                (let ((annotation (annotate-annotation-at start)))
                  (while (and (> start
                                 (point-min))
                              (null annotation))
                    (setf start (previous-overlay-change start))
                    (setf annotation (annotate-annotation-at start)))
                  annotation)))
    (let ((annotation (annotate-annotation-at pos)))
      (if annotation
          (previous-annotation-ends (1- (overlay-start annotation)))
        (previous-annotation-ends pos)))))

(defun annotate-previous-annotation (annotation)
  "Return the annotation before ANNOTATIONS or nil if no such
annotation exists."
  (annotate-previous-annotation-ends (overlay-start (annotate-chain-first annotation))))

(defun annotate-next-annotation-starts (pos)
  "Return the next annotation that starts after POS or nil if no annotation
was found.
NOTE this assumes that annotations never overlaps."
  (cl-labels ((next-annotation-ends (start)
                (let ((annotation (annotate-annotation-at start)))
                  (while (and (/= start
                                  (point-max))
                              (null annotation))
                    (setf start (next-overlay-change start))
                    (setf annotation (annotate-annotation-at start)))
                  annotation)))
    (let ((annotation (annotate-annotation-at pos)))
      (if annotation
          (next-annotation-ends (overlay-end annotation))
        (next-annotation-ends pos)))))

(defun annotate-next-annotation (annotation)
  "Return the annotation after ANNOTATIONS or nil if no such
annotation exists."
  (annotate-next-annotation-starts (overlay-end (annotate-chain-last annotation))))

(defun annotate-symbol-strictly-at-point ()
  "Return non nil if a symbol is at char immediately following
the point. This is needed as `thing-at-point' family of
 functions returns non nil if the thing (a symbol in this case)
 is around the point, according to the documentation."
  (cl-labels ((after-point ()
                (save-excursion
                  (goto-char (1+ (point)))
                  (bounds-of-thing-at-point 'symbol))))
    (let ((sym-on-point     (bounds-of-thing-at-point 'symbol))
          (sym-after-point  (after-point)))
      (and  sym-on-point
            sym-after-point
            (cl-equalp sym-on-point
                       sym-after-point)))))

(defun annotate-bounds ()
  "The bounds of the region or whatever is at point."
  (cl-labels ((left-ends ()
                (cond
                 ((use-region-p)
                  (region-beginning))
                 ((annotate-symbol-strictly-at-point)
                  (let* ((annotation-before (annotate-previous-annotation-ends (point)))
                         (boundaries        (bounds-of-thing-at-point 'symbol))
                         (symbol-start      (car boundaries))
                         (annotation-end    (if annotation-before
                                                (overlay-end annotation-before)
                                              -1)))
                    (max symbol-start
                         annotation-end)))
                 (t
                  (point))))
              (right-ends ()
                (cond
                 ((use-region-p)
                  (if (and (char-before (region-end))
                           (char-equal (char-before (region-end))
                                       ?\n))
                      (1- (region-end))
                    (region-end)))
                 ((annotate-symbol-strictly-at-point)
                  (let* ((annotation-after (annotate-next-annotation-starts (point)))
                         (boundaries       (bounds-of-thing-at-point 'symbol))
                         (symbol-end       (cdr boundaries))
                         (annotation-start (if annotation-after
                                               (overlay-start annotation-after)
                                             (1+ symbol-end))))
                    (min symbol-end
                         annotation-start)))
                 (t
                  (1+ (point))))))
    (list (left-ends)
          (right-ends))))

(defun annotate-make-annotation (beginning ending annotation annotated-text)
  "Make an annotation record that represent an annotation
starting at BEGINNING, terminate at ENDING with annotation
content ANNOTATION and annotated text ANNOTATED-TEXT."
  (list beginning ending annotation annotated-text))

(defun annotate-all-annotations ()
  "Return a list of all annotations in the current buffer."
  (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size))))

(defun annotate--make-annotation-for-record (from
                                             to
                                             annotation-text
                                             annotated-text
                                             color-index
                                             position
                                             id
                                             reply-to)
  "Make a new annotation given the fields:
FROM TO ANNOTATION-TEXT ANNOTATED-TEXT COLOR-INDEX POSITION ID REPLY-TO"
  (list from
        to
        annotation-text
        annotated-text
        color-index
        position
        id
        reply-to))

(defun annotate-describe-annotations ()
  "Return a list of all annotations in the current buffer.
The format is suitable for database dump."
  (let ((all-annotations (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size))))
        (chain-visited   ()))
    (remq nil
          (mapcar (lambda (annotation)
                    (let* ((chain       (annotate-find-chain annotation))
                           (chain-first (annotate-chain-first annotation))
                           (chain-last  (annotate-chain-last annotation))
                           (from        (overlay-start chain-first))
                           (to          (overlay-end   chain-last))
                           (face        (annotate-annotation-face chain-first))
                           (color-index (cl-position-if (lambda (a) (cl-equalp face a))
                                                        annotate-highlight-faces))
                           (position    (annotate-annotation-get-position annotation))
                           (id          (annotate-annotation-id annotation))
                           (reply-to    (annotate-annotation-reply-to annotation))
                           (annotation-text (annotate-annotation-get-annotation-text annotation)))
                      (when (not (cl-find-if (lambda (a)
                                               (eq (cl-first chain)
                                                   (cl-first a)))
                                             chain-visited))
                        (push chain chain-visited)
                        (annotate--make-annotation-for-record from
                                                              to
                                                              annotation-text
                                                              (buffer-substring-no-properties from
                                                                                              to)
                                                              color-index
                                                              position
                                                              id
                                                              reply-to))))
                  all-annotations))))

(defun annotate-info-root-dir-p (filename)
  "Is the name of this file (FILENAME) equals to the info root node?"
  (string= filename
           annotate-info-root-name))

(defun annotate-guess-file-format (filename)
  "Try to guess the file format from FILENAME.
Non nil if the file format is supported from \"annotate\" in a more
sophisticated way than plain text."
  (cl-labels ((file-contents ()
                (with-temp-buffer
                  (insert-file-contents filename)
                  (buffer-string)))
              (info-format-p ()         ; lot of guesswork here :(
                (cond
                 ((annotate-info-root-dir-p filename)
                  :info)
                 (t
                  (let* ((file-contents   (file-contents))
                         (has-info-p      (string-match "info" filename))
                         (separator-re    "\^L?\^_\^L?\^J")
                         (has-separator-p (string-match separator-re file-contents))
                         (has-node-p      (string-match "Node:" file-contents)))
                    (if (and has-separator-p
                             (or has-node-p
                                 has-info-p))
                        :info
                      nil)))))
              (gpg-format-p ()
                (with-temp-buffer
                  (let* ((magic-0    #x8c)
                         (magic-1    #x0d)
                         (magic-4    #x03)
                         (magic-5    #x02)
                         (attributes (file-attributes filename))
                         (file-size  (file-attribute-size attributes)))
                    (when (> file-size 6)
                      (let* ((bytes      (insert-file-contents-literally filename
                                                                         nil
                                                                         0
                                                                         7)))
                        (setf bytes
                              (cl-loop for i from 1 to 6 collect
                                       (elt (buffer-substring-no-properties i (1+ i))
                                            0)))
                        (when (and (= (logand (elt bytes 0) #x0000ff) magic-0)
                                   (= (logand (elt bytes 1) #x0000ff) magic-1)
                                   (= (logand (elt bytes 4) #x0000ff) magic-4)
                                   (= (logand (elt bytes 5) #x0000ff) magic-5))
                          :encrypted-symmetric)))))))
    (or (gpg-format-p)
        (info-format-p)))) ;; keep this one for last as it is the slowest

;;;; summary window procedures

(define-button-type 'annotate-summary-show-annotation-button
  'follow-link t
  'help-echo "Click to show")

(define-button-type 'annotate-summary-delete-annotation-button
  'follow-link t
  'help-echo "Click to remove annotation")

(define-button-type 'annotate-summary-replace-annotation-button
  'follow-link t
  'help-echo "Click to replace annotation")

(define-button-type 'annotate-summary-show-thread-button
  'follow-link t
  'help-echo "Click to add a note")

(defun annotate-info-setup (file-or-node buffer)
  "Display Info node FILE-OR-NODE in BUFFER.

Compatibility wrapper for the function `info-setup' and `info-pop-to-buffer'."
  (with-no-warnings
    (if (version< "30" emacs-version)
        (info-pop-to-buffer file-or-node buffer)
      (info-setup file-or-node buffer))))

(defun annotate-summary-show-annotation-button-pressed (button)
  "Callback called when an annotate-summary-show-annotation-button is activated."
  (let* ((file      (button-get button 'file))
         (file-type (annotate-guess-file-format file)))
    (cond
     ((eq file-type :info)
      (with-current-buffer-window
          "*info*" nil nil
        (annotate-info-setup file (current-buffer))
        (switch-to-buffer "*info*"))
      (with-current-buffer "*info*"
        (goto-char (button-get button 'go-to))))
     (t
      (let* ((buffer (find-file-other-window file)))
        (with-current-buffer buffer
          (goto-char (button-get button 'go-to))))))))

(defun annotate-update-visited-buffer-maybe (filename)
  "Reload annotation mode in the buffer visiting FILENAME, if such buffer exists."
  (let ((visited-buffer (find-buffer-visiting filename)))
    (when visited-buffer ;; a buffer is visiting the file
      (with-current-buffer visited-buffer
        (annotate-mode -1)
        (annotate-mode  1)))))

(defun annotate-summary-delete-annotation-button-pressed (button)
  "Callback for summary window fired when a \"delete\" button is
pressed."
  (let* ((filename        (button-get button 'file))
         (annotations-db  (annotate-load-annotation-data t))
         (annotation      (button-get button 'annotation-bound))
         (no-thread-db    (annotate-remove-annotation-thread annotations-db annotation)))
    (annotate-dump-annotation-data no-thread-db) ; save the new database with entry removed
    (cl-labels ((redraw-summary-window () ; update the summary window
                  (with-current-buffer annotate-summary-buffer-name
                    (read-only-mode -1)
                    (save-excursion
                      (button-put button 'invisible t)
                      (let* ((annotation-button (previous-button (point)))
                             (replace-button (next-button (point)))
                             (replace-button-end (button-end replace-button))
                             (thread-button (next-button replace-button-end)))
                        (button-put annotation-button 'face '(:strike-through t))
                        (button-put replace-button 'invisible t)
                        (button-put thread-button 'invisible t)))
                    (read-only-mode 1))))
      (redraw-summary-window)
      (annotate-update-visited-buffer-maybe filename))))

(defun annotate-summary-replace-annotation-button-pressed (button)
  "Callback for summary window fired when a \"replace\" button is
pressed."
  (let* ((filename             (button-get button 'file))
         (annotation-beginning (button-get button 'beginning))
         (annotation-ending    (button-get button 'ending))
         (query                (button-get button 'query))
         (db                   (annotate-load-annotation-data t))
         (old-annotation       (button-get button 'text))
         (new-annotation-text  (read-from-minibuffer annotate-annotation-prompt old-annotation)))
    (when (not (annotate-string-empty-p new-annotation-text))
      (let ((replaced-annotations-db (annotate-db-replace-annotation db
                                                                    filename
                                                                    annotation-beginning
                                                                    annotation-ending
                                                                    new-annotation-text)))
        (annotate-dump-annotation-data replaced-annotations-db)
        (annotate-update-visited-buffer-maybe filename)
        (annotate-show-annotation-summary query nil nil)))))

(defun annotate-summary-show-thread-button-pressed (button)
  "Callback called when the button to show a thread is pushed in summary window."
  (let ((annotation (button-get button 'annotation-bound)))
    (annotate--show-annotation-thread annotation)))

(cl-defun annotate-wrap-text (text &optional (wrapper "\""))
  "Wrap string TEXT with string WRAPPER."
  (concat wrapper text wrapper))

(cl-defun annotate-unwrap-text (text &optional (wrapper "\"") (left-side t))
  "Remove WRAPPER at both ends from TEXT."
  (let ((results        text)
        (wrapper-length (length wrapper)))
    (when (>= (length text)
              wrapper-length)
      (if left-side
          (let ((maybe-wrapper (substring results 0 wrapper-length)))
            (when (string= maybe-wrapper wrapper)
              (setf results (substring results wrapper-length))
              (setf results (annotate-unwrap-text results wrapper nil))))
        (let ((maybe-wrapper (substring results
                                        (- (length results)
                                           wrapper-length))))
          (when (string= maybe-wrapper wrapper)
            (setf results (substring results 0 (- (length results)
                                                  wrapper-length)))))))
    results))

(defun annotate--db-empty-p (dump)
  "Returns non nil if the database DUMP is empty."
  (cl-every (lambda (a)
              (cl-every #'null
                        (annotate-annotations-from-dump a)))
            dump))

(cl-defun annotate-show-annotation-summary (&optional arg-query cut-above-point (save-annotations t))
  "Show a summary of all the annotations in a temp buffer, the
results can be filtered with a simple query language: see
`annotate-summary-filter-db'."
  (interactive)
  (cl-labels ((ellipsize (text prefix-string)
                (let* ((prefix-length   (string-width prefix-string))
                       (ellipse-length  (string-width annotate-ellipse-text-marker))
                       (substring-limit (max 0
                                             (- (window-body-width)
                                                prefix-length
                                                ellipse-length
                                                2)))) ; this is for quotation marks
                  (if (> (string-width text)
                         substring-limit)
                      (concat (substring text 0 substring-limit)
                              annotate-ellipse-text-marker)
                    text)))
              (wrap (text)
                (annotate-wrap-text text "\""))
              (insert-item-summary (filename
                                    snippet-text
                                    button-text
                                    annotation-beginning
                                    annotation-ending
                                    serialized-annotation
                                    filter-query)
                (insert annotate-summary-list-prefix-snippet)
                (insert (wrap (ellipsize snippet-text
                                         annotate-summary-list-prefix-snippet)))
                (insert "\n")
                (insert annotate-summary-list-prefix)
                (insert-button (propertize (ellipsize button-text
                                                      annotate-summary-list-prefix)
                                           'face
                                           'bold)
                               'file   filename
                               'go-to  annotation-beginning
                               'action 'annotate-summary-show-annotation-button-pressed
                               'type   'annotate-summary-show-annotation-button)
                (insert "\n\n")
                (insert annotate-summary-list-prefix)
                (insert "  ")
                (insert-button annotate-summary-delete-button-label
                               'file       filename
                               'beginning  annotation-beginning
                               'ending     annotation-ending
                               'annotation-bound serialized-annotation
                               'action
                               'annotate-summary-delete-annotation-button-pressed
                               'type
                               'annotate-summary-delete-annotation-button
                               'begin-of-button (annotate-beginning-of-line-pos)
                               'end-of-button (annotate-end-of-line-pos))
                (insert "\n")
                (insert annotate-summary-list-prefix)
                (insert "  ")
                (insert-button annotate-summary-replace-button-label
                               'file       filename
                               'beginning  annotation-beginning
                               'ending     annotation-ending
                               'query      filter-query
                               'text       button-text
                               'action
                               'annotate-summary-replace-annotation-button-pressed
                               'type
                               'annotate-summary-replace-annotation-button)
                (insert "\n")
                (insert annotate-summary-list-prefix)
                (insert "  ")
                (insert-button annotate-summary-show-thread-button-label
                               'annotation-bound serialized-annotation
                               'action
                               'annotate-summary-show-thread-button-pressed
                               'type
                               'annotate-summary-show-thread-button)
                (insert "\n\n"))
              (clean-snippet (snippet)
                (save-match-data
                  (replace-regexp-in-string "[\r\n]"
                                            " "
                                            snippet)))
              (build-snippet-info (filename annotation-begin annotation-end)
                (with-temp-buffer
                  (annotate-info-setup filename (current-buffer))
                  (buffer-substring-no-properties annotation-begin
                                                  annotation-end)))
              (build-snippet-from-buffer (filename annotation-begin annotation-end)
                (let ((visited-buffer (find-buffer-visiting filename)))
                  (when visited-buffer ;; a buffer is visiting the file
                    (with-current-buffer visited-buffer
                      (let ((raw-snippet (buffer-substring-no-properties annotation-begin
                                                                         annotation-end)))
                        (clean-snippet raw-snippet))))))
              (build-snippet-from-file (filename annotation-begin annotation-end)
                (with-temp-buffer
                  (insert-file-contents filename
                                        nil
                                        (1- annotation-begin)
                                        (1- annotation-end))
                  (clean-snippet (buffer-string))))
              (build-snippet (filename annotation-begin annotation-end)
                (if (annotate-file-exists-p filename)
                    (cond
                     ((eq (annotate-guess-file-format filename)
                          :info)
                      (clean-snippet (build-snippet-info filename
                                                         annotation-begin
                                                         annotation-end)))
                     (t
                      (or (build-snippet-from-buffer filename
                                                     annotation-begin
                                                     annotation-end)
                          (build-snippet-from-file   filename
                                                     annotation-begin
                                                     annotation-end))))
                  (if (annotate-info-root-dir-p filename)
                      (clean-snippet (build-snippet-info filename
                                                         annotation-begin
                                                         annotation-end))
                    annotate-error-summary-win-filename-invalid)))
              (get-query     ()
                (cond
                 (arg-query
                  arg-query)
                 (annotate-summary-ask-query
                  (read-from-minibuffer "Query: "))
                 (t
                  ".*")))
              (insert-root-item (db-filename filter-query annotation-fields)
                (let* ((button-text      (format "%s"
                                                 (annotate-annotation-string annotation-fields)))
                       (annotation-begin (annotate-beginning-of-annotation annotation-fields))
                       (annotation-end   (annotate-ending-of-annotation    annotation-fields))
                       (snippet-text     (build-snippet db-filename
                                                        annotation-begin
                                                        annotation-end)))
                  (insert-item-summary db-filename
                                       snippet-text
                                       button-text
                                       annotation-begin
                                       annotation-end
                                       annotation-fields
                                       filter-query)))
              (insert-reply-item (annotations-db reply-fields)
                (let* ((parent-id       (annotate-annotation-reply-to reply-fields))
                       (parent          (annotate--find-annotation annotations-db parent-id))
                       (parent-text     (annotate-annotation-string parent))
                       (annotation-text (annotate-annotation-string reply-fields)))
                  (insert annotate-summary-list-prefix-reply
                          (wrap (ellipsize (clean-snippet parent-text) ""))
                          "\n"
                          (ellipsize annotation-text "")
                          "\n\n")
                  (insert-button annotate-summary-show-thread-button-label
                                 'annotation-bound parent
                                 'action
                                 'annotate-summary-show-thread-button-pressed
                                 'type
                                 'annotate-summary-show-thread-button)
                  (insert "\n\n"))))
    (when save-annotations
      (annotate-save-all-annotated-buffers))
    (let* ((filter-query (get-query))
           (dump         (annotate-summary-filter-db (annotate-load-annotation-data t)
                                                     filter-query
                                                     cut-above-point)))
      (if (annotate--db-empty-p dump)
          (when annotate-use-messages
            (message "The annotation database is empty"))
        (with-current-buffer-window
            annotate-summary-buffer-name nil nil
          (display-buffer annotate-summary-buffer-name)
          (select-window (get-buffer-window annotate-summary-buffer-name t))
          (outline-mode)
          (use-local-map nil)
          (local-set-key "q" (lambda ()
                               (interactive)
                               (kill-buffer annotate-summary-buffer-name)))
          (dolist (record dump)
            (let* ((all-annotations (annotate-annotations-from-dump record))
                   (db-filename     (annotate-filename-from-dump record)))
              (when (not (null all-annotations))
                (insert (format (concat annotate-summary-list-prefix-file "%s\n\n")
                                db-filename))
                (dolist (annotation-fields all-annotations)
                  (if (annotate-annotation-root-p annotation-fields)
                      (insert-root-item db-filename
                                        filter-query
                                        annotation-fields)
                    (insert-reply-item dump
                                       annotation-fields))))))
          (read-only-mode 1))))))

;;;; end summary window procedures

;;;; filtering summary window: parser, lexer, etc.

(defvar annotate-summary-query  nil
  "Holds the query to filter annotations when
summary window is shown.")

(defvar annotate-summary-query-current-token nil
  "Holds the next token of the query in `annotate-summary-query'.")

(defun annotate-summary-query-lexer-symbol (res)
  "The symbol identifying the token (e.g. \\='and)."
  (elt res 0))

(defun annotate-summary-query-lexer-string (res)
  "The string associated with this token."
  (elt res 1))

(defun annotate-summary-query-lexer-start (res)
  "The starting point of the substring of
`annotate-summary-query' for this token."
  (elt res 2))

(defun annotate-summary-query-lexer-end (res)
  "The ending point of the substring of
`annotate-summary-query' for this token."

  (elt res 3))

(cl-defun annotate-summary-lexer (&optional (look-ahead-p nil))
  "The lexer for `annotate-summary-query'.

This function, when called, will produce the next token from
`annotate-summary-query'; a token is a substring with a well
defined meaning according to our grammar.

For example this string:

p.* and (a or not b)

will be broken into these tokens:

\\='(re        \"p.*\"   0  3)
\\='(and       \"and\"   4  7)
\\='(open-par  \"(\"     8  9)
\\='(re        \"a\"     9 10)
\\='(or        \"or\"   11 12)
\\='(not       \"not\"  14 17)
\\='(re        \"b\"    18 19)
\\='(close-par \"(\"    19 20)

The format is a proper list where:
- first element
  a symbol representing the type of the token
   - \\='re                  = regular expression
   - \\='and , \\='or , \\='not    = logical operator
   - \\='open-par, \\='close-par = open and closing parenthesis respectively
- second element
  the value (the actual substring for this token)

- third and fourth element (currently unused)
 the substring limits for this token (as returned by
 MATCH-BEGINNING and MATCH-END.

Note that spaces are ignored and all the tokens except \"re\" must
not be prefixed with a backslash to match.  So, for example not ->
will match the token type \\='not but \not will match the token \\='re;
this way we can \"protect\" a regexp that contains reserved
keyword (aka escaping).

The special value :no-more-token is returned after the whole
input is processed.

Calling this function with value of LOOK-AHEAD-P nil will consume the
token from `annotate-summary-query' (i.e. that string is modified).

example:
\"a and b\" -> \"and b\", \\='(re \"a\" 0 1)

when LOOK-AHEAD-P is not nil the token is recognized but not cut away
from `annotate-summary-query'.

example:
\"a and b\" -> \"a and b\", \\='(re \"a\" 0 1)"
  (cl-labels ((build-token (token-symbol token-string token-beginning token-end)
                (list token-symbol
                      token-string
                      token-beginning
                      token-end))
              (build-results  (token-symbol register-num)
                (build-token token-symbol
                             (match-string register-num annotate-summary-query)
                             (match-beginning register-num)
                             (match-end       register-num)))
              (cut-query      (match-results)
                (setf annotate-summary-query
                      (cl-subseq annotate-summary-query
                                 (annotate-summary-query-lexer-end match-results)))))
    (let ((re (concat "\\((\\)\\|\\()\\)\\|\\(and\\)\\|\\(not\\)\\|"
                      "\\(or\\)\\|\\(\".*\"\\)\\|\\([^[:space:]]+\\)")))
      (save-match-data
        (let* ((matchedp (string-match re annotate-summary-query))
               (res      (if matchedp
                             (cond
                              ((match-string 1 annotate-summary-query)
                               (build-results 'open-par 1))
                              ((match-string 2 annotate-summary-query)
                               (build-results 'close-par 2))
                              ((match-string 3 annotate-summary-query)
                               (build-results 'and 3))
                              ((match-string 4 annotate-summary-query)
                               (build-results 'not 4))
                              ((match-string 5 annotate-summary-query)
                               (build-results 'or 5))
                              ((match-string 6 annotate-summary-query)
                               (build-results 'escaped-re 6))
                              ((match-string 7 annotate-summary-query)
                               (build-results 're 7))
                              (t
                               :no-more-tokens))
                           :no-more-tokens)))
          (when (and (listp res)
                     (not look-ahead-p))
            (cut-query res))
          res)))))

(defun annotate-summary-query-parse-end-input-p (token)
  "Non nil if there are no more tokens in `annotate-summary-query'."
  (eq token :no-more-tokens))

(defun annotate-summary-token-symbol-match (looking-symbol token)
  "Return non nil if LOOKING-SYMBOL is \"eq\" to the symbol
component of TOKEN."
  (eq looking-symbol
      (annotate-summary-query-lexer-symbol token)))

(cl-defun annotate-summary-query-parse-note (filter-fn annotation &optional (res nil))
  "Parser rule for note:

This function will parse the following production rules

NOTE       := \"(\" NOTE \")\"
               | NOTE OPERATOR NOTE
               | NOT NOTE
               | RE
               | ESCAPED-RE
               | epsilon
OPERATOR   := AND | OR
FILE-MASK  := RE
RE         := [^[:space:]] ; as regular expression
ESCAPED-RE := DELIMITER
              ANYTHING
              DELIMITER
ANYTHING   := .*           ; as a regular expression
AND        := \"and\"
OR         := \"or\"
NOT        := \"not\"
DELIMITER  := \" ; ASCII 34 (dec) 22 (hex)

Arguments:

- filter-fn is a function that accept two parameters: the regular
  expression to match (a token of type \\='re, see the lexer
  `annotate-summary-lexer' and a single annotation record (see
  `annotate-load-annotations`).

  This function will reject (its value is nil) records that do
  not match the annotation.

- annotation
  the annotation to test

- res the results of this production rule (internal use only)."
  (cl-labels ((token-symbol-match-p (looking-symbol token)
                (annotate-summary-token-symbol-match looking-symbol token))
              ;; this function will parse the rule operator
              ;; OPERATOR   := AND | OR
              ;; NOTE OPERATOR NOTE
              ;; filter-fn     see the docstring
              ;; matchp        non nil if (funcall filter-fn previous-token) is not nil
              (operator (filter-fn annotation matchp)
                (let ((look-ahead        (annotate-summary-lexer t)))
                  (if (annotate-summary-query-parse-end-input-p look-ahead)
                      ;; end of input, recurse one more time
                      (annotate-summary-query-parse-note filter-fn
                                                         annotation
                                                         matchp)
                    (let ((look-ahead-symbol
                           (annotate-summary-query-lexer-symbol look-ahead))
                          (look-ahead-string
                           (annotate-summary-query-lexer-string look-ahead)))
                      (cond
                       ((not (cl-find look-ahead-symbol '(and or close-par)))
                        (signal 'annotate-query-parsing-error
                                (list (format (concat "Expecting for operator "
                                                      "('and' or 'or') or \")\". "
                                                      "found %S instead")
                                              look-ahead-string))))
                       (t
                        ;; found operator, recurse to search for rhs of rule
                        ;; NOTE OPERATOR NOTE
                        (annotate-summary-query-parse-note filter-fn
                                                           annotation
                                                           matchp))))))))
    (let* ((look-ahead (annotate-summary-lexer t))) ; the next token that the lexer *will* consume
                                        ; note the second arg is non nil
      (if (not (annotate-summary-query-parse-end-input-p look-ahead))
          (progn
            (cond
             ((token-symbol-match-p 'close-par look-ahead) ; ignore closing parens
              res)
             ((token-symbol-match-p 'open-par look-ahead) ; next token is an open parens
              ;; trying to match the rule:
              ;; NOTE := '(' NOTE ')'
              (annotate-summary-lexer) ; consume the token ')'
              ;; match the note inside the parens
              (let ((matchp             (annotate-summary-query-parse-note filter-fn
                                                                           annotation)) ; recurse
                    ;; after the note there *must* be a closing parenthesis
                    (maybe-close-parens (annotate-summary-lexer)))
                ;; if not this is an error
                (when (or (annotate-summary-query-parse-end-input-p maybe-close-parens)
                          (not (eq (annotate-summary-query-lexer-symbol maybe-close-parens)
                                   'close-par)))
                  (signal 'annotate-query-parsing-error '("Unmatched parens")))
                ;; continue parsing
                (annotate-summary-query-parse-note filter-fn annotation matchp))) ; recurse
             ((token-symbol-match-p 'not look-ahead)
              (annotate-summary-lexer) ; consume the token 'not'
              ;; the note after the 'not'  operator in rule
              ;; NOTE := NOT NOTE
              ;; the third argument is the value to return if
              ;; there are no more token left in the input string
              (let ((res (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse
                ;; if there are no more tokens here this is an error
                ;; because, according to the grammar, after a NOT a
                ;; NOTE is non optional
                (if (eq :error res)
                    (signal 'annotate-query-parsing-error '("No more input after 'not'"))
                  ;; if the last rule (saved in res) is not nil (and
                  ;; is not :error) return nil, return the last
                  ;; annotation otherwise remember that the user asked
                  ;; for an annotation that *not* matches a regex
                  (if (null res)
                      annotation
                    nil))))
             ;; trying to match the rule:
             ;; NOTE := NOTE AND NOTE
             ((token-symbol-match-p 'and look-ahead)
              (annotate-summary-lexer) ; consume the 'and' token
              (let ((lhs res)          ; the left side of this rule lhs AND rhs
                    (rhs (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse
                (if (eq :error rhs) ; see the 'not' operator above
                    (signal 'annotate-query-parsing-error '("No more input after 'and'"))
                  (and lhs rhs)))) ; both rules must match as this is a logic and
             ;; trying to match the rule:
             ;; NOTE := NOTE OR NOTE
             ((token-symbol-match-p 'or look-ahead)
              (annotate-summary-lexer) ; consume the 'or'
              (let ((lhs res)          ; the left side of this rule (lhs OR rhs)
                    (rhs (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse
                (if (eq :error rhs)
                    (signal 'annotate-query-parsing-error '("No more input after 'or'"))
                  (or lhs rhs)))) ; either lhs or rhs match as this is a logic or
             ((token-symbol-match-p 'escaped-re look-ahead)
              ;; here we match the rule:
              ;; NOTE := ESCAPED-RE
              ;; ESCAPED-RE is a delimited string like "foo bar"
              ;; we first unescape the protected token
              ;; "\"foo bar\"" ->  "foo bar" (yes, just remove the delimiters)
              ;; then we apply the filter function (see the docstring)
              (let* ((escaped   (annotate-summary-query-lexer-string (annotate-summary-lexer)))
                     (unescaped (substring escaped 1 (1- (length escaped)))) ; remove delimiters
                     (matchp    (funcall filter-fn unescaped annotation)))   ; apply the filter function
                ;; and finally continue the parsing saving the results
                ;; of applying the filter-fn function
                (operator filter-fn annotation matchp)))
             (t
              ;; here we match the rule:
              ;; NOTE := RE
              ;; RE   := a regular expression
              ;; first just get the RE token
              (let* ((regex     (annotate-summary-query-lexer-string (annotate-summary-lexer)))
                     ;; then apply the filter function (see the docstring)
                     (matchp    (funcall filter-fn regex annotation)))
                ;; and finally continue the parsing saving the results
                ;; of applying the filter-fn function
                (operator filter-fn annotation matchp)))))
        ;; if we are here the lexer can not find any more tokens in the query
        ;; just return the value of res
        res)))) ; end of '(if (not (annotate-summary-query-parse-end-input-p look-ahead))'

(defun annotate-summary-query-parse-expression ()
  "Parse rule for expression:

I feel this  is very likely wrong in many  ways, i hope linguists
are going to forgive me :-)

EXPRESSION := FILE-MASK
               | FILE-MASK AND NOTE
               | FILE-MASK OR NOTE
               | epsilon
NOTE       := \"(\" NOTE \")\"
               | NOTE OPERATOR NOTE
               | NOT NOTE
               | RE
               | ESCAPED-RE
               | epsilon
OPERATOR   := AND | OR
FILE-MASK  := RE
RE         := [^[:space:]] ; as a regular expression
ESCAPED-RE := DELIMITER
              ANYTHING
              DELIMITER
ANYTHING   := .*           ; as a regular expression
AND        := \"and\"
OR         := \"or\"
NOT        := \"not\"
DELIMITER  := \" ; ASCII 34 (dec) 22 (hex)

Note: this function returns the annotation part of the record, see
`annotate-load-annotations'."
  (lambda (annotation query file-filter-fn note-filter-fn)
    (let ((annotate-summary-query query) ; save the query
          (query-notes-only       nil)) ; the query for just the notes
      (let ((next-token (annotate-summary-lexer))) ; get potential file-mask
        ;; if there are no more tokens just return all the records
        ;; these match the empty string as in rule
        ;; EXPRESSION := epsilon
        (if (annotate-summary-query-parse-end-input-p next-token)
            (annotate-annotations-from-dump annotation)
          ;; otherwise test the record with the file-mask
          (let* ((quoted-file-mask-p  (annotate-summary-token-symbol-match 'escaped-re
                                                                           next-token))
                 (file-mask-raw       (annotate-summary-query-lexer-string next-token))
                 (file-mask           (if quoted-file-mask-p
                                          (annotate-unwrap-text file-mask-raw "\"")
                                        file-mask-raw))
                 (filtered-annotation (funcall file-filter-fn file-mask annotation))
                 ;; get the operator as in rule
                 (operator-token (annotate-summary-lexer)))
            ;; if there are no operator just return the filtered (by file-mask)
            ;; as in rule
            ;; EXPRESSION := FILE-MASK
            (if (annotate-summary-query-parse-end-input-p operator-token)
                (annotate-annotations-from-dump filtered-annotation)
              ;; otherwise get the operator and continue to parse the rule
              ;; EXPRESSION := FILE-MASK AND NOTE
              ;; or
              ;; EXPRESSION := FILE-MASK OR  NOTE
              (let ((operator (annotate-summary-query-lexer-symbol operator-token)))
                (cond
                 ((eq operator 'or) ; operator is 'or
                  ;; try to parse with the rule
                  ;; EXPRESSION := FILE-MASK OR NOTE
                  ;; return only the list annotation filtered by
                  ;; file-mask the former is non nil
                  (if filtered-annotation
                      (annotate-annotations-from-dump filtered-annotation)
                    ;; the annotation filtered by file-mask is empty, try to
                    ;; match the NOTE rule
                    (let ((look-ahead (annotate-summary-lexer t)))
                      ;; no more input after operator this is wrong
                      ;; according to the rule we are trying to match:
                      ;; EXPRESSION := FILE-MASK OR NOTE
                      (if (annotate-summary-query-parse-end-input-p look-ahead)
                          (signal 'annotate-query-parsing-error '("No more input after 'or'"))
                        (progn
                          ;; copy the string for note parsing note
                          ;; that annotate-summary-query only contains
                          ;; the substring to match the NOTE rule
                          (setf query-notes-only (concat annotate-summary-query))
                          ;; parse all the annotations, we get a list
                          ;; where non nil elements are the annotation
                          ;; that passes the note-filter-fn test
                          (mapcar (lambda (a)
                                    (let ((annotate-summary-query (concat query-notes-only)))
                                      (annotate-summary-query-parse-note note-filter-fn
                                                                         a)))
                                  (annotate-annotations-from-dump annotation)))))))
                 ((eq operator 'and)
                  ;; try to parse with the rule
                  ;; EXPRESSION := FILE-MASK OR NOTE
                  (let ((look-ahead (annotate-summary-lexer t)))
                    ;; no more input after operator, this is wrong
                    ;; according to the rule we are trying to match:
                    ;; EXPRESSION := FILE-MASK AND NOTE
                    (if (annotate-summary-query-parse-end-input-p look-ahead)
                        (signal 'annotate-query-parsing-error '("No more input after 'and'"))
                      (progn
                        ;; copy the string for note parsing note
                        ;; that annotate-summary-query only contains
                        ;; the substring to match the NOTE rule
                        (setf query-notes-only (concat annotate-summary-query))
                        ;; parse the already filtered by file-mask annotations only
                        ;; we get a list where non nil elements are the annotation
                        ;; that passes the note-filter-fn test
                        (mapcar (lambda (a)
                                  (let ((annotate-summary-query (concat query-notes-only)))
                                    (annotate-summary-query-parse-note note-filter-fn
                                                                       a)))
                                (annotate-annotations-from-dump filtered-annotation))))))
                 (t
                  ;; there is something after the file-mask in the
                  ;; input but it is not an operator
                  (signal 'annotate-query-parsing-error
                          (list (format "Unknown operator: %s is not in '(and, or)"
                                        (annotate-summary-query-lexer-string operator-token))))))))))))))

(defun annotate-summary-filter-db (annotations-dump query remove-annotations-cutoff-point)
  "Filter an annotation database with a query.

The argument QUERY is a string that respect a simple syntax:

- [file-mask] [(and | or) [not] regex-note [(and | or) [not] regexp-note ...]]

where

- file-mask: is a regular expression that should match the filepath
 the annotation refers to;
- and, or, not : you guess? Classics logical operators;
- regex-note: the text of annotation must match this regular expression.

Examples:

- lisp$ and TODO
 matches the text \"TODO\" in all lisp files

Parenthesis can be used for the expression related to the text of
annotation, like this:

- lisp$ and (TODO or important)
 the same as above but checks also for string \"important\"

- /home/foo/
 matches all the annotation that refers to file in the directory
 '/home/foo'

- /home/foo/ and not minor
 matches all the annotation that refers to file in the directory
 '/home/foo' and that not contains the text \"minor\".

- .* and \"not\"
 the \" can be used to escape strings

If you want to remove from summary the annotations that appears
before a position in buffer set \"remove-annotations-cutoff-point\" to said
position.

The annotations in each record are sorted by starting point in ascending order."
  (let* ((parser             (annotate-summary-query-parse-expression))
         (filter-file        (lambda (file-mask annotation-dump)
                               (let ((filename
                                      (annotate-filename-from-dump annotation-dump)))
                                 (and (string-match-p file-mask filename)
                                      annotation-dump))))
         (filter-annotations (lambda (re annotation-dump-2)
                               (and (string-match-p re
                                                    (annotate-annotation-string annotation-dump-2))
                                    annotation-dump-2)))
         (filter             (lambda (single-record)
                               (let ((filtered-annotations (funcall parser
                                                                    single-record
                                                                    query
                                                                    filter-file
                                                                    filter-annotations)))
                                 (setf filtered-annotations
                                       (remq nil filtered-annotations))
                                 (when filtered-annotations
                                   (let ((filename (annotate-filename-from-dump
                                                    single-record))
                                         (checksum (annotate-checksum-from-dump
                                                    single-record)))
                                     (setf filtered-annotations
                                           (sort filtered-annotations
                                                 (lambda (a b)
                                                   (cond
                                                    ((and (annotate-annotation-root-p a)
                                                          (annotate-annotation-root-p b))
                                                     (annotate-db-annotations-starts-before-p a b))
                                                    ((annotate-annotation-root-p a)
                                                     a)
                                                    (t
                                                     b)))))
                                     (when remove-annotations-cutoff-point
                                       (setf filtered-annotations
                                             (cl-remove-if (lambda (a)
                                                             (< (annotate-ending-of-annotation a)
                                                                remove-annotations-cutoff-point))
                                                           filtered-annotations)))
                                     (annotate-make-annotation-dump-entry filename
                                                                          filtered-annotations
                                                                          checksum))))))
         (filtered           (remq nil (mapcar filter annotations-dump))))
    filtered))

;;;; end of filtering: parser, lexer, etc.

;;;; misc commands

(defun annotate-summary-of-file-from-current-pos ()
  "Shows a summary window that contains only the annotations in
the current buffer and that starts after the current cursor's
position."
  (interactive)
  (with-current-buffer (current-buffer)
    (when buffer-file-name
      (annotate-show-annotation-summary (annotate-wrap-text buffer-file-name "\"")
                                        (point)))))

;;; switching database

(defun annotate-buffers-annotate-mode ()
  "Return a list of all the buffers that have
annotate minor mode active."
  (let ((all-buffers (buffer-list)))
    (cl-labels ((annotate-mode-p (buffer)
                  (with-current-buffer buffer
                    (and (boundp 'annotate-mode) ;FIXME: Redundant test?
                         annotate-mode))))
      (cl-remove-if-not #'annotate-mode-p all-buffers))))

(cl-defun annotate-switch-db (&optional (force-load nil) (database-file-path nil))
  "Ask the user for a new annotation database files, load it and
refresh all the annotations contained in each buffer where
annotate minor mode is active.

if DATABASE-FILE-PATH is nil (the default) a prompt asking for
a file containing database is presented to the user, otherwise
the value of this argument is used.

If FORCE-LOAD is non nil no prompt asking user for confirmation
about loading the new file is shown.

Note: this function will attempt to load (compile and
eval/execute) the content of the file as it was elisp source
code, always use load files from trusted sources!"
  (interactive)
  (let ((new-db (or database-file-path
                    (read-file-name "Database file location: "))))
    (when (not (annotate-string-empty-p new-db))
      (if (annotate-file-exists-p new-db)
          (let* ((confirm-message "Loading elisp file from untrusted source may results in severe security problems. Load %S?")
                 (load-file-confirmed (or force-load
                                          (y-or-n-p (format confirm-message new-db)))))
            (if load-file-confirmed
                (progn
                  (setf annotate-file new-db)
                  (cl-loop for annotated-buffer in (annotate-buffers-annotate-mode) do
                           (with-current-buffer annotated-buffer
                             (with-silent-modifications
                               (annotate-mode -1)
                               (annotate-mode  1)))))
              (when annotate-use-messages
                (message "Load aborted by the user"))))
        (signal 'annotate-db-file-not-found (list new-db))))))

;; end of switching database

;;; merging database

(defun annotate--merge-interval (a b)
  "Merge two annotation interval A and B.

The new interval is expanded so that includes A and B."
  (let ((new-left-limit  (min (annotate--interval-left-limit a)
                              (annotate--interval-left-limit b)))
        (new-right-limit (max (annotate--interval-right-limit a)
                              (annotate--interval-right-limit b))))
    (annotate--make-interval new-left-limit
                             new-right-limit)))

(defun annotate--db-annotations-overlaps-p (annotation-a annotation-b)
  "Return non nil if ANNOTATION-A and ANNOTATION-B overlaps."
  ;; reply never overlaps
  (when (not (or (annotate-annotation-reply-p annotation-a)
                 (annotate-annotation-reply-p annotation-b)))
    (let ((interval-a (annotate-annotation-interval annotation-a))
          (interval-b (annotate-annotation-interval annotation-b)))
      (not (or (< (annotate--interval-right-limit interval-b)
                  (annotate--interval-left-limit interval-a))
               (> (annotate--interval-left-limit interval-b)
                  (annotate--interval-right-limit interval-a)))))))

(defun annotate--db-merge-annotations (host guest)
  "Merge annotation GUEST into annotation HOST.
Uses `annotate--merge-interval'.
Notes that if either HOST or GUEST are replies, this function returns NIL."
  (when (annotate--db-annotations-overlaps-p host guest)
    (let* ((interval-host       (annotate-annotation-interval host))
           (interval-guest      (annotate-annotation-interval guest))
           (text-host           (annotate-annotation-string   host))
           (text-guest          (annotate-annotation-string   guest))
           (new-interval        (annotate--merge-interval     interval-host interval-guest))
           (new-annotation-text (concat text-host " " text-guest))
           (left                (annotate--interval-left-limit new-interval))
           (right               (1+ (annotate--interval-right-limit new-interval)))
           (new-annotated-text  (with-current-buffer (current-buffer)
                                  (buffer-substring-no-properties left right)))
           (color-index         (annotate-color-index-from-dump host))
           (position            (annotate-placement-policy-from-dump host))
           (id-host             (annotate-annotation-id host))
           (reply-to            (annotate-annotation-reply-to host))) ; always nil
      (annotate--make-annotation-for-record left
                                            right
                                            new-annotation-text
                                            new-annotated-text
                                            color-index
                                            position
                                            id-host
                                            reply-to))))

(defun annotate--db-remove-overlap-annotations (annotations &optional accum)
  "Recursively merges overlapping annotations in ANNOTATIONS
using `annotate--db-merge-annotations'."
  (if (= (length annotations) 1)
      (push (cl-first annotations) accum)
    (let* ((probe            (cl-first annotations))
           (rest-annotations (cl-rest annotations))
           (position-overlap (cl-position-if (lambda (a)
                                               (annotate--db-annotations-overlaps-p probe a))
                                             rest-annotations)))
      (if position-overlap
          (let* ((annotation-overlapping    (elt rest-annotations position-overlap))
                 (annotations-before-merged (cl-subseq rest-annotations 0 position-overlap))
                 (annotations-after-merged  (cl-subseq rest-annotations (1+ position-overlap)))
                 (merged-annotation         (annotate--db-merge-annotations probe
                                                                            annotation-overlapping)))
            (annotate--db-remove-overlap-annotations (append annotations-before-merged
                                                             (list merged-annotation)
                                                             annotations-after-merged)
                                                     accum))
        (annotate--db-remove-overlap-annotations rest-annotations (push probe accum))))))

(defun annotate--db-merge-databases (db-1 db-2 &optional accum)
  "Recursively merge database DB-1 and DB-2."
  (cl-labels ((find-same-file-record (record annotations-db)
                (let ((record-filename (annotate-filename-from-dump record)))
                  (cl-find-if (lambda (a)
                                (let ((scanned-record-filename (annotate-filename-from-dump a)))
                                  (file-equal-p record-filename scanned-record-filename)))
                              annotations-db)))
              (remap-reply (db-host db-guest replies)
                (if (null db-host)
                    replies
                  (let* ((probe (cl-first db-host))
                         (probe-id (annotate-annotation-id probe))
                         (overlapped (cl-find-if (lambda (a)
                                                   (annotate--db-annotations-overlaps-p probe a))
                                                 db-guest)))
                    (if overlapped
                        (let* ((overlapped-id (annotate-annotation-id overlapped))
                               (remapped-replies (cl-loop for reply in replies
                                                          collect
                                                          (let ((reply-to-id (annotate-annotation-reply-to reply)))
                                                            (if (annotate-annotation-id= overlapped-id
                                                                                         reply-to-id)
                                                                (annotate-annotation-replace-reply-to reply
                                                                                                      probe-id)
                                                              reply)))))
                          (remap-reply (cl-rest db-host)
                                       db-guest
                                       remapped-replies)))))))
    (if (null db-1)
        (append accum db-2)
      (let* ((first-record     (cl-first db-1))
             (same-file-record (find-same-file-record first-record db-2)))
        (if same-file-record
            (let* ((filename                   (annotate-filename-from-dump first-record))
                   (db1-annotations            (annotate-annotations-from-dump first-record))
                   (db2-annotations            (annotate-annotations-from-dump same-file-record))
                   (db2-replies                (cl-remove-if-not #'annotate-annotation-reply-p db2-annotations))
                   (db2-replies-remapped       (remap-reply db1-annotations db2-annotations db2-replies))
                   (db2-roots                  (cl-remove-if #'annotate-annotation-reply-p db2-annotations))
                   (concatenated-annotations   (append db1-annotations db2-roots))
                   (non-overlapped-annotations (annotate--db-remove-overlap-annotations concatenated-annotations))
                   (concatenated-checksum      (annotate-checksum-from-dump first-record))
                   (concatenated-record        (annotate-make-record filename
                                                                     (append non-overlapped-annotations
                                                                             db2-replies-remapped)
                                                                     concatenated-checksum))
                   (rest-of-db-2               (cl-remove-if
                                                (lambda (a)
                                                  (let ((record-filename (annotate-filename-from-dump a)))
                                                    (file-equal-p record-filename filename)))
                                                db-2)))
              (annotate--db-merge-databases (cl-rest db-1)
                                            rest-of-db-2
                                            (push concatenated-record accum)))
          (annotate--db-merge-databases (cl-rest db-1)
                                        db-2
                                        (push first-record accum)))))))

(defun annotate-import-annotations ()
  "Prompt user for an annotation database file and merge it into
their personal database."
  (interactive)
  (cl-flet ((deserialize-db (file)
              (ignore-errors (annotate--deserialize-database-file file)))
            (remove-non-existing-files (annotations)
              (cl-remove-if-not (lambda (a)
                                  (let ((filename (annotate-filename-from-dump a)))
                                    (annotate-file-exists-p filename)))
                                annotations)))
    (let* ((confirm-message    (concat "Importing databases from untrusted source may cause severe "
                                       "security issues, continue?"))
           (import-confirmed-p (or (not annotate-database-confirm-import)
                                   (y-or-n-p confirm-message))))
      (when import-confirmed-p
        (let* ((imported-db-name (read-file-name "Choose the database to import: "))
               (imported-db      (remove-non-existing-files (deserialize-db imported-db-name)))
               (hosting-db       (deserialize-db annotate-file))
               (merged-db        (annotate--db-merge-databases hosting-db imported-db)))
          (annotate-dump-annotation-data merged-db)
          (annotate-switch-db t annotate-file)
          (when annotate-use-messages
            (message "Imported annotations from %s." imported-db-name)))))))

(defun annotate-get-tree-children-clsr (annotate-db)
  "Returns a function that returns the children of an annotation passed
as argument."
  (lambda (annotation)
    (annotate-get-annotation-children annotate-db annotation)))

(defun annotate-annotation-leaf-p (annotation annotations-db)
  "Returns non nil if ANNOTATION is a leaf (no replies)."
  (null (funcall (annotate-get-tree-children-clsr annotations-db)
                 annotation)))

(defun annotate-annotation-leaf-p-clsr (annotations-db)
  "Returns a function that returns non nil if annotation
passed as argument is a leaf."
  (lambda (annotation)
    (annotate-annotation-leaf-p annotation annotations-db)))

(cl-defgeneric annotate-annotation-root-p (object)
  "Returns non nil if OBJECT is a root annotation (has no parent)")

(cl-defmethod annotate-annotation-root-p ((object list))
  "Returns non nil if OBJECT is a root annotation (has no parent)"
  (null (annotate-reply-to-from-dump object)))

(cl-defmethod annotate-annotation-root-p ((object overlay))
  "Returns non nil if OBJECT is a root annotation (has no parent)"
  (null (annotate-annotation-reply-to object)))

(cl-defgeneric annotate-annotation-find-root (annotations-db object)
  "Find the root annotation of the thread where OBJECT belongs")

(cl-defmethod annotate-annotation-find-root (annotations-db object)
  "Find the root annotation of the thread where OBJECT belongs"
  (if (annotate-annotation-root-p object)
      (annotate--find-annotation annotations-db object)
    (let* ((parent-id (annotate-annotation-reply-to object))
           (parent    (annotate--find-annotation annotations-db parent-id)))
      (annotate-annotation-find-root annotations-db parent))))

(defun annotate-get-tree-data (annotation)
  "Get the data from a tree node (i.e. the annotation's text)."
  (annotate-annotation-string annotation))

(define-button-type 'annotate-thread-delete-node-button
  'follow-link t
  'help-echo "Click to delete this note")

(define-button-type 'annotate-thread-reply-node-button
  'follow-link t
  'help-echo "Click to reply to this note")

(cl-defun annotate--print-tree-data (node
                                     data
                                     format
                                     indent
                                     last-child
                                     get-children-fn
                                     &rest args)
  "Print the node tree NODE."
  (cl-labels ((insert-first-line (lines)
                (insert (apply #'format
                               (append (list (concat format "%s\n"))
                                       (append (list indent)
                                               args
                                               (list (cl-first lines)))))))
              (insert-rest-line (line format-control)
                (insert (format format-control
                                indent
                                (if last-child
                                    "  "
                                  (concat annotate-thread-trunk-string " "))
                                line)))
              (promote-to-button (target action type node)
                (save-match-data
                  (re-search-forward target)
                  (let ((start-button (match-beginning 0))
                        (end-button (match-end 0)))
                    (make-button start-button
                                 end-button
                                 'type type
                                 'action action
                                 'annotation-bound node))))
              (insert-stretched-line (line &key (add-newline nil))
                (insert-rest-line line
                                  (concat "%s%s"
                                          annotate-thread-trunk-stretch-string
                                          (if add-newline
                                              " %s\n"
                                            " %s "))))
              (insert-empty-line (line inner-node)
                (if inner-node
                    (insert-rest-line line
                                      (concat "%s%s"
                                              annotate-thread-trunk-stretch-string
                                              "%s"))
                  (insert-rest-line line "%s%s %s"))))
    (let* ((children (funcall get-children-fn node))
           (inner-node (not (annotate-annotation-root-p node)))
           (lines (append (annotate--split-lines data)
                          (when inner-node
                            (list " "))
                          (if inner-node
                              (list (concat annotate-thread-delete-button-label
                                            " "
                                            annotate-thread-reply-button-label))
                              (list annotate-thread-reply-button-label))
                          (list "\n")))
           (rest-lines (cl-rest lines)))
      (insert-first-line lines)
      (cl-loop for line in rest-lines
               for count from 0
               do
               (cond
                ((= count
                    (- (length rest-lines)
                       2)) ;; buttons
                 (if (and children
                          inner-node)
                       (insert-stretched-line line :add-newline t)
                   (insert-rest-line line "%s%s %s\n"))
                 (goto-char (1- (annotate-beginning-of-line-pos)))
                 (goto-char (annotate-beginning-of-line-pos))
                 (promote-to-button annotate-thread-reply-button-label
                                    'annotate-thread-reply-button-pressed
                                    'annotate-thread-reply-node-button
                                    node)
                 (when inner-node
                   (goto-char (annotate-beginning-of-line-pos)) ; go to "delete" button
                   (promote-to-button annotate-thread-delete-button-label
                                      'annotate-thread-delete-button-pressed
                                      'annotate-thread-delete-node-button
                                        node))
                 (goto-char (point-max)))
                ((= count
                     (- (length rest-lines)
                         1))
                 (if children
                     (insert-empty-line line inner-node)
                   (insert-rest-line line "%s%s%s")))
                (t
                 (if children
                     (insert-stretched-line line :add-newline t)
                   (insert-rest-line line "%s%s %s\n"))))))))

(defun annotate-thread-delete-button-pressed (button)
  "Callback called when a delete button in the thread window is activated."
  (let* ((annotation (button-get button 'annotation-bound))
         (annotations-db (annotate-load-annotation-data))
         (thread-root (annotate-annotation-find-root annotations-db annotation))
         (new-db      (annotate-remove-annotation-thread annotations-db annotation)))
    (annotate-dump-annotation-data new-db) ; save the new database with thread removed
    (annotate--show-annotation-thread thread-root :save-annotations t)))

(defun annotate-thread-reply-button-pressed (button)
  "Callback called when a reply button in the thread window is activated."
  (let* ((annotation (button-get button 'annotation-bound))
         (reply-author (read-from-minibuffer "Author: "
                                             (user-login-name)))
         (reply-body   (read-from-minibuffer annotate-annotation-prompt))
         (reply-serialized (annotate--make-reply-to annotation
                                                    reply-author
                                                    reply-body)))
    (let* ((annotations-db (annotate-load-annotation-data))
           (thread-root (annotate-annotation-find-root annotations-db annotation))
           (new-db      (annotate--attach-annotation-to-dump annotations-db
                                                             reply-serialized)))
      (annotate-dump-annotation-data new-db)
      (annotate--show-annotation-thread thread-root :save-annotations t))))

(cl-defun annotate-print-tree (node
                               get-children-fn
                               get-data-fn
                               leaf-p-fn
                               root-p-fn
                               print-data-fn
                               &key
                               (last-child nil)
                               (indent ""))
  "Print a thread"
  (let ((data (funcall get-data-fn node))
        (children (funcall get-children-fn node)))
    (cond
     ((annotate-annotation-root-p node)
      (funcall print-data-fn
               node
               data
               "%s"
               ""
               last-child
               get-children-fn))
     (last-child
      (funcall print-data-fn
               node
               data
               (concat "%s" annotate-thread-leaf-string)
               indent
               last-child
               get-children-fn))
     (t
      (funcall print-data-fn
               node
               data
               (concat "%s" annotate-thread-branch-string)
               indent
               last-child
               get-children-fn)))
    (cond
     ((or (null children)
          last-child)
      (setf indent (concat indent "  ")))
     ((not (annotate-annotation-root-p node))
      (setf indent (concat indent
                           annotate-thread-trunk-string
                           " "))))
    (cl-loop for child in children
             for count-children from 0
             do (annotate-print-tree child
                                     get-children-fn
                                     get-data-fn
                                     leaf-p-fn
                                     root-p-fn
                                     print-data-fn
                                     :indent indent
                                     :last-child (= count-children
                                                    (1- (length children)))))))

(cl-defmacro annotate-with-annotations-window ((buffer-name) &body body)
"Open a window in readonly mode."
`(with-current-buffer-window
     ,buffer-name nil nil
   (progn
     (read-only-mode 0)
     (display-buffer ,buffer-name)
     (select-window (get-buffer-window ,buffer-name t))
     (use-local-map nil)
     (local-set-key "q"
                    (lambda ()
                      (interactive)
                      (kill-buffer ,buffer-name)))
     ,@body
     (read-only-mode 1))))

(cl-defgeneric annotate--show-annotation-thread (object &key save-annotations)
"Show a buffer with the annotation thread that has OBJECT as root node.")

(defun annotate--make-tree-font-matcher-function (search-for)
  (lambda (limit)
    (re-search-forward search-for limit t)))

(defun annotate--add-reply-button-matcher (limit)
  (funcall (annotate--make-tree-font-matcher-function annotate-thread-reply-button-label)
           limit))

(defun annotate--delete-node-button-matcher (limit)
  (funcall (annotate--make-tree-font-matcher-function annotate-thread-delete-button-label)
           limit))

(cl-defmethod annotate--show-annotation-thread ((object list) &key (save-annotations nil))
  "Show a buffer with the annotation thread that has OBJECT as root node."
  (cl-labels ((set-font-lock-mode ()
                (font-lock-add-keywords
                 nil
                 `((annotate--delete-node-button-matcher
                    (0 `(face ,annotate-thread-action-face) append))
                   (annotate--add-reply-button-matcher
                    (0 `(face ,annotate-thread-action-face) append))
                   ("from:\\(.+$\\)" (1 `(face ,annotate-thread-author-face) append))
                   ("\\(from:\\)\\(.+$\\)" (1 `(face ,annotate-thread-tree-arrow-face) append))
                   ("\\(┃\\|┏\\|┗\\).*" (0  `(face ,annotate-thread-header-face) append))
                   ("↑" (0 `(face ,annotate-thread-action-face) append))
                   ("▶" (0 `(face ,annotate-thread-tree-arrow-face) append))
                   ("├\\|│\\|╰\\|┆" (0 `(face ,annotate-thread-tree-face) append))))))
    (when save-annotations
      (annotate-save-all-annotated-buffers))
    (let ((annotations-db (annotate-load-annotation-data t)))
      (if (annotate--db-empty-p annotations-db)
          (when annotate-use-messages
            (message "The annotation database is empty"))
        (annotate-with-annotations-window (annotate-thread-buffer-name)
           (set-font-lock-mode)
           (let ((annotated-text (annotate-annotated-text object))
                 (children-fn    (annotate-get-tree-children-clsr annotations-db)))
             (insert "┏\n")
             (cl-loop for line in (annotate--split-lines annotated-text)
                      do (insert "┃" line "\n"))
             (insert "┗\n")
             (annotate-print-tree object
                                  children-fn
                                  #'annotate-get-tree-data
                                  (annotate-annotation-leaf-p-clsr annotations-db)
                                  #'annotate-annotation-root-p
                                  #'annotate--print-tree-data)
             (font-lock-ensure)))))))

(cl-defmethod annotate--show-annotation-thread ((object overlay) &key (save-annotations nil))
  "Show a buffer with the annotation thread that has OBJECT as root node."
  (when save-annotations
    (annotate-save-all-annotated-buffers))
  (let ((annotations-db (annotate-load-annotation-data t)))
    (if (annotate--db-empty-p annotations-db)
        (when annotate-use-messages
          (message "The annotation database is empty"))
      (when-let* ((annotation-serialized (annotate--find-annotation annotations-db
                                                                    object)))
        (annotate--show-annotation-thread annotation-serialized
                                          :save-annotations nil)))))

(defun annotate-show-thread-at-point ()
  "Show a buffer with the annotation thread for the annotation under point."
  (interactive)
  (when-let* ((chain      (annotate-chain-at (point)))
              (annotation (annotate--annotation-with-reply chain)))
    (annotate--show-annotation-thread annotation)))

;;; end of merging datatase

(provide 'annotate)
;;; annotate.el ends here
