-
Notifications
You must be signed in to change notification settings - Fork 3
/
standoff-mode.el
1099 lines (976 loc) · 45.2 KB
/
standoff-mode.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; standoff-mode.el --- Create stand-off markup, also called external markup
;; Copyright (C) 2015 Christian Lück
;; Author: Christian Lück <[email protected]>
;; Homepage: https://github.com/lueck/standoff-mode
;; Keywords: text, annotations, NER, humanities
;; This file is not part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with standoff-mode. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A major mode for creating and editing stand-off markup, also called
;; external markup. It is written for use in the field of digital
;; humanities and the manual annotation of training data for
;; named-entity recognition.
;; After switching a buffer's major mode to standoff-mode, it gets
;; read-only. We then call it the source document, which the external
;; markup refers to. There are commands for creating 1) markup
;; elements, 2) relations between such elements that take the form of
;; RDF-like directed graphs, 3) attributes of markup elements and 4)
;; writing free text comments anchored on these elements. Markup
;; elements refer to portions of the source document by character
;; offsets.
;; There are several pluggable backends for storing the
;; annotations. They can be stored in JSON format or as elisp
;; s-expressions. The API for backends is defined in
;; `standoff-api.el'.
;; Usage:
;; Add the following lines to your Emacs config:
;; (add-to-list 'load-path "/path/to/standoff-mode-directory")
;; (autoload 'standoff-mode "standoff-mode.el"
;; "Mode for creating and editing stand-off markup, aka external markup" t)
;; ;; auto-load standoff-mode for files ending with .TEI-P5.xml:
;; (add-to-list 'auto-mode-alist '("\\.TEI-P5.xml$" . standoff-mode))
;; You also have to choose a backend for storing the annotations. See
;; standoff-dummy.el or standoff-json-file.el for instructions.
;;; Code:
(require 'standoff-log)
(require 'standoff-api)
(require 'standoff-xml)
(require 'standoff-relations)
(defgroup standoff nil
"Customization options for stand-off mode.")
(defcustom standoff-backend nil
"Choose a back-end for storing annotations.
The JSON file back-end is recommended for starters. Type
\"standoff-json-file\" (without quotes) into the form, then apply
and save the new value. You need to restart Emacs (at least to
close the file, which was opened in stand-off mode) to get the
newly configured back-end activated.
If you already worked with stand-off mode and until now always
dumped your annotations to file with the suffix .dump.el, then
you will want the dummy back-end. In this case, type
\"standoff-dummy\" (without quotes) into the form, then apply and
save the new value.
Follow the \"Manual\" link below to get more information."
:group 'standoff
:tag "Back-End"
:link '(custom-manual "(standoff-en)Back-Ends")
:type 'symbol
:options '('standoff-json-file 'standoff-dummy))
(defcustom standoff-login-name nil
"Your login name.
When generating meta data on your annotations, the login name of
the current system user is used. To override this behaviour, set
this option. When working on a database back-end, you have to
set this to the database user."
:group 'standoff
:tag "Login Name"
:link '(custom-manual "(standoff-en)JSON rest back-end")
:type 'string)
;;;; Checksum of source document
(defvar standoff-source-md5 nil
"The md5 checksum of the source buffer.
Stand-off markup makes sense, only if the source document is
stable. Otherwise the references to it via character offsets get
broken.")
(make-variable-buffer-local 'standoff-source-md5)
(defun standoff-source-checksum ()
"Set the checksum of the source document if and only if not yet set.
This function makes an md5 hash and stores it to the
buffer-local variable `standoff-source-md5'. This function will
be called via a mode hook, so that the checksum is there right
away for running checks against it. It can be called
interactively, but will have no effect, if the hash was already
calculated. The hash will show up in the minibuffer."
(interactive)
(unless standoff-source-md5
(setq-local standoff-source-md5 (md5 (current-buffer))))
(standoff-log (message "The document's md5 checksum is: %s" standoff-source-md5))
(standoff-log t))
;; Run from mode command directly
;;(add-hook 'standoff-mode-hook 'standoff-source-checksum)
;;;; Creating and Deleting Markup
(defcustom standoff-markup-type-require-match 'confirm
"Defines how restrictive the markup schema is handled.
This has effect when adding new markup and choosing its type. If
set to `t' then the entered type must be amongst the members of
the list returned by calling the handler function given by
`standoff-markup-types-allowed-function'. If set to `nil', the
user may exit his input with any type. If set to
`confirm' (symbol), the user may exit with any type, but is asked
to confirm his input. Cf. `completing-read'."
:group 'standoff)
(defcustom standoff-markup-types-allowed-function 'standoff-markup-types-from-elisp
"Points to the function called for a list of allowed markup types.
This variable must be set to the function's symbol (name)."
:group 'standoff
:type 'function
:options '('standoff-markup-types-from-overlay-definition
'standoff-markup-types-from-elisp))
(defcustom standoff-markup-overlays '()
"The overlay definition. This should be defined by the user."
:group 'standoff)
(defun standoff-markup-types-from-overlay-definition ()
"Return the list of user defined markup elements.
This might serve as simple handler called using
`standoff-markup-types-allowed-function'. "
(mapcar 'car standoff-markup-overlays))
(defcustom standoff-markup-types-allowed '()
"A list of allowed markup types evaluated by `standoff-markup-types-from-elisp'."
:group 'standoff
:type 'list)
(defcustom standoff-markup-labels '()
"A alist mapping the (some) members of `standoff-markup-types-allowed' to labels."
:group 'standoff
:type 'list)
(defcustom standoff-show-labels nil
"Whether or not to show labels instead of markup types."
:group 'standoff
:type 'boolean)
(defun standoff--append-remove-duplicates (&rest sequences)
"Concatenate all SEQUENCES, remove duplicates and make the result a list.
Tested with lists."
(let ((return-list '())
(sequence))
(while sequences
(setq sequence (pop sequences))
(dolist (el sequence)
(unless (member el return-list)
(push el return-list))))
return-list))
(defun standoff-markup-types-from-elisp ()
"Return the list of allowed markup types.
This function just returns the global variable
`standoff-markup-types-allowed', which should be set in
configuration."
standoff-markup-types-allowed)
(defun standoff-labels-mappable-p (types types-labels-alist)
"Returns t only if none of labels is in types AND labels are
pairwise unequal."
(let ((mappable t)
(labels '()))
(dolist (mapping types-labels-alist)
(progn
(when (or (member (cdr mapping) labels) (member (cdr mapping) types))
(setq mappable nil))
(push (cdr mapping) labels)))
mappable))
(defun standoff-labels-for-types (types types-labels-alist)
"Return a list of labels for allowed markup types.
This function is like `standoff-markup-types-from-elisp', but
tries to hide the real type Ids with labels."
(let ((labels-or-types '())
(label))
(dolist (typ types)
(setq label (cdr (assoc typ types-labels-alist)))
(if (and label (not (member label labels-or-types)))
(push label labels-or-types)
(push typ labels-or-types)))
labels-or-types))
(defun standoff-type-from-label-or-type (label-or-type types-labels-alist)
"Return the markup type for the given LABEL-OR-TYPE appling the map given by TYPES-LABELS-ALIST.
LABEL-OR-TYPE is returned, if no label is found."
(let ((mapping (rassoc label-or-type types-labels-alist)))
(if mapping
(car mapping)
label-or-type)))
(defun standoff-markup-type-from-user-input (buf &optional prompt require-match)
"Prompt the user for a markup type."
(let* (;; 1. make completion list
(types-def (funcall standoff-markup-types-allowed-function))
(types-used (if (equal standoff-markup-type-require-match t)
'()
(funcall standoff-markup-types-used-function buf)))
;; add used types to defined types, remove duplicates
(types (standoff--append-remove-duplicates types-def types-used))
;; depending on custom var and mappability replace with labels
(mappable (and standoff-show-labels
(standoff-labels-mappable-p types standoff-markup-labels)))
(labels (if mappable
(standoff-labels-for-types types standoff-markup-labels)
types))
;; sort label or types
(sorted-labels (sort labels 'string-lessp))
;; 2. get user input
(type (completing-read (or prompt "Markup type: ")
sorted-labels
nil
require-match)))
;; 3. get type if replaced with labels
(if mappable
(standoff-type-from-label-or-type type standoff-markup-labels)
type)))
(defcustom standoff-markup-post-functions nil
"A hook for handlers called when markup was successfully stored to some backend.
This hook can be used for notifications or to set some state. It
is a so called abnormal hook, cf. Info node `(emacs) Hooks',
because the hooked functions (aka handlers) must take the
following arguments:
BUFFER STARTCHAR ENDCHAR MARKUP-NAME MARKUP-INST-ID
"
:group 'standoff
:type 'hook
:options '('standoff-markup-notify))
(defun standoff-markup-region (beg end markup-type)
"Create markup for the selected region.
The region is given by BEG and END, the type of the markup is
given by MARKUP-TYPE. The id is automatically assigned by the
backend, e.g. by automatic incrementation of an integer."
(interactive
(list (region-beginning)
(region-end)
(standoff-markup-type-from-user-input
(current-buffer)
"Markup type: "
standoff-markup-type-require-match)))
(standoff-log "Creating markup element from %i to %i as %s ...\n"
beg end markup-type)
(let ((markup-id nil))
(save-restriction
(widen)
(save-excursion
(setq markup-id (funcall standoff-markup-create-function
(current-buffer) beg end markup-type))
(when markup-id
;; highlight the new markup
(standoff-highlight-markup-range (current-buffer) beg end markup-type markup-id)
;; run post processing hooks
(run-hook-with-args 'standoff-markup-post-functions
(current-buffer) beg end markup-type markup-id))))
(standoff-log t)
(deactivate-mark)))
(defun standoff-markup-region-continue (beg end markup-number)
"Add selected region as a new range continueing an existing markup element.
The markup element is identified by MARKUP-ID. The range is given
by BEG and END or point and mark, aka the region. This function
enables the user to create discontinues markup."
(interactive "r\nNIdentifying number of markup element to be continued: ")
(let* ((markup-id (or (standoff-markup-get-by-number (current-buffer) markup-number)
(error "No markup element with number %i found" markup-number)))
(markup-type (nth standoff-pos-markup-type (car (funcall standoff-markup-read-function (current-buffer) nil nil nil markup-id))))
(duplicate (funcall standoff-markup-read-function (current-buffer) beg end markup-type markup-id))
(markup-id-from-backend nil))
(if duplicate
(error "Overlapping markup with the same id and element name! Not creating a duplicate")
(standoff-log "Adding range to markup element %s spanning from %i to %i...\n"
markup-id beg end)
(save-restriction
(widen)
(save-excursion
(setq markup-id-from-backend (funcall standoff-markup-range-add-function (current-buffer) beg end markup-id))
;;(message "Hi: %s" markup-id-from-backend)
(when markup-id-from-backend
;; highlight the new markup
(standoff-highlight-markup-range (current-buffer) beg end markup-type markup-id-from-backend)
;; run post processing hooks
(run-hook-with-args 'standoff-markup-post-functions (current-buffer) beg end markup-type markup-id-from-backend))))
(standoff-log t)
(deactivate-mark))))
(defun standoff-markup-delete-range-at-point (point)
"Delete the range of a markup element at point.
The range is identified by the overlay's properties. So this
works only if there is one and exactly one overlay."
;; TODO: Collect information about related items when
;; asking "Do you really ...? (yes or no)"
(interactive "d")
(save-restriction
(widen)
(overlay-recenter (point))
(let* ((ovly (standoff-highlight-markup--select point))
(startchar (overlay-start ovly))
(endchar (overlay-end ovly))
(markup-type (standoff--overlay-property-get ovly "type"))
(markup-number (string-to-number (standoff--overlay-property-get ovly "number")))
(markup-inst-id (standoff-markup-get-by-number (current-buffer) markup-number))
(markup-ranges (funcall standoff-markup-read-function (current-buffer) nil nil nil markup-inst-id))
(precondition)
(deleted nil)
(last-range nil))
;; (message "%s" (length markup-ranges))
(if (> (length markup-ranges) 1)
(setq precondition (y-or-n-p (format "Do you really want to delete this range of '%s' %s? " markup-type markup-inst-id)))
(setq precondition (yes-or-no-p (format "Do you really want to delete markup element %s, which is a '%s', and all it's related items? " markup-inst-id markup-type))
last-range t))
(when precondition
(setq deleted (funcall standoff-markup-delete-range-function (current-buffer) startchar endchar markup-type markup-inst-id))
(when deleted
(when last-range
(standoff-markup-remove-number-mapping (current-buffer) markup-inst-id))
(delete-overlay ovly)
(standoff-log "Deleted markup range from %i to %i as %s with id %s.\n"
startchar endchar markup-type markup-inst-id)
(standoff-log t)
(message "... deleted."))))))
;;;; Highlighning and Hiding Markup
;; We use overlays to highlight markup elements
(defcustom standoff-markup-overlays nil
"This should be a alist defined by the user."
:group 'standoff
:type 'alist)
(defcustom standoff-markup-overlays-front nil
"This should be a alist defined by the user."
:group 'standoff
:type 'alist)
(defcustom standoff-markup-overlays-after nil
"This should be a alist defined by the user."
:group 'standoff
:type 'alist)
(defcustom standoff-markup-overlays-default
'(('face (:background "light grey")))
"Overlay properties for markup elements not defined in
`standoff-markup-overlays'."
:group 'standoff
:type 'alist)
(defcustom standoff-markup-overlays-front-default
'(('face (:background "light grey" :foreground "dark grey")))
"Text properties of the front string of markup
oferlays. This is used for markup elements not defined in
`standoff-markup-overlays-after'."
:group 'standoff
:type 'alist)
(defcustom standoff-markup-overlays-after-default
'(('face (:background "light grey" :foreground "dark grey")))
"Text properties of the after string which trails markup
overlays. This is used for markup elements not defined in
`standoff-markup-overlays-after'."
:group 'standoff
:type 'alist)
(defvar standoff--overlay-property-obarray nil
"An obarray for symbols used to store overlay properties.")
(defun standoff--overlay-property-obarray-init ()
"When we store the parameters of markup elements as key value
pairs of overlay properties, they are interned to a special
obarray in order to avoid namespace collisions. We also make this
special obarray buffer local."
;;TODO
(setq-local standoff--overlay-property-obarray nil))
;; Run from mode command directly
;;(add-hook 'standoff-mode-hook 'standoff--overlay-property-obarray-init)
(defvar standoff--overlay-property-value-format
"standoff-markup-element-property-symbol-%s-%s")
(defun standoff--overlay-property-format-key (key)
"Overlay properties are key value pairs where key and value are
symbols. This function returns the key as an interned
symbol. Interference with symbol names of other emacs packages
prevented if you use this function."
(intern (format "%s" key)))
(defun standoff--overlay-property-format-value (key value &optional setting)
"Overlay properties are key value pairs where key and value are
symbols. This function returns the value as an interned symbol
whichs name is made from the key and the value. Interference with
symbol names of other emacs packages prevented if you use this
function."
(let ((value-formatted (format standoff--overlay-property-value-format key value)))
(if setting
(intern value-formatted)
(intern-soft value-formatted))))
(defun standoff--overlay-property-set (ovly key value)
"A convience function to set the property of the overlay OVLY
given as KEY and VALUE."
(overlay-put ovly
(standoff--overlay-property-format-key key)
(standoff--overlay-property-format-value key value t)))
(defun standoff--overlay-property-get (ovly key)
"A convience function to get the property of an overlay.
The value of property KEY of the overlay OVLY is returned as a
string."
(let ((value-front-length (length (format standoff--overlay-property-value-format key "")))
(value-symbol (overlay-get ovly (standoff--overlay-property-format-key key))))
(if (not (and value-symbol (intern-soft value-symbol)))
nil
;; we use (format "%s" ...) to make a string from the symbol
(substring (format "%s" value-symbol) value-front-length))))
(defun standoff--normalize-markup-inst-id (id)
"Cast ID of markup instance to the format returned by `standoff--overlay-property-get'.
This is used in `standoff-highlight-markup-range' to check if a
similar overlay is already
present. `standoff--overlay-property-get' returns strings, after
`standoff--overlay-property-set' used (`format' \"...%s\"
... value) to gerate the value. So using `format' here is quite
save. But depending on the the format of the IDs for markup
instances this functions might need to be rewritten."
(format "%s" id))
(defvar standoff-markup-number-mapping)
(make-variable-buffer-local 'standoff-markup-number-mapping)
(defun standoff-markup-number-mapping-setup ()
"Make a new hashtable for mapping markup instance ids to numbers."
(setq-local standoff-markup-number-mapping (make-hash-table :test 'equal)))
;; Run from mode command directly
;;(add-hook 'standoff-mode-hook 'standoff-markup-number-mapping-setup)
(defun standoff-markup-get-number (buf markup-inst-id)
"Return the number associated to a markup instance.
This returns an integer for the markup instance given by
MARKUP-INST-ID in the buffer BUF. If there is not yet a number
assiciated with this instance, a new unique number is created."
(with-current-buffer buf
(let ((number (gethash markup-inst-id standoff-markup-number-mapping nil))
(numbers '()))
(if number
number
(maphash (lambda (k _v) (push _v numbers)) standoff-markup-number-mapping)
(puthash markup-inst-id
;; max fails for an empty list, so we cons 0
(setq number (+ (apply 'max (cons 0 numbers)) 1))
standoff-markup-number-mapping)
number))))
(defun standoff-markup-get-by-number (buf number)
"Return the markup instance ID for a number.
If no ID maps to number, nil is returned."
(with-current-buffer buf
(let ((markup-inst-id nil))
(maphash (lambda (k _v) (when (equal _v number) (setq markup-inst-id k)))
standoff-markup-number-mapping)
markup-inst-id)))
(defun standoff-markup-remove-number-mapping (buf markup-inst-id)
"Remove a markup-inst-id to number mapping from the hashtable.
This should be called when all ranges of a markup instance have
been deleted."
(with-current-buffer buf
(remhash markup-inst-id standoff-markup-number-mapping)))
(defun standoff-highlight-markup-range (buf startchar endchar markup-type markup-inst-id)
"Highlight a markup range.
This is the workhorse for highlightning markup in standoff
mode. It highlights a range of text given by STARTCHAR and
ENDCHAR in the context of buffer BUF. The range is highlighted
as MARKUP-TYPE and is assigned MARKUP-INST-ID. A number is also
assigned to it for easy access by the user. This number is not
stable over working sessions, but assigned on a per session
basis. The highlightning is done by creating overlays. This
overlay is assigned the key value `\"standoff\" t'."
(save-restriction
(widen)
(let ((ovlys (overlays-at startchar))
(ovly)
(ovly-present nil))
;; don't create the overlay if there is already a similar one
(while ovlys
(setq ovly (pop ovlys))
;; when COND
(and (equal (standoff--overlay-property-get ovly "id") (standoff--normalize-markup-inst-id markup-inst-id))
(equal (overlay-start ovly) startchar)
(equal (overlay-end ovly) endchar)
(equal (standoff--overlay-property-get ovly "type") (format "%s" markup-type))
(equal (standoff--overlay-property-get ovly "standoff") (symbol-name t))
;; BODY (of when)
(setq ovly-present t
ovlys nil)))
(unless ovly-present
;; create the overlay
(setq ovly (make-overlay startchar endchar buf))
(let* ((ovly-props (or (cdr (assoc markup-type standoff-markup-overlays))
standoff-markup-overlays-default))
(front-props (or (cdr (assoc markup-type standoff-markup-overlays-front))
standoff-markup-overlays-front-default))
(after-props (or (cdr (assoc markup-type standoff-markup-overlays-after))
standoff-markup-overlays-after-default))
(number (standoff-markup-get-number buf markup-inst-id))
(front-str (format "[%i" number))
(after-str (format "%i]" number))
(hlp-type (or (and standoff-show-labels
(cdr (assoc markup-type standoff-markup-labels)))
markup-type))
(hlp-echo (format "Type: %s\nNo: %i\nID:%s" hlp-type number markup-inst-id))
(front-string (car (mapcar #'(lambda (x) (propertize front-str (car(cdar x)) (cadr x))) front-props)))
(after-string (car (mapcar #'(lambda (x) (propertize after-str (car(cdar x)) (cadr x))) after-props))))
;;(mapcar #'(lambda (x) (overlay-put ovly (car (cdar x)) (cadr x))) ovly-props)
(dolist (prop ovly-props)
(overlay-put ovly (car (cdar prop)) (cadr prop)))
(overlay-put ovly 'help-echo hlp-echo)
(overlay-put ovly 'before-string front-string)
(overlay-put ovly 'after-string after-string)
(standoff--overlay-property-set ovly "standoff" t)
(standoff--overlay-property-set ovly "type" markup-type)
(standoff--overlay-property-set ovly "id" markup-inst-id)
(standoff--overlay-property-set ovly "number" number)
;;(overlay-put ovly 'local-map standoff-markup-range-local-map)
)))))
(defun standoff-hide-markup (&optional area-start area-end markup-type markup-number)
"Hide markup. A general function with a filter.
This function is the workhorse of hiding markup and is being
reused by more specific interactive functions for hiding markup."
(let ((startchar (or area-start (point-min)))
(endchar (or area-end (point-max)))
(ovlys-present)
(ovlys-found '())
(ovly)
(markup-number-string (format "%s" markup-number)))
(overlay-recenter (/ (+ startchar endchar) 2))
(setq ovlys-present (overlays-in startchar endchar))
(while ovlys-present
(setq ovly (pop ovlys-present))
;; when COND
(and (equal (standoff--overlay-property-get ovly "standoff") (symbol-name t))
(or (not markup-type)
(equal (standoff--overlay-property-get ovly "type") markup-type))
(or (not markup-number)
(equal (standoff--overlay-property-get ovly "number") markup-number-string))
;; BODY
(delete-overlay ovly)))))
(defun standoff-hide-markup-buffer (&optional markup-type)
"Hide markup in the current buffer, i.e. remove all overlays."
(interactive
(list (standoff-markup-type-from-user-input
(current-buffer)
"Markup type to hide, <!> for all: "
nil)))
(save-excursion
(if (or (not markup-type) (equal markup-type "!"))
(standoff-hide-markup)
(standoff-hide-markup nil nil markup-type))))
(defun standoff-hide-markup-region (area-start area-end &optional markup-type)
"Hide markup in the region, optionally filtered by type."
(interactive
(list (region-beginning)
(region-end)
(standoff-markup-type-from-user-input
(current-buffer)
"Markup type to hide, <!> for all: "
nil)))
(save-excursion
(let ((markup-type-or-nil (if (equal markup-type "!") nil markup-type)))
(standoff-hide-markup area-start area-end markup-type-or-nil))))
(defun standoff-hide-markup-at-point ()
"Hide markup at point."
(interactive)
(save-excursion
(standoff-hide-markup (point) (point))))
(defun standoff-hide-markup-by-number (markup-number)
"Hide all markup with number MARKUP-NUMBER."
(interactive "NNumber of markup element to hide: ")
(save-excursion
(standoff-hide-markup nil nil nil markup-number)))
(defun standoff--markup-offset-integer (offset)
"Do a type cast for an offset value from the backend if neccessary.
Offset values have to be integer. Some backends may store them as
strings. So we use this function to assert that we have
integers. Takes OFFSET as argument."
(cond ((numberp offset) offset)
((stringp offset) (string-to-number offset));; TODO: better regexp?
(t (error "Can not convert offset value to integer: %s" offset))))
(defun standoff-highlight-markup (&optional beg end markup-type markup-inst-id)
"Apply a filter to the markup from the backend and highlight it.
This function can be reused by other more specific interactive
functions for highlightning markup in the current buffer. It
calls `standoff-highlight-markup-range' to actually highlight a
markup element or range."
(let ((markup-elements (funcall standoff-markup-read-function (current-buffer) beg end markup-type markup-inst-id)))
;; build a list from the markup returned by the backend and apply
;; it to standoff-highlight-markup-range
(dolist (range markup-elements)
(apply 'standoff-highlight-markup-range
(list (current-buffer)
(standoff--markup-offset-integer (nth standoff-pos-startchar range))
(standoff--markup-offset-integer (nth standoff-pos-endchar range))
(nth standoff-pos-markup-type range)
(nth standoff-pos-markup-inst-id range))))))
(defun standoff-highlight-markup-region (beg end &optional markup-type)
"Create overlays for all markup in the backend."
(interactive
(list
(region-beginning)
(region-end)
(standoff-markup-type-from-user-input
(current-buffer)
"Type of markup to show up, <!> for all: "
nil)))
(let ((markup-type-or-nil (if (equal markup-type "!") nil markup-type)))
(standoff-highlight-markup beg end markup-type-or-nil)))
(defun standoff-highlight-markup-buffer (&optional markup-type)
"Highlight markup in the backend optionally filtered by MARKUP-TYPE."
(interactive
(list
(standoff-markup-type-from-user-input
(current-buffer)
"Markup type to show up, <!> for all: "
nil)))
(let ((markup-type-or-nil (if (equal markup-type "!") nil markup-type)))
(standoff-highlight-markup nil nil markup-type-or-nil)))
(defun standoff-highlight-markup-by-number (number)
"Highlight the markup element which's id is mapping to NUMBER."
(interactive "NNumber of markup element to highlight: ")
(let ((markup-inst-id (standoff-markup-get-by-number (current-buffer) number)))
(unless markup-inst-id
(error "No markup element mapping to number %s" number))
(standoff-highlight-markup nil nil nil markup-inst-id)))
;; Selection of highlighted markup
(defun standoff-highlight-markup--select (point &optional non-message ambiguous-message)
"Returns the *overlay* for the markup range at POINT.
The function will throw an error with AMBIGUOUS-MESSAGE, if
there's more than one highlighted standoff markup range at POINT,
because the selection is ambiguous then. It will thow an error
with NON-MESSAGE, if there's no highlighted markup at POINT."
(let ((ovlys '()))
(dolist (ovly (overlays-at point))
(when (equal (standoff--overlay-property-get ovly "standoff")
(symbol-name t))
(push ovly ovlys)))
(unless (car ovlys)
(error (or non-message "No highlighted markup element found")))
(when (cdr ovlys)
(error (or ambiguous-message "More than one highlighted markup element found. Please use the functions for hiding markup to make your selection non-ambiguous")))
(car ovlys)))
;;;; Navigate
(defun standoff-navigate-next ()
(interactive)
(overlay-recenter (point))
(let ((pos (next-overlay-change (point))))
(if (equal pos (point-max))
(error "Last highlighted markup element in buffer")
(goto-char pos))))
(defun standoff-navigate-previous ()
(interactive)
(overlay-recenter (point))
(let ((pos (previous-overlay-change (point))))
(if (equal pos (point-min))
(error "First highlighted markup element in buffer")
(goto-char pos))))
;;;; Relations
(defcustom standoff-predicate-require-match 'confirm
"Defines how restrictive relation types are handled.
`t' for no other names than already know names, `confirm' to
allow other than already known names, but ask for confirmation."
:group 'standoff
:type 'symbol)
(defcustom standoff-predicates-allowed-function 'standoff-predicates-allowed-from-elisp
"A pointer to the function that returns allowed predicates for a combination of subject and object.
The function must take 3 arguments: The buffer BUF of the source
document, the subject's id, the object's id."
:group 'standoff
:type 'function)
(defcustom standoff-relations-allowed '()
"A list of allowed Combinations of subject, predicate object types."
:group 'standoff
:type 'list)
(defcustom standoff-predicate-labels '()
"Alist of predicate labels."
:group 'standoff
:type 'list)
(defun standoff-predicates-allowed-from-elisp (buf subj-id obj-id)
"Filter predicates from `standoff-predicates-allowed' for combination of subject and object.
Subject and object must be given by ids, SUBJ-ID and OBJ-ID
respectively. The source document must be given in buffer BUF."
;; TODO: use pos api for (nth ...)
(let ((subj-type (nth standoff-pos-markup-type (car (funcall standoff-markup-read-function buf nil nil nil subj-id))))
(obj-type (nth standoff-pos-markup-type (car (funcall standoff-markup-read-function buf nil nil nil obj-id))))
(relations-defined (or standoff-relations-allowed '()))
(rel)
(allowed '()))
;;(message "Type: sub: %s obj: %s" subj-type obj-type)
(while relations-defined
(setq rel (pop relations-defined))
;; when COND: empty subj/obj list allows any type of subj/obj OR
;; sub/obj-type member of sub/obj list
(and (or (null (nth 0 rel)) (member subj-type (nth 0 rel)))
(or (null (nth 2 rel)) (member obj-type (nth 2 rel)))
;; BODY
(setq allowed (cons (nth 1 rel) allowed))))
allowed))
(defun standoff-predicate-from-user-input (buf subj-id obj-id &optional prompt)
"Prompt the user for a predicate."
(let* (;; 1. make completion list
(predicates-def (funcall standoff-predicates-allowed-function buf subj-id obj-id))
(predicates-used (if (equal standoff-predicate-require-match t)
'()
(funcall standoff-predicates-used-function buf subj-id obj-id)))
;; add used predicates to predicates, but without duplicates
(predicates (standoff--append-remove-duplicates predicates-def predicates-used))
;; depending on custom var and mappability do mapping
(mappable (and standoff-show-labels
(standoff-labels-mappable-p predicates standoff-predicate-labels)))
(labels (if mappable
(standoff-labels-for-types predicates standoff-predicate-labels)
predicates))
;; sort and return predicates
(sorted-labels (sort labels 'string-lessp))
;; 2. get user input
(predicate (completing-read (or prompt "Predicate: ")
sorted-labels
nil
standoff-predicate-require-match)))
;; 3. get
(if mappable
(standoff-type-from-label-or-type predicate standoff-predicate-labels)
predicate)))
(defun standoff-markup-relate (subject-id predicate object-id)
"Create a directed graph modelling a relation between two markup elements.
This establishes a rdf-like relation between markup element as
subject given by SUBJECT-ID and a markup element as object given
by OBJECT-ID. The relation is of type PREDICATE, so the graph has
the form \"subject predicate object\". When called interactively,
the markup element at point serves as subject, the object must be
given by the number mapping to its id."
(interactive
(let* ((subj-ovly (standoff-highlight-markup--select (point)))
(subj-number (string-to-number (standoff--overlay-property-get subj-ovly "number")))
(subj-id (standoff-markup-get-by-number (current-buffer) subj-number))
(obj-number (read-number (format "The subject was identified by the point, its number is %i.\nPlease enter the number of the relation's object: " subj-number)))
(obj-is-not-subj (or (not (= subj-number obj-number))
(error "The relation's object must not be the relation's subject")))
(obj-id (or (standoff-markup-get-by-number (current-buffer) obj-number)
(error "Invalid markup number")))
(predicate (standoff-predicate-from-user-input (current-buffer) subj-id obj-id)))
(list subj-id predicate obj-id)))
(standoff-log "Creating relation %s %s %s ...\n" subject-id predicate object-id)
(if (funcall standoff-relation-create-function (current-buffer) subject-id predicate object-id)
(run-hook-with-args 'standoff-markup-changed (current-buffer))
(error "Creation of relation failed"))
(standoff-log t))
;;;; Literals
(defcustom standoff-literal-key-require-match 'confirm
"Defines how restrictive keys for attributes with literal values are handled.
`t' for no other names than already know names, `confirm' to
allow other than already known names, but ask for confirmation."
:group 'standoff
:type 'symbol)
(defcustom standoff-literal-keys-allowed-function 'standoff-literal-keys-allowed-from-elisp
"A pointer to the function that returns allowed keys for attributes with literal values.
The function must take 2 arguments: The buffer of the source
document and the subject's id. The allowed keys are calculated
from the type of subject."
:group 'standoff
:type 'function)
(defcustom standoff-literal-keys-allowed '()
"Allowed combinations of markup types and keys for attributes with literal values."
:group 'standoff
:type 'list)
(defcustom standoff-literal-key-labels '()
"Alist of labels for keys in attributes with literal values."
:group 'standoff
:type 'list)
(defun standoff-literal-keys-allowed-from-elisp (buf subj-id)
"Returns keys for attributes with literal values for a the type of markup.
It filters the list `standoff-literal-keys-allowed' for markup
type given by SUBJ-ID. The source document must be given in
buffer BUF."
;; TODO: use pos api for (nth ...)
(let ((subj-type (nth standoff-pos-markup-type (car (funcall standoff-markup-read-function buf nil nil nil subj-id))))
(keys-defined (or standoff-literal-keys-allowed '()))
(key)
(allowed '()))
;;(message "Type of sub: %s" subj-type)
(while keys-defined
(setq key (pop keys-defined))
;; when COND: empty subj list allows any type of subj OR
;; sub-type member of sub list
(when (or (null (nth 0 key)) (member subj-type (nth 0 key)))
(setq allowed (cons (nth 1 key) allowed))))
allowed))
(defun standoff-literal-key-from-user-input (buf subj-id &optional prompt)
"Prompt the user for the key of an attribute with literal value."
(let* (;; 1. make completion list
(literal-keys-def (funcall standoff-literal-keys-allowed-function buf subj-id))
(literal-keys-used (if (equal standoff-literal-key-require-match t)
'()
(funcall standoff-literal-keys-used-function buf subj-id)))
;; add used literal-keys to literal-keys, but without duplicates
(literal-keys (standoff--append-remove-duplicates literal-keys-def literal-keys-used))
;; depending on custom var and mappability do mapping
(mappable (and standoff-show-labels
(standoff-labels-mappable-p literal-keys standoff-literal-key-labels)))
(labels (if mappable
(standoff-labels-for-types literal-keys standoff-literal-key-labels)
literal-keys))
;; sort and return literal-keys
(sorted-labels (sort labels 'string-lessp))
;; 2. get user input
(literal-key (completing-read (or prompt "Key: ")
sorted-labels
nil
standoff-literal-key-require-match)))
;; 3. get
(if mappable
(standoff-type-from-label-or-type literal-key standoff-literal-key-labels)
literal-key)))
(defun standoff-literal-value-attribute (markup-inst-id key val &optional typ other-type)
"Create an attribute with literal value for a markup element.
In fact this establishes a rdf-like statement on a subject given
by MARKUP-INST-ID with an data property given by KEY and a value
VAL, the literal. When called interactively, the markup element
at point serves as subject."
(interactive
(let* ((markup-ovly (standoff-highlight-markup--select (point)))
(markup-number (string-to-number (standoff--overlay-property-get markup-ovly "number")))
(markup-inst-id (standoff-markup-get-by-number (current-buffer) markup-number))
(key (standoff-literal-key-from-user-input (current-buffer) markup-inst-id))
(val (read-string "Value: ")))
(list markup-inst-id key val)))
(let ((val-type (or typ (type-of val))))
(standoff-log "Creating attribute with literal value: %s %s %s %s %s ...\n"
markup-inst-id key val val-type other-type)
(if (funcall standoff-literal-create-function
(current-buffer) markup-inst-id key val val-type other-type)
(run-hook-with-args 'standoff-markup-changed (current-buffer))
(error "Creation of attribute with literal value failed"))
(standoff-log t)))
;;;; Dumping
(defcustom standoff-dump-vars '(standoff-markup-read-function standoff-relations-read-function standoff-literals-read-function standoff-source-md5 standoff-api-description)
"A list of variables and function pointers to be dumped to elisp expressions.
The dumper function `standoff-dump-elisp' will dump variables and
even try to call the function given in a function pointer. Such
functions should take a buffer as argument and should not require
further arguments."
:group 'standoff
:type 'list
)
(defun standoff-dump-filename-default ()
"Returns a default dump file name."
(concat (buffer-file-name) ".dump.el" ))
(defun standoff-dump--print-quoted (to-buf var-name var-value)
"Dump variable VAR-NAME with value VAR-VALUE that is a list to buffer TO-BUF."
(print (list 'setq var-name (list 'quote var-value)) to-buf))
(defun standoff-dump--print (to-buf var-name var-value)
"Dump variable VAR-NAME with value VAR-VALUE to buffer TO-BUF."
(print (list 'setq var-name var-value) to-buf))
(defun standoff-dump-elisp (dump-file)
"Dump the stand-off markup in the current buffer to file DUMP-FILE."
(interactive
(list (read-file-name "File to be dumped to: "
nil
nil
'confirm
(file-relative-name (standoff-dump-filename-default)))))
(let ((source-buf (current-buffer))
(dump-buf (find-file-noselect dump-file)))
(with-current-buffer dump-buf
(erase-buffer))
;; make source buffer the current buffer, because the back-end
;; may be buffer-local like the dummy back-end
;; (set-buffer source-buf)
(dolist (var standoff-dump-vars)
(let ((dump-var-name (intern (format "%s-dumped" var))))
(if (symbolp (symbol-value var))
(cond ((functionp (symbol-value var))
(standoff-dump--print-quoted dump-buf dump-var-name (funcall (symbol-value var) source-buf)))
(t (message "Left type %s: symbol %s" var (type-of (symbol-value var)))))
(cond
((stringp (symbol-value var))
(standoff-dump--print dump-buf dump-var-name (symbol-value var)))
((consp (symbol-value var))
(standoff-dump--print-quoted dump-buf dump-var-name (symbol-value var)))
(t (message "Left type %s: variable %s" var (type-of (symbol-value var))))))))
(with-current-buffer dump-buf
(save-buffer))
(kill-buffer dump-buf)))
;;;; Displaying the Manual
(defcustom standoff-info-language "en"
"The language of the manual to show up with `standoff-display-manual'.
Defaults to the english (en) manual. There is also a german (de)
manual. `standoff-display-manual' is bound to ? in stand-off
mode. When set to nil, the system-message-locale and the
environment variable LANG are evaluated."
:group 'standoff
:type 'string
:options '("en" "de"))
(defun standoff-display-manual ()
"Display the manual for stand-off mode.
Depending on language and current mode an info page is opened."
(interactive)
(let ((lang (or standoff-info-language
system-messages-locale
(getenv "LANG"))))
(cond
((string-prefix-p "de" lang) ; german manual
(cond ((equal major-mode "*Relations*") (info "(standoff-de)Relationen anzeigen"))
(t (info "(standoff-de)"))))
(t ; other languages -> english manual
(cond ((equal major-mode "*Relations*") (info "(standoff-en)Relations"))
(t (info "(standoff-en)")))))))