\version "2.15.31"

\header {
  texidoc = "Use @code{define-event-class}, scheme engraver methods,
and grob creation methods to create a fully functional text spanner
in scheme."
}

#(define my-grob-descriptions '())

#(define my-event-classes (ly:make-context-mod))

defineEventClass =
#(define-void-function (parser location class parent)
   (symbol? symbol?)
   (ly:add-context-mod
    my-event-classes
    `(apply
      ,(lambda (context class parent)
	 (ly:context-set-property!
	  context
	  'EventClasses
	  (event-class-cons
	   class
	   parent
	   (ly:context-property context 'EventClasses '()))))
      ,class ,parent)))

\defineEventClass #'scheme-text-span-event #'span-event

#(define (add-grob-definition grob-name grob-entry)
   (let* ((meta-entry   (assoc-get 'meta grob-entry))
          (class        (assoc-get 'class meta-entry))
          (ifaces-entry (assoc-get 'interfaces meta-entry)))
     (set-object-property! grob-name 'translation-type? list?)
     (set-object-property! grob-name 'is-grob? #t)
     (set! ifaces-entry (append (case class
                                  ((Item) '(item-interface))
                                  ((Spanner) '(spanner-interface))
                                  ((Paper_column) '((item-interface
                                                     paper-column-interface)))
                                  ((System) '((system-interface
                                               spanner-interface)))
                                  (else '(unknown-interface)))
                                ifaces-entry))
     (set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))
     (set! ifaces-entry (cons 'grob-interface ifaces-entry))
     (set! meta-entry (assoc-set! meta-entry 'name grob-name))
     (set! meta-entry (assoc-set! meta-entry 'interfaces
                                  ifaces-entry))
     (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
     (set! my-grob-descriptions
           (cons (cons grob-name grob-entry)
                 my-grob-descriptions))))

#(add-grob-definition
  'SchemeTextSpanner
  `(
    (bound-details . ((left . ((Y . 0)
                               (padding . 0.25)
                               (attach-dir . ,LEFT)
                               ))
                      (left-broken . ((end-on-note . #t)))
                      (right . ((Y . 0)
                                (padding . 0.25)
                                ))
                      ))
    (dash-fraction . 0.2)
    (dash-period . 3.0)
    (direction . ,UP)
    (font-shape . italic)
    (left-bound-info . ,ly:line-spanner::calc-left-bound-info)
    (outside-staff-priority . 350)
    (right-bound-info . ,ly:line-spanner::calc-right-bound-info)
    (staff-padding . 0.8)
    (stencil . ,ly:line-spanner::print)
    (style . dashed-line)

    (meta . ((class . Spanner)
             (interfaces . (font-interface
                            line-interface
                            line-spanner-interface
                            side-position-interface))))))

#(define scheme-event-spanner-types
   '(
     (SchemeTextSpanEvent
      . ((description . "Used to signal where scheme text spanner brackets
start and stop.")
         (types . (general-music scheme-text-span-event span-event event))
         ))
     ))

#(set!
  scheme-event-spanner-types
  (map (lambda (x)
         (set-object-property! (car x)
                               'music-description
                               (cdr (assq 'description (cdr x))))
         (let ((lst (cdr x)))
           (set! lst (assoc-set! lst 'name (car x)))
           (set! lst (assq-remove! lst 'description))
           (hashq-set! music-name-to-property-table (car x) lst)
           (cons (car x) lst)))
       scheme-event-spanner-types))

#(set! music-descriptions
       (append scheme-event-spanner-types music-descriptions))

#(set! music-descriptions
       (sort music-descriptions alist<?))

#(define (add-bound-item spanner item)
   (if (null? (ly:spanner-bound spanner LEFT))
       (ly:spanner-set-bound! spanner LEFT item)
       (ly:spanner-set-bound! spanner RIGHT item)))

#(define (axis-offset-symbol axis)
   (if (eq? axis X) 'X-offset 'Y-offset))

#(define (set-axis! grob axis)
  (if (not (number? (ly:grob-property grob 'side-axis)))
      (begin
        (set! (ly:grob-property grob 'side-axis) axis)
        (ly:grob-chain-callback
         grob
         (if (eq? axis X)
             ly:side-position-interface::x-aligned-side
             ly:side-position-interface::y-aligned-side)
         (axis-offset-symbol axis)))))

schemeTextSpannerEngraver =
#(lambda (context)
   (let ((span '())
         (finished '())
         (current-event '())
         (event-drul '(() . ())))
     (make-engraver
      (listeners ((scheme-text-span-event engraver event)
		  (if (= START (ly:event-property event 'span-direction))
		      (set-car! event-drul event)
		      (set-cdr! event-drul event))))
      (acknowledgers ((note-column-interface engraver grob source-engraver)
		      (if (ly:spanner? span)
			  (begin
			    (ly:pointer-group-interface::add-grob span 'note-columns grob)
			    (add-bound-item span grob)))
		      (if (ly:spanner? finished)
			  (begin
			    (ly:pointer-group-interface::add-grob finished 'note-columns grob)
			    (add-bound-item finished grob)))))
      ((process-music trans)
       (if (ly:stream-event? (cdr event-drul))
	   (if (null? span)
	       (ly:warning "You're trying to end a scheme text spanner but you haven't started one.")
	       (begin (set! finished span)
		      (ly:engraver-announce-end-grob trans finished current-event)
		      (set! span '())
		      (set! current-event '())
		      (set-cdr! event-drul '()))))
       (if (ly:stream-event? (car event-drul))
	   (begin (set! current-event (car event-drul))
		  (set! span (ly:engraver-make-grob trans 'SchemeTextSpanner current-event))
		  (set-axis! span Y)
		  (set-car! event-drul '()))))
      ((stop-translation-timestep trans)
       (if (and (ly:spanner? span)
		(null? (ly:spanner-bound span LEFT)))
	   (set! (ly:spanner-bound span LEFT)
		 (ly:context-property context 'currentMusicalColumn)))
       (if (ly:spanner? finished)
	   (begin
	     (if (null? (ly:spanner-bound finished RIGHT))
		 (set! (ly:spanner-bound finished RIGHT)
		       (ly:context-property context 'currentMusicalColumn)))
	     (set! finished '())
	     (set! event-drul '(() . ())))))
      ((finalize trans)
       (if (ly:spanner? finished)
	   (begin
	     (if (null? (ly:spanner-bound finished RIGHT))
		 (set! (ly:spanner-bound finished RIGHT)
		       (ly:context-property context 'currentMusicalColumn)))
	     (set! finished '())))
       (if (ly:spanner? span)
	   (begin
	     (ly:warning "I think there's a dangling scheme text spanner :-(")
	     (ly:grob-suicide! span)
	     (set! span '())))))))

schemeTextSpannerStart =
#(make-span-event 'SchemeTextSpanEvent START)

schemeTextSpannerEnd =
#(make-span-event 'SchemeTextSpanEvent STOP)

\layout {
  \context {
    \Global
    \grobdescriptions #my-grob-descriptions
    #my-event-classes
  }
  \context {
    \Voice
    \consists \schemeTextSpannerEngraver
  }
}

m=\relative c' {
  a4 b \schemeTextSpannerStart c d |
  a4 b c \schemeTextSpannerEnd d |
}

\addQuote "m" \m
\new StaffGroup <<
  \new Staff \m
  \new Staff \relative c' {
    r4 \quoteDuring #"m" { s2. s1 }
  }
>>