From 5b7eafd0f00a16d78f99a27f5c7d5a0de77dc7e6 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 21 Jul 2010 09:46:51 +0200 Subject: Imported Upstream snapshot 8.3~beta0+13298 --- tools/beautify-archive | 0 tools/coq-db.el | 241 ++++++++++ tools/coq-font-lock.el | 137 ++++++ tools/coq-syntax.el | 974 +++++++++++++++++++++++++++++++++++++ tools/coq-tex.ml4 | 292 ----------- tools/coq.el | 58 +-- tools/coq_makefile.ml4 | 136 +++--- tools/coq_tex.ml4 | 292 +++++++++++ tools/coqdep.ml | 517 +++----------------- tools/coqdep_boot.ml | 46 ++ tools/coqdep_common.ml | 445 +++++++++++++++++ tools/coqdep_lexer.mll | 91 ++-- tools/coqdoc/alpha.ml | 19 +- tools/coqdoc/alpha.mli | 2 +- tools/coqdoc/cdglobals.ml | 22 +- tools/coqdoc/coqdoc.css | 129 ++++- tools/coqdoc/coqdoc.sty | 78 +-- tools/coqdoc/cpretty.mli | 14 + tools/coqdoc/cpretty.mll | 1176 +++++++++++++++++++++++++++++++++++++++++++++ tools/coqdoc/index.ml | 335 +++++++++++++ tools/coqdoc/index.mli | 22 +- tools/coqdoc/index.mll | 490 ------------------- tools/coqdoc/main.ml | 280 ++++++----- tools/coqdoc/output.ml | 759 +++++++++++++++++------------ tools/coqdoc/output.mli | 19 +- tools/coqdoc/pretty.mli | 13 - tools/coqdoc/pretty.mll | 784 ------------------------------ tools/coqdoc/tokens.ml | 171 +++++++ tools/coqdoc/tokens.mli | 78 +++ tools/coqwc.mll | 74 +-- tools/gallina.ml | 24 +- tools/gallina_lexer.mll | 34 +- 32 files changed, 4985 insertions(+), 2767 deletions(-) mode change 100755 => 100644 tools/beautify-archive create mode 100644 tools/coq-db.el create mode 100644 tools/coq-font-lock.el create mode 100644 tools/coq-syntax.el delete mode 100644 tools/coq-tex.ml4 create mode 100644 tools/coq_tex.ml4 create mode 100644 tools/coqdep_boot.ml create mode 100644 tools/coqdep_common.ml create mode 100644 tools/coqdoc/cpretty.mli create mode 100644 tools/coqdoc/cpretty.mll create mode 100644 tools/coqdoc/index.ml delete mode 100644 tools/coqdoc/index.mll delete mode 100644 tools/coqdoc/pretty.mli delete mode 100644 tools/coqdoc/pretty.mll create mode 100644 tools/coqdoc/tokens.ml create mode 100644 tools/coqdoc/tokens.mli (limited to 'tools') diff --git a/tools/beautify-archive b/tools/beautify-archive old mode 100755 new mode 100644 diff --git a/tools/coq-db.el b/tools/coq-db.el new file mode 100644 index 00000000..078c2bb6 --- /dev/null +++ b/tools/coq-db.el @@ -0,0 +1,241 @@ +;;; coq-db.el --- coq keywords database utility functions +;; +;; Author: Pierre Courtieu +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; + +;;; We store all information on keywords (tactics or command) in big +;; tables (ex: `coq-tactics-db') From there we get: menus including +;; "smart" commands, completions for command coq-insert-... +;; abbrev tables and font-lock keyword + +;;; real value defined below + +;;; Commentary: +;; + +;;; Code: + +;(require 'proof-config) ; for proof-face-specs, a macro +;(require 'holes) + +(defconst coq-syntax-db nil + "Documentation-only variable, for coq keyword databases. +Each element of a keyword database contains the definition of a \"form\", of the +form: + +(MENUNAME ABBREV INSERT STATECH KWREG INSERT-FUN HIDE) + +MENUNAME is the name of form (or form variant) as it should appear in menus or +completion lists. + +ABBREV is the abbreviation for completion via \\[expand-abbrev]. + +INSERT is the complete text of the form, which may contain holes denoted by +\"#\" or \"@{xxx}\". + +If non-nil the optional STATECH specifies that the command is not state +preserving for coq. + +If non-nil the optional KWREG is the regexp to colorize correponding to the +keyword. ex: \"simple\\\\s-+destruct\" (\\\\s-+ meaning \"one or more spaces\"). +*WARNING*: A regexp longer than another one should be put FIRST. For example: + + (\"Module Type\" ... ... t \"Module\\s-+Type\") + (\"Module\" ... ... t \"Module\") + +Is ok because the longer regexp is recognized first. + +If non-nil the optional INSERT-FUN is the function to be called when inserting +the form (instead of inserting INSERT, except when using \\[expand-abbrev]). This +allows to write functions asking for more information to assist the user. + +If non-nil the optional HIDE specifies that this form should not appear in the +menu but only in interactive completions. + +Example of what could be in your emacs init file: + +(defvar coq-user-tactics-db + '( + (\"mytac\" \"mt\" \"mytac # #\" t \"mytac\") + (\"myassert by\" \"massb\" \"myassert ( # : # ) by #\" t \"assert\") + )) + +Explanation of the first line: the tactic menu entry mytac, abbreviated by mt, +will insert \"mytac # #\" where #s are holes to fill, and \"mytac\" becomes a +new keyword to colorize." ) + +(defun coq-insert-from-db (db prompt) + "Ask for a keyword, with completion on keyword database DB and insert. +Insert corresponding string with holes at point. If an insertion function is +present for the keyword, call it instead. see `coq-syntax-db' for DB +structure." + (let* ((tac (completing-read (concat prompt " (tab for completion) : ") + db nil nil)) + (infos (cddr (assoc tac db))) + (s (car infos)) ; completion to insert + (f (car-safe (cdr-safe (cdr-safe (cdr infos))))) ; insertion function + (pt (point))) + (if f (funcall f) ; call f if present + (insert (or s tac)) ; insert completion and indent otherwise + (holes-replace-string-by-holes-backward-jump pt) + (indent-according-to-mode)))) + + + +(defun coq-build-regexp-list-from-db (db &optional filter) + "Take a keyword database DB and return the list of regexps for font-lock. +If non-nil Optional argument FILTER is a function applying to each line of DB. +For each line if FILTER returns nil, then the keyword is not added to the +regexp. See `coq-syntax-db' for DB structure." + (let ((l db) (res ())) + (while l + (let* ((hd (car l)) (tl (cdr l)) ; hd is the first infos list + (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry + (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation + (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion + (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing + (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string + ) + ;; TODO delete doublons + (when (and e5 (or (not filter) (funcall filter hd))) + (setq res (nconc res (list e5)))) ; careful: nconc destructive! + (setq l tl))) + res + )) + +;; Computes the max length of strings in a list +(defun max-length-db (db) + "Return the length of the longest first element (menu label) of DB. +See `coq-syntax-db' for DB structure." + (let ((l db) (res 0)) + (while l + (let ((lgth (length (car (car l))))) + (setq res (max lgth res)) + (setq l (cdr l)))) + res)) + + + +(defun coq-build-menu-from-db-internal (db lgth menuwidth) + "Take a keyword database DB and return one insertion submenu. +Argument LGTH is the max size of the submenu. Argument MENUWIDTH is the width +of the largest line in the menu (without abbrev and shortcut specifications). +Used by `coq-build-menu-from-db', which you should probably use instead. See +`coq-syntax-db' for DB structure." + (let ((l db) (res ()) (size lgth) + (keybind-abbrev (substitute-command-keys " \\[expand-abbrev]"))) + (while (and l (> size 0)) + (let* ((hd (car l))(tl (cdr l)) ; hd is a list of length 3 or 4 + (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry + (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation + (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion + (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing + (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string + (e6 (car-safe tl5)) ; e6 = function for smart insertion + (e7 (car-safe (cdr-safe tl5))) ; e7 = if non-nil : hide in menu + (entry-with (max (- menuwidth (length e1)) 0)) + (spaces (make-string entry-with ? )) + ;;(restofmenu (coq-build-menu-from-db-internal tl (- size 1) menuwidth)) + ) + (when (not e7) ;; if not hidden + (let ((menu-entry + (vector + ;; menu entry label + (concat e1 (if (not e2) "" (concat spaces "(" e2 keybind-abbrev ")"))) + ;;insertion function if present otherwise insert completion + (if e6 e6 `(holes-insert-and-expand ,e3)) + t))) + (setq res (nconc res (list menu-entry)))));; append *in place* + (setq l tl) + (setq size (- size 1)))) + res)) + + +(defun coq-build-title-menu (db size) + "Build a title for the first submenu of DB, of size SIZE. +Return the string made of the first and the SIZE nth first element of DB, +separated by \"...\". Used by `coq-build-menu-from-db'. See `coq-syntax-db' +for DB structure." + (concat (car-safe (car-safe db)) + " ... " + (car-safe (car-safe (nthcdr (- size 1) db))))) + +(defun coq-sort-menu-entries (menu) + (sort menu + '(lambda (x y) (string< + (downcase (elt x 0)) + (downcase (elt y 0)))))) + +(defun coq-build-menu-from-db (db &optional size) + "Take a keyword database DB and return a list of insertion menus for them. +Submenus contain SIZE entries (default 30). See `coq-syntax-db' for DB +structure." + ;; sort is destructive for the list, so copy list before sorting + (let* ((l (coq-sort-menu-entries (copy-list db))) (res ()) + (wdth (+ 2 (max-length-db db))) + (sz (or size 30)) (lgth (length l))) + (while l + (if (<= lgth sz) + (setq res ;; careful: nconc destructive! + (nconc res (list (cons + (coq-build-title-menu l lgth) + (coq-build-menu-from-db-internal l lgth wdth))))) + (setq res ; careful: nconc destructive! + (nconc res (list (cons + (coq-build-title-menu l sz) + (coq-build-menu-from-db-internal l sz wdth)))))) + (setq l (nthcdr sz l)) + (setq lgth (length l))) + res)) + +(defun coq-build-abbrev-table-from-db (db) + "Take a keyword database DB and return an abbrev table. +See `coq-syntax-db' for DB structure." + (let ((l db) (res ())) + (while l + (let* ((hd (car l))(tl (cdr l)) ; hd is a list of length 3 or 4 + (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry + (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation + (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion + ) + ;; careful: nconc destructive! + (when e2 + (setq res (nconc res (list `(,e2 ,e3 holes-abbrev-complete))))) + (setq l tl))) + res)) + + +(defun filter-state-preserving (l) + ; checkdoc-params: (l) + "Not documented." + (not (nth 3 l))) ; fourth argument is nil --> state preserving command + +(defun filter-state-changing (l) + ; checkdoc-params: (l) + "Not documented." + (nth 3 l)) ; fourth argument is nil --> state preserving command + + +;;A new face for tactics which fail when they don't kill the current goal +(defface coq-solve-tactics-face + (proof-face-specs + (:foreground "red" t) ; pour les fonds clairs + (:foreground "red" t) ; pour les fond foncés + ()) ; pour le noir et blanc + "Face for names of closing tactics in proof scripts." + :group 'proof-faces) + +(defconst coq-solve-tactics-face 'coq-solve-tactics-face + "Expression that evaluates to a face. +Required so that 'proof-solve-tactics-face is a proper facename") + + + +(provide 'coq-db) + +;;; coq-db.el ends here + +;** Local Variables: *** +;** fill-column: 80 *** +;** End: *** diff --git a/tools/coq-font-lock.el b/tools/coq-font-lock.el new file mode 100644 index 00000000..05618a04 --- /dev/null +++ b/tools/coq-font-lock.el @@ -0,0 +1,137 @@ +;; coq-font-lock.el --- Coq syntax highlighting for Emacs - compatibilty code +;; Pierre Courtieu, may 2009 +;; +;; Authors: Pierre Courtieu +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; Maintainer: Pierre Courtieu + +;; This is copy paste from ProofGeneral by David Aspinall +;; . ProofGeneral is under GPL and Copyright +;; (C) LFCS Edinburgh. + + +;;; Commentary: +;; This file contains the code necessary to coq-syntax.el and +;; coq-db.el from ProofGeneral. It is also pocked from ProofGeneral. + + +;;; History: +;; First created from ProofGeneral may 28th 2009 + + +;;; Code: + +(setq coq-version-is-V8-1 t) +(defun coq-build-regexp-list-from-db (db &optional filter) + "Take a keyword database DB and return the list of regexps for font-lock. +If non-nil Optional argument FILTER is a function applying to each line of DB. +For each line if FILTER returns nil, then the keyword is not added to the +regexp. See `coq-syntax-db' for DB structure." + (let ((l db) (res ())) + (while l + (let* ((hd (car l)) (tl (cdr l)) ; hd is the first infos list + (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry + (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation + (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion + (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing + (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string + ) + ;; TODO delete doublons + (when (and e5 (or (not filter) (funcall filter hd))) + (setq res (nconc res (list e5)))) ; careful: nconc destructive! + (setq l tl))) + res + )) +(defun filter-state-preserving (l) + ; checkdoc-params: (l) + "Not documented." + (not (nth 3 l))) ; fourth argument is nil --> state preserving command + +(defun filter-state-changing (l) + ; checkdoc-params: (l) + "Not documented." + (nth 3 l)) ; fourth argument is nil --> state preserving command + +;; Generic font-lock + +(defvar proof-id "\\(\\w\\(\\w\\|\\s_\\)*\\)" + "A regular expression for parsing identifiers.") + +;; For font-lock, we treat ,-separated identifiers as one identifier +;; and refontify commata using \{proof-zap-commas}. + +(defun proof-anchor-regexp (e) + "Anchor (\\`) and group the regexp E." + (concat "\\`\\(" e "\\)")) + +(defun proof-ids (proof-id &optional sepregexp) + "Generate a regular expression for separated lists of identifiers PROOF-ID. +Default is comma separated, or SEPREGEXP if set." + (concat proof-id "\\(\\s-*" (or sepregexp ",") "\\s-*" + proof-id "\\)*")) + +(defun proof-ids-to-regexp (l) + "Maps a non-empty list of tokens `L' to a regexp matching any element." + (if (featurep 'xemacs) + (mapconcat (lambda (s) (concat "\\_<" s "\\_>")) l "\\|") ;; old version + (concat "\\_<\\(?:" (mapconcat 'identity l "\\|") "\\)\\_>"))) + +;; TODO: get rid of this list. Does 'default work widely enough +;; by now? +(defconst pg-defface-window-systems + '(x ;; bog standard + mswindows ;; Windows + w32 ;; Windows + gtk ;; gtk emacs (obsolete?) + mac ;; used by Aquamacs + carbon ;; used by Carbon XEmacs + ns ;; NeXTstep Emacs (Emacs.app) + x-toolkit) ;; possible catch all (but probably not) + "A list of possible values for variable `window-system'. +If you are on a window system and your value of variable +`window-system' is not listed here, you may not get the correct +syntax colouring behaviour.") + +(defmacro proof-face-specs (bl bd ow) + "Return a spec for `defface' with BL for light bg, BD for dark, OW o/w." + `(append + (apply 'append + (mapcar + (lambda (ty) (list + (list (list (list 'type ty) '(class color) + (list 'background 'light)) + (quote ,bl)) + (list (list (list 'type ty) '(class color) + (list 'background 'dark)) + (quote ,bd)))) + pg-defface-window-systems)) + (list (list t (quote ,ow))))) + +;;A new face for tactics +(defface coq-solve-tactics-face + (proof-face-specs + (:foreground "forestgreen" t) ; pour les fonds clairs + (:foreground "forestgreen" t) ; pour les fond foncés + ()) ; pour le noir et blanc + "Face for names of closing tactics in proof scripts." + :group 'proof-faces) + +;;A new face for tactics which fail when they don't kill the current goal +(defface coq-solve-tactics-face + (proof-face-specs + (:foreground "red" t) ; pour les fonds clairs + (:foreground "red" t) ; pour les fond foncés + ()) ; pour le noir et blanc + "Face for names of closing tactics in proof scripts." + :group 'proof-faces) + + +(defconst coq-solve-tactics-face 'coq-solve-tactics-face + "Expression that evaluates to a face. +Required so that 'proof-solve-tactics-face is a proper facename") + +(defconst proof-tactics-name-face 'coq-solve-tactics-face) +(defconst proof-tacticals-name-face 'coq-solve-tactics-face) + +(provide 'coq-font-lock) +;;; coq-font-lock.el ends here diff --git a/tools/coq-syntax.el b/tools/coq-syntax.el new file mode 100644 index 00000000..5b88f6a5 --- /dev/null +++ b/tools/coq-syntax.el @@ -0,0 +1,974 @@ +;; coq-syntax.el Font lock expressions for Coq +;; Copyright (C) 1997-2007 LFCS Edinburgh. +;; Authors: Thomas Kleymann, Healfdene Goguen, Pierre Courtieu +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; Maintainer: Pierre Courtieu + +;; coq-syntax.el,v 9.9 2008/07/21 15:14:58 pier Exp + +;(require 'proof-syntax) +;(require 'proof-utils) ; proof-locate-executable +(require 'coq-db) + + + + ;;; keyword databases + + +(defcustom coq-user-tactics-db nil + "User defined tactic information. See `coq-syntax-db' for + syntax. It is not necessary to add your own tactics here (it is not + needed by the synchronizing/backtracking system). You may however do + so for the following reasons: + + 1 your tactics will be colorized by font-lock + + 2 your tactics will be added to the menu and to completion when + calling \\[coq-insert-tactic] + + 3 you may define an abbreviation for your tactic." + + :type '(repeat sexp) + :group 'coq) + + +(defcustom coq-user-commands-db nil + "User defined command information. See `coq-syntax-db' for + syntax. It is not necessary to add your own commands here (it is not + needed by the synchronizing/backtracking system). You may however do + so for the following reasons: + + 1 your commands will be colorized by font-lock + + 2 your commands will be added to the menu and to completion when + calling \\[coq-insert-command] + + 3 you may define an abbreviation for your command." + + :type '(repeat sexp) + :group 'coq) + +(defcustom coq-user-tacticals-db nil + "User defined tactical information. See `coq-syntax-db' for + syntax. It is not necessary to add your own commands here (it is not + needed by the synchronizing/backtracking system). You may however do + so for the following reasons: + + 1 your commands will be colorized by font-lock + + 2 your commands will be added to the menu and to completion when + calling \\[coq-insert-command] + + 3 you may define an abbreviation for your command." + + :type '(repeat sexp) + :group 'coq) + +(defcustom coq-user-solve-tactics-db nil + "User defined closing tactics. See `coq-syntax-db' for + syntax. It is not necessary to add your own commands here (it is not + needed by the synchronizing/backtracking system). You may however do + so for the following reasons: + + 1 your commands will be colorized by font-lock + + 2 your commands will be added to the menu and to completion when + calling \\[coq-insert-command] + + 3 you may define an abbreviation for your command." + + :type '(repeat sexp) + :group 'coq) + + + +(defcustom coq-user-reserved-db nil + "User defined reserved keywords information. See `coq-syntax-db' for + syntax. It is not necessary to add your own commands here (it is not + needed by the synchronizing/backtracking system). You may however do + so for the following reasons: + + 1 your commands will be colorized by font-lock + + 2 your commands will be added to the menu and to completion when + calling \\[coq-insert-command] + + 3 you may define an abbreviation for your command." + + :type '(repeat sexp) + :group 'coq) + + + +(defvar coq-tactics-db + (append + coq-user-tactics-db + '( + ("absurd " "abs" "absurd " t "absurd") + ("apply" "ap" "apply " t "apply") + ("assert by" "assb" "assert ( # : # ) by #" t "assert") + ("assert" "ass" "assert ( # : # )" t) + ;; ("assumption" "as" "assumption" t "assumption") + ("auto with arith" "awa" "auto with arith" t) + ("auto with" "aw" "auto with @{db}" t) + ("auto" "a" "auto" t "auto") + ("autorewrite with in using" "arwiu" "autorewrite with @{db,db...} in @{hyp} using @{tac}" t) + ("autorewrite with in" "arwi" "autorewrite with @{db,db...} in @{hyp}" t) + ("autorewrite with using" "arwu" "autorewrite with @{db,db...} using @{tac}" t) + ("autorewrite with" "ar" "autorewrite with @{db,db...}" t "autorewrite") + ("case" "c" "case " t "case") + ("cbv" "cbv" "cbv beta [#] delta iota zeta" t "cbv") + ("change in" "chi" "change # in #" t) + ("change with in" "chwi" "change # with # in #" t) + ("change with" "chw" "change # with" t) + ("change" "ch" "change " t "change") + ("clear" "cl" "clear" t "clear") + ("clearbody" "cl" "clearbody" t "clearbody") + ("cofix" "cof" "cofix" t "cofix") + ("coinduction" "coind" "coinduction" t "coinduction") + ("compare" "cmpa" "compare # #" t "compare") + ("compute" "cmpu" "compute" t "compute") + ;; ("congruence" "cong" "congruence" t "congruence") + ("constructor" "cons" "constructor" t "constructor") + ;; ("contradiction" "contr" "contradiction" t "contradiction") + ("cut" "cut" "cut" t "cut") + ("cutrewrite" "cutr" "cutrewrite -> # = #" t "cutrewrite") + ;; ("decide equality" "deg" "decide equality" t "decide\\s-+equality") + ("decompose record" "decr" "decompose record #" t "decompose\\s-+record") + ("decompose sum" "decs" "decompose sum #" t "decompose\\s-+sum") + ("decompose" "dec" "decompose [#] #" t "decompose") + ("dependent inversion" "depinv" "dependent inversion" t "dependent\\s-+inversion") + ("dependent inversion with" "depinvw" "dependent inversion # with #" t) + ("dependent inversion_clear" "depinvc" "dependent inversion_clear" t "dependent\\s-+inversion_clear") + ("dependent inversion_clear with" "depinvw" "dependent inversion_clear # with #" t) + ("dependent rewrite ->" "depr" "dependent rewrite -> @{id}" t "dependent\\s-+rewrite") + ("dependent rewrite <-" "depr<" "dependent rewrite <- @{id}" t) + ("destruct as" "desa" "destruct # as #" t) + ("destruct using" "desu" "destruct # using #" t) + ("destruct" "des" "destruct " t "destruct") + ;; ("discriminate" "dis" "discriminate" t "discriminate") + ("discrR" "discrR" "discrR" t "discrR") + ("double induction" "dind" "double induction # #" t "double\\s-+induction") + ("eapply" "eap" "eapply #" t "eapply") + ("eauto with arith" "eawa" "eauto with arith" t) + ("eauto with" "eaw" "eauto with @{db}" t) + ("eauto" "ea" "eauto" t "eauto") + ("econstructor" "econs" "econstructor" t "econstructor") + ("eexists" "eex" "eexists" t "eexists") + ("eleft" "eleft" "eleft" t "eleft") + ("elim using" "elu" "elim # using #" t) + ("elim" "e" "elim #" t "elim") + ("elimtype" "elt" "elimtype" "elimtype") + ("eright" "erig" "eright" "eright") + ("esplit" "esp" "esplit" t "esplit") + ;; ("exact" "exa" "exact" t "exact") + ("exists" "ex" "exists #" t "exists") + ;; ("fail" "fa" "fail" nil) + ;; ("field" "field" "field" t "field") + ("firstorder" "fsto" "firstorder" t "firstorder") + ("firstorder with" "fsto" "firstorder with #" t) + ("firstorder with using" "fsto" "firstorder # with #" t) + ("fold" "fold" "fold #" t "fold") + ;; ("fourier" "four" "fourier" t "fourier") + ("functional induction" "fi" "functional induction @{f} @{args}" t "functional\\s-+induction") + ("generalize dependent" "gd" "generalize dependent #" t "generalize\\s-+dependent") + ("generalize" "g" "generalize #" t "generalize") + ("hnf" "hnf" "hnf" t "hnf") + ("idtac" "id" "idtac" nil "idtac") ; also in tacticals with abbrev id + ("idtac \"" "id\"" "idtac \"#\"") ; also in tacticals + ("induction" "ind" "induction #" t "induction") + ("induction using" "indu" "induction # using #" t) + ("injection" "inj" "injection #" t "injection") + ("instantiate" "inst" "instantiate" t "instantiate") + ("intro" "i" "intro" t "intro") + ("intro after" "ia" "intro # after #" t) + ("intros" "is" "intros #" t "intros") + ("intros! (guess names)" nil "intros #" nil nil coq-insert-intros) + ("intros until" "isu" "intros until #" t) + ("intuition" "intu" "intuition #" t "intuition") + ("inversion" "inv" "inversion #" t "inversion") + ("inversion in" "invi" "inversion # in #" t) + ("inversion using" "invu" "inversion # using #" t) + ("inversion using in" "invui" "inversion # using # in #" t) + ("inversion_clear" "invcl" "inversion_clear" t "inversion_clear") + ("lapply" "lap" "lapply" t "lapply") + ("lazy" "lazy" "lazy beta [#] delta iota zeta" t "lazy") + ("left" "left" "left" t "left") + ("linear" "lin" "linear" t "linear") + ("load" "load" "load" t "load") + ("move after" "mov" "move # after #" t "move") + ("omega" "o" "omega" t "omega") + ("pattern" "pat" "pattern" t "pattern") + ("pattern(s)" "pats" "pattern # , #" t) + ("pattern at" "pata" "pattern # at #" t) + ("pose" "po" "pose ( # := # )" t "pose") + ("prolog" "prol" "prolog" t "prolog") + ("quote" "quote" "quote" t "quote") + ("quote []" "quote2" "quote # [#]" t) + ("red" "red" "red" t "red") + ("refine" "ref" "refine" t "refine") + ;; ("reflexivity" "refl" "reflexivity #" t "reflexivity") + ("rename into" "ren" "rename # into #" t "rename") + ("replace with" "rep" "replace # with #" t "replace") + ("replace with in" "repi" "replace # with # in #" t) + ("rewrite <- in" "ri<" "rewrite <- # in #" t) + ("rewrite <-" "r<" "rewrite <- #" t) + ("rewrite in" "ri" "rewrite # in #" t) + ("rewrite" "r" "rewrite #" t "rewrite") + ("right" "rig" "right" t "right") + ;; ("ring" "ring" "ring #" t "ring") + ("set in * |-" "seth" "set ( # := #) in * |-" t) + ("set in *" "set*" "set ( # := #) in *" t) + ("set in |- *" "setg" "set ( # := #) in |- *" t) + ("set in" "seti" "set ( # := #) in #" t) + ("set" "set" "set ( # := #)" t "set") + ("setoid_replace with" "strep2" "setoid_replace # with #" t "setoid_replace") + ("setoid replace with" "strep" "setoid replace # with #" t "setoid\\s-+replace") + ("setoid_rewrite" "strew" "setoid_rewrite #" t "setoid_rewrite") + ("setoid rewrite" "strew" "setoid rewrite #" t "setoid\\s-+rewrite") + ("simpl" "s" "simpl" t "simpl") + ("simpl" "sa" "simpl # at #" t) + ("simple destruct" "sdes" "simple destruct" t "simple\\s-+destruct") + ("simple inversion" "sinv" "simple inversion" t "simple\\s-+inversion") + ("simple induction" "sind" "simple induction" t "simple\\s-+induction") + ("simplify_eq" "simeq" "simplify_eq @{hyp}" t "simplify_eq") + ("specialize" "spec" "specialize" t "specialize") + ("split" "sp" "split" t "split") + ("split_Rabs" "spra" "splitRabs" t "split_Rabs") + ("split_Rmult" "sprm" "splitRmult" t "split_Rmult") + ("stepl" "stl" "stepl #" t "stepl") + ("stepl by" "stlb" "stepl # by #" t) + ("stepr" "str" "stepr #" t "stepr") + ("stepr by" "strb" "stepr # by #" t) + ("subst" "su" "subst #" t "subst") + ("symmetry" "sy" "symmetry" t "symmetry") + ("symmetry in" "syi" "symmetry in #" t) + ;; ("tauto" "ta" "tauto" t "tauto") + ("transitivity" "trans" "transitivity #" t "transitivity") + ("trivial" "t" "trivial" t "trivial") + ("trivial with" "tw" "trivial with @{db}" t) + ("unfold" "u" "unfold #" t "unfold") + ("unfold(s)" "us" "unfold # , #" t) + ("unfold in" "unfi" "unfold # in #" t) + ("unfold at" "unfa" "unfold # at #" t) + )) + "Coq tactics information list. See `coq-syntax-db' for syntax. " + ) + +(defvar coq-solve-tactics-db + (append + coq-user-solve-tactics-db + '( + ("assumption" "as" "assumption" t "assumption") + ("by" "by" "by #" t "by") + ("congruence" "cong" "congruence" t "congruence") + ("contradiction" "contr" "contradiction" t "contradiction") + ("decide equality" "deg" "decide equality" t "decide\\s-+equality") + ("discriminate" "dis" "discriminate" t "discriminate") + ("exact" "exa" "exact" t "exact") + ("fourier" "four" "fourier" t "fourier") + ("fail" "fa" "fail" nil) + ("field" "field" "field" t "field") + ("omega" "o" "omega" t "omega") + ("reflexivity" "refl" "reflexivity #" t "reflexivity") + ("ring" "ring" "ring #" t "ring") + ("solve" nil "solve [ # | # ]" nil "solve") + ("tauto" "ta" "tauto" t "tauto") + )) + "Coq tactic(al)s that solve a subgoal." + ) + + +(defvar coq-tacticals-db + (append + coq-user-tacticals-db + '( + ("info" nil "info #" nil "info") + ("first" nil "first [ # | # ]" nil "first") + ("abstract" nil "abstract @{tac} using @{name}." nil "abstract") + ("do" nil "do @{num} @{tac}" nil "do") + ("idtac" nil "idtac") ; also in tactics + ; ("idtac \"" nil "idtac \"#\"") ; also in tactics + ("fail" "fa" "fail" nil "fail") + ; ("fail \"" "fa\"" "fail" nil) ; + ; ("orelse" nil "orelse #" t "orelse") + ("repeat" nil "repeat #" nil "repeat") + ("try" nil "try #" nil "try") + ("progress" nil "progress #" nil "progress") + ("|" nil "[ # | # ]" nil) + ("||" nil "# || #" nil) + )) + "Coq tacticals information list. See `coq-syntax-db' for syntax.") + + + + +(defvar coq-decl-db + '( + ("Axiom" "ax" "Axiom # : #" t "Axiom") + ("Hint Constructors" "hc" "Hint Constructors # : #." t "Hint\\s-+Constructors") + ("Hint Extern" "he" "Hint Extern @{cost} @{pat} => @{tac} : @{db}." t "Hint\\s-+Extern") + ("Hint Immediate" "hi" "Hint Immediate # : @{db}." t "Hint\\s-+Immediate") + ("Hint Resolve" "hr" "Hint Resolve # : @{db}." t "Hint\\s-+Resolve") + ("Hint Rewrite ->" "hrw" "Hint Rewrite -> @{t1,t2...} using @{tac} : @{db}." t "Hint\\s-+Rewrite") + ("Hint Rewrite <-" "hrw" "Hint Rewrite <- @{t1,t2...} using @{tac} : @{db}." t ) + ("Hint Unfold" "hu" "Hint Unfold # : #." t "Hint\\s-+Unfold") + ("Hypothesis" "hyp" "Hypothesis #: #" t "Hypothesis") + ("Hypotheses" "hyp" "Hypotheses #: #" t "Hypotheses") + ("Parameter" "par" "Parameter #: #" t "Parameter") + ("Parameters" "par" "Parameter #: #" t "Parameters") + ("Conjecture" "conj" "Conjecture #: #." t "Conjecture") + ("Variable" "v" "Variable #: #." t "Variable") + ("Variables" "vs" "Variables # , #: #." t "Variables") + ("Coercion" "coerc" "Coercion @{id} : @{typ1} >-> @{typ2}." t "Coercion") + ) + "Coq declaration keywords information list. See `coq-syntax-db' for syntax." + ) + +(defvar coq-defn-db + '( + ("CoFixpoint" "cfix" "CoFixpoint # (#:#) : # :=\n#." t "CoFixpoint") + ("CoInductive" "coindv" "CoInductive # : # :=\n|# : #." t "CoInductive") + ("Declare Module : :=" "dm" "Declare Module # : # := #." t "Declare\\s-+Module") + ("Declare Module <: :=" "dm2" "Declare Module # <: # := #." t);; careful + ("Declare Module Import : :=" "dmi" "Declare Module # : # := #." t) + ("Declare Module Import <: :=" "dmi2" "Declare Module # <: # := #." t);; careful + ("Declare Module Export : :=" "dme" "Declare Module # : # := #." t) + ("Declare Module Export <: :=" "dme2" "Declare Module # <: # := #." t);; careful + ("Definition" "def" "Definition #:# := #." t "Definition");; careful + ("Definition (2 args)" "def2" "Definition # (# : #) (# : #):# := #." t) + ("Definition (3 args)" "def3" "Definition # (# : #) (# : #) (# : #):# := #." t) + ("Definition (4 args)" "def4" "Definition # (# : #) (# : #) (# : #) (# : #):# := #." t) + ("Program Definition" "pdef" "Program Definition #:# := #." t "Program\\s-+Definition");; careful ? + ("Program Definition (2 args)" "pdef2" "Program Definition # (# : #) (# : #):# := #." t) + ("Program Definition (3 args)" "pdef3" "Program Definition # (# : #) (# : #) (# : #):# := #." t) + ("Program Definition (4 args)" "pdef4" "Program Definition # (# : #) (# : #) (# : #) (# : #):# := #." t) + ("Derive Inversion" nil "Derive Inversion @{id} with # Sort #." t "Derive\\s-+Inversion") + ("Derive Dependent Inversion" nil "Derive Dependent Inversion @{id} with # Sort #." t "Derive\\s-+Dependent\\s-+Inversion") + ("Derive Inversion_clear" nil "Derive Inversion_clear @{id} with # Sort #." t) + ("Fixpoint" "fix" "Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Fixpoint") + ("Program Fixpoint" "pfix" "Program Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Program\\s-+Fixpoint") + ("Program Fixpoint measure" "pfixm" "Program Fixpoint # (#:#) {measure @{arg} @{f}} : # :=\n#." t) + ("Program Fixpoint wf" "pfixwf" "Program Fixpoint # (#:#) {wf @{arg} @{f}} : # :=\n#." t) + ("Function" "func" "Function # (#:#) {struct @{arg}} : # :=\n#." t "Function") + ("Function measure" "funcm" "Function # (#:#) {measure @{f} @{arg}} : # :=\n#." t) + ("Function wf" "func wf" "Function # (#:#) {wf @{R} @{arg}} : # :=\n#." t) + ("Functional Scheme with" "fsw" "Functional Scheme @{name} := Induction for @{fun} with @{mutfuns}." t ) + ("Functional Scheme" "fs" "Functional Scheme @{name} := Induction for @{fun}." t "Functional\\s-+Scheme") + ("Inductive" "indv" "Inductive # : # := # : #." t "Inductive") + ("Inductive (2 args)" "indv2" "Inductive # : # :=\n| # : #\n| # : #." t ) + ("Inductive (3 args)" "indv3" "Inductive # : # :=\n| # : #\n| # : #\n| # : #." t ) + ("Inductive (4 args)" "indv4" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t ) + ("Inductive (5 args)" "indv5" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t ) + ("Let" "Let" "Let # : # := #." t "Let") + ("Ltac" "ltac" "Ltac # := #" t "Ltac") + ("Module :=" "mo" "Module # : # := #." t ) ; careful + ("Module <: :=" "mo2" "Module # <: # := #." t ) ; careful + ("Module Import :=" "moi" "Module Import # : # := #." t ) ; careful + ("Module Import <: :=" "moi2" "Module Import # <: # := #." t ) ; careful + ("Module Export :=" "moe" "Module Export # : # := #." t ) ; careful + ("Module Export <: :=" "moe2" "Module Export# <: # := #." t ) ; careful + ("Record" "rec" "Record # : # := {\n# : #;\n# : # }" t "Record") + ("Scheme" "sc" "Scheme @{name} := #." t "Scheme") + ("Scheme Induction" "sci" "Scheme @{name} := Induction for # Sort #." t) + ("Scheme Minimality" "scm" "Scheme @{name} := Minimality for # Sort #." t) + ("Structure" "str" "Structure # : # := {\n# : #;\n# : # }" t "Structure") + ) + "Coq definition keywords information list. See `coq-syntax-db' for syntax. " + ) + +;; modules and section are indented like goal starters +(defvar coq-goal-starters-db + '( + ("Add Morphism" "addmor" "Add Morphism @{f} : @{id}" t "Add\\s-+Morphism") + ("Chapter" "chp" "Chapter # : #." t "Chapter") + ("Corollary" "cor" "Corollary # : #.\nProof.\n#\nQed." t "Corollary") + ("Declare Module :" "dmi" "Declare Module # : #.\n#\nEnd #." t) + ("Declare Module <:" "dmi2" "Declare Module # <: #.\n#\nEnd #." t) + ("Definition goal" "defg" "Definition #:#.\n#\nSave." t);; careful + ("Fact" "fct" "Fact # : #." t "Fact") + ("Goal" nil "Goal #." t "Goal") + ("Lemma" "l" "Lemma # : #.\nProof.\n#\nQed." t "Lemma") + ("Program Lemma" "pl" "Program Lemma # : #.\nProof.\n#\nQed." t "Program\\s-+Lemma") + ("Module! (interactive)" nil "Module # : #.\n#\nEnd #." nil nil coq-insert-section-or-module) + ("Module Type" "mti" "Module Type #.\n#\nEnd #." t "Module\\s-+Type") ; careful + ("Module :" "moi" "Module # : #.\n#\nEnd #." t "Module") ; careful + ("Module <:" "moi2" "Module # <: #.\n#\nEnd #." t ) ; careful + ("Remark" "rk" "Remark # : #.\n#\nQed." t "Remark") + ("Section" "sec" "Section #." t "Section") + ("Theorem" "th" "Theorem # : #.\n#\nQed." t "Theorem") + ("Program Theorem" "pth" "Program Theorem # : #.\nProof.\n#\nQed." t "Program\\s-+Theorem") + ("Obligation" "obl" "Obligation #.\n#\nQed." t "Obligation") + ("Next Obligation" "nobl" "Next Obligation.\n#\nQed." t "Next Obligation") + ) + "Coq goal starters keywords information list. See `coq-syntax-db' for syntax. " + ) + +;; command that are not declarations, definition or goal starters +(defvar coq-other-commands-db + '( + ;; ("Abort" nil "Abort." t "Abort" nil nil);don't appear in menu + ("About" nil "About #." nil "About") + ("Add" nil "Add #." nil "Add" nil t) + ("Add Abstract Ring" nil "Add Abstract Ring #." t "Add\\s-+Abstract\\s-+Ring") + ("Add Abstract Semi Ring" nil "Add Abstract Semi Ring #." t "Add\\s-+Abstract\\s-+Semi\\s-+Ring") + ("Add Field" nil "Add Field #." t "Add\\s-+Field") + ("Add LoadPath" nil "Add LoadPath #." nil "Add\\s-+LoadPath") + ("Add ML Path" nil "Add ML Path #." nil "Add\\s-+ML\\s-+Path") + ("Add Morphism" nil "Add Morphism #." t "Add\\s-+Morphism") + ("Add Printing" nil "Add Printing #." t "Add\\s-+Printing") + ("Add Printing If" nil "Add Printing If #." t "Add\\s-+Printing\\s-+If") + ("Add Printing Let" nil "Add Printing Let #." t "Add\\s-+Printing\\s-+Let") + ("Add Rec LoadPath" nil "Add Rec LoadPath #." nil "Add\\s-+Rec\\s-+LoadPath") + ("Add Rec ML Path" nil "Add Rec ML Path #." nil "Add\\s-+Rec\\s-+ML\\s-+Path") + ("Add Ring" nil "Add Ring #." t "Add\\s-+Ring") + ("Add Semi Ring" nil "Add Semi Ring #." t "Add\\s-+Semi\\s-+Ring") + ("Add Setoid" nil "Add Setoid #." t "Add\\s-+Setoid") + ("Admit Obligations" "oblsadmit" "Admit Obligations." nil "Admit\\s-+Obligations") + ("Arguments Scope" "argsc" "Arguments Scope @{id} [ @{_} ]" t "Arguments\\s-+Scope") + ("Bind Scope" "bndsc" "Bind Scope @{scope} with @{type}" t "Bind\\s-+Scope") + ("Canonical Structure" nil "Canonical Structure #." t "Canonical\\s-+Structure") + ("Cd" nil "Cd #." nil "Cd") + ("Check" nil "Check" nil "Check") + ("Close Local Scope" "cllsc" "Close Local Scope #" t "Close\\s-+Local\\s-+Scope") + ("Close Scope" "clsc" "Close Scope #" t "Close\\s-+Scope") + ("Comments" nil "Comments #." nil "Comments") + ("Delimit Scope" "delsc" "Delimit Scope @{scope} with @{id}." t "Delimit\\s-+Scope" ) + ("Eval" nil "Eval #." nil "Eval") + ("Export" nil "Export #." t "Export") + ("Extract Constant" "extrc" "Extract Constant @{id} => \"@{id}\"." nil "Extract\\s-+Constant") + ("Extract Inlined Constant" "extric" "Extract Inlined Constant @{id} => \"@{id}\"." nil "Extract\\s-+Inlined\\s-+Constant") + ("Extract Inductive" "extri" "Extract Inductive @{id} => \"@{id}\" [\"@{id}\" \"@{id...}\"]." nil "Extract") + ("Extraction" "extr" "Extraction @{id}." nil "Extraction") + ("Extraction (in a file)" "extrf" "Extraction \"@{file}\" @{id}." nil) + ("Extraction Inline" nil "Extraction Inline #." t "Extraction\\s-+Inline") + ("Extraction NoInline" nil "Extraction NoInline #." t "Extraction\\s-+NoInline") + ("Extraction Language" "extrlang" "Extraction Language #." t "Extraction\\s-+Language") + ("Extraction Library" "extrl" "Extraction Library @{id}." nil "Extraction\\s-+Library") + ("Focus" nil "Focus #." nil "Focus") + ("Identity Coercion" nil "Identity Coercion #." t "Identity\\s-+Coercion") + ("Implicit Arguments Off" nil "Implicit Arguments Off." t "Implicit\\s-+Arguments\\s-+Off") + ("Implicit Arguments On" nil "Implicit Arguments On." t "Implicit\\s-+Arguments\\s-+On") + ("Implicit Arguments" nil "Implicit Arguments # [#]." t "Implicit\\s-+Arguments") + ("Import" nil "Import #." t "Import") + ("Infix" "inf" "Infix \"#\" := # (at level #) : @{scope}." t "Infix") + ("Inspect" nil "Inspect #." nil "Inspect") + ("Locate" nil "Locate" nil "Locate") + ("Locate File" nil "Locate File \"#\"." nil "Locate\\s-+File") + ("Locate Library" nil "Locate Library #." nil "Locate\\s-+Library") + ("Notation (assoc)" "notas" "Notation \"#\" := # (at level #, # associativity)." t) + ("Notation (at assoc)" "notassc" "Notation \"#\" := # (at level #, # associativity) : @{scope}." t) + ("Notation (at at scope)" "notasc" "Notation \"#\" := # (at level #, # at level #) : @{scope}." t) + ("Notation (at at)" "nota" "Notation \"#\" := # (at level #, # at level #)." t) + ("Notation (only parsing)" "notsp" "Notation # := # (only parsing)." t) + ("Notation Local (only parsing)" "notslp" "Notation Local # := # (only parsing)." t) + ("Notation Local" "notsl" "Notation Local # := #." t "Notation\\s-+Local") + ("Notation (simple)" "nots" "Notation # := #." t "Notation") + ("Opaque" nil "Opaque #." nil "Opaque") + ("Obligations Tactic" nil "Obligations Tactic := #." t "Obligations\\s-+Tactic") + ("Open Local Scope" "oplsc" "Open Local Scope #" t "Open\\s-+Local\\s-+Scope") + ("Open Scope" "opsc" "Open Scope #" t "Open\\s-+Scope") + ("Print Coercions" nil "Print Coercions." nil "Print\\s-+Coercions") + ("Print Hint" nil "Print Hint." nil "Print\\s-+Hint" coq-PrintHint) + ("Print" "p" "Print #." nil "Print") + ("Qed" nil "Qed." nil "Qed") + ("Pwd" nil "Pwd." nil "Pwd") + ("Recursive Extraction" "recextr" "Recursive Extraction @{id}." nil "Recursive\\s-+Extraction") + ("Recursive Extraction Library" "recextrl" "Recursive Extraction Library @{id}." nil "Recursive\\s-+Extraction\\s-+Library") + ("Recursive Extraction Module" "recextrm" "Recursive Extraction Module @{id}." nil "Recursive\\s-+Extraction\\s-+Module") + ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath") + ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath") + ("Remove Printing If" nil "Remove Printing If #." t "Remove\\s-+Printing\\s-+If") + ("Remove Printing Let" nil "Remove Printing Let #." t "Remove\\s-+Printing\\s-+Let") + ("Require Export" nil "Require Export #." t "Require\\s-+Export") + ("Require Import" nil "Require Import #." t "Require\\s-+Import") + ("Require" nil "Require #." t "Require") + ("Reserved Notation" nil "Reserved Notation" nil "Reserved\\s-+Notation") + ("Reset Extraction Inline" nil "Reset Extraction Inline." t "Reset\\s-+Extraction\\s-+Inline") + ("Save" nil "Save." t "Save") + ("Search" nil "Search #" nil "Search") + ("SearchAbout" nil "SearchAbout #" nil "SearchAbout") + ("SearchPattern" nil "SearchPattern #" nil "SearchPattern") + ("SearchRewrite" nil "SearchRewrite #" nil "SearchRewrite") + ("Set Extraction AutoInline" nil "Set Extraction AutoInline" t "Set\\s-+Extraction\\s-+AutoInline") + ("Set Extraction Optimize" nil "Set Extraction Optimize" t "Set\\s-+Extraction\\s-+Optimize") + ("Set Implicit Arguments" nil "Set Implicit Arguments" t "Set\\s-+Implicit\\s-+Arguments") + ("Set Strict Implicit" nil "Set Strict Implicit" t "Set\\s-+Strict\\s-+Implicit") + ("Set Printing Synth" nil "Set Printing Synth" t "Set\\s-+Printing\\s-+Synth") + ("Set Printing Wildcard" nil "Set Printing Wildcard" t "Set\\s-+Printing\\s-+Wildcard") + ("Set Printing All" "sprall" "Set Printing All" t "Set\\s-+Printing\\s-+All") + ("Set Hyps Limit" nil "Set Hyps Limit #." nil "Set\\s-+Hyps\\s-+Limit") + ("Set Printing Coercions" nil "Set Printing Coercions." t "Set\\s-+Printing\\s-+Coercions") + ("Set Printing Notations" "sprn" "Set Printing Notations" t "Set\\s-+Printing\\s-+Notations") + ("Set Undo" nil "Set Undo #." nil "Set\\s-+Undo") + ("Show" nil "Show #." nil "Show") + ("Solve Obligations" "oblssolve" "Solve Obligations using #." nil "Solve\\s-+Obligations") + ("Test" nil "Test" nil "Test" nil t) + ("Test Printing Depth" nil "Test Printing Depth." nil "Test\\s-+Printing\\s-+Depth") + ("Test Printing If" nil "Test Printing If #." nil "Test\\s-+Printing\\s-+If") + ("Test Printing Let" nil "Test Printing Let #." nil "Test\\s-+Printing\\s-+Let") + ("Test Printing Synth" nil "Test Printing Synth." nil "Test\\s-+Printing\\s-+Synth") + ("Test Printing Width" nil "Test Printing Width." nil "Test\\s-+Printing\\s-+Width") + ("Test Printing Wildcard" nil "Test Printing Wildcard." nil "Test\\s-+Printing\\s-+Wildcard") + ("Transparent" nil "Transparent #." nil "Transparent") + ("Unfocus" nil "Unfocus." nil "Unfocus") + ("Unset Extraction AutoInline" nil "Unset Extraction AutoInline" t "Unset\\s-+Extraction\\s-+AutoInline") + ("Unset Extraction Optimize" nil "Unset Extraction Optimize" t "Unset\\s-+Extraction\\s-+Optimize") + ("Unset Implicit Arguments" nil "Unset Implicit Arguments" t "Unset\\s-+Implicit\\s-+Arguments") + ("Unset Strict Implicit" nil "Unset Strict Implicit" t "Unset\\s-+Strict\\s-+Implicit") + ("Unset Printing Synth" nil "Unset Printing Synth" t "Unset\\s-+Printing\\s-+Synth") + ("Unset Printing Wildcard" nil "Unset Printing Wildcard" t "Unset\\s-+Printing\\s-+Wildcard") + ("Unset Hyps Limit" nil "Unset Hyps Limit" nil "Unset\\s-+Hyps\\s-+Limit") + ("Unset Printing All" "unsprall" "Unset Printing All" nil "Unset\\s-+Printing\\s-+All") + ("Unset Printing Coercion" nil "Unset Printing Coercion #." t "Unset\\s-+Printing\\s-+Coercion") + ("Unset Printing Coercions" nil "Unset Printing Coercions." nil "Unset\\s-+Printing\\s-+Coercions") + ("Unset Printing Notations" "unsprn" "Unset Printing Notations" nil "Unset\\s-+Printing\\s-+Notations") + ("Unset Undo" nil "Unset Undo." nil "Unset\\s-+Undo") + ; ("print" "pr" "print #" "print") + ) + "Command that are not declarations, definition or goal starters." + ) + +(defvar coq-commands-db + (append coq-decl-db coq-defn-db coq-goal-starters-db + coq-other-commands-db coq-user-commands-db) + "Coq all commands keywords information list. See `coq-syntax-db' for syntax. " + ) + + +(defvar coq-terms-db + '( + ("fun (1 args)" "f" "fun #:# => #" nil "fun") + ("fun (2 args)" "f2" "fun (#:#) (#:#) => #") + ("fun (3 args)" "f3" "fun (#:#) (#:#) (#:#) => #") + ("fun (4 args)" "f4" "fun (#:#) (#:#) (#:#) (#:#) => #") + ("forall" "fo" "forall #:#,#" nil "forall") + ("forall (2 args)" "fo2" "forall (#:#) (#:#), #") + ("forall (3 args)" "fo3" "forall (#:#) (#:#) (#:#), #") + ("forall (4 args)" "fo4" "forall (#:#) (#:#) (#:#) (#:#), #") + ("if" "if" "if # then # else #" nil "if") + ("let in" "li" "let # := # in #" nil "let") + ("match! (from type)" nil "" nil "match" coq-insert-match) + ("match with" "m" "match # with\n| # => #\nend") + ("match with 2" "m2" "match # with\n| # => #\n| # => #\nend") + ("match with 3" "m3" "match # with\n| # => #\n| # => #\n| # => #\nend") + ("match with 4" "m4" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\nend") + ("match with 5" "m5" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\n| # => #\nend") + ) + "Coq terms keywords information list. See `coq-syntax-db' for syntax. " + ) + + + + + + + + ;;; Goals (and module/sections) starters detection + + +;; ----- keywords for font-lock. + +;; FIXME da: this one function breaks the nice configuration of Proof General: +;; would like to have proof-goal-regexp instead. +;; Unfortunately Coq allows "Definition" and friends to perhaps have a goal, +;; so it appears more difficult than just a proof-goal-regexp setting. +;; Future improvement may simply to be allow a function value for +;; proof-goal-regexp. + +;; FIXME Pierre: the right way IMHO here would be to set a span +;; property 'goalcommand when coq prompt says it (if the name of +;; current proof has changed). + +;; excerpt of Jacek Chrzaszcz, implementer of the module system: sorry +;; for the french: +;;*) suivant les suggestions de Chritine, pas de mode preuve dans un type de +;; module (donc pas de Definition truc:machin. Lemma, Theorem ... ) +;; +;; *) la commande Module M [ ( : | <: ) MTYP ] [ := MEXPR ] est valable +;; uniquement hors d'un MT +;; - si :=MEXPR est absent, elle demarre un nouveau module interactif +;; - si :=MEXPR est present, elle definit un module +;; (la fonction vernac_define_module dans toplevel/vernacentries) +;; +;; *) la nouvelle commande Declare Module M [ ( : | <: ) MTYP ] [ := MEXPR ] +;; est valable uniquement dans un MT +;; - si :=MEXPR absent, :MTYP absent, elle demarre un nouveau module +;; interactif +;; - si (:=MEXPR absent, :MTYP present) +;; ou (:=MEXPR present, :MTYP absent) +;; elle declare un module. +;; (la fonction vernac_declare_module dans toplevel/vernacentries) + +(defun coq-count-match (regexp strg) + "Count the number of (maximum, non overlapping) matching substring + of STRG matching REGEXP. Empty match are counted once." + (let ((nbmatch 0) (str strg)) + (while (and (proof-string-match regexp str) (not (string-equal str ""))) + (incf nbmatch) + (if (= (match-end 0) 0) (setq str (substring str 1)) + (setq str (substring str (match-end 0))))) + nbmatch)) + +;; This function is used for amalgamating a proof into a single +;; goal-save region (proof-goal-command-p used in +;; proof-done-advancing-save in generic/proof-script.el) for coq < +;; 8.0. It is the test when looking backward the start of the proof. +;; It is NOT used for coq > v8.1 +;; (coq-find-and-forget in coq.el uses state numbers, proof numbers and +;; lemma names given in the prompt) + +;; compatibility with v8.0, will delete it some day +(defun coq-goal-command-str-v80-p (str) + "See `coq-goal-command-p'." + (let* ((match (coq-count-match "\\" str)) + (with (coq-count-match "\\" str)) + (letwith (+ (coq-count-match "\\" str) (- with match))) + (affect (coq-count-match ":=" str))) + + (and (proof-string-match coq-goal-command-regexp str) + (not ; + (and + (proof-string-match "\\`\\(Local\\|Definition\\|Lemma\\|Module\\)\\>" str) + (not (= letwith affect)))) + (not (proof-string-match "\\`Declare\\s-+Module\\(\\w\\|\\s-\\|<\\)*:" str)) + ) + ) + ) + +;; Module and or section openings are detected syntactically. Module +;; *openings* are difficult to detect because there can be Module +;; ...with X := ... . So we need to count :='s to detect real openings. + +;; TODO: have opened section/chapter in the prompt too, and get rid of +;; syntactical tests everywhere +(defun coq-module-opening-p (str) + "Decide whether STR is a module or section opening or not. +Used by `coq-goal-command-p'" + (let* ((match (coq-count-match "\\" str)) + (with (coq-count-match "\\" str)) + (letwith (+ (coq-count-match "\\" str) (- with match))) + (affect (coq-count-match ":=" str))) + (and (proof-string-match "\\`\\(Module\\)\\>" str) + (= letwith affect)) + )) + +(defun coq-section-command-p (str) + (proof-string-match "\\`\\(Section\\|Chapter\\)\\>" str)) + + +(defun coq-goal-command-str-v81-p (str) + "Decide syntactically whether STR is a goal start or not. Use + `coq-goal-command-p-v81' on a span instead if possible." + (coq-goal-command-str-v80-p str) + ) + +;; This is the function that tests if a SPAN is a goal start. All it +;; has to do is look at the 'goalcmd attribute of the span. +;; It also looks if this is not a module start. + +;; TODO: have also attributes 'modulecmd and 'sectioncmd. This needs +;; something in the coq prompt telling the name of all opened modules +;; (like for open goals), and use it to set goalcmd --> no more need +;; to look at Modules and section (actually indentation will still +;; need it) +(defun coq-goal-command-p-v81 (span) + "see `coq-goal-command-p'" + (or (span-property span 'goalcmd) + ;; module and section starts are detected here + (let ((str (or (span-property span 'cmd) ""))) + (or (coq-section-command-p str) + (coq-module-opening-p str)) + ))) + +;; In coq > 8.1 This is used only for indentation. +(defun coq-goal-command-str-p (str) + "Decide whether argument is a goal or not. Use + `coq-goal-command-p' on a span instead if posible." + (cond + (coq-version-is-V8-1 (coq-goal-command-str-v81-p str)) + (coq-version-is-V8-0 (coq-goal-command-str-v80-p str)) + (t (coq-goal-command-str-v80-p str));; this is temporary + )) + +;; This is used for backtracking +(defun coq-goal-command-p (span) + "Decide whether argument is a goal or not." + (cond + (coq-version-is-V8-1 (coq-goal-command-p-v81 span)) + (coq-version-is-V8-0 (coq-goal-command-str-v80-p (span-property span 'cmd))) + (t (coq-goal-command-str-v80-p (span-property span 'cmd)));; this is temporary + )) + +(defvar coq-keywords-save-strict + '("Defined" + "Save" + "Qed" + "End" + "Admitted" + "Abort" + )) + +(defvar coq-keywords-save + (append coq-keywords-save-strict '("Proof")) + ) + +(defun coq-save-command-p (span str) + "Decide whether argument is a Save command or not" + (or (proof-string-match coq-save-command-regexp-strict str) + (and (proof-string-match "\\`Proof\\>" str) + (not (proof-string-match "Proof\\s-*\\(\\.\\|\\\\)" str))) + ) + ) + + +(defvar coq-keywords-kill-goal + '("Abort")) + +;; Following regexps are all state changing +(defvar coq-keywords-state-changing-misc-commands + (coq-build-regexp-list-from-db coq-commands-db 'filter-state-changing)) + +(defvar coq-keywords-goal + (coq-build-regexp-list-from-db coq-goal-starters-db)) + +(defvar coq-keywords-decl + (coq-build-regexp-list-from-db coq-decl-db)) + +(defvar coq-keywords-defn + (coq-build-regexp-list-from-db coq-defn-db)) + + +(defvar coq-keywords-state-changing-commands + (append + coq-keywords-state-changing-misc-commands + coq-keywords-decl ; all state changing + coq-keywords-defn ; idem + coq-keywords-goal)) ; idem + + +;; +(defvar coq-keywords-state-preserving-commands + (coq-build-regexp-list-from-db coq-commands-db 'filter-state-preserving)) + +;; concat this is faster that redoing coq-build-regexp-list-from-db on +;; whole commands-db +(defvar coq-keywords-commands + (append coq-keywords-state-changing-commands + coq-keywords-state-preserving-commands) + "All commands keyword.") + +(defvar coq-solve-tactics + (coq-build-regexp-list-from-db coq-solve-tactics-db) + "Keywords for closing tactic(al)s.") + +(defvar coq-tacticals + (coq-build-regexp-list-from-db coq-tacticals-db) + "Keywords for tacticals in a Coq script.") + + + ;; From JF Monin: +(defvar coq-reserved + (append + coq-user-reserved-db + '( + "False" "True" "after" "as" "cofix" "fix" "forall" "fun" "match" + "return" "struct" "else" "end" "if" "in" "into" "let" "then" + "using" "with" "beta" "delta" "iota" "zeta" "after" "until" + "at" "Sort" "Time")) + "Reserved keywords of Coq.") + + +(defvar coq-state-changing-tactics + (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-changing)) + +(defvar coq-state-preserving-tactics + (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-preserving)) + + +(defvar coq-tactics + (append coq-state-changing-tactics coq-state-preserving-tactics)) + +(defvar coq-retractable-instruct + (append coq-state-changing-tactics coq-keywords-state-changing-commands)) + +(defvar coq-non-retractable-instruct + (append coq-state-preserving-tactics + coq-keywords-state-preserving-commands)) + +(defvar coq-keywords + (append coq-keywords-goal coq-keywords-save coq-keywords-decl + coq-keywords-defn coq-keywords-commands) + "All keywords in a Coq script.") + + + +(defvar coq-symbols + '("|" + "||" + ":" + ";" + "," + "(" + ")" + "[" + "]" + "{" + "}" + ":=" + "=>" + "->" + ".") + "Punctuation Symbols used by Coq.") + +;; ----- regular expressions +(defvar coq-error-regexp "^\\(Error:\\|Discarding pattern\\|Syntax error:\\|System Error:\\|User Error:\\|User error:\\|Anomaly[:.]\\|Toplevel input[,]\\)" + "A regexp indicating that the Coq process has identified an error.") + +(defvar coq-id proof-id) +(defvar coq-id-shy "\\(?:\\w\\(?:\\w\\|\\s_\\)*\\)") + +(defvar coq-ids (proof-ids coq-id " ")) + +(defun coq-first-abstr-regexp (paren end) + (concat paren "\\s-*\\(" coq-ids "\\)\\s-*" end)) + +(defcustom coq-variable-highlight-enable t + "Activates partial bound variable highlighting" + :type 'boolean + :group 'coq) + + +(defvar coq-font-lock-terms + (if coq-variable-highlight-enable + (list + ;; lambda binders + (list (coq-first-abstr-regexp "\\" "\\(?:=>\\|:\\)") 1 'font-lock-variable-name-face) + ;; forall binder + (list (coq-first-abstr-regexp "\\" "\\(?:,\\|:\\)") 1 'font-lock-variable-name-face) + ; (list "\\" + ; (list 0 font-lock-type-face) + ; (list (concat "[^ :]\\s-*\\(" coq-ids "\\)\\s-*") nil nil + ; (list 0 font-lock-variable-name-face))) + ;; parenthesized binders + (list (coq-first-abstr-regexp "(" ":[ a-zA-Z]") 1 'font-lock-variable-name-face) + )) + "*Font-lock table for Coq terms.") + + + +;; According to Coq, "Definition" is both a declaration and a goal. +;; It is understood here as being a goal. This is important for +;; recognizing global identifiers, see coq-global-p. +(defconst coq-save-command-regexp-strict + (proof-anchor-regexp + (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict) + "\\)"))) +(defconst coq-save-command-regexp + (proof-anchor-regexp + (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save) + "\\)"))) +(defconst coq-save-with-hole-regexp + (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict) + "\\)\\s-+\\(" coq-id "\\)\\s-*\\.")) + +(defconst coq-goal-command-regexp + (proof-anchor-regexp (proof-ids-to-regexp coq-keywords-goal))) + +(defconst coq-goal-with-hole-regexp + (concat "\\(" (proof-ids-to-regexp coq-keywords-goal) + "\\)\\s-+\\(" coq-id "\\)\\s-*:?")) + +(defconst coq-decl-with-hole-regexp + (concat "\\(" (proof-ids-to-regexp coq-keywords-decl) + "\\)\\s-+\\(" coq-ids "\\)\\s-*:")) + +;; (defconst coq-decl-with-hole-regexp +;; (if coq-variable-highlight-enable coq-decl-with-hole-regexp-1 'nil)) + +(defconst coq-defn-with-hole-regexp + (concat "\\(" (proof-ids-to-regexp coq-keywords-defn) + "\\)\\s-+\\(" coq-id "\\)")) + +;; must match: +;; "with f x y :" (followed by = or not) +;; "with f x y (z:" (not followed by =) +;; BUT NOT: +;; "with f ... (x:=" +;; "match ... with .. => " +(defconst coq-with-with-hole-regexp + (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^=(.]*:\\|[^(]*(\\s-*" + coq-id "\\s-*:[^=]\\)")) +;; marche aussi a peu pres +;; (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^(.]*:\\|.*)[^(.]*:=\\)")) +;;"\\\\|\\\\|\\" +(defvar coq-font-lock-keywords-1 + (append + coq-font-lock-terms + (list + (cons (proof-ids-to-regexp coq-solve-tactics) 'coq-solve-tactics-face) + (cons (proof-ids-to-regexp coq-keywords) 'font-lock-keyword-face) + (cons (proof-ids-to-regexp coq-reserved) 'font-lock-type-face) + (cons (proof-ids-to-regexp coq-tactics ) 'proof-tactics-name-face) + (cons (proof-ids-to-regexp coq-tacticals) 'proof-tacticals-name-face) + (cons (proof-ids-to-regexp (list "Set" "Type" "Prop")) 'font-lock-type-face) + (cons "============================" 'font-lock-keyword-face) + (cons "Subtree proved!" 'font-lock-keyword-face) + (cons "subgoal [0-9]+ is:" 'font-lock-keyword-face) + (list "^\\([^ \n]+\\) \\(is defined\\)" + (list 2 'font-lock-keyword-face t) + (list 1 'font-lock-function-name-face t)) + + (list coq-goal-with-hole-regexp 2 'font-lock-function-name-face)) + (if coq-variable-highlight-enable (list (list coq-decl-with-hole-regexp 2 'font-lock-variable-name-face))) + (list + (list coq-defn-with-hole-regexp 2 'font-lock-function-name-face) + (list coq-with-with-hole-regexp 2 'font-lock-function-name-face) + (list coq-save-with-hole-regexp 2 'font-lock-function-name-face) + ;; Remove spurious variable and function faces on commas. + '(proof-zap-commas)))) + +(defvar coq-font-lock-keywords coq-font-lock-keywords-1) + +(defun coq-init-syntax-table () + "Set appropriate values for syntax table in current buffer." + + (modify-syntax-entry ?\$ ".") + (modify-syntax-entry ?\/ ".") + (modify-syntax-entry ?\\ ".") + (modify-syntax-entry ?+ ".") + (modify-syntax-entry ?- ".") + (modify-syntax-entry ?= ".") + (modify-syntax-entry ?% ".") + (modify-syntax-entry ?< ".") + (modify-syntax-entry ?> ".") + (modify-syntax-entry ?\& ".") + (modify-syntax-entry ?_ "_") + (modify-syntax-entry ?\' "_") + (modify-syntax-entry ?\| ".") + +;; should maybe be "_" but it makes coq-find-and-forget (in coq.el) bug + (modify-syntax-entry ?\. ".") + + (condition-case nil + ;; Try to use Emacs-21's nested comments. + (modify-syntax-entry ?\* ". 23n") + ;; Revert to non-nested comments if that failed. + (error (modify-syntax-entry ?\* ". 23"))) + (modify-syntax-entry ?\( "()1") + (modify-syntax-entry ?\) ")(4")) + + +(defconst coq-generic-expression + (mapcar (lambda (kw) + (list (capitalize kw) + (concat "\\<" kw "\\>" "\\s-+\\(\\w+\\)\\W" ) + 1)) + (append coq-keywords-decl coq-keywords-defn coq-keywords-goal))) + +(provide 'coq-syntax) + ;;; coq-syntax.el ends here + +; Local Variables: *** +; indent-tabs-mode: nil *** +; End: *** diff --git a/tools/coq-tex.ml4 b/tools/coq-tex.ml4 deleted file mode 100644 index 4c11725c..00000000 --- a/tools/coq-tex.ml4 +++ /dev/null @@ -1,292 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* () - | _ -> begin - print_string "This program only runs under Unix !\n"; - flush stdout; - exit 1 - end - -let linelen = ref 72 -let output = ref "" -let output_specified = ref false -let image = ref "" -let cut_at_blanks = ref false -let verbose = ref false -let slanted = ref false -let hrule = ref false -let small = ref false - -let coq_prompt = Str.regexp "Coq < " -let any_prompt = Str.regexp "^[A-Z0-9a-z_\\$']* < " - -let remove_prompt s = Str.replace_first any_prompt "" s - -(* First pass: extract the Coq phrases to evaluate from [texfile] - * and put them into the file [inputv] *) - -let begin_coq = Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\|eval\\)}[ \t]*$" -let end_coq = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\|eval\\)}[ \t]*$" - -let extract texfile inputv = - let chan_in = open_in texfile in - let chan_out = open_out inputv in - let rec inside () = - let s = input_line chan_in in - if Str.string_match end_coq s 0 then - outside () - else begin - output_string chan_out (s ^ "\n"); - inside () - end - and outside () = - let s = input_line chan_in in - if Str.string_match begin_coq s 0 then - inside () - else - outside () - in - try - output_string chan_out - ("Set Printing Width " ^ (string_of_int !linelen) ^".\n"); - outside () - with End_of_file -> - begin close_in chan_in; close_out chan_out end - -(* Second pass: insert the answers of Coq from [coq_output] into the - * TeX file [texfile]. The result goes in file [result]. *) - -let begin_coq_example = - Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" -let begin_coq_eval = Str.regexp "\\\\begin{coq_eval}[ \t]*$" -let end_coq_example = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" -let end_coq_eval = Str.regexp "\\\\end{coq_eval}[ \t]*$" -let dot_end_line = Str.regexp "\\.[ \t]*\\((\\*.*\\*)\\)?[ \t]*$" - -let has_match r s = - try let _ = Str.search_forward r s 0 in true with Not_found -> false - -let percent = Str.regexp "%" -let bang = Str.regexp "!" -let expos = Str.regexp "^" - -let tex_escaped s = - let rec trans = parser - | [< s1 = (parser - | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> - "\\" ^ (String.make 1 c) - | [< ''\\' >] -> "{\\char'134}" - | [< ''^' >] -> "{\\char'136}" - | [< ''~' >] -> "{\\char'176}" - | [< '' ' >] -> "~" - | [< ''<' >] -> "{<}" - | [< ''>' >] -> "{>}" - | [< 'c >] -> String.make 1 c); - s2 = trans >] -> s1 ^ s2 - | [< >] -> "" - in - trans (Stream.of_string s) - -let encapsule sl c_out s = - if sl then - Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s) - else - Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s) - -let print_block c_out bl = - List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl - -let insert texfile coq_output result = - let c_tex = open_in texfile in - let c_coq = open_in coq_output in - let c_out = open_out result in - (* next_block k : this function reads the next block of Coq output - * removing the k leading prompts. - * it returns the block as a list of string) *) - let last_read = ref "" in - let next_block k = - if !last_read = "" then last_read := input_line c_coq; - (* skip k prompts *) - for i = 1 to k do - last_read := remove_prompt !last_read; - done; - (* read and return the following lines until a prompt is found *) - let rec read_lines () = - let s = input_line c_coq in - if Str.string_match any_prompt s 0 then begin - last_read := s; [] - end else - s :: (read_lines ()) - in - let first = !last_read in first :: (read_lines ()) - in - (* we are just after \end{coq_...} block *) - let rec just_after () = - let s = input_line c_tex in - if Str.string_match begin_coq_example s 0 then begin - inside (Str.matched_group 1 s <> "example*") - (Str.matched_group 1 s <> "example#") 0 false - end - else begin - if !hrule then output_string c_out "\\hrulefill\\\\\n"; - output_string c_out "\\end{flushleft}\n"; - if !small then output_string c_out "\\end{small}\n"; - if Str.string_match begin_coq_eval s 0 then - eval 0 - else begin - output_string c_out (s ^ "\n"); - outside () - end - end - (* we are outside of a \begin{coq_...} ... \end{coq_...} block *) - and outside () = - let s = input_line c_tex in - if Str.string_match begin_coq_example s 0 then begin - if !small then output_string c_out "\\begin{small}\n"; - output_string c_out "\\begin{flushleft}\n"; - if !hrule then output_string c_out "\\hrulefill\\\\\n"; - inside (Str.matched_group 1 s <> "example*") - (Str.matched_group 1 s <> "example#") 0 true - end else if Str.string_match begin_coq_eval s 0 then - eval 0 - else begin - output_string c_out (s ^ "\n"); - outside () - end - (* we are inside a \begin{coq_example?} ... \end{coq_example?} block - * show_answers tells what kind of block it is - * k is the number of lines read until now *) - and inside show_answers show_questions k first_block = - let s = input_line c_tex in - if Str.string_match end_coq_example s 0 then begin - just_after () - end else begin - if !verbose then Printf.printf "Coq < %s\n" s; - if (not first_block) & k=0 then output_string c_out "\\medskip\n"; - if show_questions then encapsule false c_out ("Coq < " ^ s); - if has_match dot_end_line s then begin - let bl = next_block (succ k) in - if !verbose then List.iter print_endline bl; - if show_answers then print_block c_out bl; - inside show_answers show_questions 0 false - end else - inside show_answers show_questions (succ k) first_block - end - (* we are inside a \begin{coq_eval} ... \end{coq_eval} block - * k is the number of lines read until now *) - and eval k = - let s = input_line c_tex in - if Str.string_match end_coq_eval s 0 then - outside () - else begin - if !verbose then Printf.printf "Coq < %s\n" s; - if has_match dot_end_line s then - let bl = next_block (succ k) in - if !verbose then List.iter print_endline bl; - eval 0 - else - eval (succ k) - end - in - try - let _ = next_block 0 in (* to skip the Coq banner *) - let _ = next_block 0 in (* to skip the Coq answer to Set Printing Width *) - outside () - with End_of_file -> begin - close_in c_tex; - close_in c_coq; - close_out c_out - end - -(* Process of one TeX file *) - -let rm f = try Sys.remove f with _ -> () - -let one_file texfile = - let inputv = Filename.temp_file "coq_tex" ".v" in - let coq_output = Filename.temp_file "coq_tex" ".coq_output"in - let result = - if !output_specified then - !output - else if Filename.check_suffix texfile ".tex" then - (Filename.chop_suffix texfile ".tex") ^ ".v.tex" - else - texfile ^ ".v.tex" - in - try - (* 1. extract Coq phrases *) - extract texfile inputv; - (* 2. run Coq on input *) - let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv - coq_output) - in - (* 3. insert Coq output into original file *) - insert texfile coq_output result; - (* 4. clean up *) - rm inputv; rm coq_output - with e -> begin - rm inputv; rm coq_output; - raise e - end - -(* Parsing of the command line, check of the Coq command and process - * of all the files in the command line, one by one *) - -let files = ref [] - -let parse_cl () = - Arg.parse - [ "-o", Arg.String (fun s -> output_specified := true; output := s), - "output-file Specifiy the resulting LaTeX file"; - "-n", Arg.Int (fun n -> linelen := n), - "line-width Set the line width"; - "-image", Arg.String (fun s -> image := s), - "coq-image Use coq-image as Coq command"; - "-w", Arg.Set cut_at_blanks, - " Try to cut lines at blanks"; - "-v", Arg.Set verbose, - " Verbose mode (show Coq answers on stdout)"; - "-sl", Arg.Set slanted, - " Coq answers in slanted font (only with LaTeX2e)"; - "-hrule", Arg.Set hrule, - " Coq parts are written between 2 horizontal lines"; - "-small", Arg.Set small, - " Coq parts are written in small font" - ] - (fun s -> files := s :: !files) - "coq-tex [options] file ..." - -let main () = - parse_cl (); - if !image = "" then begin - Printf.printf "Warning: preprocessing with default image \"coqtop\"\n"; - image := "coqtop" - end; - if Sys.command (!image ^ " -batch > /dev/null 2>&1") <> 0 then begin - Printf.printf "Error: "; - let _ = Sys.command (!image ^ " -batch") in - exit 1 - end else begin - Printf.printf "Your version of coqtop seems OK\n"; - flush stdout - end; - List.iter one_file (List.rev !files) - -let _ = Printexc.catch main () diff --git a/tools/coq.el b/tools/coq.el index 0eb04d8d..f4c4b033 100644 --- a/tools/coq.el +++ b/tools/coq.el @@ -5,6 +5,12 @@ ;; ;; modified by Marco Maggesi for coq-inferior +; compatibility code for proofgeneral files +(require 'coq-font-lock) +; ProofGeneral files. remember to remove coq version tests in +; coq-syntax.el +(require 'coq-syntax) + (defvar coq-mode-map nil "Keymap used in Coq mode.") (if coq-mode-map @@ -57,7 +63,9 @@ (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments nil) (make-local-variable 'indent-line-function) - (setq indent-line-function 'coq-indent-command)) + (setq indent-line-function 'coq-indent-command) + (make-local-variable 'font-lock-keywords) + (setq font-lock-defaults '(coq-font-lock-keywords-1))) ;;; The major mode @@ -129,54 +137,6 @@ Does nothing otherwise." (coq-in-indentation)) (backward-delete-char-untabify coq-mode-indentation)))) -;;; Hilight - -(cond - (window-system - (setq hilit-mode-enable-list '(not text-mode) - hilit-inhibit-hooks nil - hilit-inhibit-rebinding nil) - - (require 'hilit19) - (setq hilit-quietly t) - (hilit-set-mode-patterns - 'coq-mode - '(;;comments - ("(\\*" "\\*)" comment) - ;;strings - (hilit-string-find ?' string) - ;;directives - ("^[ \t]*\\(AddPath\\|DelPath\\|Add[ \t]+ML[ \t]+Path\\|Declare[ \t]+ML[ \t]+Module\\|Require\\|Export\\|Module\\|Opaque\\|Transparent\\|Section\\|Chapter\\|End\\|Load\\|Print\\|Show\\)[ \t]+[^.]*" nil include) - ("Implicit[ \t]+Arguments[ \t]+\\(On\\|Off\\)[^.]*" nil include) - ;;grammar definitions - ("^[ \t]*Syntax[ \t]+\\(tactic\\|command\\)" nil define) - ("^[ \t]*Syntax[ \t]+\\(tactic\\|command\\)[ \t]*level[ \t]+[0-9]+[ \t]*" nil define) - ("^[ \t]*level[ \t]+[0-9]+[ \t]*:" nil define) - ("^[ \t]*Grammar.*" ":=" define) - ("^[ \t]*Tactic[ \t]+Definition" ":=" define) - ("^[ \t]*Token[^.]*" nil define) - ("^[ \t]*\\(Coercion\\|Class\\|Infix\\)[ \t]+[[A-Za-z0-9$_\\']+" nil define) - ;;declarations - ("^[ \t]*Recursive[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*Syntactic[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*Tactic[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*Inductive[ \t]+\\(Set\\|Prop\\|Type\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*Mutual[ \t]+\\(Inductive\\|CoInductive\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*\\(Inductive\\|CoInductive\\|CoFixpoint\\|Definition\\|Local\\|Fixpoint\\|with\\|Record\\|Correctness\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*\\(Derive\\|Dependant[ \t]+Derive\\)[ \t]+\\(Inversion\\|Inversion_clear\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun) - ("^[ \t]*\\(Variable\\|Parameter\\|Hypothesis\\).*" ":" defun) - ("^[ \t]*\\(Global[ \t]+Variable\\).*" ":" defun) - ("^[ \t]*\\(Realizer[ \t]+Program\\|Realizer\\)" nil defun) - ;;proofs - ("^[ \t]*\\(Lemma\\|Theorem\\|Remark\\|Axiom\\).*" ":" defun) - ("^[ \t]*Proof" nil decl) - ("^[ \t]*\\(Save\\|Qed\\|Defined\\|Hint\\|Immediate\\)[^.]*" nil decl) - ;;keywords - ("[^_]\\<\\(Case\\|Cases\\|case\\|esac\\|of\\|end\\|in\\|Match\\|with\\|Fix\\|let\\|if\\|then\\|else\\)\\>[^_]" 1 keyword) - ("[^_]\\<\\(begin\\|assert\\|invariant\\|variant\\|for\\|while\\|do\\|done\\|state\\)\\>[^_]" 1 keyword) - )) -)) - ;;; coq.el ends here (provide 'coq) diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4 index 3ca1e7d3..338aba99 100644 --- a/tools/coq_makefile.ml4 +++ b/tools/coq_makefile.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coq_makefile.ml4 12470 2009-11-05 15:50:20Z notin $ *) +(* $Id$ *) (* créer un Makefile pour un développement Coq automatiquement *) @@ -42,7 +42,7 @@ let rec print_list sep = function let list_iter_i f = let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1 -let best_ocamlc = +let best_ocamlc = if Coq_config.best = "opt" then "ocamlc.opt" else "ocamlc" let best_ocamlopt = if Coq_config.best = "opt" then "ocamlopt.opt" else "ocamlopt" @@ -85,7 +85,7 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom [-impredicative-set]: compile with option -impredicative-set of coq [-no-install]: build a makefile with no install target [-f file]: take the contents of file as arguments -[-o file]: output should go in file file +[-o file]: output should go in file file [-h]: print this usage summary [--help]: equivalent to [-h]\n"; exit 1 @@ -208,16 +208,14 @@ let make_makefile sds = let clean sds sps = print "clean:\n"; - print "\trm -f $(VOFILES) $(VIFILES) $(GFILES) *~\n"; + print "\trm -f $(CMOFILES) $(CMIFILES) $(CMXFILES) $(CMXSFILES) $(OFILES) $(VOFILES) $(VIFILES) $(GFILES) $(MLFILES:.ml=.cmo) $(MLFILES:.ml=.cmx) *~\n"; print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(HTMLFILES) \ $(GHTMLFILES) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) $(VFILES:.v=.v.d)\n"; if !some_mlfile then print "\trm -f $(CMOFILES) $(MLFILES:.ml=.cmi) $(MLFILES:.ml=.ml.d) $(MLFILES:.ml=.cmx) $(MLFILES:.ml=.o)\n"; - if Coq_config.has_natdynlink && !some_mlfile then - print "\trm -f $(CMXSFILES) $(CMXSFILES:.cmxs=.o)\n"; print "\t- rm -rf html\n"; List.iter - (fun (file,_,_) -> + (fun (file,_,_) -> if not (is_genrule file) then (print "\t- rm -f "; print file; print "\n")) sps; @@ -235,8 +233,8 @@ let clean sds sps = print "\t@echo CAMLP4LIB =\t$(CAMLP4LIB)\n\n" let header_includes () = () - -let footer_includes () = + +let footer_includes () = if !some_vfile then print "-include $(VFILES:.v=.v.d)\n.SECONDARY: $(VFILES:.v=.v.d)\n\n"; if !some_mlfile then print "-include $(MLFILES:.ml=.ml.d)\n.SECONDARY: $(MLFILES:.ml=.ml.d)\n\n" @@ -250,17 +248,17 @@ let implicit () = print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "%.cmxs: %.ml4\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $(PP) -impl $<\n\n"; print "%.ml.d: %.ml\n"; - print "\t$(CAMLBIN)ocamldep -slash $(COQSRCLIBS) $(OCAMLLIBS) $(PP) \"$<\" > \"$@\"\n\n" + print "\t$(CAMLBIN)ocamldep -slash $(OCAMLLIBS) $(PP) \"$<\" > \"$@\"\n\n" and v_rule () = - print "%.vo %.glob: %.v\n\t$(COQC) -dump-glob $*.glob $(COQDEBUG) $(COQFLAGS) $*\n\n"; + print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.g: %.v\n\t$(GALLINA) $<\n\n"; print "%.tex: %.v\n\t$(COQDOC) -latex $< -o $@\n\n"; - print "%.html: %.v %.glob\n\t$(COQDOC) -glob-from $*.glob -html $< -o $@\n\n"; + print "%.html: %.v %.glob\n\t$(COQDOC) -html $< -o $@\n\n"; print "%.g.tex: %.v\n\t$(COQDOC) -latex -g $< -o $@\n\n"; - print "%.g.html: %.v %.glob\n\t$(COQDOC) -glob-from $*.glob -html -g $< -o $@\n\n"; + print "%.g.html: %.v %.glob\n\t$(COQDOC) -html -g $< -o $@\n\n"; print "%.v.d: %.v\n"; - print "\t$(COQDEP) -glob -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" + print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in if !some_mlfile then ml_rules (); if !some_vfile then v_rule () @@ -269,7 +267,7 @@ let variables defs = let var_aux (v,def) = print v; print "="; print def; print "\n" in section "Variables definitions."; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n"; - if !opt = "-byte" then + if !opt = "-byte" then print "override OPT:=-byte\n" else print "OPT:=\n"; @@ -283,6 +281,7 @@ let variables defs = print "COQDOC:=$(COQBIN)coqdoc\n"; print "COQMKTOP:=$(COQBIN)coqmktop\n"; (* Caml executables and relative variables *) + printf "CAMLLIB:=$(shell $(CAMLBIN)%s -where)\n" best_ocamlc; printf "CAMLC:=$(CAMLBIN)%s -c -rectypes\n" best_ocamlc; printf "CAMLOPTC:=$(CAMLBIN)%s -c -rectypes\n" best_ocamlopt; printf "CAMLLINK:=$(CAMLBIN)%s -rectypes\n" best_ocamlc; @@ -291,7 +290,7 @@ let variables defs = print "CAMLP4EXTEND:=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n"; print "CAMLP4OPTIONS:=\n"; List.iter var_aux defs; - print "PP:=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n"; + print "PP:=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n"; print "\n" let parameters () = @@ -299,8 +298,8 @@ let parameters () = print "# This Makefile may take 3 arguments passed as environment variables:\n"; print "# - COQBIN to specify the directory where Coq binaries resides;\n"; print "# - CAMLBIN and CAMLP4BIN to give the path for the OCaml and Camlp4/5 binaries.\n"; - print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n"; - print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n"; + print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n"; + print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n"; print "ifndef CAMLP4BIN\n CAMLP4BIN:=$(CAMLBIN)\nendif\n\n"; print "CAMLP4LIB:=$(shell $(CAMLP4BIN)$(CAMLP4) -where)\n\n" @@ -320,14 +319,9 @@ let include_dirs (inc_i,inc_r) = -I $(COQLIB)/library -I $(COQLIB)/parsing \\ -I $(COQLIB)/pretyping -I $(COQLIB)/interp \\ -I $(COQLIB)/proofs -I $(COQLIB)/tactics \\ - -I $(COQLIB)/toplevel -I $(COQLIB)/contrib/cc -I $(COQLIB)/contrib/dp \\ - -I $(COQLIB)/contrib/extraction -I $(COQLIB)/contrib/field \\ - -I $(COQLIB)/contrib/firstorder -I $(COQLIB)/contrib/fourier \\ - -I $(COQLIB)/contrib/funind -I $(COQLIB)/contrib/interface \\ - -I $(COQLIB)/contrib/micromega -I $(COQLIB)/contrib/omega \\ - -I $(COQLIB)/contrib/ring -I $(COQLIB)/contrib/romega \\ - -I $(COQLIB)/contrib/rtauto -I $(COQLIB)/contrib/setoid_ring \\ - -I $(COQLIB)/contrib/subtac -I $(COQLIB)/contrib/xml\n"; + -I $(COQLIB)/toplevel"; + List.iter (fun c -> print " \\ + -I $(COQLIB)/plugins/"; print c) Coq_config.plugins_dirs; print "\n"; print "COQLIBS:="; print_list "\\\n " str_i'; print " "; print_list "\\\n " str_r; print "\n"; print "COQDOCLIBS:="; print_list "\\\n " str_r; print "\n\n" @@ -336,14 +330,14 @@ let rec special = function | [] -> [] | Special (file,deps,com) :: r -> (file,deps,com) :: (special r) | _ :: r -> special r - + let custom sps = - let pr_sp (file,dependencies,com) = + let pr_path (file,dependencies,com) = print file; print ": "; print dependencies; print "\n"; print "\t"; print com; print "\n\n" in if sps <> [] then section "Custom targets."; - List.iter pr_sp sps + List.iter pr_path sps let subdirs sds = let pr_subdir s = @@ -354,7 +348,7 @@ let subdirs sds = section "Special targets."; print ".PHONY: "; print_list " " - ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" + ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" :: "depend" :: "html" :: sds); print "\n\n" @@ -363,7 +357,7 @@ let rec split_arguments = function let (v,m,o,s),i,d = split_arguments r in ((canonize n::v,m,o,s),i,d) | ML n :: r -> let (v,m,o,s),i,d = split_arguments r in ((v,canonize n::m,o,s),i,d) - | Special (n,dep,c) :: r -> + | Special (n,dep,c) :: r -> let (v,m,o,s),i,d = split_arguments r in ((v,m,(n,dep,c)::o,s),i,d) | Subdir n :: r -> let (v,m,o,s),i,d = split_arguments r in ((v,m,o,n::s),i,d) @@ -371,7 +365,7 @@ let rec split_arguments = function let t,(i,r),d = split_arguments r in (t,((p,absolute_dir p)::i,r),d) | RInclude (p,l) :: r -> let t,(i,r),d = split_arguments r in (t,(i,(p,l,absolute_dir p)::r),d) - | Def (v,def) :: r -> + | Def (v,def) :: r -> let t,i,d = split_arguments r in (t,i,(v,def)::d) | [] -> ([],[],[],[]),([],[]),[] @@ -404,15 +398,15 @@ let main_targets vfiles mlfiles other_targets inc = if !some_mlfile then print "$(CMOFILES) "; if Coq_config.has_natdynlink && !some_mlfile then print "$(CMXSFILES) "; print_list "\\\n " other_targets; print "\n"; - if !some_vfile then + if !some_vfile then begin print "spec: $(VIFILES)\n\n"; print "gallina: $(GFILES)\n\n"; print "html: $(GLOBFILES) $(VFILES)\n"; - print "\t- mkdir html\n"; + print "\t- mkdir -p html\n"; print "\t$(COQDOC) -toc -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "gallinahtml: $(GLOBFILES) $(VFILES)\n"; - print "\t- mkdir html\n"; + print "\t- mkdir -p html\n"; print "\t$(COQDOC) -toc -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "all.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n"; @@ -432,20 +426,20 @@ let all_target (vfiles, mlfiles, sps, sds) inc = main_targets vfiles mlfiles other_targets inc; custom sps; subdirs sds - + let parse f = - let rec string = parser + let rec string = parser | [< '' ' | '\n' | '\t' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(string s) | [< >] -> "" - and string2 = parser + and string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(string2 s) - and skip_comment = parser + and skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> skip_comment s | [< >] -> [< >] - and args = parser + and args = parser | [< '' ' | '\n' | '\t'; s >] -> args s | [< ''#'; s >] -> args (skip_comment s) | [< ''"'; str = string2; s >] -> ("" ^ str) :: args s @@ -458,13 +452,13 @@ let parse f = res let rec process_cmd_line = function - | [] -> + | [] -> some_file := !some_file or !some_mlfile or !some_vfile; [] - | ("-h"|"--help") :: _ -> + | ("-h"|"--help") :: _ -> usage () - | ("-no-opt"|"-byte") :: r -> + | ("-no-opt"|"-byte") :: r -> opt := "-byte"; process_cmd_line r - | ("-full"|"-opt") :: r -> + | ("-full"|"-opt") :: r -> opt := "-opt"; process_cmd_line r | "-impredicative-set" :: r -> impredicative_set := true; process_cmd_line r @@ -483,65 +477,65 @@ let rec process_cmd_line = function Include d :: (process_cmd_line r) | "-R" :: p :: l :: r -> RInclude (p,l) :: (process_cmd_line r) - | ("-I"|"-custom") :: _ -> + | ("-I"|"-custom") :: _ -> usage () - | "-f" :: file :: r -> + | "-f" :: file :: r -> make_name := file; process_cmd_line ((parse file)@r) - | ["-f"] -> + | ["-f"] -> usage () - | "-o" :: file :: r -> + | "-o" :: file :: r -> makefile_name := file; output_channel := (open_out file); (process_cmd_line r) - | v :: "=" :: def :: r -> + | v :: "=" :: def :: r -> Def (v,def) :: (process_cmd_line r) | f :: r -> if Filename.check_suffix f ".v" then begin - some_vfile := true; + some_vfile := true; V f :: (process_cmd_line r) end else if (Filename.check_suffix f ".ml") || (Filename.check_suffix f ".ml4") then begin - some_mlfile := true; + some_mlfile := true; ML f :: (process_cmd_line r) end else if (Filename.check_suffix f ".mli") then begin Printf.eprintf "Warning: no need for .mli files, skipped %s\n" f; process_cmd_line r end else Subdir f :: (process_cmd_line r) - + let banner () = - print -"########################################################################## -## v # The Coq Proof Assistant ## -## print x; print " ") l - + let command_line args = print "#\n# This Makefile was generated by the command line :\n"; print "# coq_makefile "; print_list args; print "\n#\n\n" - + let directories_deps l = - let print_dep f dep = + let print_dep f dep = if dep <> [] then begin print f; print ": "; print_list dep; print "\n" end in let rec iter ((dirs,before) as acc) = function - | [] -> + | [] -> () - | (Subdir d) :: l -> + | (Subdir d) :: l -> print_dep d before; iter (d :: dirs, d :: before) l | (ML f) :: l -> print_dep f dirs; iter (dirs, f :: before) l @@ -549,7 +543,7 @@ let directories_deps l = print_dep f dirs; iter (dirs, f :: before) l | (Special (f,_,_)) :: l -> print_dep f dirs; iter (dirs, f :: before) l - | _ :: l -> + | _ :: l -> iter acc l in iter ([],[]) l @@ -567,7 +561,7 @@ let warn_install_at_root_directory (vfiles,mlfiles,_,_) (inc_i,inc_r) = if not !no_install && List.exists (fun f -> List.mem_assoc (Filename.dirname f) inc_top) files then - Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" + Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" (if inc_r_top = [] then "" else "with non trivial logical root ") let check_overlapping_include (inc_i,inc_r) = @@ -582,7 +576,7 @@ let check_overlapping_include (inc_i,inc_r) = Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l; List.iter (fun (pdir',abspdir') -> if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then - Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i + Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i in aux inc_r let do_makefile args = @@ -609,12 +603,12 @@ let do_makefile args = warning (); if not (!output_channel == stdout) then close_out !output_channel; exit 0 - + let main () = let args = if Array.length Sys.argv = 1 then usage (); List.tl (Array.to_list Sys.argv) in do_makefile args - + let _ = Printexc.catch main () diff --git a/tools/coq_tex.ml4 b/tools/coq_tex.ml4 new file mode 100644 index 00000000..c46a187c --- /dev/null +++ b/tools/coq_tex.ml4 @@ -0,0 +1,292 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* () + | _ -> begin + print_string "This program only runs under Unix !\n"; + flush stdout; + exit 1 + end + +let linelen = ref 72 +let output = ref "" +let output_specified = ref false +let image = ref "" +let cut_at_blanks = ref false +let verbose = ref false +let slanted = ref false +let hrule = ref false +let small = ref false + +let coq_prompt = Str.regexp "Coq < " +let any_prompt = Str.regexp "^[A-Z0-9a-z_\\$']* < " + +let remove_prompt s = Str.replace_first any_prompt "" s + +(* First pass: extract the Coq phrases to evaluate from [texfile] + * and put them into the file [inputv] *) + +let begin_coq = Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\|eval\\)}[ \t]*$" +let end_coq = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\|eval\\)}[ \t]*$" + +let extract texfile inputv = + let chan_in = open_in texfile in + let chan_out = open_out inputv in + let rec inside () = + let s = input_line chan_in in + if Str.string_match end_coq s 0 then + outside () + else begin + output_string chan_out (s ^ "\n"); + inside () + end + and outside () = + let s = input_line chan_in in + if Str.string_match begin_coq s 0 then + inside () + else + outside () + in + try + output_string chan_out + ("Set Printing Width " ^ (string_of_int !linelen) ^".\n"); + outside () + with End_of_file -> + begin close_in chan_in; close_out chan_out end + +(* Second pass: insert the answers of Coq from [coq_output] into the + * TeX file [texfile]. The result goes in file [result]. *) + +let begin_coq_example = + Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" +let begin_coq_eval = Str.regexp "\\\\begin{coq_eval}[ \t]*$" +let end_coq_example = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" +let end_coq_eval = Str.regexp "\\\\end{coq_eval}[ \t]*$" +let dot_end_line = Str.regexp "\\.[ \t]*\\((\\*.*\\*)\\)?[ \t]*$" + +let has_match r s = + try let _ = Str.search_forward r s 0 in true with Not_found -> false + +let percent = Str.regexp "%" +let bang = Str.regexp "!" +let expos = Str.regexp "^" + +let tex_escaped s = + let rec trans = parser + | [< s1 = (parser + | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> + "\\" ^ (String.make 1 c) + | [< ''\\' >] -> "{\\char'134}" + | [< ''^' >] -> "{\\char'136}" + | [< ''~' >] -> "{\\char'176}" + | [< '' ' >] -> "~" + | [< ''<' >] -> "{<}" + | [< ''>' >] -> "{>}" + | [< 'c >] -> String.make 1 c); + s2 = trans >] -> s1 ^ s2 + | [< >] -> "" + in + trans (Stream.of_string s) + +let encapsule sl c_out s = + if sl then + Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s) + else + Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s) + +let print_block c_out bl = + List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl + +let insert texfile coq_output result = + let c_tex = open_in texfile in + let c_coq = open_in coq_output in + let c_out = open_out result in + (* next_block k : this function reads the next block of Coq output + * removing the k leading prompts. + * it returns the block as a list of string) *) + let last_read = ref "" in + let next_block k = + if !last_read = "" then last_read := input_line c_coq; + (* skip k prompts *) + for i = 1 to k do + last_read := remove_prompt !last_read; + done; + (* read and return the following lines until a prompt is found *) + let rec read_lines () = + let s = input_line c_coq in + if Str.string_match any_prompt s 0 then begin + last_read := s; [] + end else + s :: (read_lines ()) + in + let first = !last_read in first :: (read_lines ()) + in + (* we are just after \end{coq_...} block *) + let rec just_after () = + let s = input_line c_tex in + if Str.string_match begin_coq_example s 0 then begin + inside (Str.matched_group 1 s <> "example*") + (Str.matched_group 1 s <> "example#") 0 false + end + else begin + if !hrule then output_string c_out "\\hrulefill\\\\\n"; + output_string c_out "\\end{flushleft}\n"; + if !small then output_string c_out "\\end{small}\n"; + if Str.string_match begin_coq_eval s 0 then + eval 0 + else begin + output_string c_out (s ^ "\n"); + outside () + end + end + (* we are outside of a \begin{coq_...} ... \end{coq_...} block *) + and outside () = + let s = input_line c_tex in + if Str.string_match begin_coq_example s 0 then begin + if !small then output_string c_out "\\begin{small}\n"; + output_string c_out "\\begin{flushleft}\n"; + if !hrule then output_string c_out "\\hrulefill\\\\\n"; + inside (Str.matched_group 1 s <> "example*") + (Str.matched_group 1 s <> "example#") 0 true + end else if Str.string_match begin_coq_eval s 0 then + eval 0 + else begin + output_string c_out (s ^ "\n"); + outside () + end + (* we are inside a \begin{coq_example?} ... \end{coq_example?} block + * show_answers tells what kind of block it is + * k is the number of lines read until now *) + and inside show_answers show_questions k first_block = + let s = input_line c_tex in + if Str.string_match end_coq_example s 0 then begin + just_after () + end else begin + if !verbose then Printf.printf "Coq < %s\n" s; + if (not first_block) & k=0 then output_string c_out "\\medskip\n"; + if show_questions then encapsule false c_out ("Coq < " ^ s); + if has_match dot_end_line s then begin + let bl = next_block (succ k) in + if !verbose then List.iter print_endline bl; + if show_answers then print_block c_out bl; + inside show_answers show_questions 0 false + end else + inside show_answers show_questions (succ k) first_block + end + (* we are inside a \begin{coq_eval} ... \end{coq_eval} block + * k is the number of lines read until now *) + and eval k = + let s = input_line c_tex in + if Str.string_match end_coq_eval s 0 then + outside () + else begin + if !verbose then Printf.printf "Coq < %s\n" s; + if has_match dot_end_line s then + let bl = next_block (succ k) in + if !verbose then List.iter print_endline bl; + eval 0 + else + eval (succ k) + end + in + try + let _ = next_block 0 in (* to skip the Coq banner *) + let _ = next_block 0 in (* to skip the Coq answer to Set Printing Width *) + outside () + with End_of_file -> begin + close_in c_tex; + close_in c_coq; + close_out c_out + end + +(* Process of one TeX file *) + +let rm f = try Sys.remove f with _ -> () + +let one_file texfile = + let inputv = Filename.temp_file "coq_tex" ".v" in + let coq_output = Filename.temp_file "coq_tex" ".coq_output"in + let result = + if !output_specified then + !output + else if Filename.check_suffix texfile ".tex" then + (Filename.chop_suffix texfile ".tex") ^ ".v.tex" + else + texfile ^ ".v.tex" + in + try + (* 1. extract Coq phrases *) + extract texfile inputv; + (* 2. run Coq on input *) + let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv + coq_output) + in + (* 3. insert Coq output into original file *) + insert texfile coq_output result; + (* 4. clean up *) + rm inputv; rm coq_output + with e -> begin + rm inputv; rm coq_output; + raise e + end + +(* Parsing of the command line, check of the Coq command and process + * of all the files in the command line, one by one *) + +let files = ref [] + +let parse_cl () = + Arg.parse + [ "-o", Arg.String (fun s -> output_specified := true; output := s), + "output-file Specifiy the resulting LaTeX file"; + "-n", Arg.Int (fun n -> linelen := n), + "line-width Set the line width"; + "-image", Arg.String (fun s -> image := s), + "coq-image Use coq-image as Coq command"; + "-w", Arg.Set cut_at_blanks, + " Try to cut lines at blanks"; + "-v", Arg.Set verbose, + " Verbose mode (show Coq answers on stdout)"; + "-sl", Arg.Set slanted, + " Coq answers in slanted font (only with LaTeX2e)"; + "-hrule", Arg.Set hrule, + " Coq parts are written between 2 horizontal lines"; + "-small", Arg.Set small, + " Coq parts are written in small font" + ] + (fun s -> files := s :: !files) + "coq-tex [options] file ..." + +let main () = + parse_cl (); + if !image = "" then begin + Printf.printf "Warning: preprocessing with default image \"coqtop\"\n"; + image := "coqtop" + end; + if Sys.command (!image ^ " -batch > /dev/null 2>&1") <> 0 then begin + Printf.printf "Error: "; + let _ = Sys.command (!image ^ " -batch") in + exit 1 + end else begin + Printf.printf "Your version of coqtop seems OK\n"; + flush stdout + end; + List.iter one_file (List.rev !files) + +let _ = Printexc.catch main () diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 91a7e6d0..fe930a1d 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -6,207 +6,46 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqdep.ml 12916 2010-04-10 15:18:17Z herbelin $ *) +(* $Id$ *) open Printf open Coqdep_lexer -open Unix +open Coqdep_common -let stderr = Pervasives.stderr -let stdout = Pervasives.stdout +(** The basic parts of coqdep (i.e. the parts used by [coqdep -boot]) + are now in [Coqdep_common]. The code that remains here concerns + the other options. Calling this complete coqdep with the [-boot] + option should be equivalent to calling [coqdep_boot]. +*) -let option_c = ref false let option_D = ref false let option_w = ref false -let option_i = ref false let option_sort = ref false -let option_glob = ref false -let option_slash = ref false -let suffixe = ref ".vo" -let suffixe_spec = ref ".vi" - -type dir = string option - -(* filename for printing *) -let (//) s1 s2 = - if !option_slash then s1^"/"^s2 else Filename.concat s1 s2 - -let (/) = Filename.concat - -let file_concat l = - if l=[] then "" else - List.fold_left (//) (List.hd l) (List.tl l) - -let make_ml_module_name filename = - (* Computes a ML Module name from its physical name *) - let fn = try Filename.chop_extension filename with _ -> filename in - let bn = Filename.basename fn in - String.capitalize bn - -(* Files specified on the command line *) -let mlAccu = ref ([] : (string * string * dir) list) -and mliAccu = ref ([] : (string * string * dir) list) -and vAccu = ref ([] : (string * string) list) - -(* Queue operations *) -let addQueue q v = q := v :: !q - -let safe_hash_add clq q (k,v) = - try - let v2 = Hashtbl.find q k in - if v<>v2 then - let rec add_clash = function - (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl - | cl::cltl -> cl::add_clash cltl - | [] -> [(k,[v;v2])] in - clq := add_clash !clq; - (* overwrite previous bindings, as coqc does *) - Hashtbl.add q k v - with Not_found -> Hashtbl.add q k v - -(* Files found in the loadpaths *) - -let mlKnown = (Hashtbl.create 19 : (string, dir) Hashtbl.t) -let mliKnown = (Hashtbl.create 19 : (string, dir) Hashtbl.t) -let vKnown = (Hashtbl.create 19 : (string list, string) Hashtbl.t) -let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) - -let clash_v = ref ([]: (string list * string list) list) - - -let warning_module_notfound f s = - eprintf "*** Warning : in file %s, library " f; - eprintf "%s.v is required and has not been found in loadpath !\n" - (String.concat "." s); - flush stderr - -let warning_notfound f s = - eprintf "*** Warning : in file %s, the file " f; - eprintf "%s.v is required and has not been found !\n" s; - flush stderr - -let warning_clash file dir = - match List.assoc dir !clash_v with - (f1::f2::fl) -> - let f = Filename.basename f1 in - let d1 = Filename.dirname f1 in - let d2 = Filename.dirname f2 in - let dl = List.map Filename.dirname (List.rev fl) in - eprintf - "*** Warning : in file %s, \n required library %s is ambiguous!\n (found %s.v in " - file (String.concat "." dir) f; - List.iter (fun s -> eprintf "%s, " s) dl; - eprintf "%s and %s)\n" d2 d1 - | _ -> assert false - -let safe_assoc verbose file k = - if verbose && List.mem_assoc k !clash_v then warning_clash file k; - Hashtbl.find vKnown k - -let absolute_dir dir = - let current = Sys.getcwd () in - Sys.chdir dir; - let dir' = Sys.getcwd () in - Sys.chdir current; - dir' - -let absolute_file_name basename odir = - let dir = match odir with Some dir -> dir | None -> "." in - absolute_dir dir // basename - -let file_name = function - | (s,None) -> file_concat s - | (s,Some ".") -> file_concat s - | (s,Some d) -> d // file_concat s - -let traite_fichier_ML md ext = - try - let chan = open_in (md ^ ext) in - let buf = Lexing.from_channel chan in - let deja_vu = ref [md] in - let a_faire = ref "" in - let a_faire_opt = ref "" in - begin try - while true do - let (Use_module str) = caml_action buf in - if List.mem str !deja_vu then - () - else begin - addQueue deja_vu str; - begin try - let mlidir = Hashtbl.find mliKnown str in - let filename = file_name ([str],mlidir) in - a_faire := !a_faire ^ " " ^ filename ^ ".cmi"; - with Not_found -> - try - let mldir = Hashtbl.find mlKnown str in - let filename = file_name ([str],mldir) in - a_faire := !a_faire ^ " " ^ filename ^ ".cmo"; - with Not_found -> () - end; - begin try - let mldir = Hashtbl.find mlKnown str in - let filename = file_name ([str],mldir) in - a_faire_opt := !a_faire_opt ^ " " ^ filename ^ ".cmx" - with Not_found -> - try - let mlidir = Hashtbl.find mliKnown str in - let filename = file_name ([str],mlidir) in - a_faire_opt := !a_faire_opt ^ " " ^ filename ^ ".cmi" - with Not_found -> () - end +let rec warning_mult suf iter = + let tab = Hashtbl.create 151 in + let check f d = + begin try + let d' = Hashtbl.find tab f in + if (Filename.dirname (file_name f d)) + <> (Filename.dirname (file_name f d')) then begin + eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf); + flush stderr end - done - with Fin_fichier -> () - end; - close_in chan; - (!a_faire, !a_faire_opt) - with Sys_error _ -> ("","") - -let cut_prefix p s = - let lp = String.length p in - let ls = String.length s in - if ls >= lp && String.sub s 0 lp = p then String.sub s lp (ls - lp) else s - -(* Makefile's escaping rules are awful: $ is escaped by doubling and - other special characters are escaped by backslash prefixing while - backslashes themselves must be escaped only if part of a sequence - followed by a special character (i.e. in case of ambiguity with a - use of it as escaping character). Moreover (even if not crucial) - it is apparently not possible to directly escape ';' and leading '\t'. *) - -let escape = - let s' = Buffer.create 10 in - fun s -> - Buffer.clear s'; - for i = 0 to String.length s - 1 do - let c = s.[i] in - if c = ' ' or c = '#' or c = ':' (* separators and comments *) - or c = '%' (* pattern *) - or c = '?' or c = '[' or c = ']' or c = '*' (* expansion in filenames *) - or i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || - 'A' <= s.[1] && s.[1] <= 'Z' || - 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) - then begin - let j = ref (i-1) in - while !j >= 0 && s.[!j] = '\\' do - Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) - done; - Buffer.add_char s' '\\'; - end; - if c = '$' then Buffer.add_char s' '$'; - Buffer.add_char s' c - done; - Buffer.contents s' - -let canonize f = - let f' = absolute_dir (Filename.dirname f) // Filename.basename f in - match List.filter (fun (_,full) -> f' = full) !vAccu with - | (f,_) :: _ -> f - | _ -> f + with Not_found -> () end; + Hashtbl.add tab f d + in + iter check + +let add_coqlib_known phys_dir log_dir f = + match get_extension f [".vo"] with + | (basename,".vo") -> + let name = log_dir@[basename] in + Hashtbl.add coqlibKnown [basename] (); + Hashtbl.add coqlibKnown name () + | _ -> () -let sort () = +let sort () = let seen = Hashtbl.create 97 in let rec loop file = let file = canonize file in @@ -217,13 +56,13 @@ let sort () = try while true do match coq_action lb with - | Require (_, sl) -> - List.iter - (fun s -> - try loop (Hashtbl.find vKnown s) + | Require sl -> + List.iter + (fun s -> + try loop (Hashtbl.find vKnown s) with Not_found -> ()) sl - | RequireString (_, s) -> loop s + | RequireString s -> loop s | _ -> () done with Fin_fichier -> @@ -233,82 +72,17 @@ let sort () = in List.iter (fun (name,_) -> loop name) !vAccu -let traite_fichier_Coq verbose f = - try - let chan = open_in f in - let buf = Lexing.from_channel chan in - let deja_vu_v = ref ([]: string list list) - and deja_vu_ml = ref ([] : string list) in - try - while true do - let tok = coq_action buf in - match tok with - | Require (spec,strl) -> - List.iter (fun str -> - if not (List.mem str !deja_vu_v) then begin - addQueue deja_vu_v str; - try - let file_str = safe_assoc verbose f str in - printf " %s%s" (canonize file_str) - (if spec then !suffixe_spec else !suffixe) - with Not_found -> - if verbose && not (Hashtbl.mem coqlibKnown str) then - warning_module_notfound f str - end) strl - | RequireString (spec,s) -> - let str = Filename.basename s in - if not (List.mem [str] !deja_vu_v) then begin - addQueue deja_vu_v [str]; - try - let file_str = Hashtbl.find vKnown [str] in - printf " %s%s" (canonize file_str) - (if spec then !suffixe_spec else !suffixe) - with Not_found -> - if not (Hashtbl.mem coqlibKnown [str]) then - warning_notfound f s - end - | Declare sl -> - List.iter - (fun str -> - let s = make_ml_module_name str in - if not (List.mem s !deja_vu_ml) then begin - addQueue deja_vu_ml s; - try - let mldir = Hashtbl.find mlKnown s in - let filename = file_name ([String.uncapitalize s],mldir) in - if Coq_config.has_natdynlink then - printf " %s.cmo %s.cmxs" filename filename - else - printf " %s.cmo" filename - with Not_found -> () - end) - sl - | Load str -> - let str = Filename.basename str in - if not (List.mem [str] !deja_vu_v) then begin - addQueue deja_vu_v [str]; - try - let file_str = Hashtbl.find vKnown [str] in - printf " %s.v" (canonize file_str) - with Not_found -> () - end - done - with Fin_fichier -> (); - close_in chan - with Sys_error _ -> () - - let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151 - -let mL_dep_list b f = - try + +let mL_dep_list b f = + try Hashtbl.find dep_tab f with Not_found -> - let deja_vu = ref ([] : string list) in - try - let chan = open_in f in - let buf = Lexing.from_channel chan in - try + let deja_vu = ref ([] : string list) in + try + let chan = open_in f in + let buf = Lexing.from_channel chan in + try while true do let (Use_module str) = caml_action buf in if str = b then begin @@ -319,14 +93,14 @@ let mL_dep_list b f = if not (List.mem str !deja_vu) then addQueue deja_vu str done; [] with Fin_fichier -> begin - close_in chan; + close_in chan; let rl = List.rev !deja_vu in Hashtbl.add dep_tab f rl; rl end with Sys_error _ -> [] -let affiche_Declare f dcl = +let affiche_Declare f dcl = printf "\n*** In file %s: \n" f; printf "Declare ML Module"; List.iter (fun str -> printf " \"%s\"" str) dcl; @@ -341,33 +115,33 @@ let warning_Declare f dcl = eprintf ".\n"; flush stderr -let traite_Declare f = +let traite_Declare f = let decl_list = ref ([] : string list) in let rec treat = function - | s :: ll -> - let s' = make_ml_module_name s in - if (Hashtbl.mem mlKnown s') & not (List.mem s' !decl_list) then begin - let mldir = Hashtbl.find mlKnown s in - let fullname = file_name ([(String.uncapitalize s')],mldir) in - let depl = mL_dep_list s (fullname ^ ".ml") in - treat depl; - decl_list := s :: !decl_list - end; - treat ll + | s :: ll -> + let s' = basename_noext s in + (match search_ml_known s with + | Some mldir when not (List.mem s' !decl_list) -> + let fullname = file_name (String.uncapitalize s') mldir in + let depl = mL_dep_list s (fullname ^ ".ml") in + treat depl; + decl_list := s :: !decl_list + | _ -> ()); + treat ll | [] -> () in try let chan = open_in f in let buf = Lexing.from_channel chan in - begin try + begin try while true do let tok = coq_action buf in (match tok with - | Declare sl -> + | Declare sl -> decl_list := []; treat sl; decl_list := List.rev !decl_list; - if !option_D then + if !option_D then affiche_Declare f !decl_list else if !decl_list <> sl then warning_Declare f !decl_list @@ -377,200 +151,61 @@ let traite_Declare f = close_in chan with Sys_error _ -> () -let file_mem (f,_,d) = - let rec loop = function - | (f1,_,d1) :: l -> (f1 = f && d1 = d) || (loop l) - | _ -> false - in - loop - -let mL_dependencies () = - List.iter - (fun ((name,ext,dirname) as pairname) -> - let fullname = file_name ([name],dirname) in - let (dep,dep_opt) = traite_fichier_ML fullname ext in - printf "%s.cmo: %s%s" fullname fullname ext; - if file_mem pairname !mliAccu then printf " %s.cmi" fullname; - printf "%s\n" dep; - printf "%s.cmx: %s%s" fullname fullname ext; - if file_mem pairname !mliAccu then printf " %s.cmi" fullname; - printf "%s\n" dep_opt; - flush stdout) - (List.rev !mlAccu); - List.iter - (fun ((name,ext,dirname)) -> - let fullname = file_name ([name],dirname) in - let (dep,_) = traite_fichier_ML fullname ext in - printf "%s.cmi: %s%s" fullname fullname ext; - printf "%s\n" dep; - flush stdout) - (List.rev !mliAccu) - -let coq_dependencies () = - List.iter - (fun (name,_) -> - let glob = if !option_glob then " "^name^".glob" else "" in - printf "%s%s%s: %s.v" name !suffixe glob name; - traite_fichier_Coq true (name ^ ".v"); - printf "\n"; - if !option_i then begin - printf "%s%s%s: %s.v" name !suffixe_spec glob name; - traite_fichier_Coq false (name ^ ".v"); - printf "\n"; - end; - flush stdout) - (List.rev !vAccu) - let declare_dependencies () = List.iter (fun (name,_) -> - traite_Declare (name^".v"); + traite_Declare (name^".v"); flush stdout) (List.rev !vAccu) -let rec warning_mult suf l = - let tab = Hashtbl.create 151 in - Hashtbl.iter - (fun f d -> - begin try - let d' = Hashtbl.find tab f in - if (Filename.dirname (file_name ([f],d))) - <> (Filename.dirname (file_name ([f],d'))) then begin - eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf); - flush stderr - end - with Not_found -> () end; - Hashtbl.add tab f d) - l - let usage () = eprintf "[ usage: coqdep [-w] [-I dir] [-R dir coqdir] [-coqlib dir] [-c] [-i] [-D] + ]\n"; flush stderr; exit 1 -let add_coqlib_known phys_dir log_dir f = - if Filename.check_suffix f ".vo" then - let basename = Filename.chop_suffix f ".vo" in - let name = log_dir@[basename] in - Hashtbl.add coqlibKnown [basename] (); - Hashtbl.add coqlibKnown name () - -let rec suffixes = function - | [] -> assert false - | [name] -> [[name]] - | dir::suffix as l -> l::suffixes suffix - -let add_known phys_dir log_dir f = - if (Filename.check_suffix f ".ml" || Filename.check_suffix f ".mli" || Filename.check_suffix f ".ml4") then - let basename = make_ml_module_name f in - Hashtbl.add mlKnown basename (Some phys_dir) - else if Filename.check_suffix f ".v" then - let basename = Filename.chop_suffix f ".v" in - let name = log_dir@[basename] in - let file = phys_dir//basename in - let paths = suffixes name in - List.iter - (fun n -> safe_hash_add clash_v vKnown (n,file)) paths - -(* Visits all the directories under [dir], including [dir], - or just [dir] if [recur=false] *) - -let rec add_directory recur add_file phys_dir log_dir = - let dirh = opendir phys_dir in - try - while true do - let f = readdir dirh in - (* we avoid . .. and all hidden files and subdirs (e.g. .svn, _darcs) *) - if f.[0] <> '.' && f.[0] <> '_' then - let phys_f = phys_dir//f in - match try (stat phys_f).st_kind with _ -> S_BLK with - | S_DIR when recur -> add_directory recur add_file phys_f (log_dir@[f]) - | S_REG -> add_file phys_dir log_dir f - | _ -> () - done - with End_of_file -> closedir dirh - -let add_dir add_file phys_dir log_dir = - try add_directory false add_file phys_dir log_dir with Unix_error _ -> () - -let add_rec_dir add_file phys_dir log_dir = - handle_unix_error (add_directory true add_file phys_dir) log_dir - -let rec treat_file old_dirname old_name = - let name = Filename.basename old_name - and new_dirname = Filename.dirname old_name in - let dirname = - match (old_dirname,new_dirname) with - | (d, ".") -> d - | (None,d) -> Some d - | (Some d1,d2) -> Some (d1//d2) - in - let complete_name = file_name ([name],dirname) in - match try (stat complete_name).st_kind with _ -> S_BLK with - | S_DIR -> - (if name.[0] <> '.' then - let dir=opendir complete_name in - let newdirname = - match dirname with - | None -> name - | Some d -> d//name - in - try - while true do treat_file (Some newdirname) (readdir dir) done - with End_of_file -> closedir dir) - | S_REG -> - if Filename.check_suffix name ".ml" then - let basename = Filename.chop_suffix name ".ml" in - addQueue mlAccu (basename,".ml",dirname) - else if Filename.check_suffix name ".ml4" then - let basename = Filename.chop_suffix name ".ml4" in - addQueue mlAccu (basename,".ml4",dirname) - else if Filename.check_suffix name ".mli" then - let basename = Filename.chop_suffix name ".mli" in - addQueue mliAccu (basename,".mli",dirname) - else if Filename.check_suffix name ".v" then - let basename = Filename.chop_suffix name ".v" in - let name = file_name ([basename],dirname) in - addQueue vAccu (name, absolute_file_name basename dirname) - | _ -> () - let rec parse = function | "-c" :: ll -> option_c := true; parse ll | "-D" :: ll -> option_D := true; parse ll | "-w" :: ll -> option_w := true; parse ll - | "-i" :: ll -> option_i := true; parse ll | "-boot" :: ll -> Flags.boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll - | "-glob" :: ll -> option_glob := true; parse ll + | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll + | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r [ln]; parse ll + | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_dir add_known r []; parse ll | "-I" :: [] -> usage () + | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll + | "-R" :: r :: "-as" :: [] -> usage () | "-R" :: r :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll | "-R" :: ([] | [_]) -> usage () | "-coqlib" :: (r :: ll) -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll | "-coqlib" :: [] -> usage () - | "-suffix" :: (s :: ll) -> suffixe := s ; suffixe_spec := s; parse ll + | "-suffix" :: (s :: ll) -> suffixe := s ; parse ll | "-suffix" :: [] -> usage () | "-slash" :: ll -> option_slash := true; parse ll + | ("-h"|"--help"|"-help") :: _ -> usage () | f :: ll -> treat_file None f; parse ll | [] -> () let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); + if not Coq_config.has_natdynlink then option_natdynlk := false; if !Flags.boot then begin add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "contrib" ["Coq"] + add_rec_dir add_known "plugins" ["Coq"] end else begin let coqlib = Envars.coqlib () in - add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir add_coqlib_known (coqlib//"contrib") ["Coq"]; - add_dir add_coqlib_known (coqlib//"user-contrib") [] + add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; + add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_dir add_coqlib_known (coqlib//"user-contrib") [] end; - List.iter (fun (f,_,d) -> Hashtbl.add mliKnown f d) !mliAccu; - List.iter (fun (f,_,d) -> Hashtbl.add mlKnown f d) !mlAccu; - warning_mult ".mli" mliKnown; - warning_mult ".ml" mlKnown; + List.iter (fun (f,d) -> add_mli_known f d) !mliAccu; + List.iter (fun (f,d) -> add_mllib_known f d) !mllibAccu; + List.iter (fun (f,_,d) -> add_ml_known f d) !mlAccu; + warning_mult ".mli" iter_mli_known; + warning_mult ".ml" iter_ml_known; if !option_sort then begin sort (); exit 0 end; if !option_c && not !option_D then mL_dependencies (); if not !option_D then coq_dependencies (); diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml new file mode 100644 index 00000000..b7f6ec25 --- /dev/null +++ b/tools/coqdep_boot.ml @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* option_slash := true; parse ll + | "-natdynlink" :: "no" :: ll -> option_natdynlk := false; parse ll + | "-c" :: ll -> option_c := true; parse ll + | "-boot" :: ll -> parse ll (* We're already in boot mode by default *) + | "-I" :: r :: ll -> + (* To solve conflict (e.g. same filename in kernel and checker) + we allow to state an explicit order *) + add_dir add_known r []; + norecdir_list:=r::!norecdir_list; + parse ll + | f :: ll -> treat_file None f; parse ll + | [] -> () + +let coqdep_boot () = + if Array.length Sys.argv < 2 then exit 1; + parse (List.tl (Array.to_list Sys.argv)); + if !option_c then + add_rec_dir add_known "." [] + else begin + add_rec_dir add_known "theories" ["Coq"]; + add_rec_dir add_known "plugins" ["Coq"]; + end; + if !option_c then mL_dependencies (); + coq_dependencies () + +let _ = Printexc.catch coqdep_boot () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml new file mode 100644 index 00000000..b71a47d0 --- /dev/null +++ b/tools/coqdep_common.ml @@ -0,0 +1,445 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (f, "") + | s :: _ when Filename.check_suffix f s -> (Filename.chop_suffix f s, s) + | _ :: l -> get_extension f l + +(** [basename_noext] removes both the directory part and the extension + (if necessary) of a filename *) + +let basename_noext filename = + let fn = Filename.basename filename in + try Filename.chop_extension fn with _ -> fn + +(** ML Files specified on the command line. In the entries: + - the first string is the basename of the file, without extension nor + directory part + - the second string of [mlAccu] is the extension (either .ml or .ml4) + - the [dir] part is the directory, with None used as the current directory +*) + +let mlAccu = ref ([] : (string * string * dir) list) +and mliAccu = ref ([] : (string * dir) list) +and mllibAccu = ref ([] : (string * dir) list) + +(** Coq files specifies on the command line: + - first string is the full filename, with only its extension removed + - second string is the absolute version of the previous (via getcwd) +*) + +let vAccu = ref ([] : (string * string) list) + +(** Queue operations *) + +let addQueue q v = q := v :: !q + +let safe_hash_add clq q (k,v) = + try + let v2 = Hashtbl.find q k in + if v<>v2 then + let rec add_clash = function + (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl + | cl::cltl -> cl::add_clash cltl + | [] -> [(k,[v;v2])] in + clq := add_clash !clq; + (* overwrite previous bindings, as coqc does *) + Hashtbl.add q k v + with Not_found -> Hashtbl.add q k v + +(** Files found in the loadpaths. + For the ML files, the string is the basename without extension. + To allow ML source filename to be potentially capitalized, + we perform a double search. +*) + +let mkknown () = + let h = (Hashtbl.create 19 : (string, dir) Hashtbl.t) in + let add x s = if Hashtbl.mem h x then () else Hashtbl.add h x s + and iter f = Hashtbl.iter f h + and search x = + try Some (Hashtbl.find h (String.uncapitalize x)) + with Not_found -> + try Some (Hashtbl.find h (String.capitalize x)) + with Not_found -> None + in add, iter, search + +let add_ml_known, iter_ml_known, search_ml_known = mkknown () +let add_mli_known, iter_mli_known, search_mli_known = mkknown () +let add_mllib_known, _, search_mllib_known = mkknown () + +let vKnown = (Hashtbl.create 19 : (string list, string) Hashtbl.t) +let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) + +let clash_v = ref ([]: (string list * string list) list) + +let warning_module_notfound f s = + eprintf "*** Warning: in file %s, library " f; + eprintf "%s.v is required and has not been found in loadpath!\n" + (String.concat "." s); + flush stderr + +let warning_notfound f s = + eprintf "*** Warning: in file %s, the file " f; + eprintf "%s.v is required and has not been found !\n" s; + flush stderr + +let warning_declare f s = + eprintf "*** Warning: in file %s, declared ML module " f; + eprintf "%s has not been found !\n" s; + flush stderr + +let warning_clash file dir = + match List.assoc dir !clash_v with + (f1::f2::fl) -> + let f = Filename.basename f1 in + let d1 = Filename.dirname f1 in + let d2 = Filename.dirname f2 in + let dl = List.map Filename.dirname (List.rev fl) in + eprintf + "*** Warning: in file %s, \n required library %s is ambiguous!\n (found %s.v in " + file (String.concat "." dir) f; + List.iter (fun s -> eprintf "%s, " s) dl; + eprintf "%s and %s; used the latter)\n" d2 d1 + | _ -> assert false + +let safe_assoc verbose file k = + if verbose && List.mem_assoc k !clash_v then warning_clash file k; + Hashtbl.find vKnown k + +let absolute_dir dir = + let current = Sys.getcwd () in + Sys.chdir dir; + let dir' = Sys.getcwd () in + Sys.chdir current; + dir' + +let absolute_file_name basename odir = + let dir = match odir with Some dir -> dir | None -> "." in + absolute_dir dir // basename + +let file_name s = function + | None -> s + | Some "." -> s + | Some d -> d // s + +let depend_ML str = + match search_mli_known str, search_ml_known str with + | Some mlidir, Some mldir -> + let mlifile = file_name str mlidir + and mlfile = file_name str mldir in + (" "^mlifile^".cmi"," "^mlfile^".cmx") + | None, Some mldir -> + let mlfile = file_name str mldir in + (" "^mlfile^".cmo"," "^mlfile^".cmx") + | Some mlidir, None -> + let mlifile = file_name str mlidir in + (" "^mlifile^".cmi"," "^mlifile^".cmi") + | None, None -> "", "" + +let traite_fichier_ML md ext = + try + let chan = open_in (md ^ ext) in + let buf = Lexing.from_channel chan in + let deja_vu = ref [md] in + let a_faire = ref "" in + let a_faire_opt = ref "" in + begin try + while true do + let (Use_module str) = caml_action buf in + if List.mem str !deja_vu then + () + else begin + addQueue deja_vu str; + let byte,opt = depend_ML str in + a_faire := !a_faire ^ byte; + a_faire_opt := !a_faire_opt ^ opt + end + done + with Fin_fichier -> () + end; + close_in chan; + (!a_faire, !a_faire_opt) + with Sys_error _ -> ("","") + +let traite_fichier_mllib md ext = + try + let chan = open_in (md ^ ext) in + let list = mllib_list (Lexing.from_channel chan) in + let a_faire = ref "" in + let a_faire_opt = ref "" in + List.iter + (fun str -> match search_ml_known str with + | Some mldir -> + let file = file_name str mldir in + a_faire := !a_faire^" "^file^".cmo"; + a_faire_opt := !a_faire_opt^" "^file^".cmx" + | None -> ()) list; + (!a_faire, !a_faire_opt) + with Sys_error _ -> ("","") + + +(* Makefile's escaping rules are awful: $ is escaped by doubling and + other special characters are escaped by backslash prefixing while + backslashes themselves must be escaped only if part of a sequence + followed by a special character (i.e. in case of ambiguity with a + use of it as escaping character). Moreover (even if not crucial) + it is apparently not possible to directly escape ';' and leading '\t'. *) + +let escape = + let s' = Buffer.create 10 in + fun s -> + Buffer.clear s'; + for i = 0 to String.length s - 1 do + let c = s.[i] in + if c = ' ' or c = '#' or c = ':' (* separators and comments *) + or c = '%' (* pattern *) + or c = '?' or c = '[' or c = ']' or c = '*' (* expansion in filenames *) + or i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || + 'A' <= s.[1] && s.[1] <= 'Z' || + 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) + then begin + let j = ref (i-1) in + while !j >= 0 && s.[!j] = '\\' do + Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) + done; + Buffer.add_char s' '\\'; + end; + if c = '$' then Buffer.add_char s' '$'; + Buffer.add_char s' c + done; + Buffer.contents s' + +let canonize f = + let f' = absolute_dir (Filename.dirname f) // Filename.basename f in + match List.filter (fun (_,full) -> f' = full) !vAccu with + | (f,_) :: _ -> escape f + | _ -> escape f + +let traite_fichier_Coq verbose f = + try + let chan = open_in f in + let buf = Lexing.from_channel chan in + let deja_vu_v = ref ([]: string list list) + and deja_vu_ml = ref ([] : string list) in + try + while true do + let tok = coq_action buf in + match tok with + | Require strl -> + List.iter (fun str -> + if not (List.mem str !deja_vu_v) then begin + addQueue deja_vu_v str; + try + let file_str = safe_assoc verbose f str in + printf " %s%s" (canonize file_str) !suffixe + with Not_found -> + if verbose && not (Hashtbl.mem coqlibKnown str) then + warning_module_notfound f str + end) strl + | RequireString s -> + let str = Filename.basename s in + if not (List.mem [str] !deja_vu_v) then begin + addQueue deja_vu_v [str]; + try + let file_str = Hashtbl.find vKnown [str] in + printf " %s%s" (canonize file_str) !suffixe + with Not_found -> + if not (Hashtbl.mem coqlibKnown [str]) then + warning_notfound f s + end + | Declare sl -> + let declare suff dir s = + let base = file_name s dir in + let opt = if !option_natdynlk then " "^base^".cmxs" else "" in + printf " %s%s%s" (escape base) suff opt + in + let decl str = + let s = basename_noext str in + if not (List.mem s !deja_vu_ml) then begin + addQueue deja_vu_ml s; + match search_mllib_known s with + | Some mldir -> declare ".cma" mldir s + | None -> + match search_ml_known s with + | Some mldir -> declare ".cmo" mldir s + | None -> warning_declare f str + end + in List.iter decl sl + | Load str -> + let str = Filename.basename str in + if not (List.mem [str] !deja_vu_v) then begin + addQueue deja_vu_v [str]; + try + let file_str = Hashtbl.find vKnown [str] in + printf " %s.v" (canonize file_str) + with Not_found -> () + end + done + with Fin_fichier -> (); + close_in chan + with Sys_error _ -> () + + +let mL_dependencies () = + List.iter + (fun (name,ext,dirname) -> + let fullname = file_name name dirname in + let (dep,dep_opt) = traite_fichier_ML fullname ext in + let intf = match search_mli_known name with + | None -> "" + | Some mldir -> " "^(file_name name mldir)^".cmi" + in + let efullname = escape fullname in + printf "%s.cmo:%s%s\n" efullname dep intf; + printf "%s.cmx:%s%s\n" efullname dep_opt intf; + flush stdout) + (List.rev !mlAccu); + List.iter + (fun (name,dirname) -> + let fullname = file_name name dirname in + let (dep,_) = traite_fichier_ML fullname ".mli" in + printf "%s.cmi:%s\n" (escape fullname) dep; + flush stdout) + (List.rev !mliAccu); + List.iter + (fun (name,dirname) -> + let fullname = file_name name dirname in + let (dep,dep_opt) = traite_fichier_mllib fullname ".mllib" in + let efullname = escape fullname in + printf "%s.cma:%s\n" efullname dep; + printf "%s.cmxa %s.cmxs:%s\n" efullname efullname dep_opt; + flush stdout) + (List.rev !mllibAccu) + +let coq_dependencies () = + List.iter + (fun (name,_) -> + let ename = escape name in + let glob = if !option_noglob then "" else " "^ename^".glob" in + printf "%s%s%s: %s.v" ename !suffixe glob ename; + traite_fichier_Coq true (name ^ ".v"); + printf "\n"; + flush stdout) + (List.rev !vAccu) + +let rec suffixes = function + | [] -> assert false + | [name] -> [[name]] + | dir::suffix as l -> l::suffixes suffix + +let add_known phys_dir log_dir f = + match get_extension f [".v";".ml";".mli";".ml4";".mllib"] with + | (basename,".v") -> + let name = log_dir@[basename] in + let file = phys_dir//basename in + let paths = suffixes name in + List.iter + (fun n -> safe_hash_add clash_v vKnown (n,file)) paths + | (basename,(".ml"|".ml4")) -> add_ml_known basename (Some phys_dir) + | (basename,".mli") -> add_mli_known basename (Some phys_dir) + | (basename,".mllib") -> add_mllib_known basename (Some phys_dir) + | _ -> () + +(* Visits all the directories under [dir], including [dir], + or just [dir] if [recur=false] *) + +let rec add_directory recur add_file phys_dir log_dir = + let dirh = opendir phys_dir in + try + while true do + let f = readdir dirh in + (* we avoid . .. and all hidden files and subdirs (e.g. .svn, _darcs) *) + if f.[0] <> '.' && f.[0] <> '_' then + let phys_f = if phys_dir = "." then f else phys_dir//f in + match try (stat phys_f).st_kind with _ -> S_BLK with + | S_DIR when recur -> + if List.mem phys_f !norecdir_list then () + else + let log_dir' = if log_dir = [] then ["Coq"] else log_dir@[f] in + add_directory recur add_file phys_f log_dir' + | S_REG -> add_file phys_dir log_dir f + | _ -> () + done + with End_of_file -> closedir dirh + +let add_dir add_file phys_dir log_dir = + try add_directory false add_file phys_dir log_dir with Unix_error _ -> () + +let add_rec_dir add_file phys_dir log_dir = + handle_unix_error (add_directory true add_file phys_dir) log_dir + +let rec treat_file old_dirname old_name = + let name = Filename.basename old_name + and new_dirname = Filename.dirname old_name in + let dirname = + match (old_dirname,new_dirname) with + | (d, ".") -> d + | (None,d) -> Some d + | (Some d1,d2) -> Some (d1//d2) + in + let complete_name = file_name name dirname in + match try (stat complete_name).st_kind with _ -> S_BLK with + | S_DIR -> + (if name.[0] <> '.' then + let dir=opendir complete_name in + let newdirname = + match dirname with + | None -> name + | Some d -> d//name + in + try + while true do treat_file (Some newdirname) (readdir dir) done + with End_of_file -> closedir dir) + | S_REG -> + (match get_extension name [".v";".ml";".mli";".ml4";".mllib"] with + | (base,".v") -> + let name = file_name base dirname + and absname = absolute_file_name base dirname in + addQueue vAccu (name, absname) + | (base,(".ml"|".ml4" as ext)) -> addQueue mlAccu (base,ext,dirname) + | (base,".mli") -> addQueue mliAccu (base,dirname) + | (base,".mllib") -> addQueue mllibAccu (base,dirname) + | _ -> ()) + | _ -> () diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index cc9f2175..89eeed54 100755 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -6,75 +6,77 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: coqdep_lexer.mll 10721 2008-03-26 14:40:30Z notin $ i*) - +(*i $Id$ i*) + { - open Filename + open Filename open Lexing - + type mL_token = Use_module of string type spec = bool - - type coq_token = - | Require of spec * string list list - | RequireString of spec * string + + type coq_token = + | Require of string list list + | RequireString of string | Declare of string list | Load of string let comment_depth = ref 0 - + exception Fin_fichier - + let module_current_name = ref [] let module_names = ref [] let ml_module_name = ref "" - - let specif = ref false - + let mllist = ref ([] : string list) let field_name s = String.sub s 1 (String.length s - 1) + } let space = [' ' '\t' '\n' '\r'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let coq_ident = ['a'-'z' '_' '0'-'9' 'A'-'Z']+ let coq_field = '.'['a'-'z' '_' '0'-'9' 'A'-'Z']+ +let caml_up_ident = uppercase identchar* +let caml_low_ident = lowercase identchar* let dot = '.' ( space+ | eof) rule coq_action = parse | "Require" space+ - { specif := false; module_names := []; opened_file lexbuf } + { module_names := []; opened_file lexbuf } | "Require" space+ "Export" space+ - { specif := false; module_names := []; opened_file lexbuf} + { module_names := []; opened_file lexbuf} | "Require" space+ "Import" space+ - { specif := false; module_names := []; opened_file lexbuf} - | "Declare" space+ "ML" space+ "Module" space+ + { module_names := []; opened_file lexbuf} + | "Local"? "Declare" space+ "ML" space+ "Module" space+ { mllist := []; modules lexbuf} | "Load" space+ { load_file lexbuf } | "\"" { string lexbuf; coq_action lexbuf} | "(*" (* "*)" *) - { comment_depth := 1; comment lexbuf; coq_action lexbuf } - | eof - { raise Fin_fichier} - | _ + { comment_depth := 1; comment lexbuf; coq_action lexbuf } + | eof + { raise Fin_fichier} + | _ { coq_action lexbuf } and caml_action = parse - | [' ' '\010' '\013' '\009' '\012'] + - { caml_action lexbuf } - | "open" [' ' '\010' '\013' '\009' '\012']* - { caml_opened_file lexbuf } - | lowercase identchar* + | space + { caml_action lexbuf } - | uppercase identchar* + | "open" space* (caml_up_ident as id) + { Use_module (String.uncapitalize id) } + | "module" space+ caml_up_ident + { caml_action lexbuf } + | caml_low_ident { caml_action lexbuf } + | caml_up_ident { ml_module_name := Lexing.lexeme lexbuf; qual_id lexbuf } | ['0'-'9']+ @@ -130,7 +132,7 @@ and comment = parse | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { comment lexbuf } | eof - { raise Fin_fichier } + { raise Fin_fichier } | _ { comment lexbuf } and string = parse @@ -155,7 +157,7 @@ and load_file = parse Load (if check_suffix f ".v" then chop_suffix f ".v" else f) } | coq_ident { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } - | eof + | eof { raise Fin_fichier } | _ { load_file lexbuf } @@ -169,10 +171,6 @@ and opened_file = parse | "(*" (* "*)" *) { comment_depth := 1; comment lexbuf; opened_file lexbuf } | space+ { opened_file lexbuf } - | "Implementation" - { opened_file lexbuf } - | "Specification" - { specif := true; opened_file lexbuf } | coq_ident { module_current_name := [Lexing.lexeme lexbuf]; opened_file_fields lexbuf } @@ -184,7 +182,7 @@ and opened_file = parse if Filename.check_suffix str ".v" then Filename.chop_suffix str ".v" else str in - RequireString (!specif, str) } + RequireString str } | eof { raise Fin_fichier } | _ { opened_file lexbuf } @@ -198,13 +196,13 @@ and opened_file_fields = parse { module_current_name := field_name (Lexing.lexeme lexbuf) :: !module_current_name; opened_file_fields lexbuf } - | coq_ident { module_names := + | coq_ident { module_names := List.rev !module_current_name :: !module_names; module_current_name := [Lexing.lexeme lexbuf]; opened_file_fields lexbuf } | dot { module_names := List.rev !module_current_name :: !module_names; - Require (!specif, List.rev !module_names) } + Require (List.rev !module_names) } | eof { raise Fin_fichier } | _ { opened_file_fields lexbuf } @@ -213,23 +211,22 @@ and modules = parse | "(*" (* "*)" *) { comment_depth := 1; comment lexbuf; modules lexbuf } | '"' [^'"']* '"' - { let lex = (Lexing.lexeme lexbuf) in + { let lex = (Lexing.lexeme lexbuf) in let str = String.sub lex 1 (String.length lex - 2) in mllist := str :: !mllist; modules lexbuf} - | _ { (Declare (List.rev !mllist)) } + | _ { (Declare (List.rev !mllist)) } and qual_id = parse - | '.' [^ '.' '(' '['] { Use_module (String.uncapitalize !ml_module_name) } + | '.' [^ '.' '(' '['] { + Use_module (String.uncapitalize !ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } -and caml_opened_file = parse - | uppercase identchar* - { let lex = (Lexing.lexeme lexbuf) in - let str = String.sub lex 0 (String.length lex) in - (Use_module (String.uncapitalize str)) } - | eof {raise Fin_fichier } - | _ { caml_action lexbuf } +and mllib_list = parse + | coq_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) + in s :: mllib_list lexbuf } + | space+ { mllib_list lexbuf } + | eof { [] } diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index b1a46bae..d25034f2 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -6,9 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: alpha.ml 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) -let norm_char c = match Char.uppercase c with +open Cdglobals + +let norm_char_latin1 c = match Char.uppercase c with | '\192'..'\198' -> 'A' | '\199' -> 'C' | '\200'..'\203' -> 'E' @@ -19,6 +21,13 @@ let norm_char c = match Char.uppercase c with | '\221' -> 'Y' | c -> c +let norm_char_utf8 c = Char.uppercase c + +let norm_char c = + if !utf8 then norm_char_utf8 c else + if !latin1 then norm_char_latin1 c else + Char.uppercase c + let norm_string s = let u = String.copy s in for i = 0 to String.length s - 1 do @@ -30,12 +39,14 @@ let compare_char c1 c2 = match norm_char c1, norm_char c2 with | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2 | 'A'..'Z', _ -> -1 | _, 'A'..'Z' -> 1 + | '_', _ -> -1 + | _, '_' -> 1 | c1, c2 -> compare c1 c2 -let compare_string s1 s2 = +let compare_string s1 s2 = let n1 = String.length s1 in let n2 = String.length s2 in - let rec cmp i = + let rec cmp i = if i == n1 || i == n2 then n1 - n2 else diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli index d3c26537..922a10d6 100644 --- a/tools/coqdoc/alpha.mli +++ b/tools/coqdoc/alpha.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: alpha.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (* Alphabetic order. *) diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml index b3f0739d..b2e23657 100644 --- a/tools/coqdoc/cdglobals.ml +++ b/tools/coqdoc/cdglobals.ml @@ -25,9 +25,19 @@ let out_to = ref MultFiles let out_channel = ref stdout +let coqdoc_out f = + if !output_dir <> "" && Filename.is_relative f then + if not (Sys.file_exists !output_dir) then + (Printf.eprintf "No such directory: %s\n" !output_dir; exit 1) + else + Filename.concat !output_dir f + else + f + let open_out_file f = - let f = if !output_dir <> "" && Filename.is_relative f then Filename.concat !output_dir f else f in - out_channel := open_out f + out_channel := + try open_out (coqdoc_out f) + with Sys_error s -> Printf.eprintf "%s\n" s; exit 1 let close_out_file () = close_out !out_channel @@ -37,7 +47,7 @@ type glob_source_t = | DotGlob | GlobFile of string -let glob_source = ref DotGlob +let glob_source = ref DotGlob let header_trailer = ref true let header_file = ref "" @@ -50,6 +60,7 @@ let gallina = ref false let short = ref false let index = ref true let multi_index = ref false +let index_name = ref "index" let toc = ref false let page_title = ref "" let title = ref "" @@ -58,6 +69,10 @@ let coqlib = ref Coq_config.wwwstdlib let coqlib_path = ref Coq_config.coqlib let raw_comments = ref false let parse_comments = ref false +let plain_comments = ref false +let toc_depth = (ref None : int option ref) +let lib_name = ref "Library" +let lib_subtitles = ref false let interpolate = ref false let charset = ref "iso-8859-1" @@ -82,4 +97,3 @@ type coq_module = string type file = | Vernac_file of string * coq_module | Latex_file of string - diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css index 762be5af..24b514b7 100644 --- a/tools/coqdoc/coqdoc.css +++ b/tools/coqdoc/coqdoc.css @@ -19,14 +19,16 @@ body { padding: 0px 0px; margin: 0;} -/* Contenu */ +/* Contents */ #main{ display: block; padding: 10px; - overflow: hidden; + font-family: sans-serif; font-size: 100%; line-height: 100% } +#main h1 { line-height: 95% } /* allow for multi-line headers */ + #main a.idref:visited {color : #416DFF; text-decoration : none; } #main a.idref:link {color : #416DFF; text-decoration : none; } #main a.idref:hover {text-decoration : none; } @@ -40,41 +42,93 @@ body { padding: 0px 0px; #main .keyword { color : #cf1d1d } #main { color: black } -#main .section { background-color:#90bdff; - font-size : 175% } +.section { background-color: rgb(60%,60%,100%); + padding-top: 13px; + padding-bottom: 13px; + padding-left: 3px; + margin-top: 5px; + margin-bottom: 5px; + font-size : 175% } + +h2.section { background-color: rgb(80%,80%,100%); + padding-left: 3px; + padding-top: 12px; + padding-bottom: 10px; + font-size : 130% } + +h3.section { background-color: rgb(90%,90%,100%); + padding-left: 3px; + padding-top: 7px; + padding-bottom: 7px; + font-size : 115% } + +h4.section { +/* + background-color: rgb(80%,80%,80%); + max-width: 20em; + padding-left: 5px; + padding-top: 5px; + padding-bottom: 5px; +*/ + background-color: white; + padding-left: 0px; + padding-top: 0px; + padding-bottom: 0px; + font-size : 100%; + font-style : bold; + text-decoration : underline; + } #main .doc { margin: 0px; - padding: 10px; font-family: sans-serif; font-size: 100%; - line-height: 100%; - font-weight:bold; + line-height: 125%; + max-width: 40em; color: black; + padding: 10px; background-color: #90bdff; border-style: plain} .inlinecode { display: inline; +/* font-size: 125%; */ + color: #666666; + font-family: monospace } + +.doc .inlinecode { + display: inline; + font-size: 120%; + color: rgb(30%,30%,70%); + font-family: monospace } + +.doc .inlinecode .id { + color: rgb(30%,30%,70%); +} + +.doc .code { + display: inline; + font-size: 120%; + color: rgb(30%,30%,70%); font-family: monospace } .comment { display: inline; font-family: monospace; - color: red; } + color: rgb(50%,50%,80%); +} .code { display: block; - font-family: monospace } +/* padding-left: 15px; */ + font-size: 110%; + font-family: monospace; + } /* Pied de page */ #footer { font-size: 65%; font-family: sans-serif; } -#footer a:visited { color: blue; } -#footer a:link { text-decoration: none; - color: #888888; } - .id { display: inline; } .id[type="constructor"] { @@ -129,3 +183,52 @@ body { padding: 0px 0px; color : #cf1d1d; /* color: black; */ } + +.inlinecode .id { + color: rgb(0%,0%,0%); +} + + +/* TOC */ + +#toc h2 { + padding: 10px; + background-color: rgb(60%,60%,100%); +} + +#toc li { + padding-bottom: 8px; +} + +/* Index */ + +#index { + margin: 0; + padding: 0; + width: 100%; +} + +#index #frontispiece { + margin: 1em auto; + padding: 1em; + width: 60%; +} + +.booktitle { font-size : 140% } +.authors { font-size : 90%; + line-height: 115%; } +.moreauthors { font-size : 60% } + +#index #entrance { + text-align: center; +} + +#index #entrance .spacer { + margin: 0 30px 0 30px; +} + +#index #footer { + position: absolute; + bottom: 0; + text-align: bottom; +} \ No newline at end of file diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty index fca9a1d7..4314d07d 100644 --- a/tools/coqdoc/coqdoc.sty +++ b/tools/coqdoc/coqdoc.sty @@ -65,6 +65,25 @@ % macro for typesetting tactic identifiers \newcommand{\coqdoctac}[1]{\texttt{#1}} +% These are the real macros used by coqdoc, their typesetting is +% based on the above macros by default. + +\newcommand{\coqdoclibrary}[1]{\coqdoccst{#1}} +\newcommand{\coqdocinductive}[1]{\coqdocind{#1}} +\newcommand{\coqdocdefinition}[1]{\coqdoccst{#1}} +\newcommand{\coqdocvariable}[1]{\coqdocvar{#1}} +\newcommand{\coqdocconstructor}[1]{\coqdocconstr{#1}} +\newcommand{\coqdoclemma}[1]{\coqdoccst{#1}} +\newcommand{\coqdocclass}[1]{\coqdocind{#1}} +\newcommand{\coqdocinstance}[1]{\coqdoccst{#1}} +\newcommand{\coqdocmethod}[1]{\coqdoccst{#1}} +\newcommand{\coqdocabbreviation}[1]{\coqdoccst{#1}} +\newcommand{\coqdocrecord}[1]{\coqdocind{#1}} +\newcommand{\coqdocprojection}[1]{\coqdoccst{#1}} +\newcommand{\coqdocnotation}[1]{\coqdockw{#1}} +\newcommand{\coqdocsection}[1]{\coqdoccst{#1}} +\newcommand{\coqdocaxiom}[1]{\coqdocax{#1}} +\newcommand{\coqdocmoduleid}[1]{\coqdocmod{#1}} % Environment encompassing code fragments % !!! CAUTION: This environment may have empty contents @@ -102,15 +121,18 @@ \newcommand{\coqdef}[3]{\phantomsection\hypertarget{coq:#1}{#3}} \newcommand{\coqref}[2]{\hyperlink{coq:#1}{#2}} + \newcommand{\coqexternalref}[3]{\href{#1.html\##2}{#3}} + \newcommand{\identref}[2]{\hyperlink{coq:#1}{\textsf {#2}}} - \newcommand{\coqlibrary}[2]{\cleardoublepage\phantomsection - \hypertarget{coq:#1}{\chapter{Library \texorpdfstring{\coqdoccst}{}{#2}}}} + \newcommand{\coqlibrary}[3]{\cleardoublepage\phantomsection + \hypertarget{coq:#1}{\chapter{#2\texorpdfstring{\coqdoccst}{}{#3}}}} \else \newcommand{\coqdef}[3]{#3} \newcommand{\coqref}[2]{#2} + \newcommand{\coqexternalref}[3]{#3} \newcommand{\texorpdfstring}[2]{#1} \newcommand{\identref}[2]{\textsf{#2}} - \newcommand{\coqlibrary}[2]{\cleardoublepage\chapter{Library \coqdoccst{#2}}} + \newcommand{\coqlibrary}[3]{\cleardoublepage\chapter{#2\coqdoccst{#3}}} \fi \usepackage{xr} @@ -147,54 +169,4 @@ \def\coqdoctac#1{{\color{\coqdoctaccolor}{\texttt{#1}}}} \fi -\newcommand{\coqdefinition}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqdefinitionref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqvariable}[2]{\coqdocvar{#2}} -\newcommand{\coqvariableref}[2]{\coqref{#1}{\coqdocvar{#2}}} - -\newcommand{\coqinductive}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}} -\newcommand{\coqinductiveref}[2]{\coqref{#1}{\coqdocind{#2}}} - -\newcommand{\coqconstructor}[2]{\coqdef{#1}{#2}{\coqdocconstr{#2}}} -\newcommand{\coqconstructorref}[2]{\coqref{#1}{\coqdocconstr{#2}}} - -\newcommand{\coqlemma}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqlemmaref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqclass}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}} -\newcommand{\coqclassref}[2]{\coqref{#1}{\coqdocind{#2}}} - -\newcommand{\coqinstance}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqinstanceref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqmethod}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqmethodref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqabbreviation}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqabbreviationref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqrecord}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}} -\newcommand{\coqrecordref}[2]{\coqref{#1}{\coqdocind{#2}}} - -\newcommand{\coqprojection}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqprojectionref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqnotationref}[2]{\coqref{#1}{\coqdockw{#2}}} - -\newcommand{\coqsection}[2]{\coqdef{sec:#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqsectionref}[2]{\coqref{sec:#1}{\coqdoccst{#2}}} - -%\newcommand{\coqlibrary}[2]{\chapter{Library \coqdoccst{#2}}\label{coq:#1}} - -%\newcommand{\coqlibraryref}[2]{\ref{coq:#1}} - -\newcommand{\coqlibraryref}[2]{\coqref{#1}{\coqdoccst{#2}}} - -\newcommand{\coqaxiom}[2]{\coqdef{#1}{#2}{\coqdocax{#2}}} -\newcommand{\coqaxiomref}[2]{\coqref{#1}{\coqdocax{#2}}} - -\newcommand{\coqmodule}[2]{\coqdef{mod:#1}{#2}{\coqdocmod{#2}}} -\newcommand{\coqmoduleref}[2]{\coqref{mod:#1}{\coqdocmod{#2}}} - \endinput diff --git a/tools/coqdoc/cpretty.mli b/tools/coqdoc/cpretty.mli new file mode 100644 index 00000000..213c76aa --- /dev/null +++ b/tools/coqdoc/cpretty.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Cdglobals.coq_module -> unit +val detect_subtitle : string -> Cdglobals.coq_module -> string option diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll new file mode 100644 index 00000000..be8bc85d --- /dev/null +++ b/tools/coqdoc/cpretty.mll @@ -0,0 +1,1176 @@ +(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [] + | (l :: ls) -> l :: (take (n-1) ls) + + (* count the number of spaces at the beginning of a string *) + let count_spaces s = + let n = String.length s in + let rec count c i = + if i == n then c,i else match s.[i] with + | '\t' -> count (c + (8 - (c mod 8))) (i + 1) + | ' ' -> count (c + 1) (i + 1) + | _ -> c,i + in + count 0 0 + + let remove_newline s = + let n = String.length s in + let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in + let i = count 0 in + i, String.sub s i (n - i) + + let count_dashes s = + let c = ref 0 in + for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done; + !c + + let cut_head_tail_spaces s = + let n = String.length s in + let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in + let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in + let l = look_up 0 in + let r = look_dn (n-1) in + if l <= r then String.sub s l (r-l+1) else s + + let sec_title s = + let rec count lev i = + if s.[i] = '*' then + count (succ lev) (succ i) + else + let t = String.sub s i (String.length s - i) in + lev, cut_head_tail_spaces t + in + count 0 (String.index s '*') + + let strip_eol s = + let eol = s.[String.length s - 1] = '\n' in + (eol, if eol then String.sub s 1 (String.length s - 1) else s) + + + let formatted = ref false + let brackets = ref 0 + let comment_level = ref 0 + let in_proof = ref None + let in_emph = ref false + + let start_emph () = in_emph := true; Output.start_emph () + let stop_emph () = if !in_emph then (Output.stop_emph (); in_emph := false) + + let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos; + lexbuf.lex_curr_p <- lexbuf.lex_start_p + + let backtrack_past_newline lexbuf = + let buf = lexeme lexbuf in + let splits = Str.bounded_split_delim (Str.regexp "['\n']") buf 2 in + match splits with + | [] -> () + | (_ :: []) -> () + | (s1 :: rest :: _) -> + let length_skip = 1 + String.length s1 in + lexbuf.lex_curr_pos <- lexbuf.lex_start_pos + length_skip + + let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false + + (* saving/restoring the PP state *) + + type state = { + st_gallina : bool; + st_light : bool + } + + let state_stack = Stack.create () + + let save_state () = + Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack + + let restore_state () = + let s = Stack.pop state_stack in + Cdglobals.gallina := s.st_gallina; + Cdglobals.light := s.st_light + + let without_ref r f x = save_state (); r := false; f x; restore_state () + + let without_gallina = without_ref Cdglobals.gallina + + let without_light = without_ref Cdglobals.light + + let show_all f = without_gallina (without_light f) + + let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false + let end_show () = restore_state () + + (* Reset the globals *) + + let reset () = + formatted := false; + brackets := 0; + comment_level := 0 + + (* erasing of Section/End *) + + let section_re = Str.regexp "[ \t]*Section" + let end_re = Str.regexp "[ \t]*End" + let is_section s = Str.string_match section_re s 0 + let is_end s = Str.string_match end_re s 0 + + let sections_to_close = ref 0 + + let section_or_end s = + if is_section s then begin + incr sections_to_close; true + end else if is_end s then begin + if !sections_to_close > 0 then begin + decr sections_to_close; true + end else + false + end else + true + + (* for item lists *) + type list_compare = + | Before + | StartLevel of int + | InLevel of int * bool + + (* Before : we're before any levels + StartLevel : at the same column as the dash in a level + InLevel : after the dash of this level, but before any deeper dashes. + bool is true if this is the last level *) + let find_level levels cur_indent = + match levels with + | [] -> Before + | (l::ls) -> + if cur_indent < l then Before + else + (* cur_indent will never be less than the head of the list *) + let rec findind ls n = + match ls with + | [] -> InLevel (n,true) + | (l :: []) -> if cur_indent = l then StartLevel n + else InLevel (n,true) + | (l1 :: l2 :: ls) -> + if cur_indent = l1 then StartLevel n + else if cur_indent < l2 then InLevel (n,false) + else findind (l2 :: ls) (n+1) + in + findind (l::ls) 1 + + type is_start_list = + | Rule + | List of int + | Neither + + let check_start_list str = + let n_dashes = count_dashes str in + let (n_spaces,_) = count_spaces str in + if n_dashes >= 4 && not !Cdglobals.plain_comments then + Rule + else + if n_dashes = 1 && not !Cdglobals.plain_comments then + List n_spaces + else + Neither + + (* examine a string for subtitleness *) + let subtitle m s = + match Str.split_delim (Str.regexp ":") s with + | [] -> false + | (name::_) -> + if (cut_head_tail_spaces name) = m then + true + else + false + + + (* tokens pretty-print *) + + let token_buffer = Buffer.create 1024 + + let token_re = + Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)" + let printing_token_re = + Str.regexp + "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\(&#\\|[^#]\\)*\\)#\\)?" + + let add_printing_token toks pps = + try + if Str.string_match token_re toks 0 then + let tok = Str.matched_group 1 toks in + if Str.string_match printing_token_re pps 0 then + let pp = + (try Some (Str.matched_group 3 pps) with _ -> + try Some (Str.matched_group 4 pps) with _ -> None), + (try Some (Str.matched_group 6 pps) with _ -> None) + in + Output.add_printing_token tok pp + with _ -> + () + + let remove_token_re = + Str.regexp + "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)" + + let remove_printing_token toks = + try + if Str.string_match remove_token_re toks 0 then + let tok = Str.matched_group 1 toks in + Output.remove_printing_token tok + with _ -> + () + + let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:=" + let extract_ident s = + assert (String.length s >= 3); + if Str.string_match extract_ident_re s 0 then + Str.matched_group 1 s + else + String.sub s 1 (String.length s - 3) + + let output_indented_keyword s lexbuf = + let nbsp,isp = count_spaces s in + Output.indentation nbsp; + let s = String.sub s isp (String.length s - isp) in + Output.ident s (lexeme_start lexbuf + isp) + +} + +(*s Regular expressions *) + +let space = [' ' '\t'] +let space_nl = [' ' '\t' '\n' '\r'] +let nl = "\r\n" | '\n' + +let firstchar = + ['A'-'Z' 'a'-'z' '_'] | + (* superscript 1 *) + '\194' '\185' | + (* utf-8 latin 1 supplement *) + '\195' ['\128'-'\191'] | + (* utf-8 letterlike symbols *) + (* '\206' ([ '\145' - '\183'] | '\187') | *) + (* '\xCF' [ '\x00' - '\xCE' ] | *) + (* utf-8 letterlike symbols *) + '\206' ('\160' | [ '\177'-'\183'] | '\187') | + '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) + | '\129' [ '\176'-'\187' ] (* superscripts *) + | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) +let identchar = + firstchar | ['\'' '0'-'9' '@' ] +let id = firstchar identchar* +let pfx_id = (id '.')* +let identifier = + id | pfx_id id + +(* This misses unicode stuff, and it adds "[" and "]". It's only an + approximation of idents - used for detecting whether an underscore + is part of an identifier or meant to indicate emphasis *) +let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' '\'' '0'-'9' '@' ] + +let printing_token = [^ ' ' '\t']* + +let thm_token = + "Theorem" + | "Lemma" + | "Fact" + | "Remark" + | "Corollary" + | "Proposition" + | "Property" + | "Goal" + +let prf_token = + "Next" space+ "Obligation" + | "Proof" (space* "." | space+ "with") + +let def_token = + "Definition" + | "Let" + | "Class" + | "SubClass" + | "Example" + | "Local" + | "Fixpoint" + | "Boxed" + | "CoFixpoint" + | "Record" + | "Structure" + | "Scheme" + | "Inductive" + | "CoInductive" + | "Equations" + | "Instance" + | "Global" space+ "Instance" + +let decl_token = + "Hypothesis" + | "Hypotheses" + | "Parameter" + | "Axiom" 's'? + | "Conjecture" + +let gallina_ext = + "Module" + | "Include" space+ "Type" + | "Include" + | "Declare" space+ "Module" + | "Transparent" + | "Opaque" + | "Canonical" + | "Coercion" + | "Identity" + | "Implicit" + | "Tactic" space+ "Notation" + | "Section" + | "Context" + | "Variable" 's'? + | ("Hypothesis" | "Hypotheses") + | "End" + +let notation_kw = + "Notation" + | "Infix" + | "Reserved" space+ "Notation" + +let commands = + "Pwd" + | "Cd" + | "Drop" + | "ProtectedLoop" + | "Quit" + | "Load" + | "Add" + | "Remove" space+ "Loadpath" + | "Print" + | "Inspect" + | "About" + | "Search" + | "Eval" + | "Reset" + | "Check" + | "Type" + + | "Section" + | "Chapter" + | "Variable" 's'? + | ("Hypothesis" | "Hypotheses") + | "End" + +let end_kw = "Qed" | "Defined" | "Save" | "Admitted" | "Abort" + +let extraction = + "Extraction" + | "Recursive" space+ "Extraction" + | "Extract" + +let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction + +let prog_kw = + "Program" space+ gallina_kw + | "Obligation" + | "Obligations" + | "Solve" + +let gallina_kw_to_hide = + "Implicit" space+ "Arguments" + | "Ltac" + | "Require" + | "Import" + | "Export" + | "Load" + | "Hint" + | "Open" + | "Close" + | "Delimit" + | "Transparent" + | "Opaque" + | ("Declare" space+ ("Morphism" | "Step") ) + | ("Set" | "Unset") space+ "Printing" space+ "Coercions" + | "Declare" space+ ("Left" | "Right") space+ "Step" + + +let section = "*" | "**" | "***" | "****" + +let item_space = " " + +let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl +let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl +let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl +let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl +(* +let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" +let end_verb = "(*" space* "end" space+ "verb" space* "*)" +*) + +(*s Scanning Coq, at beginning of line *) + +rule coq_bol = parse + | space* nl+ + { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) + then Output.empty_line_of_code (); + coq_bol lexbuf } + | space* "(**" space_nl + { Output.end_coq (); Output.start_doc (); + let eol = doc_bol lexbuf in + Output.end_doc (); Output.start_coq (); + if eol then coq_bol lexbuf else coq lexbuf } + | space* "Comments" space_nl + { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); + Output.start_coq (); coq lexbuf } + | space* begin_hide + { skip_hide lexbuf; coq_bol lexbuf } + | space* begin_show + { begin_show (); coq_bol lexbuf } + | space* end_show + { end_show (); coq_bol lexbuf } + | space* gallina_kw_to_hide + { let s = lexeme lexbuf in + if !Cdglobals.light && section_or_end s then + let eol = skip_to_dot lexbuf in + if eol then (coq_bol lexbuf) else coq lexbuf + else + begin + output_indented_keyword s lexbuf; + let eol = body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf + end } + | space* thm_token + { let s = lexeme lexbuf in + output_indented_keyword s lexbuf; + let eol = body lexbuf in + in_proof := Some eol; + if eol then coq_bol lexbuf else coq lexbuf } + | space* prf_token + { in_proof := Some true; + let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else + let s = lexeme lexbuf in + if s.[String.length s - 1] = '.' then false + else skip_to_dot lexbuf + in if eol then coq_bol lexbuf else coq lexbuf } + | space* end_kw { + let eol = + if not (!in_proof <> None && !Cdglobals.gallina) then + begin backtrack lexbuf; body_bol lexbuf end + else skip_to_dot lexbuf + in + in_proof := None; + if eol then coq_bol lexbuf else coq lexbuf } + | space* gallina_kw + { + in_proof := None; + let s = lexeme lexbuf in + output_indented_keyword s lexbuf; + let eol= body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + | space* prog_kw + { + in_proof := None; + let s = lexeme lexbuf in + output_indented_keyword s lexbuf; + let eol= body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + | space* notation_kw space* + { let s = lexeme lexbuf in + output_indented_keyword s lexbuf; + let eol= start_notation_string lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + + | space* "(**" space+ "printing" space+ printing_token space+ + { let tok = lexeme lexbuf in + let s = printing_token_body lexbuf in + add_printing_token tok s; + coq_bol lexbuf } + | space* "(**" space+ "printing" space+ + { eprintf "warning: bad 'printing' command at character %d\n" + (lexeme_start lexbuf); flush stderr; + comment_level := 1; + ignore (comment lexbuf); + coq_bol lexbuf } + | space* "(**" space+ "remove" space+ "printing" space+ + printing_token space* "*)" + { remove_printing_token (lexeme lexbuf); + coq_bol lexbuf } + | space* "(**" space+ "remove" space+ "printing" space+ + { eprintf "warning: bad 'remove printing' command at character %d\n" + (lexeme_start lexbuf); flush stderr; + comment_level := 1; + ignore (comment lexbuf); + coq_bol lexbuf } + | space* "(*" + { comment_level := 1; + if !Cdglobals.parse_comments then begin + let s = lexeme lexbuf in + let nbsp,isp = count_spaces s in + Output.indentation nbsp; + Output.start_comment (); + end; + let eol = comment lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + | eof + { () } + | _ + { let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else + skip_to_dot lexbuf + in + if eol then coq_bol lexbuf else coq lexbuf } + +(*s Scanning Coq elsewhere *) + +and coq = parse + | nl + { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf } + | "(**" space_nl + { Output.end_coq (); Output.start_doc (); + let eol = doc_bol lexbuf in + Output.end_doc (); Output.start_coq (); + if eol then coq_bol lexbuf else coq lexbuf } + | "(*" + { comment_level := 1; + if !Cdglobals.parse_comments then begin + let s = lexeme lexbuf in + let nbsp,isp = count_spaces s in + Output.indentation nbsp; + Output.start_comment (); + end; + let eol = comment lexbuf in + if eol then coq_bol lexbuf + else coq lexbuf + } + | nl+ space* "]]" + { if not !formatted then + begin + (* Isn't this an anomaly *) + let s = lexeme lexbuf in + let nlsp,s = remove_newline s in + let nbsp,isp = count_spaces s in + Output.indentation nbsp; + let loc = lexeme_start lexbuf + isp + nlsp in + Output.sublexer ']' loc; + Output.sublexer ']' (loc+1); + coq lexbuf + end } + | eof + { () } + | gallina_kw_to_hide + { let s = lexeme lexbuf in + if !Cdglobals.light && section_or_end s then + begin + let eol = skip_to_dot lexbuf in + if eol then coq_bol lexbuf else coq lexbuf + end + else + begin + Output.ident s (lexeme_start lexbuf); + let eol=body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf + end } + | prf_token + { let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else + let s = lexeme lexbuf in + let eol = + if s.[String.length s - 1] = '.' then false + else skip_to_dot lexbuf + in + eol + in if eol then coq_bol lexbuf else coq lexbuf } + | end_kw { + let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body lexbuf end + else + let eol = skip_to_dot lexbuf in + if !in_proof <> Some true && eol then + Output.line_break (); + eol + in + in_proof := None; + if eol then coq_bol lexbuf else coq lexbuf } + | gallina_kw + { let s = lexeme lexbuf in + Output.ident s (lexeme_start lexbuf); + let eol = body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + | notation_kw space* + { let s = lexeme lexbuf in + Output.ident s (lexeme_start lexbuf); + let eol= start_notation_string lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + | prog_kw + { let s = lexeme lexbuf in + Output.ident s (lexeme_start lexbuf); + let eol = body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } + | space+ { Output.char ' '; coq lexbuf } + | eof + { () } + | _ { let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body lexbuf end + else + skip_to_dot lexbuf + in + if eol then coq_bol lexbuf else coq lexbuf} + +(*s Scanning documentation, at beginning of line *) + +and doc_bol = parse + | space* nl+ + { Output.paragraph (); doc_bol lexbuf } + | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? + { let eol, lex = strip_eol (lexeme lexbuf) in + let lev, s = sec_title lex in + if (!Cdglobals.lib_subtitles) && + (subtitle (Output.get_module false) s) then + () + else + Output.section lev (fun () -> ignore (doc None (from_string s))); + if eol then doc_bol lexbuf else doc None lexbuf } + | space* nl space* '-'+ + { (* adding this production instead of just letting the paragraph + production and the begin list production fire eliminates + extra vertical whitespace. *) + let buf' = lexeme lexbuf in + let buf = + let bufs = Str.split_delim (Str.regexp "['\n']") buf' in + match bufs with + | (_ :: s :: []) -> s + | (_ :: _ :: s :: _) -> s + | _ -> eprintf "Internal error bad_split1 - please report\n"; + exit 1 + in + match check_start_list buf with + | Neither -> backtrack_past_newline lexbuf; doc None lexbuf + | List n -> Output.item 1; doc (Some [n]) lexbuf + | Rule -> Output.rule (); doc None lexbuf + } + | space* '-'+ + { let buf = lexeme lexbuf in + match check_start_list buf with + | Neither -> backtrack lexbuf; doc None lexbuf + | List n -> Output.item 1; doc (Some [n]) lexbuf + | Rule -> Output.rule (); doc None lexbuf + } + | "<<" space* + { Output.start_verbatim (); verbatim lexbuf; doc_bol lexbuf } + | eof + { true } + | '_' + { if !Cdglobals.plain_comments then Output.char '_' else start_emph (); + doc None lexbuf } + | _ + { backtrack lexbuf; doc None lexbuf } + +(*s Scanning lists - using whitespace *) +and doc_list_bol indents = parse + | space* '-' + { let (n_spaces,_) = count_spaces (lexeme lexbuf) in + match find_level indents n_spaces with + | Before -> backtrack lexbuf; doc_bol lexbuf + | StartLevel n -> Output.item n; doc (Some (take n indents)) lexbuf + | InLevel (n,true) -> + let items = List.length indents in + Output.item (items+1); + doc (Some (List.append indents [n_spaces])) lexbuf + | InLevel (_,false) -> + backtrack lexbuf; doc_bol lexbuf + } + | "<<" space* + { Output.start_verbatim (); + verbatim lexbuf; + doc_list_bol indents lexbuf } + | "[[" nl + { formatted := true; + Output.start_inline_coq_block (); + ignore(body_bol lexbuf); + Output.end_inline_coq_block (); + formatted := false; + doc_list_bol indents lexbuf } + | space* nl space* '-' + { (* Like in the doc_bol production, these two productions + exist only to deal properly with whitespace *) + Output.paragraph (); + backtrack_past_newline lexbuf; + doc_list_bol indents lexbuf } + | space* nl space* _ + { let buf' = lexeme lexbuf in + let buf = + let bufs = Str.split_delim (Str.regexp "['\n']") buf' in + match bufs with + | (_ :: s :: []) -> s + | (_ :: _ :: s :: _) -> s + | _ -> eprintf "Internal error bad_split2 - please report\n"; + exit 1 + in + let (n_spaces,_) = count_spaces buf in + match find_level indents n_spaces with + | InLevel _ -> + Output.paragraph (); + backtrack_past_newline lexbuf; + doc_list_bol indents lexbuf + | StartLevel n -> + if n = 1 then + begin + Output.stop_item (); + backtrack_past_newline lexbuf; + doc_bol lexbuf + end + else + begin + Output.paragraph (); + backtrack_past_newline lexbuf; + doc_list_bol indents lexbuf + end + | Before -> Output.stop_item (); + backtrack_past_newline lexbuf; + doc_bol lexbuf + + } + | space* _ + { let (n_spaces,_) = count_spaces (lexeme lexbuf) in + match find_level indents n_spaces with + | Before -> Output.stop_item (); backtrack lexbuf; + doc_bol lexbuf + | StartLevel n -> + Output.reach_item_level (n-1); + backtrack lexbuf; + doc (Some (take (n-1) indents)) lexbuf + | InLevel (n,_) -> + Output.reach_item_level n; + backtrack lexbuf; + doc (Some (take n indents)) lexbuf + } + +(*s Scanning documentation elsewhere *) +and doc indents = parse + | nl + { Output.char '\n'; + match indents with + | Some ls -> doc_list_bol ls lexbuf + | None -> doc_bol lexbuf } + | "[[" nl + { if !Cdglobals.plain_comments + then (Output.char '['; Output.char '['; doc indents lexbuf) + else (formatted := true; + Output.start_inline_coq_block (); + let eol = body_bol lexbuf in + Output.end_inline_coq_block (); formatted := false; + if eol then + match indents with + | Some ls -> doc_list_bol ls lexbuf + | None -> doc_bol lexbuf + else doc indents lexbuf)} + | "[]" + { Output.proofbox (); doc indents lexbuf } + | "[" + { if !Cdglobals.plain_comments then Output.char '[' + else (brackets := 1; Output.start_inline_coq (); escaped_coq lexbuf; + Output.end_inline_coq ()); doc indents lexbuf } + | "(*" + { backtrack lexbuf ; + let bol_parse = match indents with + | Some is -> doc_list_bol is + | None -> doc_bol + in + let eol = comment lexbuf in + if eol then bol_parse lexbuf else doc indents lexbuf + } + | '*'* "*)" space* nl + { true } + | '*'* "*)" + { false } + | "$" + { if !Cdglobals.plain_comments then Output.char '$' + else (Output.start_latex_math (); escaped_math_latex lexbuf); + doc indents lexbuf } + | "$$" + { if !Cdglobals.plain_comments then Output.char '$'; + Output.char '$'; doc indents lexbuf } + | "%" + { if !Cdglobals.plain_comments then Output.char '%' + else escaped_latex lexbuf; doc indents lexbuf } + | "%%" + { if !Cdglobals.plain_comments then Output.char '%'; + Output.char '%'; doc indents lexbuf } + | "#" + { if !Cdglobals.plain_comments then Output.char '#' + else escaped_html lexbuf; doc indents lexbuf } + | "##" + { if !Cdglobals.plain_comments then Output.char '#'; + Output.char '#'; doc indents lexbuf } + | nonidentchar '_' nonidentchar + { List.iter (fun x -> Output.char (lexeme_char lexbuf x)) [0;1;2]; + doc indents lexbuf} + | nonidentchar '_' + { Output.char (lexeme_char lexbuf 0); + if !Cdglobals.plain_comments then Output.char '_' else start_emph () ; + doc indents lexbuf } + | '_' nonidentchar + { if !Cdglobals.plain_comments then Output.char '_' else stop_emph () ; + Output.char (lexeme_char lexbuf 1); + doc indents lexbuf } + | eof + { false } + | _ + { Output.char (lexeme_char lexbuf 0); doc indents lexbuf } + +(*s Various escapings *) + +and escaped_math_latex = parse + | "$" { Output.stop_latex_math () } + | eof { Output.stop_latex_math () } + | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf } + +and escaped_latex = parse + | "%" { () } + | eof { () } + | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf } + +and escaped_html = parse + | "#" { () } + | "&#" + { Output.html_char '&'; Output.html_char '#'; escaped_html lexbuf } + | "##" + { Output.html_char '#'; escaped_html lexbuf } + | eof { () } + | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } + +and verbatim = parse + | nl ">>" space* nl { Output.verbatim_char '\n'; Output.stop_verbatim () } + | nl ">>" { Output.verbatim_char '\n'; Output.stop_verbatim () } + | eof { Output.stop_verbatim () } + | _ { Output.verbatim_char (lexeme_char lexbuf 0); verbatim lexbuf } + +(*s Coq, inside quotations *) + +and escaped_coq = parse + | "]" + { decr brackets; + if !brackets > 0 then + (Output.sublexer ']' (lexeme_start lexbuf); escaped_coq lexbuf) + else Tokens.flush_sublexer () } + | "[" + { incr brackets; + Output.sublexer '[' (lexeme_start lexbuf); escaped_coq lexbuf } + | "(*" + { Tokens.flush_sublexer (); comment_level := 1; + ignore (comment lexbuf); escaped_coq lexbuf } + | "*)" + { (* likely to be a syntax error: we escape *) backtrack lexbuf } + | eof + { Tokens.flush_sublexer () } + | (identifier '.')* identifier + { Output.ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf } + | space + { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); + escaped_coq lexbuf } + | _ + { Output.sublexer (lexeme_char lexbuf 0) (lexeme_start lexbuf); + escaped_coq lexbuf } + +(*s Coq "Comments" command. *) + +and comments = parse + | space_nl+ + { Output.char ' '; comments lexbuf } + | '"' [^ '"']* '"' + { let s = lexeme lexbuf in + let s = String.sub s 1 (String.length s - 2) in + ignore (doc None (from_string s)); comments lexbuf } + | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+ + { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf } + | "." (space_nl | eof) + { () } + | eof + { () } + | _ + { Output.char (lexeme_char lexbuf 0); comments lexbuf } + +(*s Skip comments *) + +and comment = parse + | "(*" { incr comment_level; + if !Cdglobals.parse_comments then Output.start_comment (); + comment lexbuf } + | "*)" space* nl { + if !Cdglobals.parse_comments then + (Output.end_comment (); Output.line_break ()); + decr comment_level; if !comment_level > 0 then comment lexbuf else true } + | "*)" { + if !Cdglobals.parse_comments then (Output.end_comment ()); + decr comment_level; if !comment_level > 0 then comment lexbuf else false } + | "[" { + if !Cdglobals.parse_comments then + if !Cdglobals.plain_comments then Output.char '[' + else (brackets := 1; Output.start_inline_coq (); + escaped_coq lexbuf; Output.end_inline_coq ()); + comment lexbuf } + | "[[" nl { + if !Cdglobals.parse_comments then + if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') + else (formatted := true; + Output.start_inline_coq_block (); + let _ = body_bol lexbuf in + Output.end_inline_coq_block (); formatted := false); + comment lexbuf} + | "$" + { if !Cdglobals.parse_comments then + if !Cdglobals.plain_comments then Output.char '$' + else (Output.start_latex_math (); escaped_math_latex lexbuf); + comment lexbuf } + | "$$" + { if !Cdglobals.parse_comments + then + (if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'); + doc None lexbuf } + | "%" + { if !Cdglobals.parse_comments + then + if !Cdglobals.plain_comments then Output.char '%' + else escaped_latex lexbuf; comment lexbuf } + | "%%" + { if !Cdglobals.parse_comments + then + (if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'); + comment lexbuf } + | "#" + { if !Cdglobals.parse_comments + then + if !Cdglobals.plain_comments then Output.char '$' + else escaped_html lexbuf; comment lexbuf } + | "##" + { if !Cdglobals.parse_comments + then + (if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'); + comment lexbuf } + | eof { false } + | space+ { if !Cdglobals.parse_comments + then Output.indentation (fst (count_spaces (lexeme lexbuf))); + comment lexbuf } + | nl { if !Cdglobals.parse_comments + then Output.line_break (); comment lexbuf } + | _ { if !Cdglobals.parse_comments then Output.char (lexeme_char lexbuf 0); + comment lexbuf } + +and skip_to_dot = parse + | '.' space* nl { true } + | eof | '.' space+ { false } + | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf } + | _ { skip_to_dot lexbuf } + +and body_bol = parse + | space+ + { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } + | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } + +and body = parse + | nl {Tokens.flush_sublexer(); Output.line_break(); new_line lexbuf; body_bol lexbuf} + | nl+ space* "]]" space* nl + { Tokens.flush_sublexer(); + if not !formatted then + begin + let s = lexeme lexbuf in + let nlsp,s = remove_newline s in + let _,isp = count_spaces s in + let loc = lexeme_start lexbuf + nlsp + isp in + Output.sublexer ']' loc; + Output.sublexer ']' (loc+1); + Tokens.flush_sublexer(); + body lexbuf + end + else + begin + Output.paragraph (); + true + end } + | "]]" space* nl + { Tokens.flush_sublexer(); + if not !formatted then + begin + let loc = lexeme_start lexbuf in + Output.sublexer ']' loc; + Output.sublexer ']' (loc+1); + Tokens.flush_sublexer(); + Output.line_break(); + body lexbuf + end + else + begin + Output.paragraph (); + true + end } + | eof { Tokens.flush_sublexer(); false } + | '.' space* nl | '.' space* eof + { Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); + if not !formatted then true else body_bol lexbuf } + | '.' space* nl "]]" space* nl + { Tokens.flush_sublexer(); Output.char '.'; + if not !formatted then + begin + eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); + flush stderr; + exit 1 + end + else + begin + Output.paragraph (); + true + end + } + | '.' space+ + { Tokens.flush_sublexer(); Output.char '.'; Output.char ' '; + if not !formatted then false else body lexbuf } + | "(**" space_nl + { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); + let eol = doc_bol lexbuf in + Output.end_doc (); Output.start_coq (); + if eol then body_bol lexbuf else body lexbuf } + | "(*" { Tokens.flush_sublexer(); comment_level := 1; + if !Cdglobals.parse_comments then Output.start_comment (); + let eol = comment lexbuf in + if eol + then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end + else body lexbuf } + | "where" space* + { Tokens.flush_sublexer(); + Output.ident (lexeme lexbuf) (lexeme_start lexbuf); + start_notation_string lexbuf } + | identifier + { Tokens.flush_sublexer(); + Output.ident (lexeme lexbuf) (lexeme_start lexbuf); + body lexbuf } + | ".." + { Tokens.flush_sublexer(); Output.char '.'; Output.char '.'; + body lexbuf } + | '"' + { Tokens.flush_sublexer(); Output.char '"'; + string lexbuf; + body lexbuf } + | space + { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); + body lexbuf } + + | _ { let c = lexeme_char lexbuf 0 in + Output.sublexer c (lexeme_start lexbuf); + body lexbuf } + +and start_notation_string = parse + | '"' (* a true notation *) + { Output.sublexer '"' (lexeme_start lexbuf); + notation_string lexbuf; + body lexbuf } + | _ (* an abbreviation *) + { backtrack lexbuf; body lexbuf } + +and notation_string = parse + | "\"\"" + { Output.char '"'; Output.char '"'; (* Unlikely! *) + notation_string lexbuf } + | '"' + { Tokens.flush_sublexer(); Output.char '"' } + | _ { let c = lexeme_char lexbuf 0 in + Output.sublexer c (lexeme_start lexbuf); + notation_string lexbuf } + +and string = parse + | "\"\"" { Output.char '"'; Output.char '"'; string lexbuf } + | '"' { Output.char '"' } + | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } + +and skip_hide = parse + | eof | end_hide { () } + | _ { skip_hide lexbuf } + +(*s Reading token pretty-print *) + +and printing_token_body = parse + | "*)" nl? | eof + { let s = Buffer.contents token_buffer in + Buffer.clear token_buffer; + s } + | _ { Buffer.add_string token_buffer (lexeme lexbuf); + printing_token_body lexbuf } + +(*s A small scanner to support the chapter subtitle feature *) +and st_start m = parse + | "(*" "*"+ space+ "*" space+ + { st_modname m lexbuf } + | _ + { None } + +and st_modname m = parse + | identifier space* ":" space* + { if subtitle m (lexeme lexbuf) then + st_subtitle lexbuf + else + None + } + | _ + { None } + +and st_subtitle = parse + | [^ '\n']* '\n' + { let st = lexeme lexbuf in + let i = try Str.search_forward (Str.regexp "\\**)") st 0 with + Not_found -> + (eprintf "unterminated comment at beginning of file\n"; + exit 1) + in + Some (cut_head_tail_spaces (String.sub st 0 i)) + } + | _ + { None } +(*s Applying the scanners to files *) + +{ + let coq_file f m = + reset (); + let c = open_in f in + let lb = from_channel c in + (Index.current_library := m; + Output.initialize (); + Output.start_module (); + Output.start_coq (); coq_bol lb; Output.end_coq (); + close_in c) + + let detect_subtitle f m = + let c = open_in f in + let lb = from_channel c in + let sub = st_start m lb in + close_in c; + sub +} diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml new file mode 100644 index 00000000..889e5d6f --- /dev/null +++ b/tools/coqdoc/index.ml @@ -0,0 +1,335 @@ +(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "<>" then + if id <> "<>" then + sp ^ "." ^ id + else sp + else if id <> "<>" + then id + else "" + +let add_def loc ty sp id = + Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty)); + Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty)) + +let add_ref m loc m' sp id ty = + if Hashtbl.mem reftable (m, loc) then () + else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty)); + let idx = if id = "<>" then m' else id in + if Hashtbl.mem deftable idx then () + else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty)) + +let add_mod m loc m' id = + Hashtbl.add reftable (m, loc) (Mod (m', id)); + Hashtbl.add deftable m (Mod (m', id)) + +let find m l = Hashtbl.find reftable (m, l) + +let find_string m s = Hashtbl.find deftable s + +(*s Manipulating path prefixes *) + +type stack = string list + +let rec string_of_stack st = + match st with + | [] -> "" + | x::[] -> x + | x::tl -> (string_of_stack tl) ^ "." ^ x + +let empty_stack = [] + +let module_stack = ref empty_stack +let section_stack = ref empty_stack + +let init_stack () = + module_stack := empty_stack; section_stack := empty_stack + +let push st p = st := p::!st +let pop st = + match !st with + | [] -> () + | _::tl -> st := tl + +let head st = + match st with + | [] -> "" + | x::_ -> x + +let begin_module m = push module_stack m +let begin_section s = push section_stack s + +let end_block id = + (** determines if it ends a module or a section and pops the stack *) + if ((String.compare (head !module_stack) id ) == 0) then + pop module_stack + else if ((String.compare (head !section_stack) id) == 0) then + pop section_stack + else + () + +let make_fullid id = + (** prepends the current module path to an id *) + let path = string_of_stack !module_stack in + if String.length path > 0 then + path ^ "." ^ id + else + id + + +(* Coq modules *) + +let split_sp s = + try + let i = String.rindex s '.' in + String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) + with + Not_found -> "", s + +let modules = Hashtbl.create 97 +let local_modules = Hashtbl.create 97 + +let add_module m = + let _,id = split_sp m in + Hashtbl.add modules id m; + Hashtbl.add local_modules m () + +type module_kind = Local | External of string | Unknown + +let external_libraries = ref [] + +let add_external_library logicalpath url = + external_libraries := (logicalpath,url) :: !external_libraries + +let find_external_library logicalpath = + let rec aux = function + | [] -> raise Not_found + | (l,u)::rest -> + if String.length logicalpath > String.length l & + String.sub logicalpath 0 (String.length l + 1) = l ^"." + then u + else aux rest + in aux !external_libraries + +let init_coqlib_library () = add_external_library "Coq" !coqlib + +let find_module m = + if Hashtbl.mem local_modules m then + Local + else + try External (Filename.concat (find_external_library m) m) + with Not_found -> Unknown + + +(* Building indexes *) + +type 'a index = { + idx_name : string; + idx_entries : (char * (string * 'a) list) list; + idx_size : int } + +let map f i = + { i with idx_entries = + List.map + (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) + i.idx_entries } + +let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2 + +let sort_entries el = + let t = Hashtbl.create 97 in + List.iter + (fun c -> Hashtbl.add t c []) + ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; + 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_'; '*']; + List.iter + (fun ((s,_) as e) -> + let c = Alpha.norm_char s.[0] in + let c,l = + try c,Hashtbl.find t c with Not_found -> '*',Hashtbl.find t '*' in + Hashtbl.replace t c (e :: l)) + el; + let res = ref [] in + Hashtbl.iter (fun c l -> res := (c, List.sort compare_entries l) :: !res) t; + List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res + +let display_letter c = if c = '*' then "other" else String.make 1 c + +let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0 + +let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h [] + +let type_name = function + | Library -> + let ln = !lib_name in + if ln <> "" then String.lowercase ln else "library" + | Module -> "moduleid" + | Definition -> "definition" + | Inductive -> "inductive" + | Constructor -> "constructor" + | Lemma -> "lemma" + | Record -> "record" + | Projection -> "projection" + | Instance -> "instance" + | Class -> "class" + | Method -> "method" + | Variable -> "variable" + | Axiom -> "axiom" + | TacticDefinition -> "tactic" + | Abbreviation -> "abbreviation" + | Notation -> "notation" + | Section -> "section" + +let prepare_entry s = function + | Notation -> + (* Notations have conventially the form section.:sc:x_++_'x'_x *) + let err () = eprintf "Invalid notation in globalization file\n"; exit 1 in + let h = try String.index_from s 0 ':' with _ -> err () in + let i = try String.index_from s (h+1) ':' with _ -> err () in + let sc = String.sub s (h+1) (i-h-1) in + let ntn = String.make (String.length s) ' ' in + let k = ref 0 in + let j = ref (i+1) in + let quoted = ref false in + while !j <> String.length s do + if s.[!j] = '_' && not !quoted then ntn.[!k] <- ' ' else + if s.[!j] = 'x' && not !quoted then ntn.[!k] <- '_' else + if s.[!j] = '\'' then + if s.[!j+1] = 'x' && s.[!j+1] = '\'' then (ntn.[!k] <- 'x'; j:=!j+2) + else (quoted := not !quoted; ntn.[!k] <- '\'') + else ntn.[!k] <- s.[!j]; + incr j; incr k + done; + let ntn = String.sub ntn 0 !k in + if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" + | _ -> + s + +let all_entries () = + let gl = ref [] in + let add_g s m t = gl := (s,(m,t)) :: !gl in + let bt = Hashtbl.create 11 in + let add_bt t s m = + let l = try Hashtbl.find bt t with Not_found -> [] in + Hashtbl.replace bt t ((s,m) :: l) + in + let classify (m,_) e = match e with + | Def (s,t) -> add_g s m t; add_bt t s m + | Ref _ | Mod _ -> () + in + Hashtbl.iter classify reftable; + Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; + { idx_name = "global"; + idx_entries = sort_entries !gl; + idx_size = List.length !gl }, + Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; + idx_entries = sort_entries e; + idx_size = List.length e }) :: l) bt [] + +let type_of_string = function + | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix" + | "ex" | "scheme" -> Definition + | "prf" | "thm" -> Lemma + | "ind" | "coind" -> Inductive + | "constr" -> Constructor + | "rec" | "corec" -> Record + | "proj" -> Projection + | "class" -> Class + | "meth" -> Method + | "inst" -> Instance + | "var" -> Variable + | "defax" | "prfax" | "ax" -> Axiom + | "syndef" -> Abbreviation + | "not" -> Notation + | "lib" -> Library + | "mod" | "modtype" -> Module + | "tac" -> TacticDefinition + | "sec" -> Section + | s -> raise (Invalid_argument ("type_of_string:" ^ s)) + +let read_glob f = + let c = open_in f in + let cur_mod = ref "" in + try + while true do + let s = input_line c in + let n = String.length s in + if n > 0 then begin + match s.[0] with + | 'F' -> + cur_mod := String.sub s 1 (n - 1); + current_library := !cur_mod + | 'R' -> + (try + Scanf.sscanf s "R%d:%d %s %s %s %s" + (fun loc1 loc2 lib_dp sp id ty -> + for loc=loc1 to loc2 do + add_ref !cur_mod loc lib_dp sp id (type_of_string ty) + done) + with _ -> + try + Scanf.sscanf s "R%d %s %s %s %s" + (fun loc lib_dp sp id ty -> + add_ref !cur_mod loc lib_dp sp id (type_of_string ty)) + with _ -> ()) + | _ -> + try Scanf.sscanf s "%s %d %s %s" + (fun ty loc sp id -> add_def loc (type_of_string ty) sp id) + with Scanf.Scan_failure _ -> () + end + done; assert false + with End_of_file -> + close_in c diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index 56a3cd11..517ec97a 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: index.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) +(*i $Id$ i*) open Cdglobals type loc = int -type entry_type = +type entry_type = | Library | Module | Definition @@ -33,7 +33,7 @@ type entry_type = val type_name : entry_type -> string -type index_entry = +type index_entry = | Def of string * entry_type | Ref of coq_module * string * entry_type | Mod of coq_module * string @@ -44,28 +44,32 @@ val find_string : coq_module -> string -> index_entry val add_module : coq_module -> unit -type module_kind = Local | Coqlib | Unknown +type module_kind = Local | External of coq_module | Unknown val find_module : coq_module -> module_kind -(*s Scan identifiers introductions from a file *) +val init_coqlib_library : unit -> unit -val scan_file : string -> coq_module -> unit +val add_external_library : string -> coq_module -> unit (*s Read globalizations from a file (produced by coqc -dump-glob) *) -val read_glob : string -> coq_module +val read_glob : string -> unit (*s Indexes *) -type 'a index = { +type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } val current_library : string ref -val all_entries : unit -> +val display_letter : char -> string + +val prepare_entry : string -> entry_type -> string + +val all_entries : unit -> (coq_module * entry_type) index * (entry_type * coq_module index) list diff --git a/tools/coqdoc/index.mll b/tools/coqdoc/index.mll deleted file mode 100644 index f8adb52b..00000000 --- a/tools/coqdoc/index.mll +++ /dev/null @@ -1,490 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* "<>" then - if id <> "<>" then - sp ^ "." ^ id - else sp - else if id <> "<>" - then id - else "" - -let add_def loc ty sp id = - Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty)); - Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty)) - -let add_ref m loc m' sp id ty = - if Hashtbl.mem reftable (m, loc) then () - else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty)); - let idx = if id = "<>" then m' else id in - if Hashtbl.mem deftable idx then () - else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty)) - -let add_mod m loc m' id = - Hashtbl.add reftable (m, loc) (Mod (m', id)); - Hashtbl.add deftable m (Mod (m', id)) - -let find m l = Hashtbl.find reftable (m, l) - -let find_string m s = Hashtbl.find deftable s - -(*s Manipulating path prefixes *) - -type stack = string list - -let rec string_of_stack st = - match st with - | [] -> "" - | x::[] -> x - | x::tl -> (string_of_stack tl) ^ "." ^ x - -let empty_stack = [] - -let module_stack = ref empty_stack -let section_stack = ref empty_stack - -let init_stack () = - module_stack := empty_stack; section_stack := empty_stack - -let push st p = st := p::!st -let pop st = - match !st with - | [] -> () - | _::tl -> st := tl - -let head st = - match st with - | [] -> "" - | x::_ -> x - -let begin_module m = push module_stack m -let begin_section s = push section_stack s - -let end_block id = - (** determines if it ends a module or a section and pops the stack *) - if ((String.compare (head !module_stack) id ) == 0) then - pop module_stack - else if ((String.compare (head !section_stack) id) == 0) then - pop section_stack - else - () - -let make_fullid id = - (** prepends the current module path to an id *) - let path = string_of_stack !module_stack in - if String.length path > 0 then - path ^ "." ^ id - else - id - - -(* Coq modules *) - -let split_sp s = - try - let i = String.rindex s '.' in - String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) - with - Not_found -> "", s - -let modules = Hashtbl.create 97 -let local_modules = Hashtbl.create 97 - -let add_module m = - let _,id = split_sp m in - Hashtbl.add modules id m; - Hashtbl.add local_modules m () - -type module_kind = Local | Coqlib | Unknown - -let coq_module m = String.length m >= 4 && String.sub m 0 4 = "Coq." - -let find_module m = - if Hashtbl.mem local_modules m then - Local - else if coq_module m then - Coqlib - else - Unknown - - -(* Building indexes *) - -type 'a index = { - idx_name : string; - idx_entries : (char * (string * 'a) list) list; - idx_size : int } - -let map f i = - { i with idx_entries = - List.map - (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) - i.idx_entries } - -let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2 - -let sort_entries el = - let t = Hashtbl.create 97 in - List.iter - (fun c -> Hashtbl.add t c []) - ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; - 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_']; - List.iter - (fun ((s,_) as e) -> - let c = Alpha.norm_char s.[0] in - let l = try Hashtbl.find t c with Not_found -> [] in - Hashtbl.replace t c (e :: l)) - el; - let res = ref [] in - Hashtbl.iter - (fun c l -> res := (c, List.sort compare_entries l) :: !res) t; - List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res - -let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0 - -let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h [] - -let type_name = function - | Library -> "library" - | Module -> "module" - | Definition -> "definition" - | Inductive -> "inductive" - | Constructor -> "constructor" - | Lemma -> "lemma" - | Record -> "record" - | Projection -> "projection" - | Instance -> "instance" - | Class -> "class" - | Method -> "method" - | Variable -> "variable" - | Axiom -> "axiom" - | TacticDefinition -> "tactic" - | Abbreviation -> "abbreviation" - | Notation -> "notation" - | Section -> "section" - -let all_entries () = - let gl = ref [] in - let add_g s m t = gl := (s,(m,t)) :: !gl in - let bt = Hashtbl.create 11 in - let add_bt t s m = - let l = try Hashtbl.find bt t with Not_found -> [] in - Hashtbl.replace bt t ((s,m) :: l) - in - let classify (m,_) e = match e with - | Def (s,t) -> add_g s m t; add_bt t s m - | Ref _ | Mod _ -> () - in - Hashtbl.iter classify reftable; - Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; - { idx_name = "global"; - idx_entries = sort_entries !gl; - idx_size = List.length !gl }, - Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; - idx_entries = sort_entries e; - idx_size = List.length e }) :: l) bt [] - -} - -(*s Shortcuts for regular expressions. *) -let digit = ['0'-'9'] -let num = digit+ - -let space = - [' ' '\010' '\013' '\009' '\012'] -let firstchar = - ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] -let identchar = - ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' - '\'' '0'-'9'] -let id = firstchar identchar* -let pfx_id = (id '.')* -let ident = id | pfx_id id - -let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" -let end_hide = "(*" space* "end" space+ "hide" space* "*)" - -(*s Indexing entry point. *) - -rule traverse = parse - | ("Program" space+)? "Definition" space - { current_type := Definition; index_ident lexbuf; traverse lexbuf } - | "Tactic" space+ "Definition" space - { current_type := TacticDefinition; index_ident lexbuf; traverse lexbuf } - | ("Axiom" | "Parameter") space - { current_type := Axiom; index_ident lexbuf; traverse lexbuf } - | ("Program" space+)? "Fixpoint" space - { current_type := Definition; index_ident lexbuf; fixpoint lexbuf; - traverse lexbuf } - | ("Program" space+)? ("Lemma" | "Theorem") space - { current_type := Lemma; index_ident lexbuf; traverse lexbuf } - | "Obligation" space num ("of" ident)? - { current_type := Lemma; index_ident lexbuf; traverse lexbuf } - | "Inductive" space - { current_type := Inductive; - index_ident lexbuf; inductive lexbuf; traverse lexbuf } - | "Record" space - { current_type := Inductive; index_ident lexbuf; traverse lexbuf } - | "Module" (space+ "Type")? space - { current_type := Module; module_ident lexbuf; traverse lexbuf } -(*i*** - | "Variable" 's'? space - { current_type := Variable; index_idents lexbuf; traverse lexbuf } -***i*) - | "Require" (space+ ("Export"|"Import"))? - { module_refs lexbuf; traverse lexbuf } - | "End" space+ - { end_ident lexbuf; traverse lexbuf } - | begin_hide - { skip_hide lexbuf; traverse lexbuf } - | "(*" - { comment lexbuf; traverse lexbuf } - | '"' - { string lexbuf; traverse lexbuf } - | eof - { () } - | _ - { traverse lexbuf } - -(*s Index one identifier. *) - -and index_ident = parse - | space+ - { index_ident lexbuf } - | ident - { let fullid = - let id = lexeme lexbuf in - match !current_type with - | Definition - | Inductive - | Constructor - | Lemma -> make_fullid id - | _ -> id - in - add_def (lexeme_start lexbuf) !current_type "" fullid } - | eof - { () } - | _ - { () } - -(*s Index identifiers separated by blanks and/or commas. *) - -and index_idents = parse - | space+ | ',' - { index_idents lexbuf } - | ident - { add_def (lexeme_start lexbuf) !current_type "" (lexeme lexbuf); - index_idents lexbuf } - | eof - { () } - | _ - { skip_until_point lexbuf } - -(*s Index identifiers in an inductive definition (types and constructors). *) - -and inductive = parse - | '|' | ":=" space* '|'? - { current_type := Constructor; index_ident lexbuf; inductive lexbuf } - | "with" space - { current_type := Inductive; index_ident lexbuf; inductive lexbuf } - | '.' - { () } - | eof - { () } - | _ - { inductive lexbuf } - -(*s Index identifiers in a Fixpoint declaration. *) - -and fixpoint = parse - | "with" space - { index_ident lexbuf; fixpoint lexbuf } - | '.' - { () } - | eof - { () } - | _ - { fixpoint lexbuf } - -(*s Skip a possibly nested comment. *) - -and comment = parse - | "*)" { () } - | "(*" { comment lexbuf; comment lexbuf } - | '"' { string lexbuf; comment lexbuf } - | eof { eprintf " *** Unterminated comment while indexing" } - | _ { comment lexbuf } - -(*s Skip a constant string. *) - -and string = parse - | '"' { () } - | eof { eprintf " *** Unterminated string while indexing" } - | _ { string lexbuf } - -(*s Skip everything until the next dot. *) - -and skip_until_point = parse - | '.' { () } - | eof { () } - | _ { skip_until_point lexbuf } - -(*s Skip everything until [(* end hide *)] *) - -and skip_hide = parse - | eof | end_hide { () } - | _ { skip_hide lexbuf } - -and end_ident = parse - | space+ - { end_ident lexbuf } - | ident - { let id = lexeme lexbuf in end_block id } - | eof - { () } - | _ - { () } - -and module_ident = parse - | space+ - { module_ident lexbuf } - | '"' { string lexbuf; module_ident lexbuf } - | ident space* ":=" - { () } - | ident - { let id = lexeme lexbuf in - begin_module id; add_def (lexeme_start lexbuf) !current_type "" id } - | eof - { () } - | _ - { () } - -(*s parse module names *) - -and module_refs = parse - | space+ - { module_refs lexbuf } - | ident - { let id = lexeme lexbuf in - (try - add_mod !current_library (lexeme_start lexbuf) (Hashtbl.find modules id) id - with - Not_found -> () - ); - module_refs lexbuf } - | eof - { () } - | _ - { () } - -{ - let type_of_string = function - | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix" - | "ex" | "scheme" -> Definition - | "prf" | "thm" -> Lemma - | "ind" | "coind" -> Inductive - | "constr" -> Constructor - | "rec" | "corec" -> Record - | "proj" -> Projection - | "class" -> Class - | "meth" -> Method - | "inst" -> Instance - | "var" -> Variable - | "defax" | "prfax" | "ax" -> Axiom - | "syndef" -> Abbreviation - | "not" -> Notation - | "lib" -> Library - | "mod" | "modtype" -> Module - | "tac" -> TacticDefinition - | "sec" -> Section - | s -> raise (Invalid_argument ("type_of_string:" ^ s)) - - let read_glob f = - let c = open_in f in - let cur_mod = ref "" in - try - while true do - let s = input_line c in - let n = String.length s in - if n > 0 then begin - match s.[0] with - | 'F' -> - cur_mod := String.sub s 1 (n - 1); - current_library := !cur_mod - | 'R' -> - (try - Scanf.sscanf s "R%d %s %s %s %s" - (fun loc lib_dp sp id ty -> - add_ref !cur_mod loc lib_dp sp id (type_of_string ty)) - with _ -> ()) - | _ -> - try Scanf.sscanf s "%s %d %s %s" - (fun ty loc sp id -> add_def loc (type_of_string ty) sp id) - with Scanf.Scan_failure _ -> () - end - done; assert false - with End_of_file -> - close_in c; !cur_mod - - let scan_file f m = - init_stack (); current_library := m; - let c = open_in f in - let lb = from_channel c in - traverse lb; - close_in c -} diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 2ee9ac96..67c63865 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: main.ml 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) (* Modified by Lionel Elie Mamane on 9 & 10 Mar 2004: * - handling of absolute filenames (function coq_module) @@ -46,6 +46,7 @@ let usage () = prerr_endline " --with-footer append as html footer"; prerr_endline " --no-index do not output the index"; prerr_endline " --multi-index index split in multiple files"; + prerr_endline " --index set index name (default is index)"; prerr_endline " --toc output a table of contents"; prerr_endline " --vernac consider as a .v file"; prerr_endline " --tex consider as a .tex file"; @@ -53,8 +54,9 @@ let usage () = prerr_endline " --files-from read file names to process in "; prerr_endline " --glob-from read globalization information from "; prerr_endline " --quiet quiet mode (default)"; - prerr_endline " --verbose verbose mode"; + prerr_endline " --verbose verbose mode"; prerr_endline " --no-externals no links to Coq standard library"; + prerr_endline " --external set URL for external library d"; prerr_endline " --coqlib set URL for Coq standard library"; prerr_endline (" (default is " ^ Coq_config.wwwstdlib ^ ")"); prerr_endline " --boot run in boot mode"; @@ -66,6 +68,11 @@ let usage () = prerr_endline " --inputenc set LaTeX input encoding"; prerr_endline " --interpolate try to typeset identifiers in comments using definitions in the same module"; prerr_endline " --parse-comments parse regular comments"; + prerr_endline " --plain-comments consider comments as non-literate text"; + prerr_endline " --toc-depth don't include TOC entries for sections below level "; + prerr_endline " --no-lib-name don't display \"Library\" before library names in the toc"; + prerr_endline " --lib-name call top level toc entries instead of \"Library\""; + prerr_endline " --lib-subtitles first line comments of the form (** * ModuleName : text *) will be interpreted as subtitles"; prerr_endline ""; exit 1 @@ -74,20 +81,20 @@ let obsolete s = (*s \textbf{Banner.} Always printed. Notice that it is printed on error output, so that when the output of [coqdoc] is redirected this header - is not (unless both standard and error outputs are redirected, of + is not (unless both standard and error outputs are redirected, of course). *) let banner () = eprintf "This is coqdoc version %s, compiled on %s\n" Coq_config.version Coq_config.compile_date; flush stderr - -let target_full_name f = + +let target_full_name f = match !Cdglobals.target_language with | HTML -> f ^ ".html" | Raw -> f ^ ".txt" | _ -> f ^ ".tex" - + (*s \textbf{Separation of files.} Files given on the command line are separated according to their type, which is determined by their suffix. Coq files have suffixe \verb!.v! or \verb!.g! and \LaTeX\ @@ -95,12 +102,12 @@ let target_full_name f = let check_if_file_exists f = if not (Sys.file_exists f) then begin - eprintf "\ncoqdoc: %s: no such file\n" f; + eprintf "coqdoc: %s: no such file\n" f; exit 1 end -(*s Manipulations of paths and path aliases *) +(*s Manipulations of paths and path aliases *) let normalize_path p = (* We use the Unix subsystem to normalize a physical path (relative @@ -109,50 +116,43 @@ let normalize_path p = works... *) (* Rq: Sys.getcwd () returns paths without '/' at the end *) let orig = Sys.getcwd () in - Sys.chdir p; - let res = Sys.getcwd () in - Sys.chdir orig; - res + Sys.chdir p; + let res = Sys.getcwd () in + Sys.chdir orig; + res let normalize_filename f = let basename = Filename.basename f in let dirname = Filename.dirname f in - Filename.concat (normalize_path dirname) basename + normalize_path dirname, basename (* [paths] maps a physical path to a name *) let paths = ref [] - -let add_path dir name = - (* if dir is relative we add both the relative and absolute name *) + +let add_path dir name = let p = normalize_path dir in - paths := (p,name) :: !paths - -(* turn A/B/C into A.B.C *) -let name_of_path = Str.global_replace (Str.regexp "/") ".";; + paths := (p,name) :: !paths -let coq_module filename = +(* turn A/B/C into A.B.C *) +let rec name_of_path p name dirname suffix = + if p = dirname then String.concat "." (name::suffix) + else + let subdir = Filename.dirname dirname in + if subdir = dirname then raise Not_found + else name_of_path p name subdir (Filename.basename dirname::suffix) + +let coq_module filename = let bfname = Filename.chop_extension filename in - let nfname = normalize_filename bfname in - let rec change_prefix map f = - match map with - | [] -> - (* There is no prefix alias; - we just cut the name wrt current working directory *) - let cwd = Sys.getcwd () in - let exp = Str.regexp (Str.quote (cwd ^ "/")) in - if (Str.string_match exp f 0) then - name_of_path (Str.replace_first exp "" f) - else - name_of_path f - | (p, name) :: rem -> - let expp = Str.regexp (Str.quote p) in - if (Str.string_match expp f 0) then - let newp = Str.replace_first expp name f in - name_of_path newp - else - change_prefix rem f + let dirname, fname = normalize_filename bfname in + let rec change_prefix = function + (* Follow coqc: if in scope of -R, substitute logical name *) + (* otherwise, keep only base name *) + | [] -> fname + | (p, name) :: rem -> + try name_of_path p name dirname [fname] + with Not_found -> change_prefix rem in - change_prefix !paths nfname + change_prefix !paths let what_file f = check_if_file_exists f; @@ -160,10 +160,10 @@ let what_file f = Vernac_file (f, coq_module f) else if Filename.check_suffix f ".tex" then Latex_file f - else + else (eprintf "\ncoqdoc: don't know what to do with %s\n" f; exit 1) - -(*s \textbf{Reading file names from a file.} + +(*s \textbf{Reading file names from a file.} * File names may be given * in a file instead of being given on the command * line. [(files_from_file f)] returns the list of file names contained @@ -181,7 +181,7 @@ let files_from_file f = | ' ' | '\t' | '\n' -> if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l; Buffer.clear buf - | c -> + | c -> Buffer.add_char buf c done; [] with End_of_file -> @@ -193,12 +193,12 @@ let files_from_file f = let l = files_from_channel ch in close_in ch;l with Sys_error s -> begin - eprintf "\ncoqdoc: cannot read from file %s (%s)\n" f s; + eprintf "coqdoc: cannot read from file %s (%s)\n" f s; exit 1 end - + (*s \textbf{Parsing of the command line.} *) - + let dvi = ref false let ps = ref false let pdf = ref false @@ -208,7 +208,7 @@ let parse () = let add_file f = files := f :: !files in let rec parse_rec = function | [] -> () - + | ("-nopreamble" | "--nopreamble" | "--no-preamble" | "-bodyonly" | "--bodyonly" | "--body-only") :: rem -> header_trailer := false; parse_rec rem @@ -228,17 +228,21 @@ let parse () = index := false; parse_rec rem | ("-multi-index" | "--multi-index") :: rem -> multi_index := true; parse_rec rem + | ("-index" | "--index") :: s :: rem -> + Cdglobals.index_name := s; parse_rec rem + | ("-index" | "--index") :: [] -> + usage () | ("-toc" | "--toc" | "--table-of-contents") :: rem -> toc := true; parse_rec rem | ("-stdout" | "--stdout") :: rem -> out_to := StdOut; parse_rec rem | ("-o" | "--output") :: f :: rem -> out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem - | ("-o" | "--output") :: [] -> + | ("-o" | "--output") :: [] -> usage () | ("-d" | "--directory") :: dir :: rem -> output_dir := dir; parse_rec rem - | ("-d" | "--directory") :: [] -> + | ("-d" | "--directory") :: [] -> usage () | ("-s" | "--short") :: rem -> short := true; parse_rec rem @@ -276,39 +280,60 @@ let parse () = Cdglobals.raw_comments := true; parse_rec rem | ("-parse-comments" | "--parse-comments") :: rem -> Cdglobals.parse_comments := true; parse_rec rem + | ("-plain-comments" | "--plain-comments") :: rem -> + Cdglobals.plain_comments := true; parse_rec rem | ("-interpolate" | "--interpolate") :: rem -> Cdglobals.interpolate := true; parse_rec rem + | ("-toc-depth" | "--toc-depth") :: [] -> + usage () + | ("-toc-depth" | "--toc-depth") :: ds :: rem -> + let d = try int_of_string ds with + Failure _ -> + (eprintf "--toc-depth must be followed by an integer\n"; + exit 1) + in + Cdglobals.toc_depth := Some d; + parse_rec rem + | ("-no-lib-name" | "--no-lib-name") :: rem -> + Cdglobals.lib_name := ""; + parse_rec rem + | ("-lib-name" | "--lib-name") :: ds :: rem -> + Cdglobals.lib_name := ds; + parse_rec rem + | ("-lib-subtitles" | "--lib-subtitles") :: rem -> + Cdglobals.lib_subtitles := true; + parse_rec rem | ("-latin1" | "--latin1") :: rem -> Cdglobals.set_latin1 (); parse_rec rem | ("-utf8" | "--utf8") :: rem -> Cdglobals.set_utf8 (); parse_rec rem - + | ("-q" | "-quiet" | "--quiet") :: rem -> quiet := true; parse_rec rem | ("-v" | "-verbose" | "--verbose") :: rem -> quiet := false; parse_rec rem - + | ("-h" | "-help" | "-?" | "--help") :: rem -> banner (); usage () | ("-V" | "-version" | "--version") :: _ -> banner (); exit 0 - | ("-vernac-file" | "--vernac-file") :: f :: rem -> + | ("-vernac-file" | "--vernac-file") :: f :: rem -> check_if_file_exists f; add_file (Vernac_file (f, coq_module f)); parse_rec rem | ("-vernac-file" | "--vernac-file") :: [] -> usage () - | ("-tex-file" | "--tex-file") :: f :: rem -> + | ("-tex-file" | "--tex-file") :: f :: rem -> add_file (Latex_file f); parse_rec rem | ("-tex-file" | "--tex-file") :: [] -> usage () | ("-files" | "--files" | "--files-from") :: f :: rem -> - List.iter (fun f -> add_file (what_file f)) (files_from_file f); + List.iter (fun f -> add_file (what_file f)) (files_from_file f); parse_rec rem | ("-files" | "--files") :: [] -> usage () - | "-R" :: path :: log :: rem -> + | "-R" :: path :: log :: rem -> add_path path log; parse_rec rem | "-R" :: ([] | [_]) -> usage () @@ -318,6 +343,8 @@ let parse () = usage () | ("--no-externals" | "-no-externals" | "-noexternals") :: rem -> Cdglobals.externals := false; parse_rec rem + | ("--external" | "-external") :: u :: logicalpath :: rem -> + Index.add_external_library logicalpath u; parse_rec rem | ("--coqlib" | "-coqlib") :: u :: rem -> Cdglobals.coqlib := u; parse_rec rem | ("--coqlib" | "-coqlib") :: [] -> @@ -328,16 +355,15 @@ let parse () = Cdglobals.coqlib_path := d; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: [] -> usage () - | f :: rem -> + | f :: rem -> add_file (what_file f); parse_rec rem - in + in parse_rec (List.tl (Array.to_list Sys.argv)); - Output.initialize (); List.rev !files - + (*s The following function produces the output. The default output is - the \LaTeX\ document: in that case, we just call [Web.produce_document]. + the \LaTeX\ document: in that case, we just call [Web.produce_document]. If option \verb!-dvi!, \verb!-ps! or \verb!-html! is invoked, then we make calls to \verb!latex! or \verb!dvips! or \verb!pdflatex! accordingly. *) @@ -359,9 +385,9 @@ let clean_temp_files basefile = remove (basefile ^ ".pdf"); remove (basefile ^ ".haux"); remove (basefile ^ ".html") - + let clean_and_exit file res = clean_temp_files file; exit res - + let cat file = let c = open_in file in try @@ -370,20 +396,26 @@ let cat file = close_in c let copy src dst = - let cin = open_in src - and cout = open_out dst in + let cin = open_in src in + try + let cout = open_out dst in try while true do Pervasives.output_char cout (input_char cin) done with End_of_file -> - close_in cin; close_out cout - + close_out cout; + close_in cin + with Sys_error e -> + eprintf "%s\n" e; + exit 1 (*s Functions for generating output files *) let gen_one_file l = let file = function - | Vernac_file (f,m) -> - Output.set_module m; Pretty.coq_file f m + | Vernac_file (f,m) -> + let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in + Output.set_module m sub; + Cpretty.coq_file f m | Latex_file _ -> () in if (!header_trailer) then Output.header (); @@ -391,74 +423,73 @@ let gen_one_file l = List.iter file l; if !index then Output.make_index(); if (!header_trailer) then Output.trailer () - + let gen_mult_files l = let file = function - | Vernac_file (f,m) -> - Output.set_module m; + | Vernac_file (f,m) -> + let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in let hf = target_full_name m in + Output.set_module m sub; open_out_file hf; - if (!header_trailer) then Output.header (); - Pretty.coq_file f m; + if (!header_trailer) then Output.header (); + Cpretty.coq_file f m; if (!header_trailer) then Output.trailer (); close_out_file() | Latex_file _ -> () in List.iter file l; if (!index && !target_language=HTML) then begin - if (!multi_index) then Output.make_multi_index (); - open_out_file "index.html"; + if (!multi_index) then Output.make_multi_index (); + open_out_file (!index_name^".html"); page_title := (if !title <> "" then !title else "Index"); - if (!header_trailer) then Output.header (); - Output.make_index (); + if (!header_trailer) then Output.header (); + Output.make_index (); if (!header_trailer) then Output.trailer (); close_out_file() end; if (!toc && !target_language=HTML) then begin - open_out_file "toc.html"; + open_out_file "toc.html"; page_title := (if !title <> "" then !title else "Table of contents"); if (!header_trailer) then Output.header (); if !title <> "" then printf "

%s

\n" !title; - Output.make_toc (); + Output.make_toc (); if (!header_trailer) then Output.trailer (); close_out_file() - end + end (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *) -let read_glob x = - match x with - | Vernac_file (f,m) -> - let glob = (Filename.chop_extension f) ^ ".glob" in - (try - Vernac_file (f, Index.read_glob glob) - with e -> - eprintf "Warning: file %s cannot be used; links will not be available: %s\n" glob (Printexc.to_string e); - x) - | Latex_file _ -> x +let read_glob_file x = + try Index.read_glob x + with Sys_error s -> + eprintf "Warning: %s (links will not be available)\n" s + +let read_glob_file_of = function + | Vernac_file (f,_) -> read_glob_file (Filename.chop_extension f ^ ".glob") + | Latex_file _ -> () let index_module = function - | Vernac_file (f,m) -> + | Vernac_file (f,m) -> Index.add_module m | Latex_file _ -> () - + +let copy_style_file file = + let src = + List.fold_left + Filename.concat !Cdglobals.coqlib_path ["tools";"coqdoc";file] in + let dst = coqdoc_out file in + if Sys.file_exists src then copy src dst + else eprintf "Warning: file %s does not exist\n" src + let produce_document l = - (if !target_language=HTML then - let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.css") in - let dst = if !output_dir <> "" then Filename.concat !output_dir "coqdoc.css" else "coqdoc.css" in - if (Sys.file_exists src) then (copy src dst) else eprintf "Warning: file %s does not exist\n" src); - (if !target_language=LaTeX then - let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.sty") in - let dst = if !output_dir <> "" then - Filename.concat !output_dir "coqdoc.sty" - else "coqdoc.sty" in - if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src); + if !target_language=HTML then copy_style_file "coqdoc.css"; + if !target_language=LaTeX then copy_style_file "coqdoc.sty"; (match !Cdglobals.glob_source with | NoGlob -> () - | DotGlob -> ignore (List.map read_glob l) - | GlobFile f -> ignore (Index.read_glob f)); + | DotGlob -> List.iter read_glob_file_of l + | GlobFile f -> read_glob_file f); List.iter index_module l; match !out_to with - | StdOut -> + | StdOut -> Cdglobals.out_channel := stdout; gen_one_file l | File f -> @@ -467,11 +498,11 @@ let produce_document l = close_out_file() | MultFiles -> gen_mult_files l - + let produce_output fl = - if not (!dvi || !ps || !pdf) then + if not (!dvi || !ps || !pdf) then produce_document fl - else + else begin let texfile = Filename.temp_file "coqdoc" ".tex" in let basefile = Filename.chop_suffix texfile ".tex" in @@ -479,52 +510,52 @@ let produce_output fl = out_to := File texfile; output_dir := (Filename.dirname texfile); produce_document fl; - + let latexexe = if !pdf then "pdflatex" else "latex" in - let latexcmd = + let latexcmd = let file = Filename.basename texfile in - let file = - if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file + let file = + if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file in sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "") in let res = locally (Filename.dirname texfile) Sys.command latexcmd in if res <> 0 then begin - eprintf "Couldn't run LaTeX successfully\n"; + eprintf "Couldn't run LaTeX successfully\n"; clean_and_exit basefile res end; - + let dvifile = basefile ^ ".dvi" in - if !dvi then + if !dvi then begin match final_out_to with | MultFiles | StdOut -> cat dvifile | File f -> copy dvifile f end; let pdffile = basefile ^ ".pdf" in - if !pdf then + if !pdf then begin match final_out_to with | MultFiles | StdOut -> cat pdffile | File f -> copy pdffile f end; if !ps then begin - let psfile = basefile ^ ".ps" + let psfile = basefile ^ ".ps" in - let command = - sprintf "dvips %s -o %s %s" dvifile psfile + let command = + sprintf "dvips %s -o %s %s" dvifile psfile (if !quiet then "> /dev/null 2>&1" else "") in let res = Sys.command command in if res <> 0 then begin - eprintf "Couldn't run dvips successfully\n"; + eprintf "Couldn't run dvips successfully\n"; clean_and_exit basefile res end; match final_out_to with | MultFiles | StdOut -> cat psfile | File f -> copy psfile f end; - + clean_temp_files basefile end @@ -534,7 +565,8 @@ let produce_output fl = let main () = let files = parse () in + Index.init_coqlib_library (); if not !quiet then banner (); if files <> [] then produce_output files - + let _ = Printexc.catch main () diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 1ad8b14f..93e1f843 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: output.ml 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) open Cdglobals open Index @@ -25,26 +25,26 @@ let sprintf = Printf.sprintf (*s Coq keywords *) -let build_table l = +let build_table l = let h = Hashtbl.create 101 in List.iter (fun key ->Hashtbl.add h key ()) l; function s -> try Hashtbl.find h s; true with Not_found -> false -let is_keyword = +let is_keyword = build_table [ "AddPath"; "Axiom"; "Abort"; "Boxed"; "Chapter"; "Check"; "Coercion"; "CoFixpoint"; - "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; + "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint"; - "Hypothesis"; "Hypotheses"; - "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive"; - "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; + "Hypothesis"; "Hypotheses"; + "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive"; + "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; "Module"; "Module Type"; "Declare Module"; "Include"; "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; - "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; + "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; - "Delimit"; "Bind"; "Open"; "Scope"; + "Delimit"; "Bind"; "Open"; "Scope"; "Boxed"; "Unboxed"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; @@ -54,13 +54,13 @@ let is_keyword = "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next"; "Program Instance"; "Equations"; "Equations_nocomp"; (*i (* coq terms *) *) - "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; + "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "fun"; "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure"; (* Ltac *) "before"; "after" ] -let is_tactic = +let is_tactic = build_table [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; @@ -77,30 +77,51 @@ let is_tactic = (*s Current Coq module *) -let current_module = ref "" +let current_module : (string * string option) ref = ref ("",None) -let set_module m = current_module := m; page_title := m +let get_module withsub = + let (m,sub) = !current_module in + if withsub then + match sub with + | None -> m + | Some sub -> m ^ ": " ^ sub + else + m + +let set_module m sub = current_module := (m,sub); + page_title := get_module true (*s Common to both LaTeX and HTML *) let item_level = ref 0 - -(*s Customized pretty-print *) - -let token_pp = Hashtbl.create 97 - -let add_printing_token = Hashtbl.replace token_pp - -let find_printing_token tok = - try Hashtbl.find token_pp tok with Not_found -> None, None - -let remove_printing_token = Hashtbl.remove token_pp - -(* predefined pretty-prints *) -let initialize () = +let in_doc = ref false + +(*s Customized and predefined pretty-print *) + +let initialize_texmacs () = + let ensuremath x = sprintf ">" x in + List.fold_right (fun (s,t) tt -> Tokens.ttree_add tt s t) + [ "*", ensuremath "times"; + "->", ensuremath "rightarrow"; + "<-", ensuremath "leftarrow"; + "<->", ensuremath "leftrightarrow"; + "=>", ensuremath "Rightarrow"; + "<=", ensuremath "le"; + ">=", ensuremath "ge"; + "<>", ensuremath "noteq"; + "~", ensuremath "lnot"; + "/\\", ensuremath "land"; + "\\/", ensuremath "lor"; + "|-", ensuremath "vdash" + ] Tokens.empty_ttree + +let token_tree_texmacs = ref (initialize_texmacs ()) + +let initialize_tex_html () = let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in - List.iter - (fun (s,l,l') -> Hashtbl.add token_pp s (Some l, l')) + List.fold_right (fun (s,l,l') (tt,tt') -> + (Tokens.ttree_add tt s l, + match l' with None -> tt' | Some l' -> Tokens.ttree_add tt' s l')) [ "*" , "\\ensuremath{\\times}", if_utf8 "×"; "|", "\\ensuremath{|}", None; "->", "\\ensuremath{\\rightarrow}", if_utf8 "→"; @@ -119,14 +140,27 @@ let initialize () = "forall", "\\ensuremath{\\forall}", if_utf8 "∀"; "exists", "\\ensuremath{\\exists}", if_utf8 "∃"; "Π", "\\ensuremath{\\Pi}", if_utf8 "Π"; - "λ", "\\ensuremath{\\lambda}", if_utf8 "λ" + "λ", "\\ensuremath{\\lambda}", if_utf8 "λ"; (* "fun", "\\ensuremath{\\lambda}" ? *) - ] + ] (Tokens.empty_ttree,Tokens.empty_ttree) + +let token_tree_latex = ref (fst (initialize_tex_html ())) +let token_tree_html = ref (snd (initialize_tex_html ())) + +let add_printing_token s (t1,t2) = + (match t1 with None -> () | Some t1 -> + token_tree_latex := Tokens.ttree_add !token_tree_latex s t1); + (match t2 with None -> () | Some t2 -> + token_tree_html := Tokens.ttree_add !token_tree_html s t2) + +let remove_printing_token s = + token_tree_latex := Tokens.ttree_remove !token_tree_latex s; + token_tree_html := Tokens.ttree_remove !token_tree_html s (*s Table of contents *) -type toc_entry = - | Toc_library of string +type toc_entry = + | Toc_library of string * string option | Toc_section of int * (unit -> unit) * string let (toc_q : toc_entry Queue.t) = Queue.create () @@ -140,7 +174,6 @@ let new_label = let r = ref 0 in fun () -> incr r; "lab" ^ string_of_int !r module Latex = struct let in_title = ref false - let in_doc = ref false (*s Latex preamble *) @@ -155,10 +188,14 @@ module Latex = struct printf "\\usepackage[T1]{fontenc}\n"; printf "\\usepackage{fullpage}\n"; printf "\\usepackage{coqdoc}\n"; + printf "\\usepackage{amsmath,amssymb}\n"; + (match !toc_depth with + | None -> () + | Some n -> printf "\\setcounter{tocdepth}{%i}\n" n); Queue.iter (fun s -> printf "%s\n" s) preamble; printf "\\begin{document}\n" end; - output_string + output_string "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"; output_string "%% This file has been automatically generated with the command\n"; @@ -173,21 +210,28 @@ module Latex = struct printf "\\end{document}\n" end + (*s Latex low-level translation *) + + let nbsp () = output_char '~' + let char c = match c with - | '\\' -> + | '\\' -> printf "\\symbol{92}" - | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> + | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> output_char '\\'; output_char c - | '^' | '~' -> + | '^' | '~' -> output_char '\\'; output_char c; printf "{}" - | _ -> + | _ -> output_char c let label_char c = match c with - | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_' - | '^' | '~' -> () - | _ -> - output_char c + | '_' -> output_char ' ' + | '\\' | '$' | '#' | '%' | '&' | '{' | '}' + | '^' | '~' -> printf "x%X" (Char.code c) + | _ -> if c >= '\x80' then printf "x%X" (Char.code c) else output_char c + + let label_ident s = + for i = 0 to String.length s - 1 do label_char s.[i] done let latex_char = output_char let latex_string = output_string @@ -195,19 +239,36 @@ module Latex = struct let html_char _ = () let html_string _ = () - let raw_ident s = - for i = 0 to String.length s - 1 do char s.[i] done - - let label_ident s = - for i = 0 to String.length s - 1 do label_char s.[i] done - - let start_module () = - if not !short then begin - printf "\\coqlibrary{"; - label_ident !current_module; - printf "}{"; - raw_ident !current_module; - printf "}\n\n" + (*s Latex char escaping *) + + let escaped = + let buff = Buffer.create 5 in + fun s -> + Buffer.clear buff; + for i = 0 to String.length s - 1 do + match s.[i] with + | '\\' -> + Buffer.add_string buff "\\symbol{92}" + | '$' | '#' | '%' | '&' | '{' | '}' | '_' as c -> + Buffer.add_char buff '\\'; Buffer.add_char buff c + | '^' | '~' as c -> + Buffer.add_char buff '\\'; Buffer.add_char buff c; + Buffer.add_string buff "{}" + | c -> + Buffer.add_char buff c + done; + Buffer.contents buff + + (*s Latex reference and symbol translation *) + + let start_module () = + let ln = !lib_name in + if not !short then begin + printf "\\coqlibrary{"; + label_ident (get_module false); + printf "}{"; + if ln <> "" then printf "%s " ln; + printf "}{%s}\n\n" (escaped (get_module true)) end let start_latex_math () = output_char '$' @@ -218,89 +279,101 @@ module Latex = struct let stop_verbatim () = printf "\\end{verbatim}\n" - let indentation n = - if n == 0 then + let indentation n = + if n == 0 then printf "\\coqdocnoindent\n" else let space = 0.5 *. (float n) in printf "\\coqdocindent{%2.2fem}\n" space - let with_latex_printing f tok = - try - (match Hashtbl.find token_pp tok with - | Some s, _ -> output_string s - | _ -> f tok) - with Not_found -> - f tok - - let module_ref m s = - printf "\\moduleid{%s}{" m; raw_ident s; printf "}" - (*i - match find_module m with - | Local -> - printf "" m; raw_ident s; printf "" - | Coqlib when !externals -> - let m = Filename.concat !coqlib m in - printf "" m; raw_ident s; printf "" - | Coqlib | Unknown -> - raw_ident s - i*) + let module_ref m s = + printf "\\moduleid{%s}{%s}" m (escaped s) let ident_ref m fid typ s = let id = if fid <> "" then (m ^ "." ^ fid) else m in match find_module m with | Local -> - printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}" - | Coqlib when !externals -> - let _m = Filename.concat !coqlib m in - printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}" - | Coqlib | Unknown -> - printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}" + if typ = Variable then + printf "\\coqdoc%s{%s}" (type_name typ) s + else + (printf "\\coqref{"; label_ident id; + printf "}{\\coqdoc%s{%s}}" (type_name typ) s) + | External m when !externals -> + printf "\\coqexternalref{"; label_ident fid; + printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s + | External _ | Unknown -> + printf "\\coqdoc%s{%s}" (type_name typ) s let defref m id ty s = - printf "\\coq%s{" (type_name ty); label_ident (m ^ "." ^ id); printf "}{"; raw_ident s; printf "}" + printf "\\coqdef{"; label_ident (m ^ "." ^ id); + printf "}{%s}{\\coqdoc%s{%s}}" s (type_name ty) s let reference s = function - | Def (fullid,typ) -> - defref !current_module fullid typ s + | Def (fullid,typ) -> + defref (get_module false) fullid typ s | Mod (m,s') when s = s' -> module_ref m s - | Ref (m,fullid,typ) -> + | Ref (m,fullid,typ) -> ident_ref m fullid typ s | Mod _ -> - printf "\\coqdocvar{"; raw_ident s; printf "}" - - let ident s loc = - if is_keyword s then begin - printf "\\coqdockw{"; raw_ident s; printf "}" - end else begin - begin + printf "\\coqdocvar{%s}" (escaped s) + + (*s The sublexer buffers symbol characters and attached + uninterpreted ident and try to apply special translation such as, + predefined, translation "->" to "\ensuremath{\rightarrow}" or, + virtually, a user-level translation from "=_h" to "\ensuremath{=_{h}}" *) + + let output_sublexer_string doescape issymbchar tag s = + let s = if doescape then escaped s else s in + match tag with + | Some ref -> reference s ref + | None -> if issymbchar then output_string s else printf "\\coqdocvar{%s}" s + + let sublexer c loc = + let tag = + try Some (Index.find (get_module false) loc) with Not_found -> None + in + Tokens.output_tagged_symbol_char tag c + + let initialize () = + Tokens.token_tree := token_tree_latex; + Tokens.outfun := output_sublexer_string + + (*s Interpreting ident with fallback on sublexer if unknown ident *) + + let translate s = + match Tokens.translate s with Some s -> s | None -> escaped s + + let ident s loc = + try + let tag = Index.find (get_module false) loc in + reference (translate s) tag + with Not_found -> + if is_tactic s then + printf "\\coqdoctac{%s}" (translate s) + else if is_keyword s then + printf "\\coqdockw{%s}" (translate s) + else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) + then try - reference s (Index.find !current_module loc) - with Not_found -> - if is_tactic s then begin - printf "\\coqdoctac{"; raw_ident s; printf "}" - end else begin - if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) - then - try reference s (Index.find_string !current_module s) - with _ -> (printf "\\coqdocvar{"; raw_ident s; printf "}") - else (printf "\\coqdocvar{"; raw_ident s; printf "}") - end - end - end + let tag = Index.find_string (get_module false) s in + reference (translate s) tag + with _ -> Tokens.output_tagged_ident_string s + else Tokens.output_tagged_ident_string s - let ident s l = + let ident s l = if !in_title then ( printf "\\texorpdfstring{\\protect"; - with_latex_printing (fun s -> ident s l) s; - printf "}{"; raw_ident s; printf "}") + ident s l; + printf "}{%s}" (translate s)) else - with_latex_printing (fun s -> ident s l) s - - let symbol s = with_latex_printing raw_ident s + ident s l + + (*s Translating structure *) + + let proofbox () = printf "\\ensuremath{\\Box}" - let rec reach_item_level n = + let rec reach_item_level n = if !item_level < n then begin printf "\n\\begin{itemize}\n\\item "; incr item_level; reach_item_level n @@ -320,7 +393,11 @@ module Latex = struct let end_doc () = in_doc := false; stop_item () - let comment c = char c + (* This is broken if we are in math mode, but coqdoc currently isn't + tracking that *) + let start_emph () = printf "\\textit{" + + let stop_emph () = printf "}" let start_comment () = printf "\\begin{coqdoccomment}\n" @@ -350,12 +427,16 @@ module Latex = struct let rule () = printf "\\par\n\\noindent\\hrulefill\\par\n\\noindent{}" - let paragraph () = stop_item (); printf "\n\n" + let paragraph () = printf "\n\n" let line_break () = printf "\\coqdoceol\n" let empty_line_of_code () = printf "\\coqdocemptyline\n" + let start_inline_coq_block () = line_break (); empty_line_of_code () + + let end_inline_coq_block () = empty_line_of_code () + let start_inline_coq () = () let end_inline_coq () = () @@ -377,9 +458,9 @@ module Html = struct if !header_trailer then if !header_file_spec then let cin = Pervasives.open_in !header_file in - try - while true do - let s = Pervasives.input_line cin in + try + while true do + let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin @@ -396,14 +477,14 @@ module Html = struct end let trailer () = - if !index && !current_module <> "Index" then - printf "\n\n
\n
Index"; - if !header_trailer then + if !index && (get_module false) <> "Index" then + printf "
\n\n
\n
Index" !index_name; + if !header_trailer then if !footer_file_spec then let cin = Pervasives.open_in !footer_file in - try - while true do - let s = Pervasives.input_line cin in + try + while true do + let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin @@ -414,26 +495,47 @@ module Html = struct printf "
\n\n\n\n\n" end - let start_module () = + let start_module () = + let ln = !lib_name in if not !short then begin - add_toc_entry (Toc_library !current_module); - printf "

Library %s

\n\n" !current_module + let (m,sub) = !current_module in + add_toc_entry (Toc_library (m,sub)); + if ln = "" then + printf "

%s

\n\n" (get_module true) + else + printf "

%s %s

\n\n" ln (get_module true) end let indentation n = for i = 1 to n do printf " " done let line_break () = printf "
\n" - let empty_line_of_code () = + let empty_line_of_code () = printf "\n
\n" + let nbsp () = printf " " + let char = function | '<' -> printf "<" | '>' -> printf ">" | '&' -> printf "&" | c -> output_char c - let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done + let raw_string s = + for i = 0 to String.length s - 1 do char s.[i] done + + let escaped = + let buff = Buffer.create 5 in + fun s -> + Buffer.clear buff; + for i = 0 to String.length s - 1 do + match s.[i] with + | '<' -> Buffer.add_string buff "<" + | '>' -> Buffer.add_string buff ">" + | '&' -> Buffer.add_string buff "&" + | c -> Buffer.add_char buff c + done; + Buffer.contents buff let latex_char _ = () let latex_string _ = () @@ -447,74 +549,81 @@ module Html = struct let start_verbatim () = printf "
"
   let stop_verbatim () = printf "
\n" - let module_ref m s = + let module_ref m s = match find_module m with | Local -> - printf "" m; raw_ident s; printf "" - | Coqlib when !externals -> - let m = Filename.concat !coqlib m in - printf "" m; raw_ident s; printf "" - | Coqlib | Unknown -> - raw_ident s + printf "%s" m s + | External m when !externals -> + printf "%s" m s + | External _ | Unknown -> + output_string s let ident_ref m fid typ s = match find_module m with | Local -> printf "" m fid; - printf "" typ; - raw_ident s; - printf "" - | Coqlib when !externals -> - let m = Filename.concat !coqlib m in - printf "" m fid; - printf "" typ; - raw_ident s; printf "" - | Coqlib | Unknown -> - printf "" typ; raw_ident s; printf "" - - let ident s loc = - if is_keyword s then begin - printf ""; - raw_ident s; - printf "" - end else - begin - try - (match Index.find !current_module loc with - | Def (fullid,ty) -> - printf "" fullid; - printf "" (type_name ty); - raw_ident s; printf "" - | Mod (m,s') when s = s' -> - module_ref m s - | Ref (m,fullid,ty) -> - ident_ref m fullid (type_name ty) s - | Mod _ -> - printf ""; raw_ident s ; printf "") - with Not_found -> - if is_tactic s then - (printf ""; raw_ident s; printf "") - else - (printf ""; raw_ident s ; printf "") - end + printf "%s" typ s + | External m when !externals -> + printf "" m fid; + printf "%s" typ s + | External _ | Unknown -> + printf "%s" typ s + + let reference s r = + match r with + | Def (fullid,ty) -> + printf "" fullid; + printf "%s" (type_name ty) s + | Mod (m,s') when s = s' -> + module_ref m s + | Ref (m,fullid,ty) -> + ident_ref m fullid (type_name ty) s + | Mod _ -> + printf "%s" s + + let output_sublexer_string doescape issymbchar tag s = + let s = if doescape then escaped s else s in + match tag with + | Some ref -> reference s ref + | None -> + if issymbchar then output_string s + else printf "%s" s + + let sublexer c loc = + let tag = + try Some (Index.find (get_module false) loc) with Not_found -> None + in + Tokens.output_tagged_symbol_char tag c - let with_html_printing f tok = - try - (match Hashtbl.find token_pp tok with - | _, Some s -> output_string s - | _ -> f tok) - with Not_found -> - f tok + let initialize () = + Tokens.token_tree := token_tree_html; + Tokens.outfun := output_sublexer_string - let ident s l = - with_html_printing (fun s -> ident s l) s + let translate s = + match Tokens.translate s with Some s -> s | None -> escaped s - let symbol s = - with_html_printing raw_ident s + let ident s loc = + if is_keyword s then begin + printf "%s" (translate s) + end else begin + try reference (translate s) (Index.find (get_module false) loc) + with Not_found -> + if is_tactic s then + printf "%s" (translate s) + else + if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) + then + try reference (translate s) (Index.find_string (get_module false) s) + with _ -> Tokens.output_tagged_ident_string s + else + Tokens.output_tagged_ident_string s + end - let rec reach_item_level n = + let proofbox () = printf "☐" + + let rec reach_item_level n = if !item_level < n then begin - printf "\n
    \n
  • "; incr item_level; + printf "
      \n
    • "; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n
      • \n
    \n"; decr item_level; @@ -532,14 +641,18 @@ module Html = struct let end_coq () = if not !raw_comments then printf "\n" - let start_doc () = + let start_doc () = in_doc := true; if not !raw_comments then printf "\n
    \n" - let end_doc () = - stop_item (); + let end_doc () = in_doc := false; + stop_item (); if not !raw_comments then printf "\n
    \n" + let start_emph () = printf "" + + let stop_emph () = printf "" + let start_comment () = printf "(*" let end_comment () = printf "*)" @@ -552,16 +665,19 @@ module Html = struct let end_inline_coq () = printf "" - let paragraph () = - let i = !item_level in - stop_item (); - if i > 0 then printf "\n" - else printf "\n

    \n" + let start_inline_coq_block () = line_break (); start_inline_coq () + + let end_inline_coq_block () = end_inline_coq () + + let paragraph () = printf "\n

    \n" let section lev f = let lab = new_label () in - let r = sprintf "%s.html#%s" !current_module lab in - add_toc_entry (Toc_section (lev, f, r)); + let r = sprintf "%s.html#%s" (get_module false) lab in + (match !toc_depth with + | None -> add_toc_entry (Toc_section (lev, f, r)) + | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r)) + else ()); stop_item (); printf "" lab lev; f (); @@ -572,64 +688,70 @@ module Html = struct (* make a HTML index from a list of triples (name,text,link) *) let index_ref i c = let idxc = sprintf "%s_%c" i.idx_name c in - if !multi_index then "index_" ^ idxc ^ ".html" else "index.html#" ^ idxc + !index_name ^ (if !multi_index then "_" ^ idxc ^ ".html" else ".html#" ^ idxc) let letter_index category idx (c,l) = if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in - printf "

    %c %s

    \n" idx c c cat; - List.iter - (fun (id,(text,link)) -> - printf "%s %s
    \n" link id text) l; + printf "

    %s %s

    \n" idx c (display_letter c) cat; + List.iter + (fun (id,(text,link,t)) -> + let id' = prepare_entry id t in + printf "%s %s
    \n" link id' text) l; printf "

    " end - + let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries (* Construction d'une liste des index (1 index global, puis 1 index par catégorie) *) let format_global_index = - Index.map - (fun s (m,t) -> - if t = Library then - "[library]", m ^ ".html" - else - sprintf "[%s, in %s]" (type_name t) m m , - sprintf "%s.html#%s" m s) + Index.map + (fun s (m,t) -> + if t = Library then + let ln = !lib_name in + if ln <> "" then + "[" ^ String.lowercase ln ^ "]", m ^ ".html", t + else + "[library]", m ^ ".html", t + else + sprintf "[%s, in %s]" (type_name t) m m , + sprintf "%s.html#%s" m s, t) let format_bytype_index = function | Library, idx -> - Index.map (fun id m -> "", m ^ ".html") idx + Index.map (fun id m -> "", m ^ ".html", Library) idx | (t,idx) -> - Index.map - (fun s m -> + Index.map + (fun s m -> let text = sprintf "[in %s]" m m in - (text, sprintf "%s.html#%s" m s)) idx + (text, sprintf "%s.html#%s" m s, t)) idx (* Impression de la table d'index *) let print_index_table_item i = printf "\n%s Index\n" (String.capitalize i.idx_name); - List.iter - (fun (c,l) -> + List.iter + (fun (c,l) -> if l <> [] then - printf "%c\n" (index_ref i c) c + printf "%s\n" (index_ref i c) + (display_letter c) else - printf "%c\n" c) + printf "%s\n" (display_letter c)) i.idx_entries; let n = i.idx_size in printf "(%d %s)\n" n (if n > 1 then "entries" else "entry"); printf "\n" - let print_index_table idxl = + let print_index_table idxl = printf "\n"; List.iter print_index_table_item idxl; printf "
    \n" - + let make_one_multi_index prt_tbl i = - (* Attn: make_one_multi_index créé un nouveau fichier... *) + (* Attn: make_one_multi_index crée un nouveau fichier... *) let idx = i.idx_name in let one_letter ((c,l) as cl) = - open_out_file (sprintf "index_%s_%c.html" idx c); + open_out_file (sprintf "%s_%s_%c.html" !index_name idx c); if (!header_trailer) then header (); prt_tbl (); printf "
    "; letter_index true idx cl; @@ -639,16 +761,16 @@ module Html = struct in List.iter one_letter i.idx_entries - let make_multi_index () = - let all_index = + let make_multi_index () = + let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in List.iter (make_one_multi_index print_table) all_index - + let make_index () = - let all_index = + let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in @@ -659,26 +781,33 @@ module Html = struct all_letters i end in - current_module := "Index"; + set_module "Index" None; if !title <> "" then printf "

    %s

    \n" !title; print_table (); - if not (!multi_index) then + if not (!multi_index) then begin List.iter print_one_index all_index; printf "
    "; print_table () end - - let make_toc () = - let make_toc_entry = function - | Toc_library m -> - stop_item (); - printf "

    Library %s

    \n" m m - | Toc_section (n, f, r) -> - item n; - printf "" r; f (); printf "\n" - in - Queue.iter make_toc_entry toc_q; - stop_item (); + + let make_toc () = + let ln = !lib_name in + let make_toc_entry = function + | Toc_library (m,sub) -> + stop_item (); + let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in + if ln = "" then + printf "

    %s

    \n" m ms + else + printf "

    %s %s

    \n" m ln ms + | Toc_section (n, f, r) -> + item n; + printf "" r; f (); printf "\n" + in + printf "
    \n"; + Queue.iter make_toc_entry toc_q; + stop_item (); + printf "
    \n" end @@ -689,21 +818,21 @@ module TeXmacs = struct (*s Latex preamble *) - let in_doc = ref false - - let (preamble : string Queue.t) = + let (preamble : string Queue.t) = in_doc := false; Queue.create () let push_in_preamble s = Queue.add s preamble let header () = - output_string + output_string "(*i This file has been automatically generated with the command \n"; - output_string + output_string " "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf " *)\n" let trailer () = () + let nbsp () = output_char ' ' + let char_true c = match c with | '\\' -> printf "\\\\" | '<' -> printf "\\<" @@ -734,7 +863,7 @@ module TeXmacs = struct let indentation n = () - let ident_true s = + let ident_true s = if is_keyword s then begin printf "" end else begin @@ -742,27 +871,20 @@ module TeXmacs = struct end let ident s _ = if !in_doc then ident_true s else raw_ident s - - let symbol_true s = - let ensuremath x = printf ">" x in - match s with - | "*" -> ensuremath "times" - | "->" -> ensuremath "rightarrow" - | "<-" -> ensuremath "leftarrow" - | "<->" ->ensuremath "leftrightarrow" - | "=>" -> ensuremath "Rightarrow" - | "<=" -> ensuremath "le" - | ">=" -> ensuremath "ge" - | "<>" -> ensuremath "noteq" - | "~" -> ensuremath "lnot" - | "/\\" -> ensuremath "land" - | "\\/" -> ensuremath "lor" - | "|-" -> ensuremath "vdash" - | s -> raw_ident s - - let symbol s = if !in_doc then symbol_true s else raw_ident s - - let rec reach_item_level n = + + let output_sublexer_string doescape issymbchar tag s = + if doescape then raw_ident s else output_string s + + let sublexer c l = + if !in_doc then Tokens.output_tagged_symbol_char None c else char c + + let initialize () = + Tokens.token_tree := token_tree_texmacs; + Tokens.outfun := output_sublexer_string + + let proofbox () = printf "QED" + + let rec reach_item_level n = if !item_level < n then begin printf "\n<\\itemize>\n"; incr item_level; reach_item_level n @@ -786,6 +908,9 @@ module TeXmacs = struct let end_coq () = () + let start_emph () = printf "" + let start_comment () = () let end_comment () = () @@ -801,13 +926,13 @@ module TeXmacs = struct let section lev f = stop_item (); - printf "<"; output_string (section_kind lev); printf "|"; + printf "<"; output_string (section_kind lev); printf "|"; f (); printf ">\n\n" let rule () = printf "\n\n" - let paragraph () = stop_item (); printf "\n\n" + let paragraph () = printf "\n\n" let line_break_true () = printf "" @@ -819,6 +944,10 @@ module TeXmacs = struct let end_inline_coq () = printf "]>" + let start_inline_coq_block () = line_break (); start_inline_coq () + + let end_inline_coq_block () = end_inline_coq () + let make_multi_index () = () let make_index () = () @@ -828,7 +957,7 @@ module TeXmacs = struct end -(*s LaTeX output *) +(*s Raw output *) module Raw = struct @@ -836,13 +965,9 @@ module Raw = struct let trailer () = () - let char = output_char + let nbsp () = output_char ' ' - let label_char c = match c with - | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_' - | '^' | '~' -> () - | _ -> - output_char c + let char = output_char let latex_char = output_char let latex_string = output_string @@ -863,22 +988,31 @@ module Raw = struct let stop_verbatim () = () - let indentation n = + let indentation n = for i = 1 to n do printf " " done let ident s loc = raw_ident s - let symbol s = raw_ident s + let sublexer c l = char c - let item n = printf "- " + let initialize () = + Tokens.token_tree := ref Tokens.empty_ttree; + Tokens.outfun := (fun _ _ _ _ -> failwith "Useless") + + let proofbox () = printf "[]" + let item n = printf "- " let stop_item () = () + let reach_item_level _ = () let start_doc () = printf "(** " let end_doc () = printf " *)\n" - let start_comment () = () - let end_comment () = () + let start_emph () = printf "_" + let stop_emph () = printf "_" + + let start_comment () = printf "(*" + let end_comment () = printf "*)" let start_coq () = () let end_coq () = () @@ -886,15 +1020,15 @@ module Raw = struct let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () - let section_kind = + let section_kind = function - | 1 -> "*" - | 2 -> "**" - | 3 -> "***" - | 4 -> "****" - | _ -> assert false + | 1 -> "* " + | 2 -> "** " + | 3 -> "*** " + | 4 -> "**** " + | _ -> assert false - let section lev f = + let section lev f = output_string (section_kind lev); f () @@ -909,9 +1043,12 @@ module Raw = struct let start_inline_coq () = () let end_inline_coq () = () + let start_inline_coq_block () = line_break (); start_inline_coq () + let end_inline_coq_block () = end_inline_coq () + let make_multi_index () = () let make_index () = () - let make_toc () = () + let make_toc () = () end @@ -919,7 +1056,7 @@ end (*s Generic output *) -let select f1 f2 f3 f4 x = +let select f1 f2 f3 f4 x = match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x | Raw -> f4 x let push_in_preamble = Latex.push_in_preamble @@ -927,7 +1064,7 @@ let push_in_preamble = Latex.push_in_preamble let header = select Latex.header Html.header TeXmacs.header Raw.header let trailer = select Latex.trailer Html.trailer TeXmacs.trailer Raw.trailer -let start_module = +let start_module = select Latex.start_module Html.start_module TeXmacs.start_module Raw.start_module let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc Raw.start_doc @@ -940,45 +1077,61 @@ let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.star let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code -let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code +let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code -let start_inline_coq = +let start_inline_coq = select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq -let end_inline_coq = +let end_inline_coq = select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq Raw.end_inline_coq +let start_inline_coq_block = + select Latex.start_inline_coq_block Html.start_inline_coq_block + TeXmacs.start_inline_coq_block Raw.start_inline_coq_block +let end_inline_coq_block = + select Latex.end_inline_coq_block Html.end_inline_coq_block TeXmacs.end_inline_coq_block Raw.end_inline_coq_block + let indentation = select Latex.indentation Html.indentation TeXmacs.indentation Raw.indentation let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph Raw.paragraph let line_break = select Latex.line_break Html.line_break TeXmacs.line_break Raw.line_break -let empty_line_of_code = select +let empty_line_of_code = select Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code Raw.empty_line_of_code let section = select Latex.section Html.section TeXmacs.section Raw.section let item = select Latex.item Html.item TeXmacs.item Raw.item let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item Raw.stop_item +let reach_item_level = select Latex.reach_item_level Html.reach_item_level TeXmacs.reach_item_level Raw.reach_item_level let rule = select Latex.rule Html.rule TeXmacs.rule Raw.rule +let nbsp = select Latex.nbsp Html.nbsp TeXmacs.nbsp Raw.nbsp let char = select Latex.char Html.char TeXmacs.char Raw.char let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident -let symbol = select Latex.symbol Html.symbol TeXmacs.symbol Raw.symbol +let sublexer = select Latex.sublexer Html.sublexer TeXmacs.sublexer Raw.sublexer +let initialize = select Latex.initialize Html.initialize TeXmacs.initialize Raw.initialize + +let proofbox = select Latex.proofbox Html.proofbox TeXmacs.proofbox Raw.proofbox let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char Raw.latex_char -let latex_string = +let latex_string = select Latex.latex_string Html.latex_string TeXmacs.latex_string Raw.latex_string let html_char = select Latex.html_char Html.html_char TeXmacs.html_char Raw.html_char -let html_string = +let html_string = select Latex.html_string Html.html_string TeXmacs.html_string Raw.html_string -let start_latex_math = +let start_emph = + select Latex.start_emph Html.start_emph TeXmacs.start_emph Raw.start_emph +let stop_emph = + select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph + +let start_latex_math = select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math -let stop_latex_math = +let stop_latex_math = select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math Raw.stop_latex_math -let start_verbatim = +let start_verbatim = select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim -let stop_verbatim = +let stop_verbatim = select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim -let verbatim_char = +let verbatim_char = select output_char Html.char TeXmacs.char Raw.char let hard_verbatim_char = output_char diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index 75c7ccf8..d836f6b3 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: output.mli 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) open Cdglobals open Index @@ -16,7 +16,8 @@ val initialize : unit -> unit val add_printing_token : string -> string option * string option -> unit val remove_printing_token : string -> unit -val set_module : coq_module -> unit +val set_module : coq_module -> string option -> unit +val get_module : bool -> string val header : unit -> unit val trailer : unit -> unit @@ -28,6 +29,9 @@ val start_module : unit -> unit val start_doc : unit -> unit val end_doc : unit -> unit +val start_emph : unit -> unit +val stop_emph : unit -> unit + val start_comment : unit -> unit val end_comment : unit -> unit @@ -40,6 +44,9 @@ val end_code : unit -> unit val start_inline_coq : unit -> unit val end_inline_coq : unit -> unit +val start_inline_coq_block : unit -> unit +val end_inline_coq_block : unit -> unit + val indentation : int -> unit val line_break : unit -> unit val paragraph : unit -> unit @@ -48,12 +55,18 @@ val empty_line_of_code : unit -> unit val section : int -> (unit -> unit) -> unit val item : int -> unit +val stop_item : unit -> unit +val reach_item_level : int -> unit val rule : unit -> unit +val nbsp : unit -> unit val char : char -> unit val ident : string -> loc -> unit -val symbol : string -> unit +val sublexer : char -> loc -> unit +val initialize : unit -> unit + +val proofbox : unit -> unit val latex_char : char -> unit val latex_string : string -> unit diff --git a/tools/coqdoc/pretty.mli b/tools/coqdoc/pretty.mli deleted file mode 100644 index dda0439e..00000000 --- a/tools/coqdoc/pretty.mli +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Cdglobals.coq_module -> unit diff --git a/tools/coqdoc/pretty.mll b/tools/coqdoc/pretty.mll deleted file mode 100644 index b29e0734..00000000 --- a/tools/coqdoc/pretty.mll +++ /dev/null @@ -1,784 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* count (c + (8 - (c mod 8))) (i + 1) - | ' ' -> count (c + 1) (i + 1) - | _ -> c,i - in - count 0 0 - - let count_dashes s = - let c = ref 0 in - for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done; - !c - - let cut_head_tail_spaces s = - let n = String.length s in - let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in - let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in - let l = look_up 0 in - let r = look_dn (n-1) in - if l <= r then String.sub s l (r-l+1) else s - - let sec_title s = - let rec count lev i = - if s.[i] = '*' then - count (succ lev) (succ i) - else - let t = String.sub s i (String.length s - i) in - lev, cut_head_tail_spaces t - in - count 0 (String.index s '*') - - let strip_eol s = - let eol = s.[String.length s - 1] = '\n' in - (eol, if eol then String.sub s 1 (String.length s - 1) else s) - - - let formatted = ref false - let brackets = ref 0 - let comment_level = ref 0 - let in_proof = ref None - - let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos - - let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false - - (* saving/restoring the PP state *) - - type state = { - st_gallina : bool; - st_light : bool - } - - let state_stack = Stack.create () - - let save_state () = - Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack - - let restore_state () = - let s = Stack.pop state_stack in - Cdglobals.gallina := s.st_gallina; - Cdglobals.light := s.st_light - - let without_ref r f x = save_state (); r := false; f x; restore_state () - - let without_gallina = without_ref Cdglobals.gallina - - let without_light = without_ref Cdglobals.light - - let show_all f = without_gallina (without_light f) - - let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false - let end_show () = restore_state () - - (* Reset the globals *) - - let reset () = - formatted := false; - brackets := 0; - comment_level := 0 - - (* erasing of Section/End *) - - let section_re = Str.regexp "[ \t]*Section" - let end_re = Str.regexp "[ \t]*End" - let is_section s = Str.string_match section_re s 0 - let is_end s = Str.string_match end_re s 0 - - let sections_to_close = ref 0 - - let section_or_end s = - if is_section s then begin - incr sections_to_close; true - end else if is_end s then begin - if !sections_to_close > 0 then begin - decr sections_to_close; true - end else - false - end else - true - - (* tokens pretty-print *) - - let token_buffer = Buffer.create 1024 - - let token_re = - Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)" - let printing_token_re = - Str.regexp - "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\(&#\\|[^#]\\)*\\)#\\)?" - - let add_printing_token toks pps = - try - if Str.string_match token_re toks 0 then - let tok = Str.matched_group 1 toks in - if Str.string_match printing_token_re pps 0 then - let pp = - (try Some (Str.matched_group 3 pps) with _ -> - try Some (Str.matched_group 4 pps) with _ -> None), - (try Some (Str.matched_group 6 pps) with _ -> None) - in - Output.add_printing_token tok pp - with _ -> - () - - let remove_token_re = - Str.regexp - "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)" - - let remove_printing_token toks = - try - if Str.string_match remove_token_re toks 0 then - let tok = Str.matched_group 1 toks in - Output.remove_printing_token tok - with _ -> - () - - let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:=" - let extract_ident s = - assert (String.length s >= 3); - if Str.string_match extract_ident_re s 0 then - Str.matched_group 1 s - else - String.sub s 1 (String.length s - 3) - - let symbol lexbuf s = Output.symbol s - -} - -(*s Regular expressions *) - -let space = [' ' '\t'] -let space_nl = [' ' '\t' '\n' '\r'] -let nl = "\r\n" | '\n' - -let firstchar = - ['A'-'Z' 'a'-'z' '_' - (* iso 8859-1 accents *) - '\192'-'\214' '\216'-'\246' '\248'-'\255' ] | - (* *) - '\194' '\185' | - (* utf-8 latin 1 supplement *) - '\195' ['\128'-'\191'] | - (* utf-8 letterlike symbols *) - '\206' ('\160' | [ '\177'-'\183'] | '\187') | - '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) - | '\129' [ '\176'-'\187' ] (* superscripts *) - | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) -let identchar = - firstchar | ['\'' '0'-'9' '@' ] -let id = firstchar identchar* -let pfx_id = (id '.')* -let identifier = - id | pfx_id id - -let symbolchar_symbol_no_brackets = - ['!' '$' '%' '&' '*' '+' ',' '^' '#' - '\\' '/' '-' '<' '>' '|' ':' '?' '=' '~' ] | - (* utf-8 symbols *) - '\226' ['\134'-'\143' '\152'-'\155' '\164'-'\165' '\168'-'\171'] _ -let symbolchar_no_brackets = symbolchar_symbol_no_brackets | - [ '@' '{' '}' '(' ')' 'A'-'Z' 'a'-'z' '_'] -let symbolchar = symbolchar_no_brackets | '[' | ']' -let token_no_brackets = symbolchar_symbol_no_brackets symbolchar_no_brackets* -let token = symbolchar_symbol_no_brackets symbolchar* | '[' [^ '[' ']' ':']* ']' -let printing_token = (token | id)+ - -(* tokens with balanced brackets *) -let token_brackets = - ( token_no_brackets ('[' token_no_brackets? ']')* - | token_no_brackets? ('[' token_no_brackets? ']')+ ) - token_no_brackets? - -let thm_token = - "Theorem" - | "Lemma" - | "Fact" - | "Remark" - | "Corollary" - | "Proposition" - | "Property" - | "Goal" - -let prf_token = - "Next" space+ "Obligation" - | "Proof" (space* "." | space+ "with") - -let def_token = - "Definition" - | "Let" - | "Class" - | "SubClass" - | "Example" - | "Local" - | "Fixpoint" - | "Boxed" - | "CoFixpoint" - | "Record" - | "Structure" - | "Scheme" - | "Inductive" - | "CoInductive" - | "Equations" - | "Instance" - | "Global" space+ "Instance" - -let decl_token = - "Hypothesis" - | "Hypotheses" - | "Parameter" - | "Axiom" 's'? - | "Conjecture" - -let gallina_ext = - "Module" - | "Include" space+ "Type" - | "Include" - | "Declare" space+ "Module" - | "Transparent" - | "Opaque" - | "Canonical" - | "Coercion" - | "Identity" - | "Implicit" - | "Notation" - | "Infix" - | "Tactic" space+ "Notation" - | "Reserved" space+ "Notation" - | "Section" - | "Context" - | "Variable" 's'? - | ("Hypothesis" | "Hypotheses") - | "End" - -let commands = - "Pwd" - | "Cd" - | "Drop" - | "ProtectedLoop" - | "Quit" - | "Load" - | "Add" - | "Remove" space+ "Loadpath" - | "Print" - | "Inspect" - | "About" - | "Search" - | "Eval" - | "Reset" - | "Check" - | "Type" - - | "Section" - | "Chapter" - | "Variable" 's'? - | ("Hypothesis" | "Hypotheses") - | "End" - -let end_kw = "Qed" | "Defined" | "Save" | "Admitted" | "Abort" - -let extraction = - "Extraction" - | "Recursive" space+ "Extraction" - | "Extract" - -let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction - -let prog_kw = - "Program" space+ gallina_kw - | "Obligation" - | "Obligations" - | "Solve" - -let gallina_kw_to_hide = - "Implicit" space+ "Arguments" - | "Ltac" - | "Require" - | "Import" - | "Export" - | "Load" - | "Hint" - | "Open" - | "Close" - | "Delimit" - | "Transparent" - | "Opaque" - | ("Declare" space+ ("Morphism" | "Step") ) - | ("Set" | "Unset") space+ "Printing" space+ "Coercions" - | "Declare" space+ ("Left" | "Right") space+ "Step" - - -let section = "*" | "**" | "***" | "****" - -let item_space = " " - -let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl -let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl -let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl -let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl -(* -let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" -let end_verb = "(*" space* "end" space+ "verb" space* "*)" -*) - - - -(*s Scanning Coq, at beginning of line *) - -rule coq_bol = parse - | space* nl+ - { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } - | space* "(**" space_nl - { Output.end_coq (); Output.start_doc (); - let eol = doc_bol lexbuf in - Output.end_doc (); Output.start_coq (); - if eol then coq_bol lexbuf else coq lexbuf } - | space* "Comments" space_nl - { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); - Output.start_coq (); coq lexbuf } - | space* begin_hide - { skip_hide lexbuf; coq_bol lexbuf } - | space* begin_show - { begin_show (); coq_bol lexbuf } - | space* end_show - { end_show (); coq_bol lexbuf } - | space* gallina_kw_to_hide - { let s = lexeme lexbuf in - if !Cdglobals.light && section_or_end s then - let eol = skip_to_dot lexbuf in - if eol then (coq_bol lexbuf) else coq lexbuf - else - begin - let nbsp,isp = count_spaces s in - Output.indentation nbsp; - let s = String.sub s isp (String.length s - isp) in - Output.ident s (lexeme_start lexbuf + isp); - let eol = body lexbuf in - if eol then coq_bol lexbuf else coq lexbuf - end } - | space* thm_token - { let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - let s = String.sub s isp (String.length s - isp) in - Output.indentation nbsp; - Output.ident s (lexeme_start lexbuf + isp); - let eol = body lexbuf in - in_proof := Some eol; - if eol then coq_bol lexbuf else coq lexbuf } - | space* prf_token - { in_proof := Some true; - let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end - else - let s = lexeme lexbuf in - if s.[String.length s - 1] = '.' then false - else skip_to_dot lexbuf - in if eol then coq_bol lexbuf else coq lexbuf } - | space* end_kw { - let eol = - if not (!in_proof <> None && !Cdglobals.gallina) then - begin backtrack lexbuf; body_bol lexbuf end - else skip_to_dot lexbuf - in - in_proof := None; - if eol then coq_bol lexbuf else coq lexbuf } - | space* gallina_kw - { - in_proof := None; - let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - let s = String.sub s isp (String.length s - isp) in - Output.indentation nbsp; - Output.ident s (lexeme_start lexbuf + isp); - let eol= body lexbuf in - if eol then coq_bol lexbuf else coq lexbuf } - | space* prog_kw - { - in_proof := None; - let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - Output.indentation nbsp; - let s = String.sub s isp (String.length s - isp) in - Output.ident s (lexeme_start lexbuf + isp); - let eol= body lexbuf in - if eol then coq_bol lexbuf else coq lexbuf } - - | space* "(**" space+ "printing" space+ printing_token space+ - { let tok = lexeme lexbuf in - let s = printing_token_body lexbuf in - add_printing_token tok s; - coq_bol lexbuf } - | space* "(**" space+ "printing" space+ - { eprintf "warning: bad 'printing' command at character %d\n" - (lexeme_start lexbuf); flush stderr; - comment_level := 1; - ignore (comment lexbuf); - coq_bol lexbuf } - | space* "(**" space+ "remove" space+ "printing" space+ - (identifier | token) space* "*)" - { remove_printing_token (lexeme lexbuf); - coq_bol lexbuf } - | space* "(**" space+ "remove" space+ "printing" space+ - { eprintf "warning: bad 'remove printing' command at character %d\n" - (lexeme_start lexbuf); flush stderr; - comment_level := 1; - ignore (comment lexbuf); - coq_bol lexbuf } - | space* "(*" - { comment_level := 1; - if !Cdglobals.parse_comments then begin - let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - Output.indentation nbsp; - Output.start_comment (); - end; - let eol = comment lexbuf in - if eol then coq_bol lexbuf else coq lexbuf } - | eof - { () } - | _ - { let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end - else - skip_to_dot lexbuf - in - if eol then coq_bol lexbuf else coq lexbuf } - -(*s Scanning Coq elsewhere *) - -and coq = parse - | nl - { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf } - | "(**" space_nl - { Output.end_coq (); Output.start_doc (); - let eol = doc_bol lexbuf in - Output.end_doc (); Output.start_coq (); - if eol then coq_bol lexbuf else coq lexbuf } - | "(*" - { comment_level := 1; - if !Cdglobals.parse_comments then begin - let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - Output.indentation nbsp; - Output.start_comment (); - end; - let eol = comment lexbuf in - if eol then coq_bol lexbuf - else coq lexbuf - } - | nl+ space* "]]" - { if not !formatted then begin symbol lexbuf (lexeme lexbuf); coq lexbuf end } - | eof - { () } - | gallina_kw_to_hide - { let s = lexeme lexbuf in - if !Cdglobals.light && section_or_end s then - begin - let eol = skip_to_dot lexbuf in - if eol then coq_bol lexbuf else coq lexbuf - end - else - begin - Output.ident s (lexeme_start lexbuf); - let eol=body lexbuf in - if eol then coq_bol lexbuf else coq lexbuf - end } - | prf_token - { let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end - else - let s = lexeme lexbuf in - let eol = - if s.[String.length s - 1] = '.' then false - else skip_to_dot lexbuf - in - eol - in if eol then coq_bol lexbuf else coq lexbuf } - | end_kw { - let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body lexbuf end - else - let eol = skip_to_dot lexbuf in - if !in_proof <> Some true && eol then - Output.line_break (); - eol - in - in_proof := None; - if eol then coq_bol lexbuf else coq lexbuf } - | gallina_kw - { let s = lexeme lexbuf in - Output.ident s (lexeme_start lexbuf); - let eol = body lexbuf in - if eol then coq_bol lexbuf else coq lexbuf } - | prog_kw - { let s = lexeme lexbuf in - Output.ident s (lexeme_start lexbuf); - let eol = body lexbuf in - if eol then coq_bol lexbuf else coq lexbuf } - | space+ { Output.char ' '; coq lexbuf } - | eof - { () } - | _ { let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body lexbuf end - else - skip_to_dot lexbuf - in - if eol then coq_bol lexbuf else coq lexbuf} - -(*s Scanning documentation, at beginning of line *) - -and doc_bol = parse - | space* nl+ - { Output.paragraph (); doc_bol lexbuf } - | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? - { let eol, lex = strip_eol (lexeme lexbuf) in - let lev, s = sec_title lex in - Output.section lev (fun () -> ignore (doc (from_string s))); - if eol then doc_bol lexbuf else doc lexbuf } - | space* '-'+ - { let n = count_dashes (lexeme lexbuf) in - if n >= 4 then Output.rule () else Output.item n; - doc lexbuf } - | "<<" space* - { Output.start_verbatim (); verbatim lexbuf; doc_bol lexbuf } - | eof - { true } - | _ - { backtrack lexbuf; doc lexbuf } - -(*s Scanning documentation elsewhere *) - -and doc = parse - | nl - { Output.char '\n'; doc_bol lexbuf } - | "[[" nl - { formatted := true; Output.line_break (); Output.start_inline_coq (); - let eol = body_bol lexbuf in - Output.end_inline_coq (); formatted := false; - if eol then doc_bol lexbuf else doc lexbuf} - | "[" - { brackets := 1; - Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq (); - doc lexbuf } - | '*'* "*)" space* nl - { true } - | '*'* "*)" - { false } - | "$" - { Output.start_latex_math (); escaped_math_latex lexbuf; doc lexbuf } - | "$$" - { Output.char '$'; doc lexbuf } - | "%" - { escaped_latex lexbuf; doc lexbuf } - | "%%" - { Output.char '%'; doc lexbuf } - | "#" - { escaped_html lexbuf; doc lexbuf } - | "##" - { Output.char '#'; doc lexbuf } - | eof - { false } - | _ - { Output.char (lexeme_char lexbuf 0); doc lexbuf } - -(*s Various escapings *) - -and escaped_math_latex = parse - | "$" { Output.stop_latex_math () } - | eof { Output.stop_latex_math () } - | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf } - -and escaped_latex = parse - | "%" { () } - | eof { () } - | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf } - -and escaped_html = parse - | "#" { () } - | "&#" - { Output.html_char '&'; Output.html_char '#'; escaped_html lexbuf } - | "##" - { Output.html_char '#'; escaped_html lexbuf } - | eof { () } - | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } - -and verbatim = parse - | nl ">>" { Output.verbatim_char '\n'; Output.stop_verbatim () } - | eof { Output.stop_verbatim () } - | _ { Output.verbatim_char (lexeme_char lexbuf 0); verbatim lexbuf } - -(*s Coq, inside quotations *) - -and escaped_coq = parse - | "]" - { decr brackets; - if !brackets > 0 then begin Output.char ']'; escaped_coq lexbuf end } - | "[" - { incr brackets; Output.char '['; escaped_coq lexbuf } - | "(*" - { comment_level := 1; ignore (comment lexbuf); escaped_coq lexbuf } - | "*)" - { (* likely to be a syntax error: we escape *) backtrack lexbuf } - | eof - { () } - | token_brackets - { let s = lexeme lexbuf in - symbol lexbuf s; escaped_coq lexbuf } - | (identifier '.')* identifier - { Output.ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf } - | _ - { Output.char (lexeme_char lexbuf 0); escaped_coq lexbuf } - -(*s Coq "Comments" command. *) - -and comments = parse - | space_nl+ - { Output.char ' '; comments lexbuf } - | '"' [^ '"']* '"' - { let s = lexeme lexbuf in - let s = String.sub s 1 (String.length s - 2) in - ignore (doc (from_string s)); comments lexbuf } - | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+ - { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf } - | "." (space_nl | eof) - { () } - | eof - { () } - | _ - { Output.char (lexeme_char lexbuf 0); comments lexbuf } - -(*s Skip comments *) - -and comment = parse - | "(*" { incr comment_level; - if !Cdglobals.parse_comments then Output.start_comment (); - comment lexbuf } - | "*)" space* nl { - if !Cdglobals.parse_comments then (Output.end_comment (); Output.line_break ()); - decr comment_level; if !comment_level > 0 then comment lexbuf else true } - | "*)" { - if !Cdglobals.parse_comments then (Output.end_comment ()); - decr comment_level; if !comment_level > 0 then comment lexbuf else false } - | "[" { - if !Cdglobals.parse_comments then ( - brackets := 1; - Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ()); - comment lexbuf } - | eof { false } - | space+ { if !Cdglobals.parse_comments then - Output.indentation (fst (count_spaces (lexeme lexbuf))); comment lexbuf } - | nl { if !Cdglobals.parse_comments then Output.line_break (); comment lexbuf } - | _ { if !Cdglobals.parse_comments then Output.char (lexeme_char lexbuf 0); - comment lexbuf } - -and skip_to_dot = parse - | '.' space* nl { true } - | eof | '.' space+ { false } - | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf } - | _ { skip_to_dot lexbuf } - -and body_bol = parse - | space+ - { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } - | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } - -and body = parse - | nl {Output.line_break(); body_bol lexbuf} - | nl+ space* "]]" - { if not !formatted then begin symbol lexbuf (lexeme lexbuf); body lexbuf end else true } - | eof { false } - | '.' space* nl | '.' space* eof - { Output.char '.'; Output.line_break(); - if not !formatted then true else body_bol lexbuf } - | '.' space+ { Output.char '.'; Output.char ' '; - if not !formatted then false else body lexbuf } - | '"' { Output.char '"'; ignore(notation lexbuf); body lexbuf } - | "(*" { comment_level := 1; - if !Cdglobals.parse_comments then Output.start_comment (); - let eol = comment lexbuf in - if eol - then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end - else body lexbuf } - | identifier - { let s = lexeme lexbuf in - Output.ident s (lexeme_start lexbuf); - body lexbuf } - | token_no_brackets - { let s = lexeme lexbuf in - symbol lexbuf s; body lexbuf } - | ".." - { Output.char '.'; Output.char '.'; - body lexbuf } - | _ { let c = lexeme_char lexbuf 0 in - Output.char c; - body lexbuf } - -and notation_bol = parse - | space+ - { Output.indentation (fst (count_spaces (lexeme lexbuf))); notation lexbuf } - | _ { backtrack lexbuf; notation lexbuf } - -and notation = parse - | nl { Output.line_break(); notation_bol lexbuf } - | '"' { Output.char '"'} - | token - { let s = lexeme lexbuf in - symbol lexbuf s; notation lexbuf } - | _ { let c = lexeme_char lexbuf 0 in - Output.char c; - notation lexbuf } - -and skip_hide = parse - | eof | end_hide { () } - | _ { skip_hide lexbuf } - -(*s Reading token pretty-print *) - -and printing_token_body = parse - | "*)" nl? | eof - { let s = Buffer.contents token_buffer in - Buffer.clear token_buffer; - s } - | _ { Buffer.add_string token_buffer (lexeme lexbuf); - printing_token_body lexbuf } - -(*s Applying the scanners to files *) - -{ - - let coq_file f m = - reset (); - Index.current_library := m; - Output.start_module (); - let c = open_in f in - let lb = from_channel c in - Output.start_coq (); coq_bol lb; Output.end_coq (); - close_in c - -} - diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml new file mode 100644 index 00000000..c2a47308 --- /dev/null +++ b/tools/coqdoc/tokens.ml @@ -0,0 +1,171 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None with + | Some tt' -> + CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch) + | None -> + let tt' = {node = None; branch = CharMap.empty} in + CharMap.add c (insert tt' (i + 1)) tt.branch + in + { node = tt.node; branch = br } + in + insert ttree 0 + +(* Removes a string from a dictionary: returns an equal dictionary + if the word not present. *) +let ttree_remove ttree str = + let rec remove tt i = + if i == String.length str then + {node = None; branch = tt.branch} + else + let c = str.[i] in + let br = + match try Some (CharMap.find c tt.branch) with Not_found -> None with + | Some tt' -> + CharMap.add c (remove tt' (i + 1)) (CharMap.remove c tt.branch) + | None -> tt.branch + in + { node = tt.node; branch = br } + in + remove ttree 0 + +let ttree_descend ttree c = CharMap.find c ttree.branch + +let ttree_find ttree str = + let rec proc_rec tt i = + if i == String.length str then tt + else proc_rec (CharMap.find str.[i] tt.branch) (i+1) + in + proc_rec ttree 0 + +(*s Parameters of the translation automaton *) + +type out_function = bool -> bool -> Index.index_entry option -> string -> unit + +let token_tree = ref (ref empty_ttree) +let outfun = ref (fun _ _ _ _ -> failwith "outfun not initialized") + +(*s Translation automaton *) + +let buff = Buffer.create 4 + +let flush_buffer was_symbolchar tag tok = + let hastr = String.length tok <> 0 in + if hastr then !outfun false was_symbolchar tag tok; + if Buffer.length buff <> 0 then + !outfun true (if hastr then not was_symbolchar else was_symbolchar) + tag (Buffer.contents buff); + Buffer.clear buff + +type sublexer_state = + | Neutral + | Buffering of bool * Index.index_entry option * string * ttree + +let translation_state = ref Neutral + +let buffer_char is_symbolchar ctag c = + let rec aux = function + | Neutral -> + restart_buffering () + | Buffering (was_symbolchar,tag,translated,tt) -> + if tag <> ctag then + (* A strong tag comes from Coq; if different Coq tags *) + (* hence, we don't try to see the chars as part of a single token *) + let translated = + match tt.node with + | Some tok -> Buffer.clear buff; tok + | None -> translated in + flush_buffer was_symbolchar tag translated; + restart_buffering () + else + begin + (* If we change the category of characters (symbol vs ident) *) + (* we accept this as a possible token cut point and remember the *) + (* translated token up to that point *) + let translated = + if is_symbolchar <> was_symbolchar then + match tt.node with + | Some tok -> Buffer.clear buff; tok + | None -> translated + else translated in + (* We try to make a significant token from the current *) + (* buffer and the new character *) + try + let tt = ttree_descend tt c in + Buffer.add_char buff c; + Buffering (is_symbolchar,ctag,translated,tt) + with Not_found -> + (* No existing translation for the given set of chars *) + if is_symbolchar <> was_symbolchar then + (* If we changed the category of character read, we accept it *) + (* as a possible cut point and restart looking for a translation *) + (flush_buffer was_symbolchar tag translated; + restart_buffering ()) + else + (* If we did not change the category of character read, we do *) + (* not want to cut arbitrarily in the middle of the sequence of *) + (* symbol characters or identifier characters *) + (Buffer.add_char buff c; + Buffering (is_symbolchar,tag,translated,empty_ttree)) + end + + and restart_buffering () = + let tt = try ttree_descend !(!token_tree) c with Not_found -> empty_ttree in + Buffer.add_char buff c; + Buffering (is_symbolchar,ctag,"",tt) + + in + translation_state := aux !translation_state + +let output_tagged_ident_string s = + for i = 0 to String.length s - 1 do buffer_char false None s.[i] done + +let output_tagged_symbol_char tag c = + buffer_char true tag c + +let flush_sublexer () = + match !translation_state with + | Neutral -> () + | Buffering (was_symbolchar,tag,translated,tt) -> + let translated = + match tt.node with + | Some tok -> Buffer.clear buff; tok + | None -> translated in + flush_buffer was_symbolchar tag translated; + translation_state := Neutral + +(* Translation not using the automaton *) +let translate s = + try (ttree_find !(!token_tree) s).node with Not_found -> None diff --git a/tools/coqdoc/tokens.mli b/tools/coqdoc/tokens.mli new file mode 100644 index 00000000..a85e75c4 --- /dev/null +++ b/tools/coqdoc/tokens.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string -> string -> ttree + +(* Remove a translation from a dictionary: returns an equal dictionary + if the word not present *) +val ttree_remove : ttree -> string -> ttree + +(* Translate a string *) +val translate : string -> string option + +(* Sublexer automaton *) + +(* The sublexer buffers the chars it receives; if after some time, it + recognizes that a sequence of chars has a translation in the + current dictionary, it replaces the buffer by the translation *) + +(* Received chars can come with a "tag" (usually made from + informations from the globalization file). A sequence of chars can + be considered a word only, if all chars have the same "tag". Rules + for cutting words are the following: + + - in a sequence like "**" where * is in the dictionary but not **, + "**" is not translated; otherwise said, to be translated, a sequence + must not be surrounded by other symbol-like chars + + - in a sequence like "<>_h*", where <>_h is in the dictionary, the + translation is done because the switch from a letter to a symbol char + is an acceptable cutting point + + - in a sequence like "<>_ha", where <>_h is in the dictionary, the + translation is not done because it is considered that h and a are + not separable (however, if h and a have different tags, and h has + the same tags as <, > and _, the translation happens) + + - in a sequence like "<>_ha", where <> but not <>_h is in the + dictionary, the translation is done for <> and _ha is considered + independently because the switch from a symbol char to a letter + is considered to be an acceptable cutting point + + - the longest-word rule applies: if both <> and <>_h are in the + dictionary, "<>_h" is one word and gets translated +*) + +(* Warning: do not output anything on output channel inbetween a call + to [output_tagged_*] and [flush_sublexer]!! *) + +type out_function = + bool (* needs escape *) -> + bool (* it is a symbol, not a pure ident *) -> + Index.index_entry option (* the index type of the token if any *) -> + string -> unit + +(* This must be initialized before calling the sublexer *) +val token_tree : ttree ref ref +val outfun : out_function ref + +(* Process an ident part that might be a symbol part *) +val output_tagged_ident_string : string -> unit + +(* Process a non-ident char (possibly equipped with a tag) *) +val output_tagged_symbol_char : Index.index_entry option -> char -> unit + +(* Flush the buffered content of the lexer using [outfun] *) +val flush_sublexer : unit -> unit diff --git a/tools/coqwc.mll b/tools/coqwc.mll index 81fe06cd..f3646a8a 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -9,12 +9,12 @@ (* coqwc - counts the lines of spec, proof and comments in Coq sources * Copyright (C) 2003 Jean-Christophe Filliâtre *) -(*i $Id: coqwc.mll 9691 2007-03-08 15:29:27Z msozeau $ i*) +(*i $Id$ i*) -(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. +(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. It assumes the files to be lexically well-formed. *) -(*i*){ +(*i*){ open Printf open Lexing open Filename @@ -40,8 +40,8 @@ let tplines = ref 0 let tdlines = ref 0 let update_totals () = - tslines := !tslines + !slines; - tplines := !tplines + !plines; + tslines := !tslines + !slines; + tplines := !tplines + !plines; tdlines := !tdlines + !dlines (*s The following booleans indicate whether we have seen spec, proof or @@ -53,12 +53,12 @@ let seen_proof = ref false let seen_comment = ref false let newline () = - if !seen_spec then incr slines; - if !seen_proof then incr plines; - if !seen_comment then incr dlines; + if !seen_spec then incr slines; + if !seen_proof then incr plines; + if !seen_comment then incr dlines; seen_spec := false; seen_proof := false; seen_comment := false -let reset_counters () = +let reset_counters () = seen_spec := false; seen_proof := false; seen_comment := false; slines := 0; plines := 0; dlines := 0 @@ -83,7 +83,7 @@ let print_totals () = print_line !tslines !tplines !tdlines (Some "total") (*i*)}(*i*) (*s Shortcuts for regular expressions. The [rcs] regular expression - is used to skip the CVS infos possibly contained in some comments, + is used to skip the CVS infos possibly contained in some comments, in order not to consider it as documentation. *) let space = [' ' '\t' '\r'] @@ -96,7 +96,7 @@ let rcs_keyword = let rcs = "\036" rcs_keyword [^ '$']* "\036" let stars = "(*" '*'* "*)" let dot = '.' (' ' | '\t' | '\n' | '\r' | eof) -let proof_start = +let proof_start = "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next" let proof_end = ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.' @@ -105,10 +105,10 @@ let proof_end = rule spec = parse | "(*" { comment lexbuf; spec lexbuf } - | '"' { let n = string lexbuf in slines := !slines + n; + | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec lexbuf } | '\n' { newline (); spec lexbuf } - | space+ | stars + | space+ | stars { spec lexbuf } | proof_start space { seen_spec := true; spec_to_dot lexbuf; proof lexbuf } @@ -118,7 +118,7 @@ rule spec = parse { seen_spec := true; definition lexbuf } | "Program"? "Fixpoint" space { seen_spec := true; definition lexbuf } - | character | _ + | character | _ { seen_spec := true; spec lexbuf } | eof { () } @@ -126,29 +126,29 @@ rule spec = parse and spec_to_dot = parse | "(*" { comment lexbuf; spec_to_dot lexbuf } - | '"' { let n = string lexbuf in slines := !slines + n; + | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec_to_dot lexbuf } | '\n' { newline (); spec_to_dot lexbuf } | dot { () } - | space+ | stars + | space+ | stars { spec_to_dot lexbuf } - | character | _ + | character | _ { seen_spec := true; spec_to_dot lexbuf } | eof { () } -(*s [definition] scans a definition; passes to [proof] is the body is +(*s [definition] scans a definition; passes to [proof] is the body is absent, and to [spec] otherwise *) and definition = parse | "(*" { comment lexbuf; definition lexbuf } - | '"' { let n = string lexbuf in slines := !slines + n; + | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; definition lexbuf } | '\n' { newline (); definition lexbuf } | ":=" { seen_spec := true; spec lexbuf } | dot { proof lexbuf } - | space+ | stars + | space+ | stars { definition lexbuf } - | character | _ + | character | _ { seen_spec := true; definition lexbuf } | eof { () } @@ -156,30 +156,30 @@ and definition = parse and proof = parse | "(*" { comment lexbuf; proof lexbuf } - | '"' { let n = string lexbuf in plines := !plines + n; + | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof lexbuf } - | space+ | stars + | space+ | stars { proof lexbuf } | '\n' { newline (); proof lexbuf } - | "Proof" space* '.' + | "Proof" space* '.' { seen_proof := true; proof lexbuf } | "Proof" space { proof_term lexbuf } | proof_end { seen_proof := true; spec lexbuf } - | character | _ + | character | _ { seen_proof := true; proof lexbuf } | eof { () } and proof_term = parse | "(*" { comment lexbuf; proof_term lexbuf } - | '"' { let n = string lexbuf in plines := !plines + n; + | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof_term lexbuf } - | space+ | stars + | space+ | stars { proof_term lexbuf } | '\n' { newline (); proof_term lexbuf } | dot { spec lexbuf } - | character | _ + | character | _ { seen_proof := true; proof_term lexbuf } | eof { () } @@ -188,12 +188,12 @@ and proof_term = parse and comment = parse | "(*" { comment lexbuf; comment lexbuf } | "*)" { () } - | '"' { let n = string lexbuf in dlines := !dlines + n; + | '"' { let n = string lexbuf in dlines := !dlines + n; seen_comment := true; comment lexbuf } | '\n' { newline (); comment lexbuf } | space+ | stars { comment lexbuf } - | character | _ + | character | _ { seen_comment := true; comment lexbuf } | eof { () } @@ -212,9 +212,9 @@ and string = parse It stops whenever it encounters an empty line or any character outside a comment. In this last case, it correctly resets the lexer position on that character (decreasing [lex_curr_pos] by 1). *) - + and read_header = parse - | "(*" { skip_comment lexbuf; skip_until_nl lexbuf; + | "(*" { skip_comment lexbuf; skip_until_nl lexbuf; read_header lexbuf } | "\n" { () } | space+ { read_header lexbuf } @@ -250,9 +250,9 @@ let process_file f = print_file (Some f); update_totals () with - | Sys_error "Is a directory" -> + | Sys_error "Is a directory" -> flush stdout; eprintf "coqwc: %s: Is a directory\n" f; flush stderr - | Sys_error s -> + | Sys_error s -> flush stdout; eprintf "coqwc: %s\n" s; flush stderr (*s Parsing of the command line. *) @@ -269,9 +269,9 @@ let usage () = let rec parse = function | [] -> [] | ("-h" | "-?" | "-help" | "--help") :: _ -> usage () - | ("-s" | "--spec-only") :: args -> + | ("-s" | "--spec-only") :: args -> proof_only := false; spec_only := true; parse args - | ("-r" | "--proof-only") :: args -> + | ("-r" | "--proof-only") :: args -> spec_only := false; proof_only := true; parse args | ("-p" | "--percentage") :: args -> percentage := true; parse args | ("-e" | "--header") :: args -> skip_header := false; parse args @@ -281,7 +281,7 @@ let rec parse = function let main () = let files = parse (List.tl (Array.to_list Sys.argv)) in - if not (!spec_only || !proof_only) then + if not (!spec_only || !proof_only) then printf " spec proof comments\n"; match files with | [] -> process_channel stdin; print_file None diff --git a/tools/gallina.ml b/tools/gallina.ml index a2c05c6d..8ba9ae10 100644 --- a/tools/gallina.ml +++ b/tools/gallina.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: gallina.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id$ *) open Gallina_lexer @@ -16,29 +16,29 @@ let option_moins = ref false let option_stdout = ref false -let traite_fichier f = - try - let chan_in = open_in (f^".v") in +let traite_fichier f = + try + let chan_in = open_in (f^".v") in let buf = Lexing.from_channel chan_in in if not !option_stdout then chan_out := open_out (f ^ ".g"); - try + try while true do Gallina_lexer.action buf done - with Fin_fichier -> begin + with Fin_fichier -> begin flush !chan_out; close_in chan_in; if not !option_stdout then close_out !chan_out end - with Sys_error _ -> - () + with Sys_error _ -> + () let traite_stdin () = try let buf = Lexing.from_channel stdin in - try + try while true do Gallina_lexer.action buf done - with Fin_fichier -> + with Fin_fichier -> flush !chan_out - with Sys_error _ -> + with Sys_error _ -> () let gallina () = @@ -52,7 +52,7 @@ let gallina () = | "-" -> option_moins := true | "-stdout" -> option_stdout := true | "-nocomments" -> comments := false - | f -> + | f -> if Filename.check_suffix f ".v" then vfiles := (Filename.chop_suffix f ".v") :: !vfiles in diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll index 7eaec2a8..6d35d839 100644 --- a/tools/gallina_lexer.mll +++ b/tools/gallina_lexer.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: gallina_lexer.mll 11301 2008-08-04 19:41:18Z herbelin $ *) +(* $Id$ *) { open Lexing @@ -17,7 +17,7 @@ let cRcpt = ref 0 let comments = ref true let print s = output_string !chan_out s - + exception Fin_fichier } @@ -26,17 +26,17 @@ let space = [' ' '\t' '\n' '\r'] let enddot = '.' (' ' | '\t' | '\n' | '\r' | eof) rule action = parse - | "Theorem" space { print "Theorem "; body lexbuf; + | "Theorem" space { print "Theorem "; body lexbuf; cRcpt := 1; action lexbuf } - | "Lemma" space { print "Lemma "; body lexbuf; + | "Lemma" space { print "Lemma "; body lexbuf; cRcpt := 1; action lexbuf } - | "Fact" space { print "Fact "; body lexbuf; + | "Fact" space { print "Fact "; body lexbuf; cRcpt := 1; action lexbuf } - | "Remark" space { print "Remark "; body lexbuf; + | "Remark" space { print "Remark "; body lexbuf; cRcpt := 1; action lexbuf } - | "Goal" space { print "Goal "; body lexbuf; + | "Goal" space { print "Goal "; body lexbuf; cRcpt := 1; action lexbuf } - | "Correctness" space { print "Correctness "; body_pgm lexbuf; + | "Correctness" space { print "Correctness "; body_pgm lexbuf; cRcpt := 1; action lexbuf } | "Definition" space { print "Definition "; body_def lexbuf; cRcpt := 1; action lexbuf } @@ -55,7 +55,7 @@ rule action = parse | _ { print (Lexing.lexeme lexbuf); cRcpt := 0; action lexbuf } and comment = parse - | "(*" { (if !comments then print "(*"); + | "(*" { (if !comments then print "(*"); comment_depth := succ !comment_depth; comment lexbuf } | "*)" { (if !comments then print "*)"); comment_depth := pred !comment_depth; @@ -63,15 +63,15 @@ and comment = parse | "*)" [' ''\t']*'\n' { (if !comments then print (Lexing.lexeme lexbuf)); comment_depth := pred !comment_depth; if !comment_depth > 0 then comment lexbuf } - | eof { raise Fin_fichier } - | _ { (if !comments then print (Lexing.lexeme lexbuf)); + | eof { raise Fin_fichier } + | _ { (if !comments then print (Lexing.lexeme lexbuf)); comment lexbuf } and skip_comment = parse | "(*" { comment_depth := succ !comment_depth; skip_comment lexbuf } | "*)" { comment_depth := pred !comment_depth; if !comment_depth > 0 then skip_comment lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { skip_comment lexbuf } and body_def = parse @@ -83,14 +83,14 @@ and body = parse | ":=" { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body lexbuf } and body_pgm = parse | enddot { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body_pgm lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body_pgm lexbuf } and skip_until_point = parse @@ -98,13 +98,13 @@ and skip_until_point = parse | enddot { end_of_line lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_until_point lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { skip_until_point lexbuf } and end_of_line = parse | [' ' '\t' ]* { end_of_line lexbuf } | '\n' { () } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf) } and skip_proof = parse @@ -124,5 +124,5 @@ and skip_proof = parse | "Proof" [' ' '\t']* '.' { skip_proof lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_proof lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { skip_proof lexbuf } -- cgit v1.2.3