path: root/lisp/modules/progmodes/sgml.lsp

;;
;; Copyright (c) 2002 by The XFree86 Project, Inc.
;;
;; 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 XFREE86 PROJECT 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.
;;
;; Except as contained in this notice, the name of the XFree86 Project shall
;; not be used in advertising or otherwise to promote the sale, use or other
;; dealings in this Software without prior written authorization from the
;; XFree86 Project.
;;
;; Author: Paulo César Pereira de Andrade
;;
;;
;; $XFree86: xc/programs/xedit/lisp/modules/progmodes/sgml.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $
;;

(require "syntax")
(in-package "XEDIT")

;; Default property the text is shown.
(defsynprop *prop-sgml-default*
    "default"
    :font	"-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1"
    :foreground	"Gray10"
)

(defsynprop *prop-sgml-default-short*
    "default-short"
    :font	"-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1"
    :foreground	"Gray10"
    :underline	t
)

;; Large font.
(defsynprop *prop-sgml-sect*
    "sect"
    :font	"-*-helvetica-bold-r-*-*-17-*-*-*-*-*-*-1"
    :foreground	"Gray20"
)

;; Monospaced property.
(defsynprop *prop-sgml-tt*
    "tt"
    :font	"-*-courier-medium-r-*-*-12-*-*-*-*-*-*-1"
    :foreground	"Black"
)

;; Italic property.
(defsynprop *prop-sgml-it*
    "it"
    :font	"-*-helvetica-medium-o-*-*-12-*-*-*-*-*-*-1"
    :foreground	"Black"
)

;; Bold font property.
(defsynprop *prop-sgml-bf*
    "bf"
    :font	"-*-helvetica-bold-r-*-*-12-*-*-*-*-*-*-1"
    :foreground	"Gray10"
)

;; Looks like a link...
(defsynprop *prop-sgml-link*
    "link"
    :font	"-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1"
    :foreground	"blue"
    :underline	t
)

;; Monospaced, also looks like a link...
(defsynprop *prop-sgml-email*
    "email"
    :font	"-*-courier-medium-r-*-*-12-*-*-*-*-*-*-1"
    :foreground	"blue"
    :underline	t
)

;; Another monospaced property,
(defsynprop *prop-sgml-screen*
    "screen"
    :font	"-*-fixed-*-*-*-*-*-*-*-*-*-*-*-1"
    :foreground	"Gray10"
)

