;;; ada-to-wiki.el --- print MediaWiki markup around Ada tokens ;; Copyright (C) 2005 Georg Bauhaus ;; 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 2 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 this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, ;; MA 02111-1307 USA ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Usage: ;;; mark a region, then command M-x Ada-to-WiKi. Modifies the ;;; current buffer by replacing the text in the region. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst atwk-version "20051217") ;; or whatever version tag, if any, should be in ATWK-VERSION ;; * Overview of Implementation * ;; Starting at the first character of region, the translation first ;; creates a list of simple text tokens. The lexical elements are found ;; through some regular expressions, and using a function for string ;; literals. The tokenizer looks at the text at the current position to ;; see whether a prefix matches an expression. The expressions must be ;; tried in a certain order. ;; When there is a simple token list, the next step looks at each pair ;; of consecutive tokens in the list. If a pair can be combined into ;; an Ada two-character delimiter or operator, this is done, and the ;; result wrapped in appropriate markup. This process creates another ;; list of "WiKi tokens". If the first of the original tokens is '-' ;; or ''', special processing for comments, characters literals, and ;; attributes takes place. If the tokens cannot be combined, or if there ;; is only one token left, a similar function operates on the single ;; token returning an element suitably wrapped in markup if needed. ;; Finally, the original region is killed, and the wiki tokens ;; concatenated to form the replacement text of the region. ;; The new region is then indented by one space. This preserves ;; the original layout in a program text box. ;;; Data: ; reserved words copied from draft 13 of AARM Ada 2005 (defconst atwk-Ada-Keywords ;; important: words must be lower case on this list (list "abort" "abs" "abstract" "accept" "access" "aliased" "all" "and" "array" "at" "begin" "body" "case" "constant" "declare" "delay" "delta" "digits" "do" "else" "elsif" "end" "entry" "exception" "exit" "for" "function" "generic" "goto" "if" "in" "interface" "is" "limited" "loop" "mod" "new" "not" "null" "of" "or" "others" "out" "overriding" "package" "pragma" "private" "procedure" "protected" "raise" "range" "record" "rem" "renames" "requeue" "return" "reverse" "select" "separate" "subtype" "synchronized" "tagged" "task" "terminate" "then" "type" "until" "use" "when" "while" "with" "xor")) (defconst atwk-Ada-Attributes ;; important: every name on this list matches as if (UPCASE-INITIALS ;; (DOWNCASE NAME)) had been applied (list "Access" "Address" "Adjacent" "Aft" "Alignment" "Base" "Bit_Order" "Body_Version" "Callable" "Caller" "Ceiling" "Class" "Component_Size" "Compose" "Constrained" "Copy_Sign" "Count" "Definite" "Delta" "Denorm" "Digits" "Exponent" "External_Tag" "First" "Floor" "Fore" "Fraction" "Identity" "Image" "Class" "Input" "Last" "Leading_Part" "Length" "Machine" "Machine_Emax" "Machine_Emin" "Machine_Mantissa" "Machine_Overflows" "Machine_Radix" "Machine_Rounding" "Machine_Rounds" "Max" "Max_Size_In_Storage_Elements" "Min" "Mod" "Model" "Model_Emin" "Model_Epsilon" "Model_Mantissa" "Model_Small" "Modulus" "Output" "Partition_Id" "Pos" "Pred" "Priority" "Range" "Read" "Remainder" "Round" "Rounding" "Safe_First" "Safe_Last" "Scale" "Scaling" "Signed_Zeros" "Size" "Small" "Storage_Pool" "Storage_Size" "Stream_Size" "Succ" "Tag" "Terminated" "Truncation" "Unbiased_Rounding" "Unchecked_Access" "Val" "Valid" "Value" "Version" "Wide_Image" "Wide_Value" "Wide_Wide_Image" "Wide_Wide_Value" "Wide_Wide_Width" "Wide_Width" "Width" "Write")) ; Pieces of syntax *sufficiently* *similar* to Ada's. (Some obsolescent ; parts excluded.) Note that numbers and identifiers are combined in a ; single pattern. This is possible and useful because they are treated ; the same when producing output. There is no markup around either of ; them. (defconst atwk-letter (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz" "€" ; currency symbols ;; regional "éèàâ" ; French "ł" ; Polish "ΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΨΩ" "αβγδεζηΘικλμνξοπρστυφψω") "Letters occuring in identifiers. Some of the non-ASCII characters are included. The intent is to include at least those that are used somewhere in wikibook-ada.") (defconst atwk-digit "0123456789#aAbBcCdDeEfF" "characters occuring in numeric literals") (defconst atwk-identifier (concat "[" atwk-letter atwk-digit "_" "]+") "a span of characters making up a number or an identfier") ; atwk-delimiter1 must include atwk-operator1 (defconst atwk-operator1 "[&*+/<=>-]" "single character operators.") (defconst atwk-operator2 (regexp-opt '("**" ">=" "<=" "/=") t) "two-character operators.") (defconst atwk-delimiter1 "[&'()*+,./:;<=>|!-]" "single character delimiters.") (defconst atwk-delimiter2 (regexp-opt '(">=" ".." "**" ":=" "/=" ">=" "<=" "<<" ">>" "<>") t) "two-character delimiters.") ; not used: ; special '?@{}[]`$\^~' (defconst atwk-white "[[:blank:]\n]+" "tabs, spaces, and new line characters.") ; (? can/should this depend on the current syntax table and use [:space:]?) (defconst atwk-attribute (concat "'\\(" "[" atwk-letter "][" atwk-letter "_" "]+\\)") "an apostrophe, followed by at least two letters, and possibly underscores. Must produce a group from the attribute characters") (defconst atwk-start-of-string "[%\"]" "characters that may start a string literal.") (defconst atwk-regression-testing nil "If t, the functions that produce output will be bound to an identity function, enabling regression testing. The transformation then calls identity functions instead of the functions that produce MediaWiKi markup around tokens.") ;;; Funtions: (defun atwk-upto-end-of-string (beg end &optional quotation-mark) "Find a quotation-mark after BEG that ends a string literal and update match data. BEG is assumend to be the position of the first character of the (sub)string, after a quotation-mark. Doubled quotation marks are skipped." (let* ((Q (or quotation-mark "\"")) (QQ (concat Q Q))) (or (and (search-forward QQ end t) (atwk-upto-end-of-string (point) end Q)) (and (search-forward Q end t))))) (defun atwk-message (msg) "Announce the current time followed by MSG." (let* ((now (current-time)) (high (car now)) (low (car(cdr now))) (micro (car(cdr(cdr now))))) (message "Ada-to-WiKi, Time: %s/%d %s" (substring (current-time-string now) 11 19) ;; (+ (* high (lsh 2 15)) low) micro msg))) (defun atwk-make-verbatim-maybe (start end) "insert a space at the beginning of each line fully contained between START and END" (interactive "r") (if (not atwk-regression-testing) (let ((middle-of-line (not (bolp))) (original-buffer (current-buffer)) (tmp-buffer (get-buffer-create " *atwk-temporary-buffer*"))) (kill-new (delete-and-extract-region start end)) (save-excursion (set-buffer tmp-buffer) (insert (car kill-ring)) (goto-char (point-min)) (if middle-of-line (forward-line 1)) (replace-regexp "^" " " (not 'DELIMITED)) (set-buffer original-buffer) (insert-buffer tmp-buffer) (set-buffer tmp-buffer) (delete-region (point-min) (point-max)))))) (defun Ada-to-WiKi (start end) "Tokenize region and insert MediaWiki markup around some Ada tokens. The text between START and END is first tokenized and the results made a list. Ada comments can contain any kind of character, they are passed as two delimiters followed by the remaining text on the line. There are similar special circuits for character literals, string literals, and attributes, too. Some elements of the token list are then wrapped in MediaWiki markup, notably reserved words, delimiters, attributes, and comments. The results are inserted into the buffer replacing the text of the region." (interactive "r") (goto-char start) ;; (message "input text: [%s]" (atwk-buf-sub start end)) (atwk-message "start") (let ((simple-tokens-list (atwk-tokenize start end))) (atwk-message (format "%d simple tokens found..." (length simple-tokens-list))) (let ((wiki-text (atwk-to-wiki simple-tokens-list))) (if wiki-text (progn (atwk-message (format "Replacing %d tokens of region (%d, %d)" (length wiki-text) start end)) (kill-region start end) (insert (mapconcat (function identity) wiki-text "")) (atwk-make-verbatim-maybe start (point)) (atwk-message "Done.")) ;; (message "new text is [%s]" (mapconcat 'upcase wiki-text "\\\\"))) (error "Something is wrong, no WiKi text has arrived"))))) ;; setup of either MediaWiki or identity functions (for regression testing) ;; There is a LAMBDA in ATWK-ADA-COMMENT because of the MediaWiki Ada ;; markup for comments which is {{Ada/comment| comment text}}. This ;; markup omits the '-' characters from the original "-- comment text" ;; (3 tokens originally). Rendering will show the hyphens again. The ;; tokens are therefore not cons'd onto the result list. The lambda ;; reintroduces them for regression testing, as there is no automatic ;; rendering of the hyphens. (defconst atwk-Ada-attribute (if atwk-regression-testing (function concat) (function atwk-Ada-attribute-MW))) (defconst atwk-Ada-comment (if atwk-regression-testing (lambda (c) (concat "--" c)) (function atwk-Ada-comment-MW))) (defconst atwk-Ada-delimiter (if atwk-regression-testing (function concat) (function atwk-Ada-delimiter-MW))) (defconst atwk-Ada-operator (if atwk-regression-testing (function concat) (function atwk-Ada-operator-MW))) (defconst atwk-Ada-keyword (if atwk-regression-testing (function concat) (function atwk-Ada-keyword-MW))) ;; mute indirect invocation chant (defsubst atwk-ATTR (tok) (funcall atwk-Ada-attribute tok)) (defsubst atwk-CMNT (tok) (funcall atwk-Ada-comment tok)) (defsubst atwk-DELIM (tok) (funcall atwk-Ada-delimiter tok)) (defsubst atwk-KW (tok) (funcall atwk-Ada-keyword tok)) (defsubst atwk-OP (tok) (funcall atwk-Ada-operator tok)) (defsubst atwk-matching-text (n) "buffer text of match group N without text properties." (buffer-substring-no-properties (match-beginning n) (match-end n))) (defun atwk-pos-after-match (end) "new scanning position provided match doesn't exceed END. An error is signalled if it does." (if (<= (match-end 0) end) (match-end 0) (error "atwk-tokenize: last token [%s] exceeds region in ...%s[REGION END]" (atwk-matching-text 0) (buffer-substring (match-beginning 0) end)))) (defun atwk-tokenize (p end) "turn a region of program text into a list of text tokens. Tokens include white space, string/character literals, ``identifiers'', delimiters, comments, and attributes. The last token must end before region's END, otherwise there is an ERROR." (let ((result (list))) (while (< p end) (goto-char p) (cond ((eolp) ;; (assert (< (point) end)) (beginning-of-line 2) ; next line (setq result (cons "\n" result) p (point))) ((looking-at atwk-white) (setq result (cons (atwk-matching-text 0) result) p (atwk-pos-after-match end))) ((looking-at "--\\(.*\\)$") (setq result (cons (atwk-matching-text 1) (cons "-" (cons "-" result))) p (atwk-pos-after-match end))) ;; character literals (any character, including ''') ((looking-at "'\\(.\\)'") (setq result (cons "'" (cons (atwk-matching-text 1) (cons "'" result))) p (atwk-pos-after-match end))) ;; attributes ((looking-at atwk-attribute) (setq result (cons (atwk-matching-text 1) (cons "'" result)) p (atwk-pos-after-match end))) ;; Whichever of the characters in ATWK-START-OF-STRING is found ;; first will be taken to be the quotation mark that both ;; brackets the string and may occur doubled in the string. ((and (looking-at atwk-start-of-string) (let* ((saved-point (match-end 0)) (eol (progn (end-of-line) (point))) (qm (atwk-matching-text 0))) (goto-char saved-point) (atwk-upto-end-of-string (match-end 0) eol qm))) (setq result (cons (buffer-substring-no-properties p (match-end 0)) result) p (atwk-pos-after-match end))) ((looking-at atwk-identifier) (setq result (cons (atwk-matching-text 0) result) p (atwk-pos-after-match end))) ((looking-at atwk-delimiter1) (setq result (cons (atwk-matching-text 0) result) p (atwk-pos-after-match end))) (t (let* ((eol (progn (end-of-line) (point))) (remaining (buffer-substring p eol))) (error "Looking at [%s], cannot parse" remaining))))) (nreverse result))) ;; token * regex * regex -> string (defun atwk-to-wiki-1 (tok operator1-exactly delimiter1-exactly) "Process a single token. See ATWK-TO-WIKI." (cond ((string-match operator1-exactly tok) (atwk-OP tok)) ((string-match delimiter1-exactly tok) (atwk-DELIM tok)) ((member (downcase tok) atwk-Ada-Keywords) (atwk-KW tok)) (t ; anything else, including white space tokens ; Attributes come after ''', they are taken care of ; in the two-tokens conditional in ATWK-TO-WIKI. tok))) ;; [token] -> [string] (defun atwk-to-wiki (ts) "turn a list of text tokens into another list with markup around some tokens." (let ((result (list)) (operator1-exactly (concat "^" atwk-operator1 "$")) (delimiter1-exactly (concat "^" atwk-delimiter1 "$")) (operator2-exactly (concat "^" atwk-operator2 "$")) (delimiter2-exactly (concat "^" atwk-delimiter2 "$"))) (while (not (null ts)) (let ((tok1 (car ts))) (cond ((null (cdr ts)) ;; tok1 is the final token (setq result (cons (atwk-to-wiki-1 tok1 operator1-exactly delimiter1-exactly) result) ts (cdr ts))) (t ; another token ahead (let* ((tok2 (car (cdr ts))) (two-toks (concat tok1 tok2))) ; (message "two-toks: [%s]" two-toks) (cond ((string-equal "--" two-toks) (setq result (cons (atwk-CMNT (car (cdr(cdr ts)))) result) ts (cdr(cdr(cdr ts))))) ((string-match operator2-exactly two-toks) (setq result (cons (atwk-OP two-toks) result) ts (cdr(cdr ts)))) ((string-match delimiter2-exactly two-toks) (setq result (cons (atwk-DELIM two-toks) result) ts (cdr(cdr ts)))) ;; attributes, character literals. Be optimistic ;; about correctness of input, i.e. not ''x ((string-equal "'" tok1) (cond ((and (> (length tok2) 1) (member (upcase-initials (downcase tok2)) atwk-Ada-Attributes)) (setq result (cons (atwk-ATTR tok2) (cons (atwk-DELIM tok1) result)) ts (cdr(cdr ts)))) (t ; a character literal (setq result (cons tok2 (cons (atwk-DELIM tok1) result)) ts (cdr(cdr ts)))))) (t ; process TOK1 only and shift (setq result (cons (atwk-to-wiki-1 tok1 operator1-exactly delimiter1-exactly) result) ts (cdr ts))))))))) (nreverse result))) ; wrap pieces of program text in MediaWiki markup ; See also ATWK-ADA-DELIMITER-MW and ATWK-ADA-OPERATOR-MW. (defconst MW-long-link-names '(("+" . "plus") ("<" . "less_than") (">" . "greater_than") ("|" . "vertical_line") ("." . "dot") ;; two characters (".." . "double_dot") (">=" . "greater_than_or_equal_to") ("<=" . "less_than_or_equal_to") (">>" . "right_label") ("<<" . "left_label") ("<>" . "box") ("=>" . "arrow")) "Because of the way MediaWiKi sites organise their pages and links using files and URLs, some names are not permitted. So some operators and delimiters are not rendered/linked correctly unless special care is taken, referring to operators and delimiters via names, too, not just via the character(s). MediaWiKi Titles note: ``The following characters are not allowed in page titles: ``# + < > [ ] | { } ``Colon ...'' ``..'' doesn't work either, probably because it denotes a parent directory in a URL. (Correct?) ") (defun atwk-Ada-attribute-MW (text) "wrap TEXT in suitable MediaWiki markup. Note that the tick mark is not automatically produced when the markup is rendered, it must be present in the WiKi text before the attribute." (concat "{{Ada/attribute|" text "}}")) (defun atwk-Ada-comment-MW (text) "wrap comment TEXT in suitable MediaWiki markup. Ada text in comments is considered plain text." (let ((wiki-syntax-replaced (replace-regexp-in-string "[|={}]" ; no bars, no braces; '=' is used ; in named template parameters (lambda (m) (cond ((equal m "|") "|") ((equal m "=") "=") ((equal m "{") "{") ((equal m "}") "}") (t (error "In atwk-Ada-attribute-MW: %s" "This shouldn't happen")))) text 'FIXEDCASE 'LITERAL))) (concat "{{Ada/--|" wiki-syntax-replaced "}}"))) (defun atwk-Ada-delimiter-MW (text) "wrap TEXT in suitable MediaWiki markup" (cond ((equal text "|") ; special case, as parameter 2=| doesn't work "{{Ada/delimiter 2|vertical_line||}}") ((assoc text MW-long-link-names) (let ((text2 ; {{Ada/delimiter 2|box|<>}} (concat " 2|" (cdr (assoc text MW-long-link-names)) "|2=" text))) (concat "{{Ada/delimiter" text2 "}}"))) (t (concat "{{Ada/delimiter|1=" text "}}")))) (defun atwk-Ada-keyword-MW (text) "wrap TEXT in suitable MediaWiki markup" (concat "{{Ada/keyword|" text "}}")) (defun atwk-Ada-operator-MW (text) "wrap TEXT in suitable MediaWiki markup" (cond ((assoc text MW-long-link-names) (let ((text2 ; {{Ada/operator 2|greater_than|2=>}} (concat " 2|" (cdr (assoc text MW-long-link-names)) "|2=" text))) (concat "{{Ada/operator" text2 "}}"))) (t (concat "{{Ada/operator|1=" text "}}"))))