emacs_el/lyqi-parser.el

   1 ;;      $RCSfile: lyqi-parser.el,v $
   2 ;;      $Revision: 1.5 $
   3 ;;      $Date: 2003/09/27 16:33:49 $
   4 ;;      $Author: nicolas $
   5 ;;;
   6 ;;; Part of lyqi, a major emacs mode derived from LilyPond-Mode,
   7 ;;; for quick note insertion while editing GNU LilyPond music scores.
   8 ;;;
   9 ;;; (c) copyright 2003 Nicolas Sceaux <nicolas.sceaux@free.fr>
  10 ;;; See http://nicolas.sceaux.free.fr/lilypond/
  11 ;;;
  12
  13 (eval-when-compile (require 'cl))
  14 (require 'eieio)
  15 (require 'lyqi-base)
  16
  17 ;;;;;; few string utilities ;;;;;;;;;;
  18
  19 ;; for XEmacs21 compatibility
  20 (if (not (fboundp 'match-string-no-properties))
  21     (defalias 'match-string-no-properties 'match-string))
  22
  23 (defun my-join (string-list joiner)
  24   "Returns a concatenation of all string-list elements, with joiner between elements"
  25   (apply 'concat
  26          (car string-list)
  27          (mapcar (lambda (str) (concat joiner str))
  28                  (cdr string-list))))
  29
  30 (defun my-sort-string-by-length (string-list)
  31   "Sort the given string list by decreasing string length."
  32   (nreverse
  33    (sort string-list
  34          (lambda (str1 str2)
  35            (or (< (length str1) (length str2))
  36                (and (= (length str1) (length str2))
  37                     (string< str1 str2)))))))
  38
  39 (defun my-char-to-restring (char)
  40   (concat (if (member char '(?. ?* ?+ ??)) "\\" "")
  41           (char-to-string char)))
  42
  43 ;;;;;; parser classes ;;;;;;;;;
  44
  45 (defclass base-parser ()
  46   ((regexp :initarg :regexp
  47            :documentation "A regular expression associated with the parser"))
  48   "base class for parsers")
  49
  50 (defmethod update-regexp ((parser base-parser))
  51            "(do nothing) Return the parser's regexp"
  52   (slot-value parser 'regexp))
  53
  54 (defclass syllab-parser (base-parser)
  55   nil
  56   "A syllab parser, ie a specialized word component parser.")
  57
  58 (defclass word-parser (base-parser)
  59   ((regexp-not-before :initarg :not-before
  60                       :initform nil
  61                       :documentation "A regexp describing what should not be found after the words
  62 that the parser recognize.")
  63    (regexp-not-after  :initarg :not-after
  64                       :initform nil
  65                       :documentation "A regexp describing what should not be found before the words
  66 that the parser recognize.")
  67    (syllab-parsers :initarg :syllab-parsers
  68                    :initform nil
  69                    :documentation "A list of (syllab-parser . facultative) pair, where `syllab-parser'
  70 is a syllab-parser object, and facultative says if the syylab if facultative in the word.")
  71    (word-class :initarg :word-class
  72                :type symbol
  73                :documentation "The class name of the recognized words."))
  74   "A word parser, which aims at building a given type of objects when parsing a recognized word.
  75 A word is composed of syllabs, and thus a word-parser is composed of syllab-parsers.")
  76
  77 (defmethod update-regexp ((parser word-parser))
  78            "Update the parser's regexp thanks to its syllabe-parsers regexps.
  79 Return the new regexp."
  80   (with-slots (syllab-parsers) parser
  81     (setf (slot-value parser 'regexp)
  82           (apply 'concat "\\b" (mapcar (lambda (sylparser)
  83                                          (format (if (cdr sylparser) "\\(%s\\)?" "%s")
  84                                                  (update-regexp (car sylparser))))
  85                                        syllab-parsers)))))
  86
  87 (defclass text-parser (base-parser)
  88   ((word-parsers :initarg :word-parsers
  89                  :initform nil
  90                  :documentation "List of word-parser objects used to parse a text. Order matters.")
  91    (class-unknown :initarg :class-unknown
  92                   :type symbol
  93                   :documentation "Class name used to store not recognized text.")
  94    (slot-unknown :initarg :slot-unknown
  95                  :type symbol
  96                  :documentation "Slot name of class-unknown where the not recognized text will be stored"))
  97   "A text parser, which aims at building an object list, each object being built when a word is recognized.
  98 A text is composed of words, and thus a text-parser is composed of word-parsers. When a piece of text is not
  99 recognized by word-parsers, it is stored in the slot `slot-unknown' of an object of class `class-unknown'.")
 100
 101 (defmethod update-regexp ((parser text-parser))
 102            "Update the text-parser's regexp thanks to its word-parsers regexps.
 103 Return the new regexp."
 104   (with-slots (word-parsers) parser
 105     (setf (slot-value parser 'regexp)
 106           (format "\\(%s\\)" (my-join (mapcar (lambda (word-parser)
 107                                                 (format "\\(%s\\)" (update-regexp word-parser)))
 108                                               word-parsers)
 109                                       "\\|")))))
 110
 111 ;;;;;;;; mudela parser ;;;;;;;;;;;;;
 112 ;; no multiple inheritance with eieio... can not define a base class that has an editing-state slot
 113
 114 (defclass mudela-syllab-parser (syllab-parser)
 115   ((editing-state :initarg :editing-state
 116                   :documentation "The current editing state (language, relative/absolute octaves, etc),
 117 used to generate mudela regexps"))
 118   "A syllab parser specialized for mudela.")
 119
 120 (defmethod parse-string ((parser mudela-syllab-parser) mudela-str note-state)
 121            "do nothing"
 122   nil)
 123
 124 (defclass duration-parser (mudela-syllab-parser)
 125   nil
 126   "A duration and dots parser.")
 127
 128 (defmethod init-parser ((parser duration-parser) editing-state)
 129            "Init the parser regexp"
 130   (setf (slot-value parser 'editing-state) editing-state)
 131   (setf (slot-value parser 'regexp)
 132         (format "\\(%s\\)\\(%s*\\)"
 133                 (my-join (my-sort-string-by-length
 134                           (mapcar 'int-to-string
 135                                   (mapcar (lambda (n) (expt 2 (- n 1)))
 136                                           '(1 2 3 4 5 6 7 8))))
 137                          "\\|")
 138                 (my-char-to-restring (get-translation editing-state 'dot))))
 139   parser)
 140
 141 (defmethod parse-string ((parser duration-parser) mudela-str note-state)
 142            "If `parser' regexp matches `mudela-str', return slot initialization description,
 143 ie (:duration N :dots P), with N and P read from `mudela-str'. Otherwise, a default definition
 144 is generated thanks to `note-state'."
 145   (with-slots (regexp) parser
 146     (if (string-match regexp mudela-str)
 147       (list :duration (round (1+ (log (string-to-number (match-string-no-properties 1 mudela-str)) 2)))
 148             :dots (length (match-string-no-properties 2 mudela-str)))
 149       (with-slots (duration dots) note-state
 150         (list :duration duration :dots dots)))))
 151
 152 (defclass pitch-parser (mudela-syllab-parser)
 153   nil
 154   "A pitch, alteration and octave parser.")
 155
 156 (defmethod update-regexp ((parser pitch-parser))
 157            "Update the parser's regexp and return it"
 158   (with-slots (editing-state) parser
 159     (setf (slot-value parser 'regexp)
 160           (format "\\(%s\\)\\(%s+\\|%s+\\)?"
 161                   (my-join (my-sort-string-by-length (mapcar 'cdr (slot-value editing-state 'pitch-dict)))
 162                            "\\|")
 163                   (my-char-to-restring (get-translation editing-state 'octave-down))
 164                   (my-char-to-restring (get-translation editing-state 'octave-up))))))
 165
 166 (defmethod init-parser ((parser pitch-parser) editing-state)
 167            "Init the parser regexp"
 168   (setf (slot-value parser 'editing-state) editing-state)
 169   (update-regexp parser)
 170   parser)
 171
 172 (defmethod parse-string ((parser pitch-parser) mudela-str note-state)
 173            "If `parser' regexp matches `mudela-str', return slot initialization description,
 174 ie (:pitch N :alteration P :octave Q), with N, P and Q read from `mudela-str'."
 175   (with-slots (regexp editing-state) parser
 176     (when (string-match regexp mudela-str)
 177       (let* ((pitch-alter (get-pitch editing-state (match-string-no-properties 1 mudela-str)))
 178              (pitch (car pitch-alter))
 179              (alter (cdr pitch-alter)))
 180         (list :pitch pitch
 181               :alteration alter
 182               :octave (+ 0
 183                          (if (slot-value editing-state 'relative-octave)
 184                              (+ (slot-value note-state 'octave)
 185                                 (cond ((> (- pitch (slot-value note-state 'pitch)) 3) -1)
 186                                       ((> (- (slot-value note-state 'pitch) pitch) 3) 1)
 187                                       (t 0)))
 188                              0)
 189                          (if (match-string-no-properties 2 mudela-str)
 190                              (* (if (string= (char-to-string (get-translation editing-state 'octave-down))
 191                                              (substring (match-string-no-properties 2 mudela-str) 0 1))
 192                                     -1
 193                                     1)
 194                                 (length (match-string-no-properties 2 mudela-str)))
 195                              0)))))))
 196
 197 (defclass chromatic-parser (mudela-syllab-parser)
 198   nil
 199   "A chromatic information parser.")
 200
 201 (defmethod init-parser ((parser chromatic-parser) editing-state)
 202            "Init the parser regexp"
 203   (setf (slot-value parser 'editing-state) editing-state)
 204   (setf (slot-value parser 'regexp)
 205         (format "\\(%s\\|%s\\)"
 206                 (my-char-to-restring (get-translation editing-state 'reminder-accidental))
 207                 (my-char-to-restring (get-translation editing-state 'cautionary-accidental))))
 208   parser)
 209
 210 (defmethod parse-string ((parser chromatic-parser) mudela-str note-state)
 211            "If `parser' regexp matches `mudela-str', return slot initialization description,
 212 ie (:reminder-accidental N :cautionary-accidental P, with N and P read from `mudela-str'."
 213   (with-slots (regexp editing-state) parser
 214     (if (string-match regexp mudela-str)
 215         (list :reminder-accidental (string= (char-to-string (get-translation editing-state 'reminder-accidental))
 216                                             (substring (match-string-no-properties 0 mudela-str) 0 1))
 217               :cautionary-accidental (string= (char-to-string (get-translation editing-state 'cautionary-accidental))
 218                                               (substring (match-string-no-properties 0 mudela-str) 0 1)))
 219         (list :reminder-accidental nil :cautionary-accidental nil))))
 220
 221 (defclass r-parser (mudela-syllab-parser)
 222   nil
 223   "A r (rest) parser.")
 224
 225 (defmethod init-parser ((parser r-parser) editing-state)
 226            "Init the parser regexp"
 227   (setf (slot-value parser 'editing-state) editing-state)
 228   (setf (slot-value parser 'regexp)
 229         (format "\\(%s\\|%s\\)"
 230                 (get-translation editing-state 'rest)
 231                 (upcase (get-translation editing-state 'rest))))
 232   parser)
 233
 234 (defclass s-parser (mudela-syllab-parser)
 235   ((editing-state :initarg :editing-state
 236                   :documentation "The current editing state (language, relative/absolute octaves, etc),
 237 used to generate mudela regexps"))
 238   "A s (skip) parser.")
 239
 240 (defmethod init-parser ((parser s-parser) editing-state)
 241            "Init the parser regexp"
 242   (setf (slot-value parser 'editing-state) editing-state)
 243   (setf (slot-value parser 'regexp) (get-translation editing-state 'skip))
 244   parser)
 245
 246 (defclass mudela-word-parser (word-parser)
 247   ((editing-state :initarg :editing-state
 248                   :documentation "The current editing state (language, relative/absolute octaves, etc),
 249 used to generate mudela regexps"))
 250   "A specialized mudella word parser.")
 251
 252 (defmethod init-parser ((parser mudela-word-parser) editing-state)
 253            "Init the parser regexp"
 254   (setf (slot-value parser 'editing-state) editing-state)
 255   (with-slots (syllab-parsers) parser
 256     (dolist (sylparser syllab-parsers)
 257       (init-parser (car sylparser) editing-state)))
 258   (update-regexp parser)
 259   parser)
 260
 261 (defmethod parse-string ((parser mudela-word-parser) mudela-str note-state &optional before after)
 262            "If the parser regexp matches `mudela-str' exactly and if `regexp-not-after' and
 263 `regexp-not-before' do not match the strings `before' or `after', return an instance
 264 of `word-class' by parsing `mudela-str'."
 265   (with-slots (word-class syllab-parsers regexp regexp-not-after regexp-not-before) parser
 266     (when (and (string-match regexp mudela-str)
 267                (string= (match-string-no-properties 0 mudela-str) mudela-str)
 268                (not (and before (string-match regexp-not-after before)))
 269                (not (and after (string-match regexp-not-before after))))
 270       (apply 'make-instance word-class (apply 'append
 271                                               (remove-if 'null (mapcar (lambda (syl-parser)
 272                                                                          (parse-string (car syl-parser) mudela-str note-state))
 273                                                                        syllab-parsers)))))))
 274
 275 (defclass mudela-parser (text-parser)
 276   ((editing-state :initarg :editing-state
 277                   :documentation "The current editing state (language, relative/absolute octaves, etc),
 278 used to generate mudela regexps"))
 279   "A simple mudela parser, that can read notes, rests and skips")
 280
 281 (defmethod init-parser ((parser mudela-parser) editing-state)
 282            "Initialize `parser' : editing-state, syllab and word parsers, etc."
 283   (setf (slot-value parser 'editing-state) editing-state)
 284   (with-slots (word-parsers) parser
 285     (dolist (word-pars word-parsers)
 286       (init-parser word-pars editing-state)))
 287   (update-regexp parser)
 288   parser)
 289
 290 (defmethod parse-string ((parser mudela-parser) mudela-str note-state &optional before after)
 291            "If `mudela-str' is exactly recognized as a known word, return an object
 292 corresponding to that word. Otherwise, return nil."
 293   (with-slots (word-parsers) parser
 294     (do* ((wparsers word-parsers (cdr wparsers))
 295           (wparser (car wparsers) (car wparsers))
 296           obj)
 297         ((or obj (not wparser)) obj)
 298       (setq obj (parse-string wparser mudela-str note-state before after)))))
 299
 300 (defmethod get-word ((parser mudela-parser) note-state &optional backward limit)
 301            "Return a (word beginning end) list, `word' being the first mudela-word
 302 found after (if `backward' is nil) or before (otherwise) point, `beginning' and
 303 `end' being its beginning and end points. If no such word is found,
 304  (nil beginning end) is returned, `beginning' and `end' being the parsed region.
 305 The position is preserved."
 306   (save-excursion
 307     (with-slots (regexp) parser
 308       (let (word
 309             (beginning (and (not backward) (point)))
 310             (end (and backward (point))))
 311         (while (and (not word)
 312                     (if backward
 313                         (re-search-backward regexp limit t)
 314                         (re-search-forward regexp limit t)))
 315           (let* ((b (match-beginning 0))
 316                  (e (match-end 0))
 317                  (point-before (and (> b (point-min)) (1- b)))
 318                  (point-after  (and (< e (point-max)) e))
 319                  (str-before   (and point-before (buffer-substring-no-properties point-before (1+ point-before))))
 320                  (str-after    (and point-after (buffer-substring-no-properties point-after (1+ point-after))))
 321                  (token (parse-string parser (match-string-no-properties 0) note-state str-before str-after)))
 322             (if token
 323                 (setq word token
 324                       beginning b
 325                       end e)
 326                 (goto-char (if backward (1- e) (1+ b))))))
 327         (list word
 328               (if backward (or beginning limit) beginning)
 329               (if backward end (or end limit)))))))
 330
 331 (defmethod parse-region ((parser mudela-parser) beginning end)
 332            "Return an object list describing what as been read by `parser' in the
 333 region delimited by `beginning' and `end'."
 334   (with-slots (class-unknown slot-unknown) parser
 335     (labels ((make-verbatim (text)
 336                             (let ((obj (make-instance class-unknown)))
 337                               (setf (slot-value obj slot-unknown) text)
 338                               obj)))
 339       (save-excursion
 340         (let ((start-verb beginning)
 341               tokens
 342               (note-state (make-instance 'mudela-note-state)))
 343           (goto-char beginning)
 344           (do ((word-descr (get-word parser note-state nil end)
 345                            (get-word parser note-state nil end)))
 346               ((or (null (car word-descr)) (>= (point) end)))
 347             ;; first, we push verbatim text in tokens
 348             (push (make-verbatim (buffer-substring-no-properties start-verb (cadr word-descr))) tokens)
 349             ;; then, the recognized word
 350             (push (car word-descr) tokens)
 351             ;; finally, update position
 352             (goto-char (caddr word-descr))
 353             (setq start-verb (point))
 354             (setf note-state (update-note-state (car word-descr) note-state)))
 355           ;; remaining verbatim text
 356           (when (< start-verb end)
 357             (push (make-verbatim (buffer-substring-no-properties start-verb end)) tokens))
 358           (nreverse tokens))))))
 359
 360
 361 (defun make-mudela-parser (editing-state)
 362   "Build and initialize a simple mudela parser."
 363   (let* (;; syllab-parsers
 364          (duration-pars (make-instance 'duration-parser))
 365          (pitch-pars (make-instance 'pitch-parser))
 366          (chromatic-pars (make-instance 'chromatic-parser))
 367          (r-pars (make-instance 'r-parser))
 368          (s-pars (make-instance 's-parser))
 369          ;; word-parsers
 370          (note-pars (make-instance 'mudela-word-parser
 371                                    :not-before "[a-zA-Z]"
 372                                    :not-after "[a-zA-Z\\\\]"
 373                                    :word-class 'mudela-note
 374                                    :syllab-parsers (list (cons pitch-pars nil)
 375                                                          (cons chromatic-pars t)
 376                                                          (cons duration-pars t))))
 377          (rest-pars (make-instance 'mudela-word-parser
 378                                    :not-before "[a-zA-Z]"
 379                                    :not-after "[a-zA-Z\\\\]"
 380                                    :word-class 'mudela-rest
 381                                    :syllab-parsers (list (cons r-pars nil)
 382                                                          (cons duration-pars t))))
 383          (skip-pars (make-instance 'mudela-word-parser
 384                                    :not-before "[a-zA-Z]"
 385                                    :not-after "[a-zA-Z\\\\]"
 386                                    :word-class 'mudela-skip
 387                                    :syllab-parsers (list (cons s-pars nil)
 388                                                          (cons duration-pars t))))
 389          ;; text-parser
 390          (mudela-pars (make-instance 'mudela-parser
 391                                     :class-unknown 'mudela-verbatim
 392                                     :slot-unknown 'text
 393                                     :word-parsers (list note-pars
 394                                                         rest-pars
 395                                                         skip-pars))))
 396     (init-parser mudela-pars editing-state)
 397     mudela-pars))
 398
 399 (provide 'lyqi-parser)