(defsynprop *prop-sgml-maybe-entity*
    "maybe-entity"
    :font	"*lucidatypewriter-medium-r*-12-*"
    :foreground	"VioletRed4"
    :background	"LightYellow"
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  The macros sgml-syntoken and sgml-syntable allows creating rules for
;; matching text inside tags in the format:
;;	<tag> or <tag arg=value> or <tag arg1=value ... argn=value>
;;		any-text
;;	</tag>
;;  The generated rules don't allow things like: < tag> or </tag >
;;
;;  This could also be done as a normal definition, with a starting rule like:
;;	"<(tag1|tag2|tag3)\\>"
;; and an ending rule like:
;;	"</(tag1|tag2|tag3)>"
;;  But is implemented in way that will fail on purpose for things like:
;;	<tag1>any text</tag3></tag1>
;;
;; NOTE: These definitions aren't cheap in the time required to process the
;;	file, and are just adaptations/tests with the syntax-highlight code,
;;	probably it is better to avoid using it in other syntax definitions.
;; NOTE2: It cannot be defined as a single macro because it is required to
;;	  generate 2 entries in the main SGML syntax highlight definition,
;;	  or, should generate the entire definition from a macro; you will
;;	  need to type the tag name twice, but shouldn't be a problem if
;;	  you are using sgml :-)
;; XXX: Maybe the syntax-highlight code could save the starting match and
;;	apply a regex generated at run-time to check for the ending tag,
;;	but this probably would make the parser too slow, better to have
;;	a specialized parser if that is required...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro sgml-syntoken (name)
    `(syntoken (string-concat "<" ,name "\\>")
	:icase t
	:contained t
	:begin (intern (string-concat ,name "$") 'keyword))
)
(defmacro sgml-syntable (name property)
    `(let
	(
	(label (intern (string-concat ,name "$") 'keyword))
	(nested-label (intern (string (gensym)) 'keyword))
	)
	(syntable label *prop-preprocessor* nil
	    ;; tag is still open, process any options
	    (synaugment :generic-tag)
	    (syntoken ">"
		:nospec t
		:property *prop-preprocessor*
		:begin nested-label)
	    ;;	Generate a nested table that includes everything, and only
	    ;; returns when the closing tag is found.
	    (syntable nested-label ,property nil
		(syntoken (string-concat "</" ,name ">")
		    :icase t
		    :nospec t
		    :property *prop-preprocessor*
		    :switch -2)
		(synaugment :main)
	    )
	)
    )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generate tokens for tags that don't require and ending tag.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro sgml-syntable-simple (name property)
    `(let
	(
	(label (intern (string-concat ,name "$") 'keyword))
	(nested-label (intern (string (gensym)) 'keyword))
	)
	(syntable label *prop-preprocessor* nil
	    ;; tag is still open, process any options
	    (synaugment :generic-tag)
	    (syntoken ">"
		:nospec t
		:property *prop-preprocessor*
		:begin nested-label)
	    ;;	Generate a nested table that finishes whenever an unmatched
	    ;; start or end tag is found.
	    (syntable nested-label ,property nil
		(syntoken "</"
		    :icase t
		    :nospec t
		    :contained t
		    :begin :simple-nested-tag)
		;;  These will take precedence over other rules
		(syntoken "<"
		    :icase t
		    :nospec t
		    :contained t
		    :begin :simple-nested-tag)
		(syntoken "<p>"
		    :icase t
		    :nospec t
		    :property *prop-preprocessor*
		    :switch :main)
		(synaugment :main)
	    )
	)
    )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Define some macros to generate tokens for tags in the format:
;;	<tag/  ... /
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro sgml-syntoken-short (name)
    `(syntoken (string-concat "<" ,name "/")
	:icase t
	:property *prop-preprocessor*
	:begin (intern (string-concat ,name "/") 'keyword))
)
(defmacro sgml-syntable-short (name property)
    `(syntable (intern (string-concat ,name "/") 'keyword) ,property nil
	(syntoken "/"
	    :nospec t
	    :property *prop-preprocessor*
	    :switch -1)
	(syntoken "</?\\w+>"
	    :property *prop-control*
	    :switch :main)
    )
)


;; The main SGML syntax table
(defsyntax *sgml-mode* :main *prop-sgml-default* nil nil
    ;; Comments
    (syntoken "<!--"
	:nospec t
	:contained t
	:begin :comment)
    (syntable :comment *prop-comment* nil
	;; Only one rule, to finish the comment.
	(syntoken "-->"
	    :nospec t
	    :switch -1)
    )

    ;; Entities
    (syntoken "&[a-zA-Z0-9_.-]+;"
	:property *prop-constant*)
    ;; Probably an entity, missing ending `;'
    (syntoken "&[a-zA-Z0-9_.-]+"
	:property *prop-sgml-maybe-entity*)

    ;; Strings
    (syntable :string *prop-string* nil
	;;  Ignore escaped characters.
	(syntoken "\\\\.")
	;;  Rule to finish the string.
	(syntoken "\""
	    :nospec t
	    :switch -1)
    )

    ;; Links
    (syntable :link *prop-preprocessor* nil
	;; No link string following "url="
	(syntoken ">"
	    :nospec t
	    :property *prop-control*
	    :switch -1)
	(syntoken "\""
	    :nospec t
	    :contained t
	    :begin :link-string)
	(syntable :link-string *prop-sgml-link* nil
	    ;; Ignore escaped characters.
	    (syntoken "\\\\.")
	    ;; Rule to finish the link, note that returns two levels.
	    (syntoken "\""
		:nospec t
		:switch -2)
	)
    )

    ;; "Special" tag
    (syntoken "<!"
	:nospec t
	:contained t
	:begin :special-tag)
    ;;  Rules for "special" tags
    (syntable :special-tag *prop-preprocessor* nil
	(syntoken "["
	    :nospec t
	    :property *prop-preprocessor*
	    :begin :brackets)
	;; Finish the "special" tag
	(syntoken ">"
	    :nospec t
	    :switch -1)
	(syntable :brackets *prop-sgml-default* nil
	    (syntoken "]"
		:nospec t
		:property *prop-preprocessor*
		:switch -1)
	    ;; Allow nesting.
	    (syntoken "["
		:nospec t
		:property *prop-preprocessor*
		:begin :brackets)
	    ;; Entities.
	    (syntoken "%[a-zA-Z0-9_.-]+;?"
		:property *prop-annotation*)
	    ;;  Allow everything inside the brackets
	    (synaugment :main)
	)
	;; Don't use generic tag tokens, only create a rule for strings
	(syntoken "\""
	    :nospec t
	    :begin :string
	    :contained t)
	;; Allow everything inside the "special" tag
	(synaugment :main)
    )

    ;; Some "short" tags
    (sgml-syntoken-short "tt")
    (sgml-syntable-short "tt" *prop-sgml-tt*)
    (sgml-syntoken-short "it")
    (sgml-syntable-short "it" *prop-sgml-it*)
    (sgml-syntoken-short "bf")
    (sgml-syntable-short "bf" *prop-sgml-bf*)
    (sgml-syntoken-short "em")
    (sgml-syntable-short "em" *prop-sgml-bf*)

    ;; Short tag
    (syntoken "<\\w+/"
	:property *prop-preprocessor*
	:begin :short-tag)
    (syntable :short-tag *prop-sgml-default-short* nil
	(syntoken "/"
	    :nospec t
	    :property *prop-preprocessor*
	    :switch -1)
	(syntoken "</?\\w+>"
	    :property *prop-control*
	    :switch -1)
    )

    ;;  Don't allow spaces, this may and may not be the start of a tag,
    ;; but the syntax-highlight definition is not specialized...
    (syntoken "<([^/a-zA-Z]|$)"
	:property *prop-control*)

    ;; Some tags that require an end tag
    (sgml-syntoken "tt")
    (sgml-syntable "tt" *prop-sgml-tt*)
    (sgml-syntoken "code")
    (sgml-syntable "code" *prop-sgml-tt*)
    (sgml-syntoken "tag")
    (sgml-syntable "tag" *prop-sgml-tt*)
    (sgml-syntoken "verb")
    (sgml-syntable "verb" *prop-sgml-tt*)
    (sgml-syntoken "programlisting")
    (sgml-syntable "programlisting" *prop-sgml-tt*)
    (sgml-syntoken "it")
    (sgml-syntable "it" *prop-sgml-it*)
    (sgml-syntoken "bf")
    (sgml-syntable "bf" *prop-sgml-bf*)
    (sgml-syntoken "em")
    (sgml-syntable "em" *prop-sgml-bf*)
    (sgml-syntoken "mail")
    (sgml-syntable "mail" *prop-sgml-email*)
    (sgml-syntoken "email")
    (sgml-syntable "email" *prop-sgml-email*)
    (sgml-syntoken "screen")
    (sgml-syntable "screen" *prop-sgml-screen*)
    (sgml-syntoken "tscreen")
    (sgml-syntable "tscreen" *prop-sgml-screen*)


    ;;  Helper for tags that don't need an ending one.
    ;;  NOTE: Since the parser is not specialized, if the tag is
    ;;	      folowed by one that has a special property defined here,
    ;;	      it may not be detected, i.e. put a <p> after the <sect>
    ;;	      and it will work.
    (syntable :simple-nested-tag *prop-preprocessor* nil
	;; tag is still open, process any options
	(synaugment :generic-tag)
	(syntoken ">"
	    :nospec t
	    :property *prop-preprocessor*
	    :switch -3)
    )
    (sgml-syntoken "sect")
    (sgml-syntable-simple "sect" *prop-sgml-sect*)
    (sgml-syntoken "sect1")
    (sgml-syntable-simple "sect1" *prop-sgml-sect*)
    (sgml-syntoken "sect2")
    (sgml-syntable-simple "sect2" *prop-sgml-sect*)

    ;; Generic tags
    (syntoken "<"
	:nospec t
	:contained t
	:begin :tag)
    ;; Table :generic-tag is defined to be augmented, no rule to finish it.
    (syntable :generic-tag *prop-preprocessor* nil
	;; Start string
	(syntoken "\""
	    :nospec t
	    :begin :string
	    :contained t)
	;; Start url link
	(syntoken "url="
	    :nospec t
	    :begin :link)
	;; Cannot nest
	(syntoken "<"
	    :nospec t
	    :property *prop-control*)
    )
    (syntable :tag *prop-preprocessor* nil
	;; Finish the tag
	(syntoken ">"
	    :nospec t
	    :switch -1)
	;; Import generic definitions
	(synaugment :generic-tag)
    )
)