lisp/nxml/rng-pttrn.el

   1 ;;; rng-pttrn.el --- RELAX NG patterns  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: wp, hypermedia, languages, XML, RelaxNG
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; pattern ::=
  26 ;;   (ref <pattern> <local-name>)
  27 ;;   | (choice <pattern> <pattern> ...)
  28 ;;   | (group <pattern> <pattern> ...)
  29 ;;   | (interleave <pattern> <pattern> ...)
  30 ;;   | (zero-or-more <pattern>)
  31 ;;   | (one-or-more <pattern>)
  32 ;;   | (optional <pattern>)
  33 ;;   | (mixed <pattern>)
  34 ;;   | (value <datatype> <string> <context>)
  35 ;;   | (data <datatype> <params>)
  36 ;;   | (data-except <datatype> <params> <pattern>)
  37 ;;   | (list <pattern>)
  38 ;;   | (element <name-class> <pattern>)
  39 ;;   | (attribute <name-class> <pattern>)
  40 ;;   | (text)
  41 ;;   | (empty)
  42 ;;   | (not-allowed)
  43 ;;
  44 ;; params ::=
  45 ;;   ((<param-name> . <param-value> ) ...)
  46 ;; param-name ::= <symbol>
  47 ;; param-value ::= <string>
  48 ;;
  49 ;; name-class ::=
  50 ;;   (name <name>)
  51 ;;   | (any-name)
  52 ;;   | (any-name-except <name-class>)
  53 ;;   | (ns-name <ns>)
  54 ;;   | (ns-name-except <ns> <name-class>)
  55 ;;   | (choice <name-class> <name-class> ...)
  56 ;;
  57 ;; name ::= (<ns> . <local-name>)
  58 ;; ns ::= nil | <symbol>
  59 ;; local-name ::= <string>
  60 ;; datatype ::= (<datatype-uri> . <datatype-local-name>)
  61 ;; datatype-uri ::= nil | <symbol>
  62 ;; datatype-local-name ::= <symbol>
  63
  64 ;;; Code:
  65
  66 (defvar rng-schema-change-hook nil
  67   "Hook to be run after `rng-current-schema' changes.")
  68
  69 (defvar rng-current-schema nil
  70   "Pattern to be used as schema for the current buffer.")
  71 (make-variable-buffer-local 'rng-current-schema)
  72
  73 (defun rng-make-ref (name)
  74   (list 'ref nil name))
  75
  76 (defun rng-ref-set (ref pattern)
  77   (setcar (cdr ref) pattern))
  78
  79 (defun rng-ref-get (ref) (cadr ref))
  80
  81 (defun rng-make-choice (patterns)
  82   (cons 'choice patterns))
  83
  84 (defun rng-make-group (patterns)
  85   (cons 'group patterns))
  86
  87 (defun rng-make-interleave (patterns)
  88   (cons 'interleave patterns))
  89
  90 (defun rng-make-zero-or-more (pattern)
  91   (list 'zero-or-more pattern))
  92
  93 (defun rng-make-one-or-more (pattern)
  94   (list 'one-or-more pattern))
  95
  96 (defun rng-make-optional (pattern)
  97   (list 'optional pattern))
  98
  99 (defun rng-make-mixed (pattern)
 100   (list 'mixed pattern))
 101
 102 (defun rng-make-value (datatype str context)
 103   (list 'value datatype str context))
 104
 105 (defun rng-make-data (name params)
 106   (list 'data name params))
 107
 108 (defun rng-make-data-except (name params pattern)
 109   (list 'data-except name params pattern))
 110
 111 (defun rng-make-list (pattern)
 112   (list 'list pattern))
 113
 114 (defun rng-make-element (name-class pattern)
 115   (list 'element name-class pattern))
 116
 117 (defun rng-make-attribute (name-class pattern)
 118   (list 'attribute name-class pattern))
 119
 120 (defun rng-make-text ()
 121   '(text))
 122
 123 (defun rng-make-empty ()
 124   '(empty))
 125
 126 (defun rng-make-not-allowed ()
 127   '(not-allowed))
 128
 129 (defun rng-make-any-name-name-class ()
 130   '(any-name))
 131
 132 (defun rng-make-any-name-except-name-class (name-class)
 133   (list 'any-name-except name-class))
 134
 135 (defun rng-make-ns-name-name-class (ns)
 136   (list 'ns-name ns))
 137
 138 (defun rng-make-ns-name-except-name-class (ns name-class)
 139   (list 'ns-name-except ns name-class))
 140
 141 (defun rng-make-name-name-class (name)
 142   (list 'name name))
 143
 144 (defun rng-make-choice-name-class (name-classes)
 145   (cons 'choice name-classes))
 146
 147 (defconst rng-any-content
 148   (let* ((ref (rng-make-ref "any-content"))
 149          (pattern (rng-make-zero-or-more
 150                     (rng-make-choice
 151                      (list
 152                       (rng-make-text)
 153                       (rng-make-attribute (rng-make-any-name-name-class)
 154                                           (rng-make-text))
 155                       (rng-make-element (rng-make-any-name-name-class)
 156                                         ref))))))
 157     (rng-ref-set ref pattern)
 158     pattern)
 159   "A pattern that matches the attributes and content of any element.")
 160
 161 (defconst rng-any-element
 162   (let* ((ref (rng-make-ref "any-element"))
 163          (pattern
 164           (rng-make-element
 165            (rng-make-any-name-name-class)
 166            (rng-make-zero-or-more
 167             (rng-make-choice
 168              (list
 169               (rng-make-text)
 170               (rng-make-attribute (rng-make-any-name-name-class)
 171                                   (rng-make-text))
 172               ref))))))
 173     (rng-ref-set ref pattern)
 174     pattern)
 175   "A pattern that matches any element.")
 176
 177 ;;; Names
 178
 179 (defun rng-make-name (ns local-name)
 180   (cons ns local-name))
 181
 182 ;;; Datatypes
 183
 184 (defun rng-make-datatype (uri local-name)
 185   (cons uri (intern local-name)))
 186
 187 (provide 'rng-pttrn)
 188
 189 ;;; rng-pttrn.el ends here