summaryrefslogtreecommitdiff
path: root/ide
diff options
context:
space:
mode:
authorGravatar Enrico Tassi <gareuselesinge@debian.org>2015-01-25 14:42:51 +0100
committerGravatar Enrico Tassi <gareuselesinge@debian.org>2015-01-25 14:42:51 +0100
commit7cfc4e5146be5666419451bdd516f1f3f264d24a (patch)
treee4197645da03dc3c7cc84e434cc31d0a0cca7056 /ide
parent420f78b2caeaaddc6fe484565b2d0e49c66888e5 (diff)
Imported Upstream version 8.5~beta1+dfsg
Diffstat (limited to 'ide')
-rw-r--r--ide/.merlin6
-rw-r--r--ide/FAQ25
-rw-r--r--ide/MacOS/Info.plist.template89
-rw-r--r--ide/MacOS/coqfile.icnsbin0 -> 234599 bytes
-rw-r--r--ide/MacOS/coqide.icnsbin0 -> 326632 bytes
-rw-r--r--ide/MacOS/default_accel_map (renamed from ide/mac_default_accel_map)64
-rwxr-xr-xide/MacOS/relatify_with-respect-to_.sh15
-rw-r--r--ide/Make6
-rw-r--r--ide/command_windows.ml158
-rw-r--r--ide/config_lexer.mll9
-rw-r--r--ide/coq-ssreflect.lang246
-rw-r--r--ide/coq.lang216
-rw-r--r--ide/coq.ml462
-rw-r--r--ide/coq.mli195
-rw-r--r--ide/coq.pngbin6269 -> 71924 bytes
-rw-r--r--ide/coqOps.ml824
-rw-r--r--ide/coqOps.mli43
-rw-r--r--ide/coq_commands.ml6
-rw-r--r--ide/coq_lex.mll174
-rw-r--r--ide/coq_style.xml26
-rw-r--r--ide/coqide-gtk2rc39
-rw-r--r--ide/coqide.ml4100
-rw-r--r--ide/coqide.mli14
-rw-r--r--ide/coqide_main.ml4169
-rw-r--r--ide/coqide_ui.ml28
-rw-r--r--ide/coqidetop.mllib2
-rw-r--r--ide/document.ml186
-rw-r--r--ide/document.mli115
-rw-r--r--ide/fileOps.ml154
-rw-r--r--ide/fileOps.mli (renamed from ide/undo_lablgtk_lt26.mli)34
-rw-r--r--ide/gtk_parsing.ml33
-rw-r--r--ide/ide.mllib22
-rw-r--r--ide/ide_slave.ml505
-rw-r--r--ide/ide_win32_stubs.c44
-rw-r--r--ide/ideutils.ml541
-rw-r--r--ide/ideutils.mli91
-rw-r--r--ide/interface.mli242
-rw-r--r--ide/macos_prehook.ml37
-rw-r--r--ide/minilib.ml218
-rw-r--r--ide/minilib.mli44
-rw-r--r--ide/nanoPG.ml321
-rw-r--r--ide/preferences.ml389
-rw-r--r--ide/preferences.mli30
-rw-r--r--ide/project_file.ml4102
-rw-r--r--ide/sentence.ml126
-rw-r--r--ide/sentence.mli (renamed from ide/undo_lablgtk_ge26.mli)30
-rw-r--r--ide/session.ml517
-rw-r--r--ide/session.mli50
-rw-r--r--ide/tags.ml50
-rw-r--r--ide/tags.mli23
-rw-r--r--ide/undo.ml175
-rw-r--r--ide/undo_lablgtk_ge212.mli35
-rw-r--r--ide/utf8_convert.mll2
-rw-r--r--ide/utils/config_file.ml4
-rw-r--r--ide/utils/config_file.mli4
-rw-r--r--ide/utils/configwin_ihm.ml14
-rw-r--r--ide/utils/configwin_messages.ml2
-rw-r--r--ide/utils/configwin_types.ml6
-rw-r--r--ide/utils/editable_cells.ml1
-rw-r--r--ide/utils/okey.ml2
-rw-r--r--ide/wg_Command.ml166
-rw-r--r--ide/wg_Command.mli (renamed from ide/command_windows.mli)12
-rw-r--r--ide/wg_Completion.ml453
-rw-r--r--ide/wg_Completion.mli34
-rw-r--r--ide/wg_Detachable.ml89
-rw-r--r--ide/wg_Detachable.mli42
-rw-r--r--ide/wg_Find.ml199
-rw-r--r--ide/wg_Find.mli18
-rw-r--r--ide/wg_MessageView.ml63
-rw-r--r--ide/wg_MessageView.mli22
-rw-r--r--ide/wg_Notebook.ml (renamed from ide/typed_notebook.ml)16
-rw-r--r--ide/wg_Notebook.mli38
-rw-r--r--ide/wg_ProofView.ml (renamed from ide/ideproof.ml)81
-rw-r--r--ide/wg_ProofView.mli19
-rw-r--r--ide/wg_ScriptView.ml467
-rw-r--r--ide/wg_ScriptView.mli54
-rw-r--r--ide/wg_Segment.ml143
-rw-r--r--ide/wg_Segment.mli21
-rw-r--r--ide/xmlprotocol.ml737
-rw-r--r--ide/xmlprotocol.mli58
80 files changed, 9350 insertions, 4447 deletions
diff --git a/ide/.merlin b/ide/.merlin
new file mode 100644
index 00000000..3f3d9d27
--- /dev/null
+++ b/ide/.merlin
@@ -0,0 +1,6 @@
+PKG lablgtk2.sourceview2
+
+S utils
+B utils
+
+REC
diff --git a/ide/FAQ b/ide/FAQ
index f07f229f..07b81824 100644
--- a/ide/FAQ
+++ b/ide/FAQ
@@ -6,8 +6,8 @@ R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more i
Q1) How to enable Emacs keybindings?
R1: Insert
gtk-key-theme-name = "Emacs"
- in your "coqide-gtk2rc" file. It should be in $XDG_CONFIG_DIRS/coq dir.
- This is done by default.
+in your gtkrc file. The location of this file is system-dependent. If you're running
+Gnome, you may use the graphical configuration tools.
Q2) How to enable antialiased fonts?
R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2.
@@ -34,27 +34,14 @@ R5)-First solution : type "<CONTROL><SHIFT>2200" to enter a forall in the script
2200 is the hexadecimal code for forall in unicode charts and is encoded as "∀"
in UTF-8.
2203 is for exists. See http://www.unicode.org for more codes.
--Second solution : rebind "<AltGr>a" to forall and "<AltGr>e" to exists.
- Under X11, you need to use something like
- xmodmap -e "keycode 24 = a A F13 F13"
- xmodmap -e "keycode 26 = e E F14 F14"
- and then to add
- bind "F13" {"insert-at-cursor" ("∀")}
- bind "F14" {"insert-at-cursor" ("∃")}
- to your "binding "text"" section in coqiderc-gtk2rc.
- The strange ("∀") argument is the UTF-8 encoding for
- 0x2200.
- You can compute these encodings using the lablgtk2 toplevel with
- Glib.Utf8.from_unichar 0x2200;;
- Further symbols can be bound on higher Fxx keys or on even on other keys you
- do not need .
+-Second solution : Use an input method editor, such as SCIM or iBus. The latter offers
+a module for LaTeX-like inputting.
Q6) How to customize the shortcuts for menus?
R6) Two solutions are offered:
- Edit $XDG_CONFIG_HOME/coq/coqide.keys by hand or
- - Add "gtk-can-change-accels = 1" in your coqide-gtk2rc file. Then
- from CoqIde, you may select a menu entry and press the desired
- shortcut.
+ - If your system allows it, from CoqIde, you may select a menu entry and press the
+ desired shortcut.
Q7) What encoding should I use? What is this \x{iiii} in my file?
R7) The encoding option is related to the way files are saved.
diff --git a/ide/MacOS/Info.plist.template b/ide/MacOS/Info.plist.template
new file mode 100644
index 00000000..fd80c839
--- /dev/null
+++ b/ide/MacOS/Info.plist.template
@@ -0,0 +1,89 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>CFBundleDocumentTypes</key>
+ <array>
+ <dict>
+ <key>CFBundleTypeExtensions</key>
+ <array>
+ <string>*</string>
+ </array>
+ <key>CFBundleTypeName</key>
+ <string>NSStringPboardType</string>
+ <key>CFBundleTypeOSTypes</key>
+ <array>
+ <string>****</string>
+ </array>
+ <key>CFBundleTypeRole</key>
+ <string>Editor</string>
+ </dict>
+ <dict>
+ <key>CFBundleTypeIconFile</key>
+ <string>coqfile.icns</string>
+ <key>CFBundleTypeName</key>
+ <string>Coq file</string>
+ <key>CFBundleTypeRole</key>
+ <string>Editor</string>
+ <key>CFBundleTypeMIMETypes</key>
+ <array>
+ <string>text/plain</string>
+ </array>
+ <key>CFBundleTypeExtensions</key>
+ <array>
+ <string>v</string>
+ </array>
+ <key>LSHandlerRank</key>
+ <string>Owner</string>
+ </dict>
+ <dict>
+ <key>CFBundleTypeName</key>
+ <string>All</string>
+ <key>CFBundleTypeRole</key>
+ <string>Editor</string>
+ <key>CFBundleTypeMIMETypes</key>
+ <array>
+ <string>text/plain</string>
+ </array>
+ <key>LSHandlerRank</key>
+ <string>Default</string>
+ <key>CFBundleTypeExtensions</key>
+ <array>
+ <string>*</string>
+ </array>
+ </dict>
+ </array>
+ <key>CFBundleIconFile</key>
+ <string>coqide.icns</string>
+ <key>CFBundleVersion</key>
+ <string>390</string>
+ <key>CFBundleName</key>
+ <string>CoqIDE</string>
+ <key>CFBundleShortVersionString</key>
+ <string>VERSION</string>
+ <key>CFBundleDisplayName</key>
+ <string>Coq Proof Assistant vVERSION</string>
+ <key>CFBundleGetInfoString</key>
+ <string>Coq_vVERSION</string>
+ <key>NSHumanReadableCopyright</key>
+ <string>Copyright 1999-2014, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string>
+ <key>CFBundleHelpBookFolder</key>
+ <string>share/doc/coq/html/</string>
+ <key>CFAppleHelpAnchor</key>
+ <string>index</string>
+ <key>CFBundleExecutable</key>
+ <string>coqide</string>
+ <key>CFBundlePackageType</key>
+ <string>APPL</string>
+ <key>CFBundleInfoDictionaryVersion</key>
+ <string>6.0</string>
+ <key>CFBundleIdentifier</key>
+ <string>fr.inria.coq.coqide</string>
+ <key>LSApplicationCategoryType</key>
+ <string>public.app-category.developer-tools</string>
+ <key>CFBundleDevelopmentRegion</key>
+ <string>English</string>
+ <key>NSPrincipalClass</key>
+ <string>NSApplication</string>
+</dict>
+</plist>
diff --git a/ide/MacOS/coqfile.icns b/ide/MacOS/coqfile.icns
new file mode 100644
index 00000000..107e7043
--- /dev/null
+++ b/ide/MacOS/coqfile.icns
Binary files differ
diff --git a/ide/MacOS/coqide.icns b/ide/MacOS/coqide.icns
new file mode 100644
index 00000000..92bdfe77
--- /dev/null
+++ b/ide/MacOS/coqide.icns
Binary files differ
diff --git a/ide/mac_default_accel_map b/ide/MacOS/default_accel_map
index 636447e3..6f474eb1 100644
--- a/ide/mac_default_accel_map
+++ b/ide/MacOS/default_accel_map
@@ -22,10 +22,9 @@
(gtk_accel_path "<Actions>/Tactics/auto with *" "<Primary><Control>asterisk")
; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear" "")
; (gtk_accel_path "<Actions>/Templates/Template Implicit Arguments" "")
-(gtk_accel_path "<Actions>/Edit/Find backwards" "<Primary>b")
; (gtk_accel_path "<Actions>/Edit/Copy" "<Primary>c")
; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using" "")
-(gtk_accel_path "<Actions>/View/Previous tab" "<Control>Left")
+; (gtk_accel_path "<Actions>/View/Previous tab" "<Shift>Left")
; (gtk_accel_path "<Actions>/Tactics/Tactic change -- in" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic jp" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic red" "")
@@ -61,69 +60,73 @@
; (gtk_accel_path "<Actions>/Tactics/Tactic destruct" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic intro after" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic abstract" "")
+; (gtk_accel_path "<Actions>/Compile/Compile buffer" "")
; (gtk_accel_path "<Actions>/Queries/About" "F5")
; (gtk_accel_path "<Actions>/Templates/Template CoInductive" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing Wildcard" "")
; (gtk_accel_path "<Actions>/Templates/Template Unset Hyps--limit" "")
+; (gtk_accel_path "<Actions>/Templates/Template Transparent" "")
; (gtk_accel_path "<Actions>/Export/Ps" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic elim" "")
-; (gtk_accel_path "<Actions>/Templates/Template Transparent" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extract Constant" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:--)" "")
; (gtk_accel_path "<Actions>/Templates/Template Add Rec LoadPath" "")
-; (gtk_accel_path "<Actions>/Templates/Template Extract Constant" "")
+; (gtk_accel_path "<Actions>/Edit/Redo" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic compute" "")
; (gtk_accel_path "<Actions>/Compile/Next error" "F7")
; (gtk_accel_path "<Actions>/Templates/Template Add ML Path" "")
-; (gtk_accel_path "<Actions>/Templates/Template Test Printing Wildcard" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing If" "")
+; (gtk_accel_path "<Actions>/Templates/Template Load Verbose" "")
+; (gtk_accel_path "<Actions>/Templates/Template Reset Extraction Inline" "")
; (gtk_accel_path "<Actions>/Templates/Template Set Implicit Arguments" "")
; (gtk_accel_path "<Actions>/Templates/Template Test Printing Let" "")
; (gtk_accel_path "<Actions>/Windows/Windows" "")
; (gtk_accel_path "<Actions>/Templates/Template Defined." "")
(gtk_accel_path "<Actions>/Templates/match" "<Shift><Primary>c")
; (gtk_accel_path "<Actions>/Tactics/Tactic set (--:=--)" "")
-; (gtk_accel_path "<Actions>/Templates/Template Test Printing If" "")
+; (gtk_accel_path "<Actions>/Templates/Template Proof." "")
; (gtk_accel_path "<Actions>/Compile/Make" "F6")
; (gtk_accel_path "<Actions>/Templates/Template Module Type" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic apply -- with" "")
; (gtk_accel_path "<Actions>/File/Save as" "")
-; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "")
; (gtk_accel_path "<Actions>/Templates/Template Set Hyps--limit" "")
; (gtk_accel_path "<Actions>/Templates/Template Global Variable" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic trivial" "")
+; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "")
; (gtk_accel_path "<Actions>/Templates/Template Add Setoid" "")
-; (gtk_accel_path "<Actions>/Templates/Template Proof." "")
-; (gtk_accel_path "<Actions>/Templates/Template Load Verbose" "")
-; (gtk_accel_path "<Actions>/Compile/Compile buffer" "")
+; (gtk_accel_path "<Actions>/Edit/Find Next" "F3")
+; (gtk_accel_path "<Actions>/Edit/Find" "<Primary>f")
+; (gtk_accel_path "<Actions>/Templates/Template Add Relation" "")
; (gtk_accel_path "<Actions>/Queries/Print" "F4")
; (gtk_accel_path "<Actions>/Templates/Template Obligations Tactic" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic trivial" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic first" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic case" "")
; (gtk_accel_path "<Actions>/Templates/Template Hint Constructors" "")
; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T." "")
; (gtk_accel_path "<Actions>/Templates/Template Coercion Local" "")
-; (gtk_accel_path "<Actions>/View/Show Query Pane" "Escape")
-; (gtk_accel_path "<Actions>/Templates/Template Add Relation" "")
+(gtk_accel_path "<Actions>/View/Show Query Pane" "<Control>Escape")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear -- in" "")
-; (gtk_accel_path "<Actions>/Templates/Template Definition" "")
; (gtk_accel_path "<Actions>/Templates/Template Add Rec ML Path" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic apply" "")
; (gtk_accel_path "<Actions>/Export/Latex" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using -- in" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic generalize" "")
-; (gtk_accel_path "<Actions>/Templates/Template Reset Extraction Inline" "")
+(gtk_accel_path "<Actions>/Navigation/Backward" "<Primary><Control>Up")
+; (gtk_accel_path "<Actions>/Tactics/Tactic p" "")
(gtk_accel_path "<Actions>/Navigation/Hide" "<Primary><Control>h")
; (gtk_accel_path "<Actions>/File/Close buffer" "<Primary>w")
; (gtk_accel_path "<Actions>/Tactics/Tactic induction" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic eauto with" "")
(gtk_accel_path "<Actions>/View/Display raw matching expressions" "<Shift><Control>m")
-(gtk_accel_path "<Actions>/Navigation/Backward" "<Primary><Control>Up")
+; (gtk_accel_path "<Actions>/Tactics/Tactic d" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic u" "")
; (gtk_accel_path "<Actions>/Templates/Templates" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic p" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic s" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic lapply" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic t" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic s" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic r" "")
+; (gtk_accel_path "<Actions>/Edit/Replace" "<Primary>r")
; (gtk_accel_path "<Actions>/Tactics/Tactic case -- with" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic eexact" "")
; (gtk_accel_path "<Actions>/Queries/Check" "F3")
@@ -133,10 +136,10 @@
; (gtk_accel_path "<Actions>/Tactics/Tactic intro" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic j" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic i" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic e" "")
+; (gtk_accel_path "<Actions>/Templates/Template Definition" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic g" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic f" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic d" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic e" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic c" "")
(gtk_accel_path "<Actions>/File/Rehighlight" "<Primary>l")
; (gtk_accel_path "<Actions>/Tactics/Tactic simple inversion" "")
@@ -179,10 +182,9 @@
; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry in" "")
; (gtk_accel_path "<Actions>/Help/Help" "")
(gtk_accel_path "<Actions>/Templates/Inductive" "<Shift><Primary>i")
-; (gtk_accel_path "<Actions>/Edit/Clear Undo Stack" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "")
-; (gtk_accel_path "<Actions>/Templates/Template Syntax" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic idtac" "")
+; (gtk_accel_path "<Actions>/Templates/Template Syntax" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic fold -- in" "")
; (gtk_accel_path "<Actions>/Templates/Template Program Definition" "")
(gtk_accel_path "<Actions>/Tactics/Wizard" "<Primary><Control>dollar")
@@ -242,20 +244,20 @@
; (gtk_accel_path "<Actions>/Templates/Template Notation" "")
; (gtk_accel_path "<Actions>/Edit/Cut" "<Primary>x")
; (gtk_accel_path "<Actions>/Templates/Template Theorem" "")
-; (gtk_accel_path "<Actions>/Templates/Template Unset Printing Wildcard" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic constructor" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "")
; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "")
; (gtk_accel_path "<Actions>/Queries/Whelp Locate" "")
(gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l")
; (gtk_accel_path "<Actions>/Tactics/Tactic right" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "")
+; (gtk_accel_path "<Actions>/Edit/Find Previous" "<Shift>F3")
; (gtk_accel_path "<Actions>/Tactics/Tactic cofix" "")
; (gtk_accel_path "<Actions>/Templates/Template Restore State" "")
; (gtk_accel_path "<Actions>/Templates/Template Lemma" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic refine" "")
; (gtk_accel_path "<Actions>/Templates/Template Section" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:=--)" "")
-; (gtk_accel_path "<Actions>/Edit/Find in buffer" "<Primary>f")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Printing Wildcard" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic progress" "")
; (gtk_accel_path "<Actions>/Templates/Template Add Printing If" "")
; (gtk_accel_path "<Actions>/Templates/Template Chapter" "")
@@ -285,8 +287,8 @@
; (gtk_accel_path "<Actions>/Templates/Template Set Extraction AutoInline" "")
; (gtk_accel_path "<Actions>/Templates/Template Unset Undo" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion" "")
-; (gtk_accel_path "<Actions>/Templates/Template Add Field" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--rewrite" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Field" "")
; (gtk_accel_path "<Actions>/Templates/Template Require Export" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <-" "")
(gtk_accel_path "<Actions>/Tactics/omega" "<Primary><Control>o")
@@ -348,15 +350,15 @@
; (gtk_accel_path "<Actions>/Tactics/Tactic set" "")
; (gtk_accel_path "<Actions>/Edit/External editor" "")
; (gtk_accel_path "<Actions>/View/Show Toolbar" "")
-(gtk_accel_path "<Actions>/Edit/Complete Word" "<Primary>slash")
; (gtk_accel_path "<Actions>/Tactics/Tactic try" "")
-(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Primary>f")
; (gtk_accel_path "<Actions>/Tactics/Tactic discriminate" "")
+(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Primary>f")
+(gtk_accel_path "<Actions>/Edit/Complete Word" "<Primary>slash")
(gtk_accel_path "<Actions>/Navigation/Next" "<Primary><Control>greater")
; (gtk_accel_path "<Actions>/Tactics/Tactic elimtype" "")
; (gtk_accel_path "<Actions>/Templates/Template End" "")
; (gtk_accel_path "<Actions>/Templates/Template Fixpoint" "")
-(gtk_accel_path "<Actions>/View/Next tab" "<Control>Right")
+; (gtk_accel_path "<Actions>/View/Next tab" "<Shift>Right")
; (gtk_accel_path "<Actions>/File/File" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--replace" "")
; (gtk_accel_path "<Actions>/Tactics/Tactic generalize dependent" "")
diff --git a/ide/MacOS/relatify_with-respect-to_.sh b/ide/MacOS/relatify_with-respect-to_.sh
new file mode 100755
index 00000000..a24af939
--- /dev/null
+++ b/ide/MacOS/relatify_with-respect-to_.sh
@@ -0,0 +1,15 @@
+#!/bin/sh
+
+set -e
+
+for i in "$3/"*.dylib
+do install_name_tool -change "$2"/$(basename $i) @executable_path/../Resources/lib/$(basename $i) "$1"
+done
+case "$1" in
+ *.dylib)
+ install_name_tool -id @executable_path/../Resources/lib/$(basename $1) $1
+ for i in "$3"/*.dylib
+ do install_name_tool -change "$2/"$(basename $1) @executable_path/../Resources/lib/$(basename $1) $i
+ done;;
+ *)
+esac
diff --git a/ide/Make b/ide/Make
new file mode 100644
index 00000000..c0881ca3
--- /dev/null
+++ b/ide/Make
@@ -0,0 +1,6 @@
+interface.mli
+xmlprotocol.mli
+xmlprotocol.ml
+ide_slave.ml
+
+coqidetop.mllib
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
deleted file mode 100644
index 67b09656..00000000
--- a/ide/command_windows.ml
+++ /dev/null
@@ -1,158 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-class command_window coqtop current =
-(* let window = GWindow.window
- ~allow_grow:true ~allow_shrink:true
- ~width:500 ~height:250
- ~position:`CENTER
- ~title:"CoqIde queries" ~show:false ()
- in *)
- let views = ref [] in
- let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in
- let _ = frame#misc#hide () in
- let _ = GtkData.AccelGroup.create () in
- let hbox = GPack.hbox ~homogeneous:false ~packing:frame#add () in
- let toolbar = GButton.toolbar
- ~orientation:`VERTICAL
- ~style:`ICONS
- ~tooltips:true
- ~packing:(hbox#pack
- ~expand:false
- ~fill:false)
- ()
- in
- let notebook = GPack.notebook ~scrollable:true
- ~packing:(hbox#pack
- ~expand:true
- ~fill:true
- )
- ()
- in
- let _ =
- toolbar#insert_button
- ~tooltip:"Hide Commands Pane"
- ~text:"Hide Pane"
- ~icon:(Ideutils.stock_to_widget `CLOSE)
- ~callback:frame#misc#hide
- ()
- in
- let new_page_menu =
- toolbar#insert_button
- ~tooltip:"New Page"
- ~text:"New Page"
- ~icon:(Ideutils.stock_to_widget `NEW)
- ()
- in
-
- let remove_cb () =
- let index = notebook#current_page in
- let () = notebook#remove_page index in
- views := Minilib.list_filter_i (fun i x -> i <> index) !views
- in
- let _ =
- toolbar#insert_button
- ~tooltip:"Delete Page"
- ~text:"Delete Page"
- ~icon:(Ideutils.stock_to_widget `DELETE)
- ~callback:remove_cb
- ()
- in
-object(self)
- val frame = frame
-
-
- val new_page_menu = new_page_menu
- val notebook = notebook
-
- method frame = frame
- method new_command ?command ?term () =
- let frame = GBin.frame
- ~shadow_type:`ETCHED_OUT
- ()
- in
- let _ = notebook#append_page frame#coerce in
- notebook#goto_page (notebook#page_num frame#coerce);
- let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
- let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
- let (combo,_) = GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving
- ~packing:hbox#pack
- ()
- in
- let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) () in
- entry#misc#set_can_default true;
- let r_bin =
- GBin.scrolled_window
- ~vpolicy:`AUTOMATIC
- ~hpolicy:`AUTOMATIC
- ~packing:(vbox#pack ~fill:true ~expand:true) () in
- let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in
- let result = GText.view ~packing:r_bin#add () in
- let () = views := !views @ [result] in
- result#misc#modify_font !current.Preferences.text_font;
- let clr = Tags.color_of_string !current.Preferences.background_color in
- result#misc#modify_base [`NORMAL, `COLOR clr];
- result#misc#set_can_focus true; (* false causes problems for selection *)
- result#set_editable false;
- let on_activate c () =
- if List.mem combo#entry#text Coq_commands.state_preserving then c ()
- else result#buffer#set_text "Error: Not a state preserving command"
- in
- let callback () =
- let com = combo#entry#text in
- let phrase =
- if String.get com (String.length com - 1) = '.'
- then com ^ " " else com ^ " " ^ entry#text ^" . "
- in
- try
- result#buffer#set_text
- (match Coq.interp !coqtop ~raw:true 0 phrase with
- | Interface.Fail (l,str) ->
- ("Error while interpreting "^phrase^":\n"^str)
- | Interface.Good results ->
- ("Result for command " ^ phrase ^ ":\n" ^ results))
- with e ->
- let s = Printexc.to_string e in
- assert (Glib.Utf8.validate s);
- result#buffer#set_text s
- in
- ignore (combo#entry#connect#activate ~callback:(on_activate callback));
- ignore (ok_b#connect#clicked ~callback:(on_activate callback));
-
- begin match command,term with
- | None,None -> ()
- | Some c, None ->
- combo#entry#set_text c;
-
- | Some c, Some t ->
- combo#entry#set_text c;
- entry#set_text t
-
- | None , Some t ->
- entry#set_text t
- end;
- on_activate callback ();
- entry#misc#grab_focus ();
- entry#misc#grab_default ();
- ignore (entry#connect#activate ~callback);
- ignore (combo#entry#connect#activate ~callback);
- self#frame#misc#show ()
-
- method refresh_font () =
- let iter view = view#misc#modify_font !current.Preferences.text_font in
- List.iter iter !views
-
- method refresh_color () =
- let clr = Tags.color_of_string !current.Preferences.background_color in
- let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in
- List.iter iter !views
-
- initializer
- ignore (new_page_menu#connect#clicked ~callback:self#new_command);
- (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*)
-end
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
index aafc90f4..87cc6d06 100644
--- a/ide/config_lexer.mll
+++ b/ide/config_lexer.mll
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -10,7 +10,6 @@
open Lexing
open Format
- open Minilib
let string_buffer = Buffer.create 1024
@@ -23,7 +22,7 @@ let ignore = space | ('#' [^ '\n']*)
rule prefs m = parse
|ignore* (ident as id) ignore* '=' { let conf = str_list [] lexbuf in
- prefs (Stringmap.add id conf m) lexbuf }
+ prefs (Util.String.Map.add id conf m) lexbuf }
| _ { let c = lexeme_start lexbuf in
eprintf "coqiderc: invalid character (%d)\n@." c;
prefs m lexbuf }
@@ -48,7 +47,7 @@ and string = parse
let load_file f =
let c = open_in f in
let lb = from_channel c in
- let m = prefs Stringmap.empty lb in
+ let m = prefs Util.String.Map.empty lb in
close_in c;
m
@@ -59,7 +58,7 @@ and string = parse
| [] -> ()
| s :: sl -> fprintf fmt "%S@ %a" s print_list sl
in
- Stringmap.iter
+ Util.String.Map.iter
(fun k s -> fprintf fmt "@[<hov 2>%s = %a@]@\n" k print_list s) m;
fprintf fmt "@.";
close_out c
diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang
new file mode 100644
index 00000000..4c488ae8
--- /dev/null
+++ b/ide/coq-ssreflect.lang
@@ -0,0 +1,246 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<language id="coq-ssreflect" _name="Coq + Ssreflect" version="2.0" _section="Scientific">
+ <metadata>
+ <property name="globs">*.v</property>
+ <property name="block-comment-start">\(\*</property>
+ <property name="block-comment-stop">\*\)</property>
+ </metadata>
+
+ <styles>
+ <style id="comment" _name="Comment" map-to="def:comment"/>
+ <style id="coqdoc" _name="Coqdoc text" map-to="def:note"/>
+ <style id="vernac-keyword" _name="Vernacular keyword" map-to="def:keyword"/>
+ <style id="gallina-keyword" _name="Gallina keyword" map-to="def:keyword"/>
+ <style id="identifier" _name="Identifier" map-to="def:identifier"/>
+ <style id="constr-keyword" _name="Cic keyword" map-to="def:keyword"/>
+ <style id="constr-sort" _name="Cic sort" map-to="def:builtin"/>
+ <style id="string" _name="String" map-to="def:string"/>
+ <style id="escape" _name="Escaped Character" map-to="def:special-char"/>
+ <style id="error" _name="Error" map-to="def:error"/>
+ <style id="safe" _name="Checked Part"/>
+ <style id="sentence" _name="Sentence terminator"/>
+ <style id="tactic" _name="Tactic"/>
+ <style id="endtactic" _name="Tactic terminator"/>
+ <style id="iterator" _name="Tactic iterator"/>
+ </styles>
+
+ <definitions>
+ <define-regex id="space">\s</define-regex>
+ <define-regex id="first_ident_char">[_\p{L}]</define-regex>
+ <define-regex id="ident_char">[_\p{L}'\pN]</define-regex>
+ <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex>
+ <define-regex id="qualit">(\%{ident}*\.)*\%{ident}</define-regex>
+ <define-regex id="undotted_sep">[-+*{}]</define-regex>
+ <define-regex id="dot_sep">\.(\s|\z)</define-regex>
+ <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)|(Canonical)|(Coercion)</define-regex>
+ <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex>
+ <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex>
+ <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex>
+ <define-regex id="end_proof">(Qed)|(Defined)|(Admitted)|(Abort)</define-regex>
+ <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space}+)?(\%{single_decl}|\%{begin_proof}))\%{space}+(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}+\%{ident})*))</define-regex>
+
+ <context id="escape-seq" style-ref="escape">
+ <match>""</match>
+ </context>
+ <context id="string" style-ref="string">
+ <start>"</start>
+ <end>"</end>
+ <include>
+ <context ref="escape-seq"/>
+ </include>
+ </context>
+ <context id="ssr-iter" style-ref="iterator">
+ <keyword>do</keyword>
+ <keyword>last</keyword>
+ <keyword>first</keyword>
+ </context>
+ <context id="ssr-tac" style-ref="tactic">
+ <keyword>apply</keyword>
+ <keyword>auto</keyword>
+ <keyword>case</keyword>
+ <keyword>case</keyword>
+ <keyword>congr</keyword>
+ <keyword>elim</keyword>
+ <keyword>exists</keyword>
+ <keyword>have</keyword>
+ <keyword>gen have</keyword>
+ <keyword>generally have</keyword>
+ <keyword>move</keyword>
+ <keyword>pose</keyword>
+ <keyword>rewrite</keyword>
+ <keyword>set</keyword>
+ <keyword>split</keyword>
+ <keyword>suffices</keyword>
+ <keyword>suff</keyword>
+ <keyword>transitivity</keyword>
+ <keyword>without loss</keyword>
+ <keyword>wlog</keyword>
+ </context>
+ <context id="ssr-endtac" style-ref="endtactic">
+ <keyword>by</keyword>
+ <keyword>exact</keyword>
+ <keyword>reflexivity</keyword>
+ </context>
+ <context id="coq-ssreflect" class="no-spell-check">
+ <include>
+ <context ref="string"/>
+ <context id="coqdoc" style-ref="coqdoc" class-disabled="no-spell-check">
+ <start>\(\*\*(\s|\z)</start>
+ <end>\*\)</end>
+ <include>
+ <context ref="comment-in-comment"/>
+ <context ref="string"/>
+ <context ref="escape-seq"/>
+ </include>
+ </context>
+ <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+ <start>\(\*</start>
+ <end>\*\)</end>
+ <include>
+ <context id="comment-in-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+ <start>\(\*</start>
+ <end>\*\)</end>
+ <include>
+ <context ref="comment-in-comment"/>
+ <context ref="string"/>
+ <context ref="escape-seq"/>
+ </include>
+ </context>
+ <context ref="string"/>
+ <context ref="escape-seq"/>
+ </include>
+ </context>
+ <context id="declaration">
+ <start>\%{decl_head}</start>
+ <end>\%{dot_sep}</end>
+ <include>
+ <context sub-pattern="id" where="start" style-ref="identifier"/>
+ <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/>
+ <context sub-pattern="id_list" where="start" style-ref="identifier"/>
+ <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/>
+ <context id="constr-keyword" style-ref="constr-keyword">
+ <keyword>forall</keyword>
+ <keyword>fun</keyword>
+ <keyword>match</keyword>
+ <keyword>fix</keyword>
+ <keyword>cofix</keyword>
+ <keyword>with</keyword>
+ <keyword>for</keyword>
+ <keyword>end</keyword>
+ <keyword>as</keyword>
+ <keyword>let</keyword>
+ <keyword>in</keyword>
+ <keyword>if</keyword>
+ <keyword>then</keyword>
+ <keyword>else</keyword>
+ <keyword>return</keyword>
+ <keyword>using</keyword>
+ </context>
+ <context id="constr-sort" style-ref="constr-sort">
+ <keyword>Prop</keyword>
+ <keyword>Set</keyword>
+ <keyword>Type</keyword>
+ </context>
+ <context id="dot-nosep">
+ <match>\.\.</match>
+ </context>
+ <context ref="comment"/>
+ <context ref="string"/>
+ <context ref="coqdoc"/>
+ </include>
+ </context>
+ <context id="proof">
+ <start>Proof</start>
+ <end>\%{end_proof}\%{dot_sep}</end>
+ <include>
+ <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
+ <context sub-pattern="0" where="end" style-ref="vernac-keyword"/>
+ <context ref="command"/>
+ <context ref="scope-command"/>
+ <context ref="hint-command"/>
+ <context ref="command-for-qualit"/>
+ <context ref="declaration"/>
+ <context ref="comment"/>
+ <context ref="string"/>
+ <context ref="coqdoc"/>
+ <context ref="proof"/>
+ <context ref="undotted-sep"/>
+ <context id="tactic" extend-parent="false">
+ <start></start>
+ <end>\%{dot_sep}</end>
+ <include>
+ <context ref="ssr-tac"/>
+ <context ref="ssr-endtac"/>
+ <context ref="ssr-iter"/>
+ <context ref="dot-nosep"/>
+ <context ref="constr-keyword"/>
+ <context ref="constr-sort"/>
+ <context ref="comment"/>
+ <context ref="string"/>
+ </include>
+ </context>
+ </include>
+ </context>
+ <context id="undotted-sep" style-ref="vernac-keyword">
+ <match>\%{undotted_sep}</match>
+ </context>
+ <context id="command" style-ref="vernac-keyword">
+ <keyword>Add</keyword>
+ <keyword>Check</keyword>
+ <keyword>Eval</keyword>
+ <keyword>Load</keyword>
+ <keyword>Undo</keyword>
+ <keyword>Goal</keyword>
+ <keyword>Print</keyword>
+ <keyword>Save</keyword>
+ <keyword>Comments</keyword>
+ <keyword>Solve\%{space}+Obligation</keyword>
+ <keyword>((Uns)|(S))et(\%{space}+\%{ident})+</keyword>
+ <keyword>(\%{locality}|((Reserved)|(Tactic))\%{space}+)?Notation</keyword>
+ <keyword>\%{locality}Infix</keyword>
+ <keyword>(Print)|(Reset)\%{space}+Extraction\%{space}+(Inline)|(Blacklist)</keyword>
+ </context>
+ <context id="hint-command" style-ref="vernac-keyword">
+ <prefix>\%{locality}Hint\%{space}+</prefix>
+ <keyword>Resolve</keyword>
+ <keyword>Immediate</keyword>
+ <keyword>Constructors</keyword>
+ <keyword>unfold</keyword>
+ <keyword>Opaque</keyword>
+ <keyword>Transparent</keyword>
+ <keyword>Extern</keyword>
+ </context>
+ <context id="scope-command" style-ref="vernac-keyword">
+ <suffix>\%{space}+Scope</suffix>
+ <keyword>\%{locality}Open</keyword>
+ <keyword>\%{locality}Close</keyword>
+ <keyword>Bind</keyword>
+ <keyword>Delimit</keyword>
+ </context>
+ <context id="command-for-qualit">
+ <suffix>\%{space}+(?'qua'\%{qualit})</suffix>
+ <keyword>Chapter</keyword>
+ <keyword>Combined\%{space}+Scheme</keyword>
+ <keyword>End</keyword>
+ <keyword>Section</keyword>
+ <keyword>Arguments</keyword>
+ <keyword>Implicit\%{space}+Arguments</keyword>
+ <keyword>(Import)|(Include)</keyword>
+ <keyword>Require(\%{space}+((Import)|(Export)))?</keyword>
+ <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword>
+ <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword>
+ <include>
+ <context sub-pattern="1" style-ref="vernac-keyword"/>
+ </include>
+ </context>
+ <context id="command-for-qualit-list" style-ref="vernac-keyword">
+ <suffix>(?'qua_list'(\%{space}+\%{qualit})+)</suffix>
+ <keyword>Typeclasses (Transparent)|(Opaque)</keyword>
+ <include>
+ <context sub-pattern="qua_list" style-ref="identifier"/>
+ </include>
+ </context>
+ </include>
+ </context>
+ </definitions>
+</language>
diff --git a/ide/coq.lang b/ide/coq.lang
new file mode 100644
index 00000000..608a4aea
--- /dev/null
+++ b/ide/coq.lang
@@ -0,0 +1,216 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<language id="coq" _name="Coq" version="2.0" _section="Scientific">
+ <metadata>
+ <property name="globs">*.v</property>
+ <property name="block-comment-start">\(\*</property>
+ <property name="block-comment-stop">\*\)</property>
+ </metadata>
+
+ <styles>
+ <style id="comment" _name="Comment" map-to="def:comment"/>
+ <style id="coqdoc" _name="Coqdoc text" map-to="def:note"/>
+ <style id="vernac-keyword" _name="Vernacular keyword" map-to="def:keyword"/>
+ <style id="gallina-keyword" _name="Gallina keyword" map-to="def:keyword"/>
+ <style id="identifier" _name="Identifier" map-to="def:identifier"/>
+ <style id="constr-keyword" _name="Cic keyword" map-to="def:keyword"/>
+ <style id="constr-sort" _name="Cic sort" map-to="def:builtin"/>
+ <style id="string" _name="String" map-to="def:string"/>
+ <style id="escape" _name="Escaped Character" map-to="def:special-char"/>
+ <style id="error" _name="Error" map-to="def:error"/>
+ <style id="safe" _name="Checked Part"/>
+ <style id="sentence" _name="Sentence terminator"/>
+ </styles>
+
+ <definitions>
+ <define-regex id="space">\s</define-regex>
+ <define-regex id="first_ident_char">[_\p{L}]</define-regex>
+ <define-regex id="ident_char">[_\p{L}'\pN]</define-regex>
+ <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex>
+ <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex>
+ <define-regex id="undotted_sep">[-+*{}]</define-regex>
+ <define-regex id="dot_sep">\.(\s|\z)</define-regex>
+ <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)</define-regex>
+ <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex>
+ <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex>
+ <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex>
+ <define-regex id="end_proof">(Qed)|(Defined)|(Admitted)|(Abort)</define-regex>
+ <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space}+)?(\%{single_decl}|\%{begin_proof}))\%{space}+(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}+\%{ident})*))|(?'gal2'Goal)</define-regex>
+
+ <context id="escape-seq" style-ref="escape">
+ <match>""</match>
+ </context>
+ <context id="string" style-ref="string">
+ <start>"</start>
+ <end>"</end>
+ <include>
+ <context ref="escape-seq"/>
+ </include>
+ </context>
+ <context id="coq" class="no-spell-check">
+ <include>
+ <context ref="string"/>
+ <context id="coqdoc" style-ref="coqdoc" class-disabled="no-spell-check">
+ <start>\(\*\*(\s|\z)</start>
+ <end>\*\)</end>
+ <include>
+ <context ref="comment-in-comment"/>
+ <context ref="string"/>
+ </include>
+ </context>
+ <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+ <start>\(\*</start>
+ <end>\*\)</end>
+ <include>
+ <context id="comment-in-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+ <start>\(\*</start>
+ <end>\*\)</end>
+ <include>
+ <context ref="comment-in-comment"/>
+ <context ref="string"/>
+ </include>
+ </context>
+ <context ref="string"/>
+ </include>
+ </context>
+ <context id="declaration">
+ <start>\%{decl_head}</start>
+ <end>\%{dot_sep}</end>
+ <include>
+ <context sub-pattern="id" where="start" style-ref="identifier"/>
+ <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/>
+ <context sub-pattern="gal2" where="start" style-ref="gallina-keyword"/>
+ <context sub-pattern="id_list" where="start" style-ref="identifier"/>
+ <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/>
+ <context id="constr-keyword" style-ref="constr-keyword">
+ <keyword>forall</keyword>
+ <keyword>fun</keyword>
+ <keyword>match</keyword>
+ <keyword>fix</keyword>
+ <keyword>cofix</keyword>
+ <keyword>with</keyword>
+ <keyword>for</keyword>
+ <keyword>end</keyword>
+ <keyword>as</keyword>
+ <keyword>let</keyword>
+ <keyword>in</keyword>
+ <keyword>if</keyword>
+ <keyword>then</keyword>
+ <keyword>else</keyword>
+ <keyword>return</keyword>
+ <keyword>using</keyword>
+ </context>
+ <context id="constr-sort" style-ref="constr-sort">
+ <keyword>Prop</keyword>
+ <keyword>Set</keyword>
+ <keyword>Type</keyword>
+ </context>
+ <context id="dot-nosep">
+ <match>\.\.</match>
+ </context>
+ <context ref="comment"/>
+ <context ref="string"/>
+ <context ref="coqdoc"/>
+ </include>
+ </context>
+ <context id="proof">
+ <start>Proof(\%{dot_sep}|\%{space}+(using)|\%{space}+(with))</start>
+ <end>\%{end_proof}\%{dot_sep}</end>
+ <include>
+ <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
+ <context sub-pattern="0" where="end" style-ref="vernac-keyword"/>
+ <context ref="command"/>
+ <context ref="scope-command"/>
+ <context ref="hint-command"/>
+ <context ref="command-for-qualit"/>
+ <context ref="declaration"/>
+ <context ref="comment"/>
+ <context ref="string"/>
+ <context ref="coqdoc"/>
+ <context ref="proof"/>
+ <context ref="undotted-sep"/>
+ <context id="tactic" extend-parent="false">
+ <start>\b[^-+*{}]</start>
+ <end>\%{dot_sep}</end>
+ <include>
+ <context ref="dot-nosep"/>
+ <context ref="constr-keyword"/>
+ <context ref="constr-sort"/>
+ </include>
+ </context>
+ </include>
+ </context>
+ <context id="exact-proof">
+ <start>Proof</start>
+ <end>\%{dot_sep}</end>
+ <include>
+ <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
+ <context ref="constr-keyword"/>
+ <context ref="constr-sort"/>
+ </include>
+ </context>
+ <context id="undotted-sep" style-ref="vernac-keyword">
+ <match>\%{undotted_sep}</match>
+ </context>
+ <context id="command" style-ref="vernac-keyword">
+ <keyword>Add</keyword>
+ <keyword>Check</keyword>
+ <keyword>Eval</keyword>
+ <keyword>Load</keyword>
+ <keyword>Undo</keyword>
+ <keyword>Print</keyword>
+ <keyword>Save</keyword>
+ <keyword>Comments</keyword>
+ <keyword>Solve\%{space}+Obligation</keyword>
+ <keyword>((Uns)|(S))et(\%{space}+\%{ident})+</keyword>
+ <keyword>(\%{locality}|((Reserved)|(Tactic))\%{space}+)?Notation</keyword>
+ <keyword>\%{locality}Infix</keyword>
+ <keyword>(Print)|(Reset)\%{space}+Extraction\%{space}+(Inline)|(Blacklist)</keyword>
+ </context>
+ <context id="hint-command" style-ref="vernac-keyword">
+ <prefix>\%{locality}Hint\%{space}+</prefix>
+ <keyword>Resolve</keyword>
+ <keyword>Immediate</keyword>
+ <keyword>Constructors</keyword>
+ <keyword>Unfold</keyword>
+ <keyword>Opaque</keyword>
+ <keyword>Transparent</keyword>
+ <keyword>Extern</keyword>
+ <keyword>Rewrite</keyword>
+ </context>
+ <context id="scope-command" style-ref="vernac-keyword">
+ <suffix>\%{space}+Scope</suffix>
+ <keyword>\%{locality}Open</keyword>
+ <keyword>\%{locality}Close</keyword>
+ <keyword>Bind</keyword>
+ <keyword>Delimit</keyword>
+ </context>
+ <context id="command-for-qualit">
+ <suffix>\%{space}+(?'qua'\%{qualit})</suffix>
+ <keyword>Chapter</keyword>
+ <keyword>Combined\%{space}+Scheme</keyword>
+ <keyword>End</keyword>
+ <keyword>Section</keyword>
+ <keyword>Arguments</keyword>
+ <keyword>Implicit\%{space}+Arguments</keyword>
+ <keyword>Import</keyword>
+ <keyword>Include</keyword>
+ <keyword>Export</keyword>
+ <keyword>Require(\%{space}+((Import)|(Export)))?</keyword>
+ <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword>
+ <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword>
+ <include>
+ <context sub-pattern="1" style-ref="vernac-keyword"/>
+ <context sub-pattern="qua" style-ref="identifier"/>
+ </include>
+ </context>
+ <context id="command-for-qualit-list" style-ref="vernac-keyword">
+ <suffix>(?'qua_list'(\%{space}+\%{qualit})+)</suffix>
+ <keyword>Typeclasses (Transparent)|(Opaque)</keyword>
+ <include>
+ <context sub-pattern="qua_list" style-ref="identifier"/>
+ </include>
+ </context>
+ </include>
+ </context>
+ </definitions>
+</language>
diff --git a/ide/coq.ml b/ide/coq.ml
index 1d1a7dd0..b7753e6e 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -1,12 +1,13 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
open Ideutils
+open Preferences
(** * Version and date *)
@@ -53,7 +54,7 @@ let rec read_all_lines in_chan =
let arg = input_line in_chan in
let len = String.length arg in
let arg =
- if arg.[len - 1] = '\r' then
+ if len > 0 && arg.[len - 1] = '\r' then
String.sub arg 0 (len - 1)
else arg
in
@@ -112,8 +113,7 @@ let rec filter_coq_opts args =
filtered_args := read_all_lines oc;
errlines := read_all_lines ec;
match Unix.close_process_full (oc,ic,ec) with
- | Unix.WEXITED 0 ->
- List.iter check_remaining_opt !filtered_args; !filtered_args
+ | Unix.WEXITED 0 -> !filtered_args
| Unix.WEXITED 127 -> asks_for_coqtop args
| _ -> display_coqtop_answer cmd (!filtered_args @ !errlines)
with Sys_error _ -> asks_for_coqtop args
@@ -125,7 +125,7 @@ and asks_for_coqtop args =
~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
match pb_mes#run () with
| `YES ->
- let () = !Preferences.current.Preferences.cmd_coqtop <- None in
+ let () = current.cmd_coqtop <- None in
let () = custom_coqtop := None in
let () = pb_mes#destroy () in
filter_coq_opts args
@@ -151,37 +151,106 @@ let print_status = function
let check_connection args =
let lines = ref [] in
let argstr = String.concat " " (List.map Filename.quote args) in
- let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in
+ let cmd = Filename.quote (coqtop_path ()) ^ " -batch -ideslave " ^ argstr in
let cmd = requote cmd in
try
- let ic = Unix.open_process_in cmd in
- lines := read_all_lines ic;
- match Unix.close_process_in ic with
+ let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in
+ lines := read_all_lines oc @ read_all_lines ec;
+ match Unix.close_process_full (oc,ic,ec) with
| Unix.WEXITED 0 -> () (* coqtop seems ok *)
| st -> raise (WrongExitStatus (print_status st))
with e -> connection_error cmd !lines e
+(** Useful stuff *)
+
+let ignore_error f arg =
+ try ignore (f arg) with _ -> ()
+
+(** An abstract copy of unit.
+ This will help ensuring that we do not forget to finally call
+ continuations when building tasks in other modules. *)
+
+type void = Void
+
+(** ccb : existential type for a (call + callback) type.
+
+ Reference: http://alan.petitepomme.net/cwn/2004.01.13.html
+ To rewrite someday with GADT. *)
+
+type 'a poly_ccb = 'a Xmlprotocol.call * ('a Interface.value -> void)
+type 't scoped_ccb = { bind_ccb : 'a. 'a poly_ccb -> 't }
+type ccb = { open_ccb : 't. 't scoped_ccb -> 't }
+
+let mk_ccb poly = { open_ccb = fun scope -> scope.bind_ccb poly }
+let with_ccb ccb e = ccb.open_ccb e
+
+let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint)
+
(** * The structure describing a coqtop sub-process *)
-type coqtop = {
- pid : int; (* Unix process id *)
- cout : in_channel ;
- cin : out_channel ;
- sup_args : string list;
+let gio_channel_of_descr_socket = ref Glib.Io.channel_of_descr
+
+module GlibMainLoop = struct
+ type async_chan = Glib.Io.channel
+ type watch_id = Glib.Io.id
+ type condition = Glib.Io.condition
+ let add_watch ~callback chan =
+ Glib.Io.add_watch ~cond:[`ERR; `HUP; `IN; `NVAL; `PRI] ~callback chan
+ let remove_watch x = try Glib.Io.remove x with Glib.GError _ -> ()
+ let read_all = Ideutils.io_read_all
+ let async_chan_of_file fd = Glib.Io.channel_of_descr fd
+ let async_chan_of_socket s = !gio_channel_of_descr_socket s
+ let add_timeout ~sec callback =
+ ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback)
+end
+
+module CoqTop = Spawn.Async(GlibMainLoop)
+
+type handle = {
+ proc : CoqTop.process;
+ xml_oc : Xml_printer.t;
+ mutable alive : bool;
+ mutable waiting_for : (ccb * logger) option; (* last call + callback + log *)
}
-(** * Count of all active coqtops *)
+(** Coqtop process status :
+ - New : a process has been spawned, but not initialized via [init_coqtop].
+ It will reject tasks given via [try_grab].
+ - Ready : no current task, accepts new tasks via [try_grab].
+ - Busy : has accepted a task via [init_coqtop] or [try_grab],
+ It will reject other tasks for the moment
+ - Closed : the coqide buffer has been closed, we discard any further task.
+*)
-let toplvl_ctr = ref 0
+type status = New | Ready | Busy | Closed
-let toplvl_ctr_mtx = Mutex.create ()
+type 'a task = handle -> ('a -> void) -> void
-let coqtop_zombies () =
- Mutex.lock toplvl_ctr_mtx;
- let res = !toplvl_ctr in
- Mutex.unlock toplvl_ctr_mtx;
- res
+type reset_kind = Planned | Unexpected
+
+type coqtop = {
+ (* non quoted command-line arguments of coqtop *)
+ mutable sup_args : string list;
+ (* called whenever coqtop dies *)
+ mutable reset_handler : reset_kind -> unit task;
+ (* called whenever coqtop sends a feedback message *)
+ mutable feedback_handler : Feedback.feedback -> unit;
+ (* actual coqtop process and its status *)
+ mutable handle : handle;
+ mutable status : status;
+}
+let return (x : 'a) : 'a task =
+ (); fun _ k -> k x
+
+let bind (m : 'a task) (f : 'a -> 'b task) : 'b task =
+ (); fun h k -> m h (fun x -> f x h k)
+
+let seq (m : unit task) (n : 'a task) : 'a task =
+ (); fun h k -> m h (fun () -> n h k)
+
+let lift (f : unit -> 'a) : 'a task =
+ (); fun _ k -> k (f ())
(** * Starting / signaling / ending a real coqtop sub-process *)
@@ -215,107 +284,304 @@ let coqtop_zombies () =
closed in coqide.
*)
-let open_process_pid prog args =
- let (ide2top_r,ide2top_w) = Unix.pipe () in
- let (top2ide_r,top2ide_w) = Unix.pipe () in
- Unix.set_close_on_exec ide2top_w;
- Unix.set_close_on_exec top2ide_r;
- let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in
- assert (pid <> 0);
- Unix.close ide2top_r;
- Unix.close top2ide_w;
- let oc = Unix.out_channel_of_descr ide2top_w in
- let ic = Unix.in_channel_of_descr top2ide_r in
- set_binary_mode_out oc true;
- set_binary_mode_in ic true;
- (pid,ic,oc)
+exception TubeError of string
+exception AnswerWithoutRequest of string
+
+let rec check_errors = function
+| [] -> ()
+| (`IN | `PRI) :: conds -> check_errors conds
+| `ERR :: _ -> raise (TubeError "ERR")
+| `HUP :: _ -> raise (TubeError "HUP")
+| `NVAL :: _ -> raise (TubeError "NVAL")
+| `OUT :: _ -> raise (TubeError "OUT")
+
+let handle_intermediate_message handle xml =
+ let message = Pp.to_message xml in
+ let level = message.Pp.message_level in
+ let content = message.Pp.message_content in
+ let logger = match handle.waiting_for with
+ | Some (_, l) -> l
+ | None -> function
+ | Pp.Error -> Minilib.log ~level:`ERROR
+ | Pp.Info -> Minilib.log ~level:`INFO
+ | Pp.Notice -> Minilib.log ~level:`NOTICE
+ | Pp.Warning -> Minilib.log ~level:`WARNING
+ | Pp.Debug _ -> Minilib.log ~level:`DEBUG
+ in
+ logger level content
+
+let handle_feedback feedback_processor xml =
+ let feedback = Feedback.to_feedback xml in
+ feedback_processor feedback
+
+let handle_final_answer handle xml =
+ let () = Minilib.log "Handling coqtop answer" in
+ let ccb = match handle.waiting_for with
+ | None -> raise (AnswerWithoutRequest (Xml_printer.to_string_fmt xml))
+ | Some (c, _) -> c in
+ let () = handle.waiting_for <- None in
+ with_ccb ccb { bind_ccb = fun (c, f) -> f (Xmlprotocol.to_answer c xml) }
+
+type input_state = {
+ mutable fragment : string;
+ mutable lexerror : int option;
+}
+
+let unsafe_handle_input handle feedback_processor state conds ~read_all =
+ check_errors conds;
+ let s = read_all () in
+ if String.length s = 0 then raise (TubeError "EMPTY");
+ let s = state.fragment ^ s in
+ state.fragment <- s;
+ let lex = Lexing.from_string s in
+ let p = Xml_parser.make (Xml_parser.SLexbuf lex) in
+ let rec loop () =
+ let xml = Xml_parser.parse p in
+ let l_end = Lexing.lexeme_end lex in
+ state.fragment <- String.sub s l_end (String.length s - l_end);
+ state.lexerror <- None;
+ if Pp.is_message xml then begin
+ handle_intermediate_message handle xml;
+ loop ()
+ end else if Feedback.is_feedback xml then begin
+ handle_feedback feedback_processor xml;
+ loop ()
+ end else begin
+ ignore (handle_final_answer handle xml)
+ end
+ in
+ try loop ()
+ with Xml_parser.Error _ as e ->
+ (* Parsing error at the end of s : we have only received a part of
+ an xml answer. We store the current fragment for later *)
+ let l_end = Lexing.lexeme_end lex in
+ (** Heuristic hack not to reimplement the lexer: if ever the lexer dies
+ twice at the same place, then this is a non-recoverable error *)
+ if state.lexerror = Some l_end then raise e;
+ state.lexerror <- Some l_end
+
+let print_exception = function
+ | Xml_parser.Error e -> Xml_parser.error e
+ | Serialize.Marshal_error -> "Protocol violation"
+ | e -> Printexc.to_string e
+
+let input_watch handle respawner feedback_processor =
+ let state = { fragment = ""; lexerror = None; } in
+ (fun conds ~read_all ->
+ let h = handle () in
+ if not h.alive then false
+ else
+ try unsafe_handle_input h feedback_processor state conds ~read_all; true
+ with e ->
+ Minilib.log ("Coqtop reader failed, resetting: "^print_exception e);
+ respawner ();
+ false)
+
+let bind_self_as f =
+ let me = ref None in
+ let get_me () = Option.get !me in
+ me := Some(f get_me);
+ Option.get !me
+
+(** This launches a fresh handle from its command line arguments. *)
+let spawn_handle args respawner feedback_processor =
+ let prog = coqtop_path () in
+ let args = Array.of_list ("-async-proofs" :: "on" :: "-ideslave" :: args) in
+ let env =
+ match !Flags.ideslave_coqtop_flags with
+ | None -> None
+ | Some s ->
+ let open Str in
+ let open Array in
+ let opts = split_delim (regexp ",") s in
+ begin try
+ let erex = regexp "^extra-env=" in
+ let echunk = List.find (fun s -> string_match erex s 0) opts in
+ Some (append
+ (of_list (split_delim (regexp ";") (replace_first erex "" echunk)))
+ (Unix.environment ()))
+ with Not_found -> None end in
+ bind_self_as (fun handle ->
+ let proc, oc =
+ CoqTop.spawn ?env prog args (input_watch handle respawner feedback_processor) in
+ {
+ proc;
+ xml_oc = Xml_printer.make (Xml_printer.TChannel oc);
+ alive = true;
+ waiting_for = None;
+ })
+
+(** This clears any potentially remaining open garbage. *)
+let clear_handle h =
+ if h.alive then begin
+ (* invalidate the old handle *)
+ CoqTop.kill h.proc;
+ ignore(CoqTop.wait h.proc);
+ h.alive <- false;
+ end
+
+let mkready coqtop =
+ fun () -> coqtop.status <- Ready; Void
+
+let rec respawn_coqtop ?(why=Unexpected) coqtop =
+ clear_handle coqtop.handle;
+ ignore_error (fun () ->
+ coqtop.handle <-
+ spawn_handle
+ coqtop.sup_args
+ (fun () -> respawn_coqtop coqtop)
+ coqtop.feedback_handler) ();
+ (* Normally, the handle is now a fresh one.
+ If not, there isn't much we can do ... *)
+ assert (coqtop.handle.alive = true);
+ coqtop.status <- New;
+ ignore (coqtop.reset_handler why coqtop.handle (mkready coqtop))
let spawn_coqtop sup_args =
- Mutex.lock toplvl_ctr_mtx;
- try
- let prog = coqtop_path () in
- let args = Array.of_list (prog :: "-ideslave" :: sup_args) in
- let (pid,ic,oc) = open_process_pid prog args in
- incr toplvl_ctr;
- Mutex.unlock toplvl_ctr_mtx;
- { pid = pid; cin = oc; cout = ic ; sup_args = sup_args }
- with e ->
- Mutex.unlock toplvl_ctr_mtx;
- raise e
+ bind_self_as (fun this -> {
+ handle = spawn_handle sup_args
+ (fun () -> respawn_coqtop (this ()))
+ (fun msg -> (this ()).feedback_handler msg);
+ sup_args = sup_args;
+ reset_handler = (fun _ _ k -> k ());
+ feedback_handler = (fun _ -> ());
+ status = New;
+ })
-let respawn_coqtop coqtop = spawn_coqtop coqtop.sup_args
+let set_reset_handler coqtop hook = coqtop.reset_handler <- hook
-let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint)
-let killer = ref (fun pid -> Unix.kill pid Sys.sigkill)
+let set_feedback_handler coqtop hook = coqtop.feedback_handler <- hook
+
+let is_computing coqtop = (coqtop.status = Busy)
+
+(* For closing a coqtop, we don't try to send it a Quit call anymore,
+ but rather close its channels:
+ - a listening coqtop will handle this just as a Quit call
+ - a busy coqtop will anyway have to be killed *)
+
+let close_coqtop coqtop =
+ coqtop.status <- Closed;
+ clear_handle coqtop.handle
+
+let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop
let break_coqtop coqtop =
- try !interrupter coqtop.pid
- with _ -> prerr_endline "Error while sending Ctrl-C"
-
-let kill_coqtop coqtop =
- let pid = coqtop.pid in
- begin
- try !killer pid
- with _ -> prerr_endline "Kill -9 failed. Process already terminated ?"
- end;
- try
- ignore (Unix.waitpid [] pid);
- Mutex.lock toplvl_ctr_mtx; decr toplvl_ctr; Mutex.unlock toplvl_ctr_mtx
- with _ -> prerr_endline "Error while waiting for child"
+ try !interrupter (CoqTop.unixpid coqtop.handle.proc)
+ with _ -> Minilib.log "Error while sending Ctrl-C"
-(** * Calls to coqtop *)
+let get_arguments coqtop = coqtop.sup_args
-(** Cf [Ide_intf] for more details *)
+let set_arguments coqtop args =
+ coqtop.sup_args <- args;
+ reset_coqtop coqtop
+
+let process_task coqtop task =
+ assert (coqtop.status = Ready || coqtop.status = New);
+ coqtop.status <- Busy;
+ try ignore (task coqtop.handle (mkready coqtop))
+ with e ->
+ Minilib.log ("Coqtop writer failed, resetting: " ^ Printexc.to_string e);
+ if coqtop.status <> Closed then respawn_coqtop coqtop
-let p = Xml_parser.make ()
-let () = Xml_parser.check_eof p false
+let try_grab coqtop task abort =
+ match coqtop.status with
+ |Closed -> ()
+ |Busy|New -> abort ()
+ |Ready -> process_task coqtop task
-let eval_call coqtop (c:'a Ide_intf.call) =
- Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c);
- flush coqtop.cin;
- let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in
- (Ide_intf.to_answer xml c : 'a Interface.value)
+let init_coqtop coqtop task =
+ assert (coqtop.status = New);
+ process_task coqtop task
-let interp coqtop ?(raw=false) ?(verbose=true) i s =
- eval_call coqtop (Ide_intf.interp (i,raw,verbose,s))
-let rewind coqtop i = eval_call coqtop (Ide_intf.rewind i)
-let inloadpath coqtop s = eval_call coqtop (Ide_intf.inloadpath s)
-let mkcases coqtop s = eval_call coqtop (Ide_intf.mkcases s)
-let status coqtop = eval_call coqtop (Ide_intf.status ())
-let hints coqtop = eval_call coqtop (Ide_intf.hints ())
+(** * Calls to coqtop *)
+
+(** Cf [Ide_intf] for more details *)
+
+type 'a query = 'a Interface.value task
+
+let eval_call ?(logger=default_logger) call handle k =
+ (** Send messages to coqtop and prepare the decoding of the answer *)
+ Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call);
+ assert (handle.alive && handle.waiting_for = None);
+ handle.waiting_for <- Some (mk_ccb (call,k), logger);
+ Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call);
+ Minilib.log "End eval_call";
+ Void
+
+let add ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.add x)
+let edit_at i = eval_call (Xmlprotocol.edit_at i)
+let query ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.query x)
+let mkcases s = eval_call (Xmlprotocol.mkcases s)
+let status ?logger force = eval_call ?logger (Xmlprotocol.status force)
+let hints x = eval_call (Xmlprotocol.hints x)
+let search flags = eval_call (Xmlprotocol.search flags)
+let init x = eval_call (Xmlprotocol.init x)
+let stop_worker x = eval_call (Xmlprotocol.stop_worker x)
module PrintOpt =
struct
type t = string list
+
+ (* Boolean options *)
+
let implicit = ["Printing"; "Implicit"]
let coercions = ["Printing"; "Coercions"]
- let raw_matching = ["Printing"; "Matching"; "Synth"]
+ let raw_matching = ["Printing"; "Matching"]
let notations = ["Printing"; "Notations"]
let all_basic = ["Printing"; "All"]
let existential = ["Printing"; "Existential"; "Instances"]
let universes = ["Printing"; "Universes"]
- let state_hack = Hashtbl.create 11
- let _ = List.iter (fun opt -> Hashtbl.add state_hack opt false)
- [ implicit; coercions; raw_matching; notations; all_basic; existential; universes ]
+ type bool_descr = { opts : t list; init : bool; label : string }
+
+ let bool_items = [
+ { opts = [implicit]; init = false; label = "Display _implicit arguments" };
+ { opts = [coercions]; init = false; label = "Display _coercions" };
+ { opts = [raw_matching]; init = true;
+ label = "Display raw _matching expressions" };
+ { opts = [notations]; init = true; label = "Display _notations" };
+ { opts = [all_basic]; init = false;
+ label = "Display _all basic low-level contents" };
+ { opts = [existential]; init = false;
+ label = "Display _existential variable instances" };
+ { opts = [universes]; init = false; label = "Display _universe levels" };
+ { opts = [all_basic;existential;universes]; init = false;
+ label = "Display all _low-level contents" }
+ ]
+
+ (** The current status of the boolean options *)
+
+ let current_state = Hashtbl.create 11
+
+ let set opt v = Hashtbl.replace current_state opt v
+
+ let reset () =
+ let init_descr d = List.iter (fun o -> set o d.init) d.opts in
+ List.iter init_descr bool_items
+
+ let _ = reset ()
+
+ (** Integer option *)
+
+ let width = ["Printing"; "Width"]
+ let width_state = ref None
+ let set_printing_width w = width_state := Some w
- let set coqtop options =
- let () = List.iter (fun (name, v) -> Hashtbl.replace state_hack name v) options in
- let options = List.map (fun (name, v) -> (name, Interface.BoolValue v)) options in
- match eval_call coqtop (Ide_intf.set_options options) with
- | Interface.Good () -> ()
- | _ -> raise (Failure "Cannot set options.")
+ (** Transmitting options to coqtop *)
- let enforce_hack coqtop =
- let elements = Hashtbl.fold (fun opt v acc -> (opt, v) :: acc) state_hack [] in
- set coqtop elements
+ let enforce h k =
+ let mkopt o v acc = (o, Interface.BoolValue v) :: acc in
+ let opts = Hashtbl.fold mkopt current_state [] in
+ let opts = (width, Interface.IntValue !width_state) :: opts in
+ eval_call (Xmlprotocol.set_options opts) h
+ (function
+ | Interface.Good () -> k ()
+ | _ -> failwith "Cannot set options. Resetting coqtop")
end
-let goals coqtop =
- let () = PrintOpt.enforce_hack coqtop in
- eval_call coqtop (Ide_intf.goals ())
+let goals ?logger x h k =
+ PrintOpt.enforce h (fun () -> eval_call ?logger (Xmlprotocol.goals x) h k)
-let evars coqtop =
- let () = PrintOpt.enforce_hack coqtop in
- eval_call coqtop (Ide_intf.evars ())
+let evars x h k =
+ PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.evars x) h k)
diff --git a/ide/coq.mli b/ide/coq.mli
index c255d08f..a72c67b4 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,67 +8,168 @@
(** Coq : Interaction with the Coq toplevel *)
-(** * Version and date *)
+(** {5 General structures} *)
-val short_version : unit -> string
-val version : unit -> string
+type coqtop
+(** The structure describing a coqtop sub-process .
-(** * Launch a test coqtop processes, ask for a correct coqtop if it fails.
- @return the list of arguments that coqtop did not understand
- (the files probably ..). This command may terminate coqide in
- case of trouble. *)
-val filter_coq_opts : string list -> string list
+ Liveness management of coqtop is automatic. Whenever a coqtop dies abruptly,
+ this module is responsible for relaunching the whole process. The reset
+ handler set through [set_reset_handler] will be called after such an
+ abrupt failure. It is also called when explicitely requesting coqtop to
+ reset. *)
-(** Launch a coqtop with the user args in order to be sure that it works,
- checking in particular that initial.coq is found. This command
- may terminate coqide in case of trouble *)
-val check_connection : string list -> unit
+type 'a task
+(** Coqtop tasks.
-(** * The structure describing a coqtop sub-process *)
+ A task is a group of sequential calls to be performed on a coqtop process,
+ that ultimately return some content.
-type coqtop
+ If a task is already sent to coqtop, it is considered busy
+ ([is_computing] will answer [true]), and any other task submission
+ will be rejected by [try_grab].
-(** * Count of all active coqtops *)
+ Any exception occuring within the task will trigger a coqtop reset.
-val coqtop_zombies : unit -> int
+ Beware, because of the GTK scheduler, you never know when a task will
+ actually be executed. If you need to sequentialize imperative actions, you
+ should do so using the monadic primitives.
+*)
-(** * Starting / signaling / ending a real coqtop sub-process *)
+val return : 'a -> 'a task
+(** Monadic return of values as tasks. *)
-val spawn_coqtop : string list -> coqtop
-val respawn_coqtop : coqtop -> coqtop
-val kill_coqtop : coqtop -> unit
-val break_coqtop : coqtop -> unit
+val bind : 'a task -> ('a -> 'b task) -> 'b task
+(** Monadic binding of tasks *)
-(** In win32, we'll use a different kill function than Unix.kill *)
+val lift : (unit -> 'a) -> 'a task
+(** Return the impertative computation waiting to be processed. *)
-val killer : (int -> unit) ref
-val interrupter : (int -> unit) ref
+val seq : unit task -> 'a task -> 'a task
+(** Sequential composition *)
+
+(** {5 Coqtop process management} *)
-(** * Calls to Coqtop, cf [Ide_intf] for more details *)
+type reset_kind = Planned | Unexpected
+(** A reset may occur accidentally or voluntarily, so we discriminate between
+ these. *)
-val interp :
- coqtop -> ?raw:bool -> ?verbose:bool -> int -> string -> string Interface.value
-val rewind : coqtop -> int -> int Interface.value
-val status : coqtop -> Interface.status Interface.value
-val goals : coqtop -> Interface.goals option Interface.value
-val evars : coqtop -> Interface.evar list option Interface.value
-val hints : coqtop -> (Interface.hint list * Interface.hint) option Interface.value
-val inloadpath : coqtop -> string -> bool Interface.value
-val mkcases : coqtop -> string -> string list list Interface.value
+val is_computing : coqtop -> bool
+(** Check if coqtop is computing, i.e. already has a current task *)
-(** A specialized version of [raw_interp] dedicated to
- set/unset options. *)
+val spawn_coqtop : string list -> coqtop
+(** Create a coqtop process with some command-line arguments. *)
+
+val set_reset_handler : coqtop -> (reset_kind -> unit task) -> unit
+(** Register a handler called when a coqtop dies (badly or on purpose) *)
+
+val set_feedback_handler : coqtop -> (Feedback.feedback -> unit) -> unit
+(** Register a handler called when coqtop sends a feedback message *)
+
+val init_coqtop : coqtop -> unit task -> unit
+(** Finish initializing a freshly spawned coqtop, by running a first task on it.
+ The task should run its inner continuation at the end. *)
+
+val break_coqtop : coqtop -> unit
+(** Interrupt the current computation of coqtop. *)
+
+val close_coqtop : coqtop -> unit
+(** Close coqtop. Subsequent requests will be discarded. Hook ignored. *)
+
+val reset_coqtop : coqtop -> unit
+(** Reset coqtop. Pending requests will be discarded. The reset handler
+ of coqtop will be called with [Planned] as first argument *)
+
+val get_arguments : coqtop -> string list
+(** Get the current arguments used by coqtop. *)
+
+val set_arguments : coqtop -> string list -> unit
+(** Set process arguments. This also forces a planned reset. *)
+
+(** In win32, sockets are not like regular files *)
+val gio_channel_of_descr_socket : (Unix.file_descr -> Glib.Io.channel) ref
+
+(** {5 Task processing} *)
+
+val try_grab : coqtop -> unit task -> (unit -> unit) -> unit
+(** Try to schedule a task on a coqtop. If coqtop is available, the task
+ callback is run (asynchronously), otherwise the [(unit->unit)] callback
+ is triggered.
+ - If coqtop ever dies during the computation, this function restarts coqtop
+ and calls the restart hook with the fresh coqtop.
+ - If the argument function raises an exception, a coqtop reset occurs.
+ - The task may be discarded if a [close_coqtop] or [reset_coqtop] occurs
+ before its completion.
+ - The task callback should run its inner continuation at the end. *)
+
+(** {5 Atomic calls to coqtop} *)
+
+(**
+ These atomic calls can be combined to form arbitrary multi-call tasks.
+ They correspond to the protocol calls (cf [Serialize] for more details).
+ Note that each call is asynchronous: it will return immediately,
+ but the inner callback will be executed later to handle the call answer
+ when this answer is available.
+ Except for interp, we use the default logger for any call. *)
+
+type 'a query = 'a Interface.value task
+(** A type abbreviation for coqtop specific answers *)
+
+val add : ?logger:Ideutils.logger ->
+ Interface.add_sty -> Interface.add_rty query
+val edit_at : Interface.edit_at_sty -> Interface.edit_at_rty query
+val query : ?logger:Ideutils.logger ->
+ Interface.query_sty -> Interface.query_rty query
+val status : ?logger:Ideutils.logger ->
+ Interface.status_sty -> Interface.status_rty query
+val goals : ?logger:Ideutils.logger ->
+ Interface.goals_sty -> Interface.goals_rty query
+val evars : Interface.evars_sty -> Interface.evars_rty query
+val hints : Interface.hints_sty -> Interface.hints_rty query
+val mkcases : Interface.mkcases_sty -> Interface.mkcases_rty query
+val search : Interface.search_sty -> Interface.search_rty query
+val init : Interface.init_sty -> Interface.init_rty query
+
+val stop_worker: Interface.stop_worker_sty-> Interface.stop_worker_rty query
+
+(** A specialized version of [raw_interp] dedicated to set/unset options. *)
module PrintOpt :
sig
- type t
- val implicit : t
- val coercions : t
- val raw_matching : t
- val notations : t
- val all_basic : t
- val existential : t
- val universes : t
-
- val set : coqtop -> (t * bool) list -> unit
+ type t (** Representation of an option *)
+
+ type bool_descr = { opts : t list; init : bool; label : string }
+
+ val bool_items : bool_descr list
+
+ val set : t -> bool -> unit
+ val set_printing_width : int -> unit
+
+ (** [enforce] transmits to coq the current option values.
+ It is also called by [goals] and [evars] above. *)
+
+ val enforce : unit task
end
+
+(** {5 Miscellaneous} *)
+
+val short_version : unit -> string
+(** Return a short phrase identifying coqtop version and date of compilation, as
+ given by the [configure] script. *)
+
+val version : unit -> string
+(** More verbose description, including details about libraries and
+ architecture. *)
+
+val filter_coq_opts : string list -> string list
+(** * Launch a test coqtop processes, ask for a correct coqtop if it fails.
+ @return the list of arguments that coqtop did not understand
+ (the files probably ..). This command may terminate coqide in
+ case of trouble. *)
+
+val check_connection : string list -> unit
+(** Launch a coqtop with the user args in order to be sure that it works,
+ checking in particular that Prelude.vo is found. This command
+ may terminate coqide in case of trouble *)
+
+val interrupter : (int -> unit) ref
diff --git a/ide/coq.png b/ide/coq.png
index 06aac459..cccd5a9a 100644
--- a/ide/coq.png
+++ b/ide/coq.png
Binary files differ
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
new file mode 100644
index 00000000..52e18456
--- /dev/null
+++ b/ide/coqOps.ml
@@ -0,0 +1,824 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Util
+open Coq
+open Ideutils
+open Interface
+open Feedback
+
+type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string ]
+type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ]
+let mem_flag_of_flag : flag -> mem_flag = function
+ | `ERROR _ -> `ERROR
+ | (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag
+let str_of_flag = function
+ | `UNSAFE -> "U"
+ | `PROCESSING -> "P"
+ | `ERROR _ -> "E"
+ | `INCOMPLETE -> "I"
+
+class type signals =
+object
+ inherit GUtil.ml_signals
+ method changed : callback:(int * mem_flag list -> unit) -> GtkSignal.id
+end
+
+module SentenceId : sig
+
+ type sentence = private {
+ start : GText.mark;
+ stop : GText.mark;
+ mutable flags : flag list;
+ mutable tooltips : (int * int * string) list;
+ edit_id : int;
+ mutable index : int;
+ changed_sig : (int * mem_flag list) GUtil.signal;
+ }
+
+ val mk_sentence :
+ start:GText.mark -> stop:GText.mark -> flag list -> sentence
+
+ val set_flags : sentence -> flag list -> unit
+ val add_flag : sentence -> flag -> unit
+ val has_flag : sentence -> mem_flag -> bool
+ val remove_flag : sentence -> mem_flag -> unit
+ val same_sentence : sentence -> sentence -> bool
+ val hidden_edit_id : unit -> int
+ val find_all_tooltips : sentence -> int -> string list
+ val add_tooltip : sentence -> int -> int -> string -> unit
+ val set_index : sentence -> int -> unit
+
+ val connect : sentence -> signals
+
+ val dbg_to_string :
+ GText.buffer -> bool -> Stateid.t option -> sentence -> Pp.std_ppcmds
+
+end = struct
+
+ type sentence = {
+ start : GText.mark;
+ stop : GText.mark;
+ mutable flags : flag list;
+ mutable tooltips : (int * int * string) list;
+ edit_id : int;
+ mutable index : int;
+ changed_sig : (int * mem_flag list) GUtil.signal;
+ }
+
+ let connect s : signals =
+ object
+ inherit GUtil.ml_signals [s.changed_sig#disconnect]
+ method changed = s.changed_sig#connect ~after
+ end
+
+ let id = ref 0
+ let mk_sentence ~start ~stop flags = decr id; {
+ start = start;
+ stop = stop;
+ flags = flags;
+ edit_id = !id;
+ tooltips = [];
+ index = -1;
+ changed_sig = new GUtil.signal ();
+ }
+ let hidden_edit_id () = decr id; !id
+
+ let changed s =
+ s.changed_sig#call (s.index, List.map mem_flag_of_flag s.flags)
+
+ let set_flags s f = s.flags <- f; changed s
+ let add_flag s f = s.flags <- CList.add_set (=) f s.flags; changed s
+ let has_flag s mf =
+ List.exists (fun f -> mem_flag_of_flag f = mf) s.flags
+ let remove_flag s mf =
+ s.flags <- List.filter (fun f -> mem_flag_of_flag f <> mf) s.flags; changed s
+ let same_sentence s1 s2 = s1.edit_id = s2.edit_id
+ let find_all_tooltips s off =
+ CList.map_filter (fun (start,stop,t) ->
+ if start <= off && off <= stop then Some t else None)
+ s.tooltips
+ let add_tooltip s a b t = s.tooltips <- (a,b,t) :: s.tooltips
+
+ let set_index s i = s.index <- i
+
+ let dbg_to_string (b : GText.buffer) focused id s =
+ let ellipsize s =
+ Str.global_replace (Str.regexp "^[\n ]*") ""
+ (if String.length s > 20 then String.sub s 0 17 ^ "..."
+ else s) in
+ Pp.str (Printf.sprintf "%s[%3d,%3s](%5d,%5d) %s [%s] %s"
+ (if focused then "*" else " ")
+ s.edit_id
+ (Stateid.to_string (Option.default Stateid.dummy id))
+ (b#get_iter_at_mark s.start)#offset
+ (b#get_iter_at_mark s.stop)#offset
+ (ellipsize
+ ((b#get_iter_at_mark s.start)#get_slice (b#get_iter_at_mark s.stop)))
+ (String.concat "," (List.map str_of_flag s.flags))
+ (ellipsize
+ (String.concat ","
+ (List.map (fun (a,b,t) ->
+ Printf.sprintf "<%d,%d> %s" a b t) s.tooltips))))
+
+
+end
+open SentenceId
+
+let prefs = Preferences.current
+
+let log msg : unit task =
+ Coq.lift (fun () -> Minilib.log msg)
+
+class type ops =
+object
+ method go_to_insert : unit task
+ method go_to_mark : GText.mark -> unit task
+ method tactic_wizard : string list -> unit task
+ method process_next_phrase : unit task
+ method process_until_end_or_error : unit task
+ method handle_reset_initial : Coq.reset_kind -> unit task
+ method raw_coq_query : string -> unit task
+ method show_goals : unit task
+ method backtrack_last_phrase : unit task
+ method initialize : unit task
+ method join_document : unit task
+ method stop_worker : string -> unit task
+
+ method get_n_errors : int
+ method get_errors : (int * string) list
+ method get_slaves_status : int * int * string CString.Map.t
+
+ method handle_failure : handle_exn_rty -> unit task
+
+ method destroy : unit -> unit
+end
+
+let flags_to_color f =
+ let of_col c = `NAME (Tags.string_of_color c) in
+ if List.mem `PROCESSING f then `NAME "blue"
+ else if List.mem `ERROR f then `NAME "red"
+ else if List.mem `UNSAFE f then `NAME "orange"
+ else if List.mem `INCOMPLETE f then `NAME "gray"
+ else of_col (Tags.get_processed_color ())
+
+module Doc = Document
+
+class coqops
+ (_script:Wg_ScriptView.script_view)
+ (_pv:Wg_ProofView.proof_view)
+ (_mv:Wg_MessageView.message_view)
+ (_sg:Wg_Segment.segment)
+ (_ct:Coq.coqtop)
+ get_filename =
+object(self)
+ val script = _script
+ val buffer = (_script#source_buffer :> GText.buffer)
+ val proof = _pv
+ val messages = _mv
+ val segment = _sg
+
+ val document : sentence Doc.document = Doc.create ()
+ val mutable document_length = 0
+
+ val mutable initial_state = Stateid.initial
+
+ (* proofs being processed by the slaves *)
+ val mutable to_process = 0
+ val mutable processed = 0
+ val mutable slaves_status = CString.Map.empty
+
+ val feedbacks : feedback Queue.t = Queue.create ()
+ val feedback_timer = Ideutils.mktimer ()
+
+ initializer
+ Coq.set_feedback_handler _ct self#enqueue_feedback;
+ script#misc#set_has_tooltip true;
+ ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback);
+ feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback;
+ let on_changed (i, f) = segment#add i (flags_to_color f) in
+ let on_push s =
+ set_index s document_length;
+ (SentenceId.connect s)#changed on_changed;
+ document_length <- succ document_length;
+ segment#set_length document_length;
+ let flags = List.map mem_flag_of_flag s.flags in
+ segment#add s.index (flags_to_color flags);
+ in
+ let on_pop s =
+ set_index s (-1);
+ document_length <- pred document_length;
+ segment#set_length document_length;
+ in
+ let _ = (Doc.connect document)#pushed on_push in
+ let _ = (Doc.connect document)#popped on_pop in
+ ()
+
+ method private tooltip_callback ~x ~y ~kbd tooltip =
+ let x, y = script#window_to_buffer_coords `WIDGET x y in
+ let iter = script#get_iter_at_location x y in
+ if iter#has_tag Tags.Script.tooltip then begin
+ let s =
+ let rec aux iter =
+ let marks = iter#marks in
+ if marks = [] then aux iter#backward_char
+ else
+ let mem_marks _ _ s =
+ List.exists (fun m ->
+ Gobject.get_oid m =
+ Gobject.get_oid (buffer#get_mark s.start)) marks in
+ try Doc.find document mem_marks
+ with Not_found -> aux iter#backward_char in
+ aux iter in
+ let ss =
+ find_all_tooltips s
+ (iter#offset - (buffer#get_iter_at_mark s.start)#offset) in
+ let msg = String.concat "\n" (CList.uniquize ss) in
+ GtkBase.Tooltip.set_icon_from_stock tooltip `INFO `BUTTON;
+ script#misc#set_tooltip_markup ("<tt>" ^ msg ^ "</tt>")
+ end else begin
+ script#misc#set_tooltip_text ""; script#misc#set_has_tooltip true
+ end;
+ false
+
+ method destroy () =
+ feedback_timer.Ideutils.kill ()
+
+ method private print_stack =
+ Minilib.log "document:";
+ Minilib.log (Pp.string_of_ppcmds (Doc.print document (dbg_to_string buffer)))
+
+ method private enter_focus start stop =
+ let at id id' _ = Stateid.equal id' id in
+ self#print_stack;
+ Minilib.log("Focusing "^Stateid.to_string start^" "^Stateid.to_string stop);
+ Doc.focus document ~cond_top:(at start) ~cond_bot:(at stop);
+ self#print_stack;
+ let qed_s = Doc.tip_data document in
+ buffer#apply_tag Tags.Script.read_only
+ ~start:((buffer#get_iter_at_mark qed_s.start)#forward_find_char
+ (fun c -> not(Glib.Unichar.isspace c)))
+ ~stop:(buffer#get_iter_at_mark qed_s.stop);
+ buffer#move_mark ~where:(buffer#get_iter_at_mark qed_s.stop)
+ (`NAME "stop_of_input")
+
+ method private exit_focus =
+ Minilib.log "Unfocusing";
+ begin try
+ let { start; stop } = Doc.tip_data document in
+ buffer#remove_tag Tags.Script.read_only
+ ~start:(buffer#get_iter_at_mark start)
+ ~stop:(buffer#get_iter_at_mark stop)
+ with Doc.Empty -> () end;
+ Doc.unfocus document;
+ self#print_stack;
+ begin try
+ let where = buffer#get_iter_at_mark (Doc.tip_data document).stop in
+ buffer#move_mark ~where (`NAME "start_of_input");
+ with Doc.Empty -> () end;
+ buffer#move_mark ~where:buffer#end_iter (`NAME "stop_of_input")
+
+ method private get_start_of_input =
+ buffer#get_iter_at_mark (`NAME "start_of_input")
+
+ method private get_end_of_input =
+ buffer#get_iter_at_mark (`NAME "stop_of_input")
+
+ method private get_insert =
+ buffer#get_iter_at_mark `INSERT
+
+ method private show_goals_aux ?(move_insert=false) () =
+ Coq.PrintOpt.set_printing_width proof#width;
+ if move_insert then begin
+ buffer#place_cursor ~where:self#get_start_of_input;
+ script#recenter_insert;
+ end;
+ Coq.bind (Coq.goals ~logger:messages#push ()) (function
+ | Fail x -> self#handle_failure_aux ~move_insert x
+ | Good goals ->
+ Coq.bind (Coq.evars ()) (function
+ | Fail x -> self#handle_failure_aux ~move_insert x
+ | Good evs ->
+ proof#set_goals goals;
+ proof#set_evars evs;
+ proof#refresh ();
+ Coq.return ()
+ )
+ )
+ method show_goals = self#show_goals_aux ()
+
+ (* This method is intended to perform stateless commands *)
+ method raw_coq_query phrase =
+ let action = log "raw_coq_query starting now" in
+ let display_error s =
+ if not (Glib.Utf8.validate s) then
+ flash_info "This error is so nasty that I can't even display it."
+ else messages#add s;
+ in
+ let query =
+ Coq.query ~logger:messages#push (phrase,Stateid.dummy) in
+ let next = function
+ | Fail (_, _, err) -> display_error err; Coq.return ()
+ | Good msg ->
+ messages#add msg; Coq.return ()
+ in
+ Coq.bind (Coq.seq action query) next
+
+ method private mark_as_needed sentence =
+ Minilib.log("Marking " ^
+ Pp.string_of_ppcmds (dbg_to_string buffer false None sentence));
+ let start = buffer#get_iter_at_mark sentence.start in
+ let stop = buffer#get_iter_at_mark sentence.stop in
+ let to_process = Tags.Script.to_process in
+ let processed = Tags.Script.processed in
+ let unjustified = Tags.Script.unjustified in
+ let error_bg = Tags.Script.error_bg in
+ let error = Tags.Script.error in
+ let incomplete = Tags.Script.incomplete in
+ let all_tags = [
+ error_bg; to_process; incomplete; processed; unjustified; error ] in
+ let tags =
+ (if has_flag sentence `PROCESSING then [to_process]
+ else if has_flag sentence `ERROR then [error_bg]
+ else if has_flag sentence `INCOMPLETE then [incomplete]
+ else [processed]) @
+ (if [ `UNSAFE ] = sentence.flags then [unjustified] else [])
+ in
+ List.iter (fun t -> buffer#remove_tag t ~start ~stop) all_tags;
+ List.iter (fun t -> buffer#apply_tag t ~start ~stop) tags
+
+ method private attach_tooltip sentence loc text =
+ let start_sentence, stop_sentence, phrase = self#get_sentence sentence in
+ let pre_chars, post_chars =
+ if Loc.is_ghost loc then 0, String.length phrase else Loc.unloc loc in
+ let pre = Ideutils.glib_utf8_pos_to_offset phrase ~off:pre_chars in
+ let post = Ideutils.glib_utf8_pos_to_offset phrase ~off:post_chars in
+ let start = start_sentence#forward_chars pre in
+ let stop = start_sentence#forward_chars post in
+ let markup = Glib.Markup.escape_text text in
+ buffer#apply_tag Tags.Script.tooltip ~start ~stop;
+ add_tooltip sentence pre post markup
+
+ method private is_dummy_id id =
+ match id with
+ | Edit 0 -> true
+ | State id when Stateid.equal id Stateid.dummy -> true
+ | _ -> false
+
+ method private enqueue_feedback msg =
+ let id = msg.id in
+ if self#is_dummy_id id then () else Queue.add msg feedbacks
+
+ method private process_feedback () =
+ let rec eat_feedback n =
+ if n = 0 then true else
+ let msg = Queue.pop feedbacks in
+ let id = msg.id in
+ let sentence =
+ let finder _ state_id s =
+ match state_id, id with
+ | Some id', State id when Stateid.equal id id' -> Some (state_id, s)
+ | _, Edit id when id = s.edit_id -> Some (state_id, s)
+ | _ -> None in
+ try Some (Doc.find_map document finder)
+ with Not_found -> None in
+ let log s state_id =
+ Minilib.log ("Feedback " ^ s ^ " on " ^ Stateid.to_string
+ (Option.default Stateid.dummy state_id)) in
+ begin match msg.contents, sentence with
+ | AddedAxiom, Some (id,sentence) ->
+ log "AddedAxiom" id;
+ remove_flag sentence `PROCESSING;
+ remove_flag sentence `ERROR;
+ add_flag sentence `UNSAFE;
+ self#mark_as_needed sentence
+ | Processed, Some (id,sentence) ->
+ log "Processed" id;
+ remove_flag sentence `PROCESSING;
+ remove_flag sentence `ERROR;
+ self#mark_as_needed sentence
+ | ProcessingIn _, Some (id,sentence) ->
+ log "ProcessingIn" id;
+ add_flag sentence `PROCESSING;
+ self#mark_as_needed sentence
+ | Incomplete, Some (id, sentence) ->
+ log "Incomplete" id;
+ add_flag sentence `INCOMPLETE;
+ self#mark_as_needed sentence
+ | Complete, Some (id, sentence) ->
+ log "Complete" id;
+ remove_flag sentence `INCOMPLETE;
+ self#mark_as_needed sentence
+ | GlobRef(loc, filepath, modpath, ident, ty), Some (id,sentence) ->
+ log "GlobRef" id;
+ self#attach_tooltip sentence loc
+ (Printf.sprintf "%s %s %s" filepath ident ty)
+ | ErrorMsg(loc, msg), Some (id,sentence) ->
+ log "ErrorMsg" id;
+ remove_flag sentence `PROCESSING;
+ add_flag sentence (`ERROR msg);
+ self#mark_as_needed sentence;
+ self#attach_tooltip sentence loc msg;
+ if not (Loc.is_ghost loc) then
+ self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc))
+ | InProgress n, _ ->
+ if n < 0 then processed <- processed + abs n
+ else to_process <- to_process + n
+ | WorkerStatus(id,status), _ ->
+ log "WorkerStatus" None;
+ slaves_status <- CString.Map.add id status slaves_status
+
+ | _ ->
+ if sentence <> None then Minilib.log "Unsupported feedback message"
+ else if Doc.is_empty document then ()
+ else
+ try
+ match id, Doc.tip document with
+ | Edit _, _ -> ()
+ | State id1, id2 when Stateid.newer_than id2 id1 -> ()
+ | _ -> Queue.add msg feedbacks
+ with Doc.Empty | Invalid_argument _ -> Queue.add msg feedbacks
+ end;
+ eat_feedback (n-1)
+ in
+ eat_feedback (Queue.length feedbacks)
+
+ method private commit_queue_transaction sentence =
+ (* A queued command has been successfully done, we push it to [cmd_stack].
+ We reget the iters here because Gtk is unable to warranty that they
+ were not modified meanwhile. Not really necessary but who knows... *)
+ self#mark_as_needed sentence;
+ let stop = buffer#get_iter_at_mark sentence.stop in
+ buffer#move_mark ~where:stop (`NAME "start_of_input");
+
+ method private position_error_tag_at_iter iter phrase = function
+ | None -> ()
+ | Some (start, stop) ->
+ buffer#apply_tag Tags.Script.error
+ ~start:(iter#forward_chars (byte_offset_to_char_offset phrase start))
+ ~stop:(iter#forward_chars (byte_offset_to_char_offset phrase stop))
+
+ method private position_error_tag_at_sentence sentence loc =
+ let start, _, phrase = self#get_sentence sentence in
+ self#position_error_tag_at_iter start phrase loc
+
+ method private process_interp_error queue sentence loc msg tip id =
+ Coq.bind (Coq.return ()) (function () ->
+ let start, stop, phrase = self#get_sentence sentence in
+ buffer#remove_tag Tags.Script.to_process ~start ~stop;
+ self#discard_command_queue queue;
+ pop_info ();
+ if Stateid.equal id tip || Stateid.equal id Stateid.dummy then begin
+ self#position_error_tag_at_iter start phrase loc;
+ buffer#place_cursor ~where:stop;
+ messages#clear;
+ messages#push Pp.Error msg;
+ self#show_goals
+ end else
+ self#show_goals_aux ~move_insert:true ()
+ )
+
+ method private get_sentence sentence =
+ let start = buffer#get_iter_at_mark sentence.start in
+ let stop = buffer#get_iter_at_mark sentence.stop in
+ let phrase = start#get_slice ~stop in
+ start, stop, phrase
+
+ (** [fill_command_queue until q] fills a command queue until the [until]
+ condition returns true; it is fed with the number of phrases read and the
+ iters enclosing the current sentence. *)
+ method private fill_command_queue until queue =
+ let rec loop n iter =
+ match Sentence.find buffer iter with
+ | None -> ()
+ | Some (start, stop) ->
+ if until n start stop then begin
+ ()
+ end else if start#has_tag Tags.Script.processed then begin
+ Queue.push (`Skip (start, stop)) queue;
+ loop n stop
+ end else begin
+ buffer#apply_tag Tags.Script.to_process ~start ~stop;
+ let sentence =
+ mk_sentence
+ ~start:(`MARK (buffer#create_mark start))
+ ~stop:(`MARK (buffer#create_mark stop))
+ [] in
+ Queue.push (`Sentence sentence) queue;
+ if not stop#is_end then loop (succ n) stop
+ end
+ in
+ loop 0 self#get_start_of_input
+
+ method private discard_command_queue queue =
+ while not (Queue.is_empty queue) do
+ match Queue.pop queue with
+ | `Skip _ -> ()
+ | `Sentence sentence ->
+ let start = buffer#get_iter_at_mark sentence.start in
+ let stop = buffer#get_iter_at_mark sentence.stop in
+ buffer#remove_tag Tags.Script.to_process ~start ~stop;
+ buffer#delete_mark sentence.start;
+ buffer#delete_mark sentence.stop;
+ done
+
+ (** Compute the phrases until [until] returns [true]. *)
+ method private process_until ?move_insert until verbose =
+ let logger lvl msg = if verbose then messages#push lvl msg in
+ let fill_queue = Coq.lift (fun () ->
+ let queue = Queue.create () in
+ (* Lock everything and fill the waiting queue *)
+ push_info "Coq is computing";
+ messages#clear;
+ script#set_editable false;
+ self#fill_command_queue until queue;
+ (* Now unlock and process asynchronously. Since [until]
+ may contain iterators, it shouldn't be used anymore *)
+ script#set_editable true;
+ Minilib.log "Begin command processing";
+ queue) in
+ let conclude topstack =
+ pop_info ();
+ script#recenter_insert;
+ match topstack with
+ | [] -> self#show_goals_aux ?move_insert ()
+ | (_,s) :: _ -> self#backtrack_to_iter (buffer#get_iter_at_mark s.start) in
+ let process_queue queue =
+ let rec loop tip topstack =
+ if Queue.is_empty queue then conclude topstack else
+ match Queue.pop queue, topstack with
+ | `Skip(start,stop), [] -> assert false
+ | `Skip(start,stop), (_,s) :: topstack ->
+ assert(start#equal (buffer#get_iter_at_mark s.start));
+ assert(stop#equal (buffer#get_iter_at_mark s.stop));
+ loop tip topstack
+ | `Sentence sentence, _ :: _ -> assert false
+ | `Sentence ({ edit_id } as sentence), [] ->
+ add_flag sentence `PROCESSING;
+ Doc.push document sentence;
+ let _, _, phrase = self#get_sentence sentence in
+ let coq_query = Coq.add ~logger ((phrase,edit_id),(tip,verbose)) in
+ let handle_answer = function
+ | Good (id, (Util.Inl (* NewTip *) (), msg)) ->
+ Doc.assign_tip_id document id;
+ logger Pp.Notice msg;
+ self#commit_queue_transaction sentence;
+ loop id []
+ | Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
+ Doc.assign_tip_id document id;
+ let topstack, _ = Doc.context document in
+ self#exit_focus;
+ self#cleanup (Doc.cut_at document tip);
+ logger Pp.Notice msg;
+ self#mark_as_needed sentence;
+ if Queue.is_empty queue then loop tip []
+ else loop tip (List.rev topstack)
+ | Fail (id, loc, msg) ->
+ let sentence = Doc.pop document in
+ self#process_interp_error queue sentence loc msg tip id in
+ Coq.bind coq_query handle_answer
+ in
+ let tip =
+ try Doc.tip document
+ with Doc.Empty -> initial_state | Invalid_argument _ -> assert false in
+ loop tip [] in
+ Coq.bind fill_queue process_queue
+
+ method join_document =
+ let next = function
+ | Good _ ->
+ messages#clear;
+ messages#push Pp.Info "All proof terms checked by the kernel";
+ Coq.return ()
+ | Fail x -> self#handle_failure x in
+ Coq.bind (Coq.status ~logger:messages#push true) next
+
+ method stop_worker n =
+ Coq.bind (Coq.stop_worker n) (fun _ -> Coq.return ())
+
+ method get_slaves_status = processed, to_process, slaves_status
+
+ method get_n_errors =
+ Doc.fold_all document 0 (fun n _ _ s -> if has_flag s `ERROR then n+1 else n)
+
+ method get_errors =
+ let extract_error s =
+ match List.find (function `ERROR _ -> true | _ -> false) s.flags with
+ | `ERROR msg -> (buffer#get_iter_at_mark s.start)#line + 1, msg
+ | _ -> assert false in
+ List.rev
+ (Doc.fold_all document [] (fun acc _ _ s ->
+ if has_flag s `ERROR then extract_error s :: acc else acc))
+
+ method process_next_phrase =
+ let until n _ _ = n >= 1 in
+ self#process_until ~move_insert:true until true
+
+ method private process_until_iter iter =
+ let until _ start stop =
+ if prefs.Preferences.stop_before then stop#compare iter > 0
+ else start#compare iter >= 0
+ in
+ self#process_until until false
+
+ method process_until_end_or_error =
+ self#process_until_iter self#get_end_of_input
+
+ (* finds the state_id and if it an unfocus is needed to reach it *)
+ method private find_id until =
+ try
+ Doc.find_id document (fun id { start;stop } -> until (Some id) start stop)
+ with Not_found -> initial_state, Doc.focused document
+
+ method private cleanup seg =
+ if seg <> [] then begin
+ let start = buffer#get_iter_at_mark (CList.last seg).start in
+ let stop = buffer#get_iter_at_mark (CList.hd seg).stop in
+ Minilib.log
+ (Printf.sprintf "Cleanup in range %d -> %d" start#offset stop#offset);
+ buffer#remove_tag Tags.Script.processed ~start ~stop;
+ buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+ buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+ buffer#remove_tag Tags.Script.tooltip ~start ~stop;
+ buffer#remove_tag Tags.Script.to_process ~start ~stop;
+ buffer#move_mark ~where:start (`NAME "start_of_input")
+ end;
+ List.iter (fun { start } -> buffer#delete_mark start) seg;
+ List.iter (fun { stop } -> buffer#delete_mark stop) seg
+
+ (** Wrapper around the raw undo command *)
+ method private backtrack_to_id ?(move_insert=true) (to_id, unfocus_needed) =
+ Minilib.log("backtrack_to_id "^Stateid.to_string to_id^
+ " (unfocus_needed="^string_of_bool unfocus_needed^")");
+ let opening () =
+ push_info "Coq is undoing" in
+ let conclusion () =
+ pop_info ();
+ if move_insert then buffer#place_cursor ~where:self#get_start_of_input;
+ let start = self#get_start_of_input in
+ let stop = self#get_end_of_input in
+ Minilib.log(Printf.sprintf "cleanup tags %d %d" start#offset stop#offset);
+ buffer#remove_tag Tags.Script.tooltip ~start ~stop;
+ buffer#remove_tag Tags.Script.processed ~start ~stop;
+ buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+ buffer#remove_tag Tags.Script.to_process ~start ~stop;
+ buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+ self#show_goals in
+ Coq.bind (Coq.lift opening) (fun () ->
+ let rec undo to_id unfocus_needed =
+ Coq.bind (Coq.edit_at to_id) (function
+ | Good (CSig.Inl (* NewTip *) ()) ->
+ if unfocus_needed then self#exit_focus;
+ self#cleanup (Doc.cut_at document to_id);
+ conclusion ()
+ | Good (CSig.Inr (* Focus *) (stop_id,(start_id,tip))) ->
+ if unfocus_needed then self#exit_focus;
+ self#cleanup (Doc.cut_at document tip);
+ self#enter_focus start_id stop_id;
+ self#cleanup (Doc.cut_at document to_id);
+ conclusion ()
+ | Fail (safe_id, loc, msg) ->
+ if loc <> None then messages#push Pp.Error "Fixme LOC";
+ messages#push Pp.Error msg;
+ if Stateid.equal safe_id Stateid.dummy then self#show_goals
+ else undo safe_id
+ (Doc.focused document && Doc.is_in_focus document safe_id))
+ in
+ undo to_id unfocus_needed)
+
+ method private backtrack_until ?move_insert until =
+ self#backtrack_to_id ?move_insert (self#find_id until)
+
+ method private backtrack_to_iter ?move_insert iter =
+ let until _ _ stop = iter#compare (buffer#get_iter_at_mark stop) >= 0 in
+ self#backtrack_until ?move_insert until
+
+ method private handle_failure_aux
+ ?(move_insert=false) (safe_id, (loc : (int * int) option), msg)
+ =
+ messages#clear;
+ messages#push Pp.Error msg;
+ ignore(self#process_feedback ());
+ if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ())
+ else
+ Coq.seq
+ (self#backtrack_until ~move_insert
+ (fun id _ _ -> id = Some safe_id))
+ (Coq.lift (fun () -> script#recenter_insert))
+
+ method handle_failure f = self#handle_failure_aux f
+
+ method backtrack_last_phrase =
+ messages#clear;
+ try
+ let tgt = Doc.before_tip document in
+ self#backtrack_to_id tgt
+ with Not_found -> Coq.return (Coq.reset_coqtop _ct)
+
+ method go_to_insert =
+ Coq.bind (Coq.return ()) (fun () ->
+ messages#clear;
+ let point = self#get_insert in
+ if point#compare self#get_start_of_input >= 0
+ then self#process_until_iter point
+ else self#backtrack_to_iter ~move_insert:false point)
+
+ method go_to_mark m =
+ Coq.bind (Coq.return ()) (fun () ->
+ messages#clear;
+ let point = buffer#get_iter_at_mark m in
+ if point#compare self#get_start_of_input >= 0
+ then Coq.seq (self#process_until_iter point)
+ (Coq.lift (fun () -> Sentence.tag_on_insert buffer))
+ else Coq.seq (self#backtrack_to_iter ~move_insert:false point)
+ (Coq.lift (fun () -> Sentence.tag_on_insert buffer)))
+
+ method tactic_wizard l =
+ let insert_phrase phrase tag =
+ let stop = self#get_start_of_input in
+ let phrase' = if stop#starts_line then phrase else "\n"^phrase in
+ buffer#insert ~iter:stop phrase';
+ Sentence.tag_on_insert buffer;
+ let start = self#get_start_of_input in
+ buffer#move_mark ~where:stop (`NAME "start_of_input");
+ buffer#apply_tag tag ~start ~stop;
+ if self#get_insert#compare stop <= 0 then
+ buffer#place_cursor ~where:stop;
+ let sentence =
+ mk_sentence
+ ~start:(`MARK (buffer#create_mark start))
+ ~stop:(`MARK (buffer#create_mark stop))
+ [] in
+ Doc.push document sentence;
+ messages#clear;
+ self#show_goals
+ in
+ let display_error (loc, s) =
+ if not (Glib.Utf8.validate s) then
+ flash_info "This error is so nasty that I can't even display it."
+ else messages#add s
+ in
+ let try_phrase phrase stop more =
+ let action = log "Sending to coq now" in
+ let query = Coq.query (phrase,Stateid.dummy) in
+ let next = function
+ | Fail (_, l, str) -> (* FIXME: check *)
+ display_error (l, str);
+ messages#add ("Unsuccessfully tried: "^phrase);
+ more
+ | Good msg ->
+ messages#add msg;
+ stop Tags.Script.processed
+ in
+ Coq.bind (Coq.seq action query) next
+ in
+ let rec loop l = match l with
+ | [] -> Coq.return ()
+ | p :: l' ->
+ try_phrase ("progress "^p^".") (insert_phrase (p^".")) (loop l')
+ in
+ loop l
+
+ method handle_reset_initial why =
+ let action () =
+ if why = Coq.Unexpected then warning "Coqtop died badly. Resetting."
+ else
+ (* clear the stack *)
+ if Doc.focused document then Doc.unfocus document;
+ while not (Doc.is_empty document) do
+ let phrase = Doc.pop document in
+ buffer#delete_mark phrase.start;
+ buffer#delete_mark phrase.stop
+ done;
+ List.iter
+ (buffer#remove_tag ~start:buffer#start_iter ~stop:buffer#end_iter)
+ Tags.Script.all;
+ (* reset the buffer *)
+ buffer#move_mark ~where:buffer#start_iter (`NAME "start_of_input");
+ buffer#move_mark ~where:buffer#end_iter (`NAME "stop_of_input");
+ Sentence.tag_all buffer;
+ (* clear the views *)
+ messages#clear;
+ proof#clear ();
+ clear_info ();
+ processed <- 0;
+ to_process <- 0;
+ push_info "Restarted";
+ (* apply the initial commands to coq *)
+ in
+ Coq.seq (Coq.lift action) self#initialize
+
+ method initialize =
+ let get_initial_state =
+ let next = function
+ | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return ()
+ | Good id -> initial_state <- id; Coq.return () in
+ Coq.bind (Coq.init (get_filename ())) next in
+ Coq.seq get_initial_state Coq.PrintOpt.enforce
+
+end
diff --git a/ide/coqOps.mli b/ide/coqOps.mli
new file mode 100644
index 00000000..8e76d3b2
--- /dev/null
+++ b/ide/coqOps.mli
@@ -0,0 +1,43 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Coq
+
+class type ops =
+object
+ method go_to_insert : unit task
+ method go_to_mark : GText.mark -> unit task
+ method tactic_wizard : string list -> unit task
+ method process_next_phrase : unit task
+ method process_until_end_or_error : unit task
+ method handle_reset_initial : Coq.reset_kind -> unit task
+ method raw_coq_query : string -> unit task
+ method show_goals : unit task
+ method backtrack_last_phrase : unit task
+ method initialize : unit task
+ method join_document : unit task
+ method stop_worker : string -> unit task
+
+ method get_n_errors : int
+ method get_errors : (int * string) list
+ method get_slaves_status : int * int * string CString.Map.t
+
+
+ method handle_failure : Interface.handle_exn_rty -> unit task
+
+ method destroy : unit -> unit
+end
+
+class coqops :
+ Wg_ScriptView.script_view ->
+ Wg_ProofView.proof_view ->
+ Wg_MessageView.message_view ->
+ Wg_Segment.segment ->
+ coqtop ->
+ (unit -> string option) ->
+ ops
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
index cd189981..995c45c5 100644
--- a/ide/coq_commands.ml
+++ b/ide/coq_commands.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -92,6 +92,7 @@ let commands = [
];
["Read Module";
"Record";
+ "Variant";
"Remark";
"Remove LoadPath";
"Remove Printing Constructor";
@@ -207,7 +208,8 @@ let state_preserving = [
"Recursive Extraction Library";
"Search";
- "SearchAbout";
+ "SearchAbout (* deprecated *)";
+ "SearchHead";
"SearchPattern";
"SearchRewrite";
diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll
index 1de102d5..e333c0b2 100644
--- a/ide/coq_lex.mll
+++ b/ide/coq_lex.mll
@@ -1,161 +1,57 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
{
- open Lexing
-
- type token =
- | Comment
- | Keyword
- | Declaration
- | ProofDeclaration
- | Qed
- | String
-
- (* Without this table, the automaton would be too big and
- ocamllex would fail *)
-
- let tag_of_ident =
- let one_word_commands =
- [ "Add" ; "Check"; "Eval"; "Extraction" ;
- "Load" ; "Undo"; "Goal";
- "Proof" ; "Print";"Save" ; "Restart";
- "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ]
- in
- let one_word_declarations =
- [ (* Definitions *)
- "Definition" ; "Let" ; "Example" ; "SubClass" ;
- "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ;
- (* Assumptions *)
- "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
- "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters";
- (* Inductive *)
- "Inductive" ; "CoInductive" ; "Record" ; "Structure" ;
- (* Other *)
- "Ltac" ; "Instance"; "Include"; "Context"; "Class" ;
- "Arguments" ]
- in
- let proof_declarations =
- [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ;
- "Proposition" ; "Property" ]
- in
- let proof_ends =
- [ "Qed" ; "Defined" ; "Admitted"; "Abort" ]
- in
- let constr_keywords =
- [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for";
- "end"; "as"; "let"; "in"; "if"; "then"; "else"; "return";
- "Prop"; "Set"; "Type" ]
- in
- let h = Hashtbl.create 97 in (* for vernac *)
- let h' = Hashtbl.create 97 in (* for constr *)
- List.iter (fun s -> Hashtbl.add h s Keyword) one_word_commands;
- List.iter (fun s -> Hashtbl.add h s Declaration) one_word_declarations;
- List.iter (fun s -> Hashtbl.add h s ProofDeclaration) proof_declarations;
- List.iter (fun s -> Hashtbl.add h s Qed) proof_ends;
- List.iter (fun s -> Hashtbl.add h' s Keyword) constr_keywords;
- (fun initial id -> Hashtbl.find (if initial then h else h') id)
-
exception Unterminated
- let here f lexbuf = f (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)
+ let utf8_adjust = ref 0
+ let utf8_lexeme_start lexbuf =
+ Lexing.lexeme_start lexbuf - !utf8_adjust
}
-let space =
- [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *)
+let space = [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *)
-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 ident = firstchar identchar*
-
-let undotted_sep = [ '{' '}' '-' '+' '*' ]
+let undotted_sep = '{' | '}' | '-'+ | '+'+ | '*'+
let dot_sep = '.' (space | eof)
-let multiword_declaration =
- "Module" (space+ "Type")?
-| "Program" space+ ident
-| "Existing" space+ "Instance" "s"?
-| "Canonical" space+ "Structure"
-
-let locality = (space+ "Local")?
-
-let multiword_command =
- ("Uns" | "S")" et" (space+ ident)*
-| (("Open" | "Close") locality | "Bind" | " Delimit" )
- space+ "Scope"
-| (("Reserved" space+)? "Notation" | "Infix") locality space+
-| "Next" space+ "Obligation"
-| "Solve" space+ "Obligations"
-| "Require" space+ ("Import"|"Export")?
-| "Hint" locality space+ ident
-| "Reset" (space+ "Initial")?
-| "Tactic" space+ "Notation"
-| "Implicit" space+ "Type" "s"?
-| "Combined" space+ "Scheme"
-| "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))|
- ("Library"|"Inline"|"NoInline"|"Blacklist"))
-| "Recursive" space+ "Extraction" (space+ "Library")?
-| ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist")
-| "Extract" space+ (("Inlined" space+) "Constant"| "Inductive")
-| "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque")
-| ("Generalizable" space+) ("All" | "No")? "Variable" "s"?
-
-(* At least still missing: "Inline" + decl, variants of "Identity
- Coercion", variants of Print, Add, ... *)
+let utf8_extra_byte = [ '\x80' - '\xBF' ]
rule coq_string = parse
| "\"\"" { coq_string lexbuf }
- | "\"" { Lexing.lexeme_end lexbuf }
- | eof { Lexing.lexeme_end lexbuf }
+ | "\"" { () }
+ | eof { () }
+ | utf8_extra_byte { incr utf8_adjust; coq_string lexbuf }
| _ { coq_string lexbuf }
and comment = parse
- | "(*" { ignore (comment lexbuf); comment lexbuf }
- | "\"" { ignore (coq_string lexbuf); comment lexbuf }
- | "*)" { (true, Lexing.lexeme_start lexbuf + 2) }
- | eof { (false, Lexing.lexeme_end lexbuf) }
+ | "(*" { let _ = comment lexbuf in comment lexbuf }
+ | "\"" { let () = coq_string lexbuf in comment lexbuf }
+ | "*)" { Some (utf8_lexeme_start lexbuf) }
+ | eof { None }
+ | utf8_extra_byte { incr utf8_adjust; comment lexbuf }
| _ { comment lexbuf }
+(** NB : [mkiter] should be called on increasing offsets *)
+
and sentence initial stamp = parse
| "(*" {
- let comm_start = Lexing.lexeme_start lexbuf in
- let trully_terminated,comm_end = comment lexbuf in
- stamp comm_start comm_end Comment;
- if not trully_terminated then raise Unterminated;
- (* A comment alone is a sentence.
- A comment in a sentence doesn't terminate the sentence.
- Note: comm_end is the first position _after_ the comment,
- as required when tagging a zone, hence the -1 to locate the
- ")" terminating the comment.
- *)
- if initial then comm_end - 1 else sentence false stamp lexbuf
+ match comment lexbuf with
+ | None -> raise Unterminated
+ | Some comm_last ->
+ stamp comm_last Tags.Script.comment;
+ sentence initial stamp lexbuf
}
| "\"" {
- let str_start = Lexing.lexeme_start lexbuf in
- let str_end = coq_string lexbuf in
- stamp str_start str_end String;
- sentence false stamp lexbuf
- }
- | multiword_declaration {
- if initial then here stamp lexbuf Declaration;
+ let () = coq_string lexbuf in
sentence false stamp lexbuf
}
- | multiword_command {
- if initial then here stamp lexbuf Keyword;
- sentence false stamp lexbuf
- }
- | ident as id {
- (try here stamp lexbuf (tag_of_ident initial id) with Not_found -> ());
- sentence false stamp lexbuf }
| ".." {
(* We must have a particular rule for parsing "..", where no dot
is a terminator, even if we have a blank afterwards
@@ -164,32 +60,38 @@ and sentence initial stamp = parse
special case, where the third dot is a terminator. *)
sentence false stamp lexbuf
}
- | dot_sep { Lexing.lexeme_start lexbuf } (* The usual "." terminator *)
+ | dot_sep {
+ (* The usual "." terminator *)
+ stamp (utf8_lexeme_start lexbuf) Tags.Script.sentence;
+ sentence true stamp lexbuf
+ }
| undotted_sep {
(* Separators like { or } and bullets * - + are only active
at the start of a sentence *)
- if initial then Lexing.lexeme_start lexbuf
- else sentence false stamp lexbuf
+ if initial then stamp (utf8_lexeme_start lexbuf + String.length (Lexing.lexeme lexbuf) - 1) Tags.Script.sentence;
+ sentence initial stamp lexbuf
}
| space+ {
(* Parsing spaces is the only situation preserving initiality *)
sentence initial stamp lexbuf
}
+ | utf8_extra_byte { incr utf8_adjust; sentence false stamp lexbuf }
+ | eof { if initial then () else raise Unterminated }
| _ {
(* Any other characters *)
sentence false stamp lexbuf
}
- | eof { raise Unterminated }
{
- (** Parse a sentence in string [slice], tagging relevant parts with
- function [stamp], and returning the position of the first
- sentence delimitor (either "." or "{" or "}" or the end of a comment).
- It will raise [Unterminated] when no end of sentence is found.
+ (** Parse sentences in string [slice], tagging last characters
+ of sentences with the [stamp] function.
+ It will raise [Unterminated] if [slice] ends with an unfinished
+ sentence.
*)
- let delimit_sentence stamp slice =
+ let delimit_sentences stamp slice =
+ utf8_adjust := 0;
sentence true stamp (Lexing.from_string slice)
}
diff --git a/ide/coq_style.xml b/ide/coq_style.xml
new file mode 100644
index 00000000..67631d34
--- /dev/null
+++ b/ide/coq_style.xml
@@ -0,0 +1,26 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<style-scheme id="coq_style" _name="Coq highlighting based on Ssr manual"
+ parent-scheme="classic" version="1.0">
+<author>The Coq Dev Team</author>
+<_description>Coq/Ssreflect color scheme for the vernacular language</_description>
+
+<style name="coq:comment" foreground="#brown"/>
+<style name="coq:coqdoc" foreground="#brown" italic="true"/>
+<style name="coq:vernac-keyword" bold="true" foreground="#dark violet"/>
+<style name="coq:gallina-keyword" bold="true" foreground="#orange red"/>
+<style name="coq:identifier" foreground="#navy"/>
+<style name="coq:constr-keyword" foreground="#dark green"/>
+<style name="coq:constr-sort" foreground="#008080"/>
+
+<style name="coq-ssreflect:comment" foreground="#b22222"/>
+<style name="coq-ssreflect:coqdoc" foreground="#b22222" italic="true"/>
+<style name="coq-ssreflect:vernac-keyword" bold="true" foreground="#a021f0"/>
+<style name="coq-ssreflect:gallina-keyword" bold="true" foreground="#a021f0"/>
+<style name="coq-ssreflect:identifier" bold="true" foreground="#0000ff"/>
+<style name="coq-ssreflect:constr-keyword" foreground="#228b22"/>
+<style name="coq-ssreflect:constr-sort" foreground="#228b22"/>
+<style name="coq-ssreflect:tactic" foreground="#101092"/>
+<style name="coq-ssreflect:endtactic" foreground="#ff3f3f"/>
+<style name="coq-ssreflect:iterator" foreground="#be6ad4"/>
+<style name="coq-ssreflect:string" foreground="#8b2252"/>
+</style-scheme>
diff --git a/ide/coqide-gtk2rc b/ide/coqide-gtk2rc
deleted file mode 100644
index 9da99551..00000000
--- a/ide/coqide-gtk2rc
+++ /dev/null
@@ -1,39 +0,0 @@
-# Some default functions for CoqIde. You may copy the file in $XDG_CONFIG_HOME
-# ($HOME/.config/coq/) and edit as you want. See
-# http://developer.gnome.org/doc/API/2.0/gtk/gtk-Resource-Files.html
-# for a complete set of options
-# To set the font of the text windows, edit the .coqiderc file through the menus.
-
-gtk-key-theme-name = "Emacs"
-
-#pixmap_path "/home/"
-
-binding "text" {
- bind "<ctrl>k" { "set-anchor" ()
- "move-cursor" (display-line-ends,1,0)
- "move-cursor" (visual-positions,1,0)
- "cut-clipboard" ()
- }
- bind "<ctrl>w" { "cut-clipboard" () }
-
-# For UTF-8 inputs !
-# bind "F11" {"insert-at-cursor" ("∀")}
-# bind "F12" {"insert-at-cursor" ("∃")}
-}
-class "GtkTextView" binding "text"
-
-
-gtk-font-name = "Sans 12"
-
-style "location" {
-font_name = "Sans 10"
-}
-widget "*location*" style "location"
-
-
-gtk-can-change-accels = 1
-
-style "men" {
-#
-}
-widget "GtkMenu" style "men"
diff --git a/ide/coqide.ml b/ide/coqide.ml
index c7e14007..fa64defa 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -9,1418 +9,483 @@
open Preferences
open Gtk_parsing
open Ideutils
+open Session
-type ide_info = {
- start : GText.mark;
- stop : GText.mark;
-}
-
-(** Have we used admit or declarative mode's daimon ?
- If yes, we color differently *)
-
-type safety = Safe | Unsafe
-
-let safety_tag = function
- | Safe -> Tags.Script.processed
- | Unsafe -> Tags.Script.unjustified
-
-class type analyzed_views=
-object
- val mutable act_id : GtkSignal.id option
- val input_buffer : GText.buffer
- val input_view : Undo.undoable_view
- val last_array : string array
- val mutable last_index : bool
- val message_buffer : GText.buffer
- val message_view : GText.view
- val proof_buffer : GText.buffer
- val proof_view : GText.view
- val cmd_stack : ide_info Stack.t
- val mycoqtop : Coq.coqtop ref
- val mutable is_active : bool
- val mutable read_only : bool
- val mutable filename : string option
- val mutable stats : Unix.stats option
- method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b
- method set_auto_complete : bool -> unit
-
- method filename : string option
- method stats : Unix.stats option
- method update_stats : unit
- method revert : unit
- method auto_save : unit
- method save : string -> bool
- method save_as : string -> bool
- method read_only : bool
- method set_read_only : bool -> unit
- method is_active : bool
- method activate : unit -> unit
- method active_keypress_handler : GdkEvent.Key.t -> bool
- method backtrack_to : GText.iter -> unit
- method backtrack_to_no_lock : GText.iter -> unit
- method clear_message : unit
- method find_phrase_starting_at :
- GText.iter -> (GText.iter * GText.iter) option
- method get_insert : GText.iter
- method get_start_of_input : GText.iter
- method go_to_insert : unit
- method indent_current_line : unit
- method go_to_next_occ_of_cur_word : unit
- method go_to_prev_occ_of_cur_word : unit
- method insert_command : string -> string -> unit
- method tactic_wizard : string list -> unit
- method insert_message : string -> unit
- method process_next_phrase : bool -> unit
- method process_until_iter_or_error : GText.iter -> unit
- method process_until_end_or_error : unit
- method recenter_insert : unit
- method reset_initial : unit
- method force_reset_initial : unit
- method set_message : string -> unit
- method raw_coq_query : string -> unit
- method show_goals : unit
- method show_goals_full : unit
- method undo_last_step : unit
- method help_for_keyword : unit -> unit
- method complete_at_offset : int -> bool
-end
+(** Note concerning GtkTextBuffer
+ Be careful with gtk calls on text buffers, since many are non-atomic :
+ they emit a gtk signal and the handlers for this signal are run
+ immediately, before returning to the current function.
+ Here's a partial list of these signals and the methods that
+ trigger them (cf. documentation of GtkTextBuffer, signal section)
-type viewable_script =
- {script : Undo.undoable_view;
- tab_label : GMisc.label;
- mutable filename : string;
- mutable encoding : string;
- proof_view : GText.view;
- message_view : GText.view;
- analyzed_view : analyzed_views;
- toplvl : Coq.coqtop ref;
- command : Command_windows.command_window;
- }
-
-let kill_session s =
- (* To close the detached views of this script, we call manually
- [destroy] on it, triggering some callbacks in [detach_view].
- In a more modern lablgtk, rather use the page-removed signal ? *)
- s.script#destroy ();
- Coq.kill_coqtop !(s.toplvl)
-
-let build_session s =
- let session_paned = GPack.paned `VERTICAL () in
- let eval_paned = GPack.paned `HORIZONTAL ~border_width:5
- ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in
- let script_frame = GBin.frame ~shadow_type:`IN
- ~packing:eval_paned#add1 () in
- let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
- ~packing:script_frame#add () in
- let state_paned = GPack.paned `VERTICAL
- ~packing:eval_paned#add2 () in
- let proof_frame = GBin.frame ~shadow_type:`IN
- ~packing:state_paned#add1 () in
- let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
- ~packing:proof_frame#add () in
- let message_frame = GBin.frame ~shadow_type:`IN
- ~packing:state_paned#add2 () in
- let message_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
- ~packing:message_frame#add () in
- let session_tab = GPack.hbox ~homogeneous:false () in
- let img = GMisc.image ~icon_size:`SMALL_TOOLBAR
- ~packing:session_tab#pack () in
- let _ =
- s.script#buffer#connect#modified_changed
- ~callback:(fun () -> if s.script#buffer#modified
- then img#set_stock `SAVE
- else img#set_stock `YES) in
- let _ =
- eval_paned#misc#connect#size_allocate
- ~callback:
- (let old_paned_width = ref 2 in
- let old_paned_height = ref 2 in
- (fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
- if !old_paned_width <> paned_width || !old_paned_height <> paned_height then (
- eval_paned#set_position (eval_paned#position * paned_width / !old_paned_width);
- state_paned#set_position (state_paned#position * paned_height / !old_paned_height);
- old_paned_width := paned_width;
- old_paned_height := paned_height;
- )))
- in
- session_paned#pack2 ~shrink:false ~resize:false (s.command#frame#coerce);
- script_scroll#add s.script#coerce;
- proof_scroll#add s.proof_view#coerce;
- message_scroll#add s.message_view#coerce;
- session_tab#pack s.tab_label#coerce;
- img#set_stock `YES;
- eval_paned#set_position 1;
- state_paned#set_position 1;
- (Some session_tab#coerce,None,session_paned#coerce)
-
-let session_notebook =
- Typed_notebook.create build_session kill_session
- ~border_width:2 ~show_border:false ~scrollable:true ()
+ begin_user_action : #begin_user_action, #insert_interactive,
+ #insert_range_interactive, #delete_interactive, #delete_selection
+ end_user_action : #end_user_action, #insert_interactive,
+ #insert_range_interactive, #delete_interactive, #delete_selection
-let cb = GData.clipboard Gdk.Atom.primary
+ insert_text : #insert (and variants)
+ delete_range : #delete (and variants)
-let last_cb_content = ref ""
+ apply_tag : #apply_tag, (and some #insert)
+ remove_tag : #remove_tag
-let update_notebook_pos () =
- let pos =
- match !current.vertical_tabs, !current.opposite_tabs with
- | false, false -> `TOP
- | false, true -> `BOTTOM
- | true , false -> `LEFT
- | true , true -> `RIGHT
- in
- session_notebook#set_tab_pos pos
+ mark_deleted : #delete_mark
+ mark_set : #create_mark, #move_mark
-let to_do_on_page_switch = ref []
+ changed : ... (whenever a buffer has changed)
+ modified_changed : #set_modified (and whenever the modified bit flips)
+ Caveat : when the buffer is modified, all iterators on it become
+ invalid and shouldn't be used (nasty errors otherwise). There are
+ some special cases : boundaries given to #insert and #delete are
+ revalidated by the default signal handler.
+*)
-(** * Coqide's handling of signals *)
+(** {2 Some static elements } *)
-(** We ignore Ctrl-C, and for most of the other catchable signals
- we launch an emergency save of opened files and then exit *)
+let prefs = Preferences.current
-let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
- Sys.sigill; Sys.sigpipe; Sys.sigquit;
- (* Sys.sigsegv; Sys.sigterm;*) Sys.sigusr2]
+(** The arguments that will be passed to coqtop. No quoting here, since
+ no /bin/sh when using create_process instead of open_process. *)
+let custom_project_files = ref []
+let sup_args = ref []
-let crash_save i =
- (* ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*)
- Minilib.safe_prerr_endline "Trying to save all buffers in .crashcoqide files";
- let count = ref 0 in
- List.iter
- (function {script=view; analyzed_view = av } ->
- (let filename = match av#filename with
- | None ->
- incr count;
- "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
- | Some f -> f^".crashcoqide"
- in
- try
- if try_export filename (view#buffer#get_text ()) then
- Minilib.safe_prerr_endline ("Saved "^filename)
- else Minilib.safe_prerr_endline ("Could not save "^filename)
- with _ -> Minilib.safe_prerr_endline ("Could not save "^filename))
- )
- session_notebook#pages;
- Minilib.safe_prerr_endline "Done. Please report.";
- if i <> 127 then exit i
-
-let ignore_break () =
- List.iter
- (fun i ->
- try Sys.set_signal i (Sys.Signal_handle crash_save)
- with _ -> prerr_endline "Signal ignored (normal if Win32)")
- signals_to_crash;
- (* We ignore the Ctrl-C, this is required for the Stop button to work,
- since we will actually send Ctrl-C to all processes sharing
- our console (including us) *)
- Sys.set_signal Sys.sigint Sys.Signal_ignore
-
-
-(** * Locks *)
-
-(* Locking machinery for Coq kernel *)
-let coq_computing = Mutex.create ()
-
-(* To prevent Coq from interrupting during undoing...*)
-let coq_may_stop = Mutex.create ()
-
-(* To prevent a force_reset_initial during a force_reset_initial *)
-let resetting = Mutex.create ()
-
-exception RestartCoqtop
-exception Unsuccessful
-
-let force_reset_initial () =
- prerr_endline "Reset Initial";
- session_notebook#current_term.analyzed_view#force_reset_initial
-
-let break () =
- prerr_endline "User break received";
- Coq.break_coqtop !(session_notebook#current_term.toplvl)
-
-let do_if_not_computing text f x =
- let threaded_task () =
- if Mutex.try_lock coq_computing then
- begin
- prerr_endline "Getting lock";
- List.iter
- (fun elt -> try f elt with
- | RestartCoqtop -> elt.analyzed_view#reset_initial
- | Sys_error str ->
- elt.analyzed_view#reset_initial;
- elt.analyzed_view#set_message
- ("Unable to communicate with coqtop, restarting coqtop.\n"^
- "Error was: "^str)
- | e ->
- Mutex.unlock coq_computing;
- elt.analyzed_view#set_message
- ("Unknown error, please report:\n"^(Printexc.to_string e)))
- x;
- prerr_endline "Releasing lock";
- Mutex.unlock coq_computing;
- end
- else
- prerr_endline "Discarded order (computations are ongoing)"
- in
- prerr_endline ("Launching thread " ^ text);
- ignore (Glib.Timeout.add ~ms:300 ~callback:
- (fun () -> if Mutex.try_lock coq_computing
- then (Mutex.unlock coq_computing; false)
- else (pbar#pulse (); true)));
- ignore (Thread.create threaded_task ())
-
-let warning msg =
- GToolbox.message_box ~title:"Warning"
- ~icon:(let img = GMisc.image () in
- img#set_stock `DIALOG_WARNING;
- img#set_icon_size `DIALOG;
- img#coerce)
- msg
-
-let remove_current_view_page () =
- let do_remove () =
- let c = session_notebook#current_page in
- session_notebook#remove_page c
- in
- let current = session_notebook#current_term in
- if not current.script#buffer#modified then do_remove ()
- else
- match GToolbox.question_box ~title:"Close"
- ~buttons:["Save Buffer and Close";
- "Close without Saving";
- "Don't Close"]
- ~default:0
- ~icon:(let img = GMisc.image () in
- img#set_stock `DIALOG_WARNING;
- img#set_icon_size `DIALOG;
- img#coerce)
- "This buffer has unsaved modifications"
- with
- | 1 ->
- begin match current.analyzed_view#filename with
- | None ->
- begin match select_file_for_save ~title:"Save file" () with
- | None -> ()
- | Some f ->
- if current.analyzed_view#save_as f then begin
- flash_info ("File " ^ f ^ " saved") ;
- do_remove ()
- end else
- warning ("Save Failed (check if " ^ f ^ " is writable)")
- end
- | Some f ->
- if current.analyzed_view#save f then begin
- flash_info ("File " ^ f ^ " saved") ;
- do_remove ()
- end else
- warning ("Save Failed (check if " ^ f ^ " is writable)")
- end
- | 2 -> do_remove ()
- | _ -> ()
+let logfile = ref None
-module Opt = Coq.PrintOpt
+(** {2 Notebook of sessions } *)
-let print_items = [
- ([Opt.implicit],"Display implicit arguments","Display _implicit arguments",
- "i",false);
- ([Opt.coercions],"Display coercions","Display _coercions","c",false);
- ([Opt.raw_matching],"Display raw matching expressions",
- "Display raw _matching expressions","m",true);
- ([Opt.notations],"Display notations","Display _notations","n",true);
- ([Opt.all_basic],"Display all basic low-level contents",
- "Display _all basic low-level contents","a",false);
- ([Opt.existential],"Display existential variable instances",
- "Display _existential variable instances","e",false);
- ([Opt.universes],"Display universe levels","Display _universe levels",
- "u",false);
- ([Opt.all_basic;Opt.existential;Opt.universes], "Display all low-level contents",
- "Display all _low-level contents","l",false)
-]
+(** The main element of coqide is a notebook of session views *)
-let setopts ct opts v =
- let opts = List.map (fun o -> (o, v)) opts in
- Coq.PrintOpt.set ct opts
-
-(* Reset this to None on page change ! *)
-let (last_completion:(string*int*int*bool) option ref) = ref None
-
-let () = to_do_on_page_switch :=
- (fun i -> last_completion := None)::!to_do_on_page_switch
-
-let rec complete input_buffer w (offset:int) =
- match !last_completion with
- | Some (lw,loffset,lpos,backward)
- when lw=w && loffset=offset ->
- begin
- let iter = input_buffer#get_iter (`OFFSET lpos) in
- if backward then
- match complete_backward w iter with
- | None ->
- last_completion :=
- Some (lw,loffset,
- (find_word_end
- (input_buffer#get_iter (`OFFSET loffset)))#offset ,
- false);
- None
- | Some (ss,start,stop) as result ->
- last_completion :=
- Some (w,offset,ss#offset,true);
- result
- else
- match complete_forward w iter with
- | None ->
- last_completion := None;
- None
- | Some (ss,start,stop) as result ->
- last_completion :=
- Some (w,offset,ss#offset,false);
- result
- end
- | _ -> begin
- match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
- | None ->
- last_completion :=
- Some (w,offset,(find_word_end (input_buffer#get_iter
- (`OFFSET offset)))#offset,false);
- complete input_buffer w offset
- | Some (ss,start,stop) as result ->
- last_completion := Some (w,offset,ss#offset,true);
- result
- end
+let notebook =
+ Wg_Notebook.create Session.build_layout Session.kill
+ ~border_width:2 ~show_border:false ~scrollable:true ()
-let get_current_word () =
- match session_notebook#current_term,cb#text with
- | {script=script; analyzed_view=av;},None ->
- prerr_endline "None selected";
- let it = av#get_insert in
- let start = find_word_start it in
- let stop = find_word_end start in
- script#buffer#move_mark `SEL_BOUND ~where:start;
- script#buffer#move_mark `INSERT ~where:stop;
- script#buffer#get_text ~slice:true ~start ~stop ()
- | _,Some t ->
- prerr_endline "Some selected";
- prerr_endline t;
- t
-
-
-let input_channel b ic =
- let buf = String.create 1024 and len = ref 0 in
- while len := input ic buf 0 1024; !len > 0 do
- Buffer.add_substring b buf 0 !len
- done
-
-let with_file handler name ~f =
- try
- let ic = open_in_gen [Open_rdonly;Open_creat] 0o644 name in
- try f ic; close_in ic with e -> close_in ic; raise e
- with Sys_error s -> handler s
-
-(* For find_phrase_starting_at *)
-exception Stop of int
-
-let tag_of_sort = function
- | Coq_lex.Comment -> Tags.Script.comment
- | Coq_lex.Keyword -> Tags.Script.kwd
- | Coq_lex.Declaration -> Tags.Script.decl
- | Coq_lex.ProofDeclaration -> Tags.Script.proof_decl
- | Coq_lex.Qed -> Tags.Script.qed
- | Coq_lex.String -> failwith "No tag"
-
-let apply_tag (buffer:GText.buffer) orig off_conv from upto sort =
- try
- let tag = tag_of_sort sort in
- let start = orig#forward_chars (off_conv from) in
- let stop = orig#forward_chars (off_conv upto) in
- buffer#apply_tag ~start ~stop tag
- with _ -> ()
-
-let remove_tags (buffer:GText.buffer) from upto =
- List.iter (buffer#remove_tag ~start:from ~stop:upto)
- [ Tags.Script.comment; Tags.Script.kwd; Tags.Script.decl;
- Tags.Script.proof_decl; Tags.Script.qed ]
-
-(** Cut a part of the buffer in sentences and tag them.
- Invariant: either this slice ends the buffer, or it ends with ".".
- May raise [Coq_lex.Unterminated] when the zone ends with
- an unterminated sentence. *)
-
-let split_slice_lax (buffer:GText.buffer) from upto =
- remove_tags buffer from upto;
- buffer#remove_tag ~start:from ~stop:upto Tags.Script.sentence;
- let slice = buffer#get_text ~start:from ~stop:upto () in
- let rec split_substring str =
- let off_conv = byte_offset_to_char_offset str in
- let slice_len = String.length str in
- let end_off = Coq_lex.delimit_sentence (apply_tag buffer from off_conv) str
- in
- let start = from#forward_chars (off_conv end_off) in
- let stop = start#forward_char in
- buffer#apply_tag ~start ~stop Tags.Script.sentence;
- let next = end_off + 1 in
- if next < slice_len then begin
- ignore (from#nocopy#forward_chars (off_conv next));
- split_substring (String.sub str next (slice_len - next))
- end
- in
- split_substring slice
-(** Searching forward and backward a position fulfilling some condition *)
+(** {2 Callback functions for the user interface } *)
-let rec forward_search cond (iter:GText.iter) =
- if iter#is_end || cond iter then iter
- else forward_search cond iter#forward_char
+let on_current_term f =
+ let term = try Some notebook#current_term with Invalid_argument _ -> None in
+ match term with
+ | None -> ()
+ | Some t -> ignore (f t)
-let rec backward_search cond (iter:GText.iter) =
- if iter#is_start || cond iter then iter
- else backward_search cond iter#backward_char
+let cb_on_current_term f _ = on_current_term f
-let is_sentence_end s = s#has_tag Tags.Script.sentence
-let is_char s c = s#char = Char.code c
+(** Nota: using && here has the advantage of working both under win32 and unix.
+ If someday we want the main command to be tried even if the "cd" has failed,
+ then we should use " ; " under unix but " & " under win32 (cf. #2363). *)
-(** Search backward the first character of a sentence, starting at [iter]
- and going at most up to [soi] (meant to be the end of the locked zone).
- Raise [StartError] when no proper sentence start has been found.
- A character following a ending "." is considered as a sentence start
- only if this character is a blank. In particular, when a final "."
- at the end of the locked zone isn't followed by a blank, then this
- non-blank character will be signaled as erroneous in [tag_on_insert] below.
-*)
+let local_cd file =
+ "cd " ^ Filename.quote (Filename.dirname file) ^ " && "
-exception StartError
+let pr_exit_status = function
+ | Unix.WEXITED 0 -> " succeeded"
+ | _ -> " failed"
-let grab_sentence_start (iter:GText.iter) soi =
- let cond iter =
- if iter#compare soi < 0 then raise StartError;
- let prev = iter#backward_char in
- is_sentence_end prev &&
- (not (is_char prev '.') ||
- List.exists (is_char iter) [' ';'\n';'\r';'\t'])
- in
- backward_search cond iter
+let make_coqtop_args = function
+ |None -> !sup_args
+ |Some the_file ->
+ let get_args f = Project_file.args_from_project f
+ !custom_project_files prefs.project_file_name
+ in
+ match prefs.read_project with
+ |Ignore_args -> !sup_args
+ |Append_args -> get_args the_file @ !sup_args
+ |Subst_args -> get_args the_file
+
+(** Setting drag & drop on widgets *)
+
+let load_file_cb : (string -> unit) ref = ref ignore
+
+let drop_received context ~x ~y data ~info ~time =
+ if data#format = 8 then begin
+ let files = Str.split (Str.regexp "\r?\n") data#data in
+ let path = Str.regexp "^file://\\(.*\\)$" in
+ List.iter (fun f ->
+ if Str.string_match path f 0 then
+ !load_file_cb (Str.matched_group 1 f)
+ ) files;
+ context#finish ~success:true ~del:false ~time
+ end else context#finish ~success:false ~del:false ~time
+
+let drop_targets = [
+ { Gtk.target = "text/uri-list"; Gtk.flags = []; Gtk.info = 0}
+]
-(** Search forward the first character immediately after a sentence end *)
+let set_drag (w : GObj.drag_ops) =
+ w#dest_set drop_targets ~actions:[`COPY;`MOVE];
+ w#connect#data_received ~callback:drop_received
-let rec grab_sentence_stop (start:GText.iter) =
- (forward_search is_sentence_end start)#forward_char
+(** Session management *)
-(** Search forward the first character immediately after a "." sentence end
- (and not just a "{" or "}" or comment end *)
+let create_session f =
+ let ans = Session.create f (make_coqtop_args f) in
+ let _ = set_drag ans.script#drag in
+ ans
-let rec grab_ending_dot (start:GText.iter) =
- let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in
- (forward_search is_ending_dot start)#forward_char
+(** Auxiliary functions for the File operations *)
-(** Retag a zone that has been edited *)
+module FileAux = struct
-let tag_on_insert buffer =
- (* the start of the non-locked zone *)
- let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
- (* the inserted zone is between [prev_insert] and [insert] *)
- let insert = buffer#get_iter_at_mark `INSERT in
- let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in
- (* [prev] is normally always before [insert] even when deleting.
- Let's check this nonetheless *)
- let prev, insert =
- if insert#compare prev < 0 then insert, prev else prev, insert
- in
+let load_file ?(maycreate=false) f =
+ let f = CUnix.correct_path f (Sys.getcwd ()) in
try
- let start = grab_sentence_start prev soi in
- (** The status of "{" "}" as sentence delimiters is too fragile.
- We retag up to the next "." instead. *)
- let stop = grab_ending_dot insert in
- try split_slice_lax buffer start stop
- with Coq_lex.Unterminated ->
- (* This shouldn't happen frequently. Either:
- - we are at eof, with indeed an unfinished sentence.
- - we have just inserted an opening of comment or string.
- - the inserted text ends with a "." that interacts with the "."
- found by [grab_ending_dot] to form a non-ending "..".
- In any case, we retag up to eof, since this isn't that costly. *)
- if not stop#is_end then
- try split_slice_lax buffer start buffer#end_iter
- with Coq_lex.Unterminated -> ()
- with StartError ->
- buffer#apply_tag Tags.Script.error ~start:soi ~stop:soi#forward_char
-
-let force_retag buffer =
- try split_slice_lax buffer buffer#start_iter buffer#end_iter
- with Coq_lex.Unterminated -> ()
-
-let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) =
- (* move back twice if not into proof_decl,
- * once if into proof_decl and back_char into_proof_decl,
- * don't move if into proof_decl and back_char not into proof_decl *)
- if not (cursor#has_tag Tags.Script.proof_decl) then
- ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl));
- if cursor#backward_char#has_tag Tags.Script.proof_decl then
- ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl));
- let decl_start = cursor in
- let prf_end = decl_start#forward_to_tag_toggle (Some Tags.Script.qed) in
- let decl_end = grab_ending_dot decl_start in
- let prf_end = grab_ending_dot prf_end in
- let prf_end = prf_end#forward_char in
- if decl_start#has_tag Tags.Script.folded then (
- buffer#remove_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
- buffer#remove_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden)
- else (
- buffer#apply_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
- buffer#apply_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden)
+ Minilib.log "Loading file starts";
+ let is_f = CUnix.same_file f in
+ let rec search_f i = function
+ | [] -> false
+ | sn :: sessions ->
+ match sn.fileops#filename with
+ | Some fn when is_f fn -> notebook#goto_page i; true
+ | _ -> search_f (i+1) sessions
+ in
+ if not (search_f 0 notebook#pages) then begin
+ Minilib.log "Loading: get raw content";
+ let b = Buffer.create 1024 in
+ if Sys.file_exists f then Ideutils.read_file f b
+ else if not maycreate then flash_info ("Load failed: no such file");
+ Minilib.log "Loading: convert content";
+ let s = do_convert (Buffer.contents b) in
+ Minilib.log "Loading: create view";
+ let session = create_session (Some f) in
+ let index = notebook#append_term session in
+ notebook#goto_page index;
+ Minilib.log "Loading: stats";
+ session.fileops#update_stats;
+ let input_buffer = session.buffer in
+ Minilib.log "Loading: fill buffer";
+ input_buffer#set_text s;
+ input_buffer#set_modified false;
+ input_buffer#place_cursor ~where:input_buffer#start_iter;
+ Sentence.tag_all input_buffer;
+ session.script#clear_undo ();
+ !refresh_editor_hook ();
+ Minilib.log "Loading: success";
+ end
+ with e -> flash_info ("Load failed: "^(Printexc.to_string e))
+
+let confirm_save ok =
+ if ok then flash_info "Saved" else warning "Save Failed"
+
+let select_and_save ~saveas ?filename sn =
+ let do_save = if saveas then sn.fileops#saveas else sn.fileops#save in
+ let title = if saveas then "Save file as" else "Save file" in
+ match select_file_for_save ~title ?filename () with
+ |None -> false
+ |Some f ->
+ let ok = do_save f in
+ confirm_save ok;
+ if ok then sn.tab_label#set_text (Filename.basename f);
+ ok
+
+let check_save ~saveas sn =
+ try match sn.fileops#filename with
+ |None -> select_and_save ~saveas sn
+ |Some f ->
+ let ok = sn.fileops#save f in
+ confirm_save ok;
+ ok
+ with _ -> warning "Save Failed"; false
+
+exception DontQuit
+
+let check_quit saveall =
+ (try save_pref () with _ -> flash_info "Cannot save preferences");
+ let is_modified sn = sn.buffer#modified in
+ if List.exists is_modified notebook#pages then begin
+ let answ = GToolbox.question_box ~title:"Quit"
+ ~buttons:["Save Named Buffers and Quit";
+ "Quit without Saving";
+ "Don't Quit"]
+ ~default:0
+ ~icon:(warn_image ())#coerce
+ "There are unsaved buffers"
+ in
+ match answ with
+ | 1 -> saveall ()
+ | 2 -> ()
+ | _ -> raise DontQuit
+ end;
+ List.iter (fun sn -> Coq.close_coqtop sn.coqtop) notebook#pages
+
+(* For MacOS, just to be sure, we close all coqtops (again?) *)
+let close_and_quit () =
+ List.iter (fun sn -> Coq.close_coqtop sn.coqtop) notebook#pages;
+ exit 0
+
+let crash_save exitcode =
+ Minilib.log "Starting emergency save of buffers in .crashcoqide files";
+ let idx =
+ let r = ref 0 in
+ fun () -> incr r; string_of_int !r
+ in
+ let save_session sn =
+ let filename = match sn.fileops#filename with
+ | None -> "Unnamed_coqscript_" ^ idx () ^ ".crashcoqide"
+ | Some f -> f^".crashcoqide"
+ in
+ try
+ if try_export filename (sn.buffer#get_text ()) then
+ Minilib.log ("Saved "^filename)
+ else Minilib.log ("Could not save "^filename)
+ with _ -> Minilib.log ("Could not save "^filename)
+ in
+ List.iter save_session notebook#pages;
+ Minilib.log "End emergency save";
+ exit exitcode
-(** The arguments that will be passed to coqtop. No quoting here, since
- no /bin/sh when using create_process instead of open_process. *)
-let custom_project_files = ref []
-let sup_args = ref []
+end
-class analyzed_view (_script:Undo.undoable_view) (_pv:GText.view) (_mv:GText.view) _cs _ct _fn =
-object(self)
- val input_view = _script
- val input_buffer = _script#buffer
- val proof_view = _pv
- val proof_buffer = _pv#buffer
- val message_view = _mv
- val message_buffer = _mv#buffer
- val cmd_stack = _cs
- val mycoqtop = _ct
- val mutable is_active = false
- val mutable read_only = false
- val mutable filename = _fn
- val mutable stats = None
- val mutable last_modification_time = 0.
- val mutable last_auto_save_time = 0.
- val mutable find_forward_instead_of_backward = false
-
- val mutable auto_complete_on = !current.auto_complete
- val hidden_proofs = Hashtbl.create 32
-
- method private toggle_auto_complete =
- auto_complete_on <- not auto_complete_on
- method set_auto_complete t = auto_complete_on <- t
- method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x ->
- let old = auto_complete_on in
- self#set_auto_complete false;
- let y = f x in
- self#set_auto_complete old;
- y
-
- method filename = filename
- method stats = stats
- method update_stats =
- match filename with
- | Some f -> stats <- my_stat f
- | _ -> ()
+let () = load_file_cb := (fun s -> FileAux.load_file s)
- method revert =
- match filename with
- | Some f -> begin
- let do_revert () = begin
- push_info "Reverting buffer";
- try
- if is_active then self#force_reset_initial;
- let b = Buffer.create 1024 in
- with_file flash_info f ~f:(input_channel b);
- let s = try_convert (Buffer.contents b) in
- input_buffer#set_text s;
- self#update_stats;
- input_buffer#place_cursor ~where:input_buffer#start_iter;
- input_buffer#set_modified false;
- pop_info ();
- flash_info "Buffer reverted";
- force_retag input_buffer;
- with _ ->
- pop_info ();
- flash_info "Warning: could not revert buffer";
- end
- in
- if input_buffer#modified then
- match (GToolbox.question_box
- ~title:"Modified buffer changed on disk"
- ~buttons:["Revert from File";
- "Overwrite File";
- "Disable Auto Revert"]
- ~default:0
- ~icon:(stock_to_widget `DIALOG_WARNING)
- "Some unsaved buffers changed on disk"
- )
- with 1 -> do_revert ()
- | 2 -> if self#save f then flash_info "Overwritten" else
- flash_info "Could not overwrite file"
- | _ ->
- prerr_endline "Auto revert set to false";
- !current.global_auto_revert <- false;
- disconnect_revert_timer ()
- else do_revert ()
- end
- | None -> ()
+(** Callbacks for the File menu *)
- method save f =
- if try_export f (input_buffer#get_text ()) then begin
- filename <- Some f;
- input_buffer#set_modified false;
- stats <- my_stat f;
- (match self#auto_save_name with
- | None -> ()
- | Some fn -> try Sys.remove fn with _ -> ());
- true
- end
- else false
-
- method private auto_save_name =
- match filename with
- | None -> None
- | Some f ->
- let dir = Filename.dirname f in
- let base = (fst !current.auto_save_name) ^
- (Filename.basename f) ^
- (snd !current.auto_save_name)
- in Some (Filename.concat dir base)
-
- method private need_auto_save =
- input_buffer#modified &&
- last_modification_time > last_auto_save_time
-
- method auto_save =
- if self#need_auto_save then begin
- match self#auto_save_name with
- | None -> ()
- | Some fn ->
- try
- last_auto_save_time <- Unix.time();
- prerr_endline ("Autosave time : "^(string_of_float (Unix.time())));
- if try_export fn (input_buffer#get_text ()) then begin
- flash_info ~delay:1000 "Autosaved"
- end
- else warning
- ("Autosave failed (check if " ^ fn ^ " is writable)")
- with _ ->
- warning ("Autosave: unexpected error while writing "^fn)
- end
+module File = struct
- method save_as f =
- if Sys.file_exists f then
- match (GToolbox.question_box ~title:"File exists on disk"
- ~buttons:["Overwrite";
- "Cancel";]
- ~default:1
- ~icon:
- (let img = GMisc.image () in
- img#set_stock `DIALOG_WARNING;
- img#set_icon_size `DIALOG;
- img#coerce)
- ("File "^f^" already exists")
- )
- with 1 -> self#save f
- | _ -> false
- else self#save f
-
- method set_read_only b = read_only<-b
- method read_only = read_only
- method is_active = is_active
- method insert_message s =
- message_buffer#insert s;
- message_view#misc#draw None
-
- method set_message s =
- message_buffer#set_text s;
- message_view#misc#draw None
-
- method clear_message = message_buffer#set_text ""
- val mutable last_index = true
- val last_array = [|"";""|]
- method get_start_of_input = input_buffer#get_iter_at_mark (`NAME "start_of_input")
-
- method get_insert = get_insert input_buffer
-
- method recenter_insert =
- (* BUG : to investigate further:
- FIXED : Never call GMain.* in thread !
- PLUS : GTK BUG ??? Cannot be called from a thread...
- ADDITION: using sync instead of async causes deadlock...*)
- ignore (GtkThread.async (
- input_view#scroll_to_mark
- ~use_align:false
- ~yalign:0.75
- ~within_margin:0.25)
- `INSERT)
-
-
- method indent_current_line =
- let get_nb_space it =
- let it = it#copy in
- let nb_sep = ref 0 in
- let continue = ref true in
- while !continue do
- if it#char = space then begin
- incr nb_sep;
- if not it#nocopy#forward_char then continue := false;
- end else continue := false
- done;
- !nb_sep
- in
- let previous_line = self#get_insert in
- if previous_line#nocopy#backward_line then begin
- let previous_line_spaces = get_nb_space previous_line in
- let current_line_start = self#get_insert#set_line_offset 0 in
- let current_line_spaces = get_nb_space current_line_start in
- if input_buffer#delete_interactive
- ~start:current_line_start
- ~stop:(current_line_start#forward_chars current_line_spaces)
- ()
- then
- let current_line_start = self#get_insert#set_line_offset 0 in
- input_buffer#insert
- ~iter:current_line_start
- (String.make previous_line_spaces ' ')
- end
+let newfile _ =
+ let session = create_session None in
+ let index = notebook#append_term session in
+ !refresh_editor_hook ();
+ notebook#goto_page index
+let load _ =
+ match select_file_for_open ~title:"Load file" () with
+ | None -> ()
+ | Some f -> FileAux.load_file f
- method go_to_next_occ_of_cur_word =
- let cv = session_notebook#current_term in
- let av = cv.analyzed_view in
- let b = (cv.script)#buffer in
- let start = find_word_start (av#get_insert) in
- let stop = find_word_end start in
- let text = b#get_text ~start ~stop () in
- match stop#forward_search text with
- | None -> ()
- | Some(start, _) ->
- (b#place_cursor start;
- self#recenter_insert)
-
- method go_to_prev_occ_of_cur_word =
- let cv = session_notebook#current_term in
- let av = cv.analyzed_view in
- let b = (cv.script)#buffer in
- let start = find_word_start (av#get_insert) in
- let stop = find_word_end start in
- let text = b#get_text ~start ~stop () in
- match start#backward_search text with
+let save _ = on_current_term (FileAux.check_save ~saveas:false)
+
+let saveas sn =
+ try
+ let filename = sn.fileops#filename in
+ ignore (FileAux.select_and_save ~saveas:true ?filename sn)
+ with _ -> warning "Save Failed"
+
+let saveas = cb_on_current_term saveas
+
+let saveall _ =
+ List.iter
+ (fun sn -> match sn.fileops#filename with
| None -> ()
- | Some(start, _) ->
- (b#place_cursor start;
- self#recenter_insert)
-
- val mutable full_goal_done = true
-
- method show_goals_full =
- if not full_goal_done then
- proof_view#buffer#set_text "";
- begin
- let menu_callback = if !current.contextual_menus_on_goal then
- (fun s () -> ignore (self#insert_this_phrase_on_success
- true true false ("progress "^s) s))
- else
- (fun _ _ -> ()) in
- try
- begin match Coq.goals !mycoqtop with
- | Interface.Fail (l, str) ->
- self#set_message ("Error in coqtop :\n"^str)
- | Interface.Good goals ->
- begin match Coq.evars !mycoqtop with
- | Interface.Fail (l, str) ->
- self#set_message ("Error in coqtop :\n"^str)
- | Interface.Good evs ->
- let hints = match Coq.hints !mycoqtop with
- | Interface.Fail (_, _) -> None
- | Interface.Good hints -> hints
- in
- Ideproof.display
- (Ideproof.mode_tactic menu_callback)
- proof_view goals hints evs
- end
- end
- with
- | e -> prerr_endline (Printexc.to_string e)
- end
+ | Some f -> ignore (sn.fileops#save f))
+ notebook#pages
- method show_goals = self#show_goals_full
+let revert_all _ =
+ List.iter
+ (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert)
+ notebook#pages
- method private send_to_coq ct verbose phrase show_output show_error localize =
- let display_output msg =
- self#insert_message (if show_output then msg else "") in
- let display_error (loc,s) =
- if show_error then begin
- if not (Glib.Utf8.validate s) then
- flash_info "This error is so nasty that I can't even display it."
- else begin
- self#insert_message s;
- message_view#misc#draw None;
- if localize then
- (match loc with
- | None -> ()
- | Some (start,stop) ->
- let convert_pos = byte_offset_to_char_offset phrase in
- let start = convert_pos start in
- let stop = convert_pos stop in
- let i = self#get_start_of_input in
- let starti = i#forward_chars start in
- let stopi = i#forward_chars stop in
- input_buffer#apply_tag Tags.Script.error
- ~start:starti
- ~stop:stopi;
- input_buffer#place_cursor ~where:starti)
- end
- end in
- try
- full_goal_done <- false;
- prerr_endline "Send_to_coq starting now";
- (* It's important here to work with [ct] and not [!mycoqtop], otherwise
- we could miss a restart of coqtop and continue sending it orders. *)
- match Coq.interp ct ~verbose 0 phrase with
- | Interface.Fail (l,str) -> sync display_error (l,str); None
- | Interface.Good msg -> sync display_output msg; Some Safe
- with
- | End_of_file -> (* Coqtop has died, let's trigger a reset_initial. *)
- raise RestartCoqtop
- | e -> sync display_error (None, Printexc.to_string e); None
-
- (* This method is intended to perform stateless commands *)
- method raw_coq_query phrase =
- let () = prerr_endline "raw_coq_query starting now" in
- let display_error s =
- if not (Glib.Utf8.validate s) then
- flash_info "This error is so nasty that I can't even display it."
- else begin
- self#insert_message s;
- message_view#misc#draw None
- end
+let quit _ =
+ try FileAux.check_quit saveall; exit 0
+ with FileAux.DontQuit -> ()
+
+let close_buffer sn =
+ let do_remove () = notebook#remove_page notebook#current_page in
+ if not sn.buffer#modified then do_remove ()
+ else
+ let answ = GToolbox.question_box ~title:"Close"
+ ~buttons:["Save Buffer and Close";
+ "Close without Saving";
+ "Don't Close"]
+ ~default:0
+ ~icon:(warn_image ())#coerce
+ "This buffer has unsaved modifications"
in
- try
- match Coq.interp !mycoqtop ~raw:true ~verbose:false 0 phrase with
- | Interface.Fail (_, err) -> sync display_error err
- | Interface.Good msg ->
- sync self#insert_message msg
- with
- | End_of_file -> raise RestartCoqtop
- | e -> sync display_error (Printexc.to_string e)
-
- method find_phrase_starting_at (start:GText.iter) =
- try
- let start = grab_sentence_start start self#get_start_of_input in
- let stop = grab_sentence_stop start in
- (* Is this phrase non-empty and complete ? *)
- if stop#compare start > 0 && is_sentence_end stop#backward_char
- then Some (start,stop)
- else None
- with StartError -> None
-
- method complete_at_offset (offset:int) =
- prerr_endline ("Completion at offset : " ^ string_of_int offset);
- let it () = input_buffer#get_iter (`OFFSET offset) in
- let iit = it () in
- let start = find_word_start iit in
- if ends_word iit then
- let w = input_buffer#get_text
- ~start
- ~stop:iit
- ()
+ match answ with
+ | 1 when FileAux.check_save ~saveas:true sn -> do_remove ()
+ | 2 -> do_remove ()
+ | _ -> ()
+
+let close_buffer = cb_on_current_term close_buffer
+
+let export kind sn =
+ match sn.fileops#filename with
+ |None -> flash_info "Cannot print: this buffer has no name"
+ |Some f ->
+ let basef = Filename.basename f in
+ let output =
+ let basef_we = try Filename.chop_extension basef with _ -> basef in
+ match kind with
+ | "latex" -> basef_we ^ ".tex"
+ | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
+ | _ -> assert false
in
- if String.length w <> 0 then begin
- prerr_endline ("Completion of prefix : '" ^ w^"'");
- match complete input_buffer w start#offset with
- | None -> false
- | Some (ss,start,stop) ->
- let completion = input_buffer#get_text ~start ~stop () in
- ignore (input_buffer#delete_selection ());
- ignore (input_buffer#insert_interactive completion);
- input_buffer#move_mark `SEL_BOUND ~where:(it())#backward_char;
- true
- end else false
- else false
-
- method private process_one_phrase ct verbosely display_goals do_highlight =
- let get_next_phrase () =
- self#clear_message;
- prerr_endline "process_one_phrase starting now";
- if do_highlight then begin
- push_info "Coq is computing";
- input_view#set_editable false;
- end;
- match self#find_phrase_starting_at self#get_start_of_input with
- | None ->
- if do_highlight then begin
- input_view#set_editable true;
- pop_info ();
- end;
- None
- | Some(start,stop) ->
- prerr_endline "process_one_phrase : to_process highlight";
- if do_highlight then begin
- input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
- prerr_endline "process_one_phrase : to_process applied";
- end;
- prerr_endline "process_one_phrase : getting phrase";
- Some((start,stop),start#get_slice ~stop) in
- let remove_tag (start,stop) =
- if do_highlight then begin
- input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
- input_view#set_editable true;
- pop_info ();
- end in
- let mark_processed safe (start,stop) =
- let b = input_buffer in
- b#move_mark ~where:stop (`NAME "start_of_input");
- b#apply_tag (safety_tag safe) ~start ~stop;
- if (self#get_insert#compare) stop <= 0 then
- begin
- b#place_cursor ~where:stop;
- self#recenter_insert
- end;
- let ide_payload = { start = `MARK (b#create_mark start);
- stop = `MARK (b#create_mark stop); } in
- Stack.push ide_payload cmd_stack;
- if display_goals then self#show_goals;
- remove_tag (start,stop)
- in
- match sync get_next_phrase () with
- | None -> raise Unsuccessful
- | Some ((_,stop) as loc,phrase) ->
- if stop#backward_char#has_tag Tags.Script.comment
- then sync mark_processed Safe loc
- else try match self#send_to_coq ct verbosely phrase true true true with
- | Some safe -> sync mark_processed safe loc
- | None -> sync remove_tag loc; raise Unsuccessful
- with
- | RestartCoqtop -> sync remove_tag loc; raise RestartCoqtop
-
- method process_next_phrase verbosely =
- try self#process_one_phrase !mycoqtop verbosely true true
- with Unsuccessful -> ()
-
- method private insert_this_phrase_on_success
- show_output show_msg localize coqphrase insertphrase =
- let mark_processed safe =
- let stop = self#get_start_of_input in
- if stop#starts_line then
- input_buffer#insert ~iter:stop insertphrase
- else input_buffer#insert ~iter:stop ("\n"^insertphrase);
- tag_on_insert input_buffer;
- let start = self#get_start_of_input in
- input_buffer#move_mark ~where:stop (`NAME "start_of_input");
- input_buffer#apply_tag (safety_tag safe) ~start ~stop;
- if (self#get_insert#compare) stop <= 0 then
- input_buffer#place_cursor ~where:stop;
- let ide_payload = { start = `MARK (input_buffer#create_mark start);
- stop = `MARK (input_buffer#create_mark stop); } in
- Stack.push ide_payload cmd_stack;
- self#show_goals;
- (*Auto insert save on success...
- try (match Coq.get_current_goals () with
- | [] ->
- (match self#send_to_coq "Save.\n" true true true with
- | Some ast ->
- begin
- let stop = self#get_start_of_input in
- if stop#starts_line then
- input_buffer#insert ~iter:stop "Save.\n"
- else input_buffer#insert ~iter:stop "\nSave.\n";
- let start = self#get_start_of_input in
- input_buffer#move_mark ~where:stop (`NAME"start_of_input");
- input_buffer#apply_tag_by_name "processed" ~start ~stop;
- if (self#get_insert#compare) stop <= 0 then
- input_buffer#place_cursor stop;
- let start_of_phrase_mark =
- `MARK (input_buffer#create_mark start) in
- let end_of_phrase_mark =
- `MARK (input_buffer#create_mark stop) in
- push_phrase
- reset_info start_of_phrase_mark end_of_phrase_mark ast
- end
- | None -> ())
- | _ -> ())
- with _ -> ()*) in
- match self#send_to_coq !mycoqtop false coqphrase show_output show_msg localize with
- | Some safe -> sync mark_processed safe; true
- | None ->
- sync
- (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
- ();
- false
-
- method process_until_iter_or_error stop =
- let stop' = `OFFSET stop#offset in
- let start = self#get_start_of_input#copy in
- let start' = `OFFSET start#offset in
- sync (fun _ ->
- input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
- input_view#set_editable false) ();
- push_info "Coq is computing";
- let get_current () =
- if !current.stop_before then
- match self#find_phrase_starting_at self#get_start_of_input with
- | None -> self#get_start_of_input
- | Some (_, stop2) -> stop2
- else begin
- self#get_start_of_input
- end
- in
- let unlock () =
- sync (fun _ ->
- self#show_goals;
- (* Start and stop might be invalid if an eol was added at eof *)
- let start = input_buffer#get_iter start' in
- let stop = input_buffer#get_iter stop' in
- input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
- input_view#set_editable true) ()
- in
- (* All the [process_one_phrase] below should be done with the same [ct]
- instead of accessing multiple time [mycoqtop]. Otherwise a restart of
- coqtop could go unnoticed, and the new coqtop could receive strange
- things. *)
- let ct = !mycoqtop in
- (try
- while stop#compare (get_current()) >= 0
- do self#process_one_phrase ct false false false done
- with
- | Unsuccessful -> ()
- | RestartCoqtop -> unlock (); raise RestartCoqtop);
- unlock ();
- pop_info()
-
- method process_until_end_or_error =
- self#process_until_iter_or_error input_buffer#end_iter
-
- method reset_initial =
- mycoqtop := Coq.respawn_coqtop !mycoqtop;
- sync (fun () ->
- Stack.iter
- (function inf ->
- let start = input_buffer#get_iter_at_mark inf.start in
- let stop = input_buffer#get_iter_at_mark inf.stop in
- input_buffer#move_mark ~where:start (`NAME "start_of_input");
- input_buffer#remove_tag Tags.Script.processed ~start ~stop;
- input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
- input_buffer#delete_mark inf.start;
- input_buffer#delete_mark inf.stop;
- )
- cmd_stack;
- Stack.clear cmd_stack;
- self#clear_message) ()
-
- method force_reset_initial =
- (* Do nothing if a force_reset_initial is already ongoing *)
- if Mutex.try_lock resetting then begin
- Coq.kill_coqtop !mycoqtop;
- (* If a computation is ongoing, an exception will trigger
- the reset_initial in do_if_not_computing, not here. *)
- if Mutex.try_lock coq_computing then begin
- self#reset_initial;
- Mutex.unlock coq_computing
- end;
- Mutex.unlock resetting
- end
+ let cmd =
+ local_cd f ^ prefs.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^
+ (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1"
+ in
+ sn.messages#set ("Running: "^cmd);
+ let finally st = flash_info (cmd ^ pr_exit_status st)
+ in
+ run_command sn.messages#add finally cmd
- (* Internal method for dialoging with coqtop about a backtrack.
- The ide's cmd_stack has already been cleared up to the desired point.
- The [finish] function is used to handle minor differences between
- [go_to_insert] and [undo_last_step] *)
-
- method private do_backtrack finish n =
- (* pop n more commands if coqtop has said so (e.g. for undoing a proof) *)
- let rec n_pop n =
- if n = 0 then ()
- else
- let phrase = Stack.pop cmd_stack in
- let stop = input_buffer#get_iter_at_mark phrase.stop in
- if stop#backward_char#has_tag Tags.Script.comment
- then n_pop n
- else n_pop (pred n)
- in
- match Coq.rewind !mycoqtop n with
- | Interface.Good n ->
- n_pop n;
- sync (fun _ ->
- let start =
- if Stack.is_empty cmd_stack then input_buffer#start_iter
- else input_buffer#get_iter_at_mark (Stack.top cmd_stack).stop in
- let stop = self#get_start_of_input in
- input_buffer#remove_tag Tags.Script.processed ~start ~stop;
- input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
- input_buffer#move_mark ~where:start (`NAME "start_of_input");
- self#show_goals;
- self#clear_message;
- finish start) ()
- | Interface.Fail (l,str) ->
- sync self#set_message
- ("Error while backtracking :\n" ^ str ^ "\n" ^
- "CoqIDE and coqtop may be out of sync, you may want to use Restart.")
-
- (* backtrack Coq to the phrase preceding iterator [i] *)
- method backtrack_to_no_lock i =
- prerr_endline "Backtracking_to iter starts now.";
- full_goal_done <- false;
- (* pop Coq commands until we reach iterator [i] *)
- let rec n_step n =
- if Stack.is_empty cmd_stack then n else
- let phrase = Stack.top cmd_stack in
- let stop = input_buffer#get_iter_at_mark phrase.stop in
- if i#compare stop >= 0 then n
- else begin
- ignore (Stack.pop cmd_stack);
- if stop#backward_char#has_tag Tags.Script.comment
- then n_step n
- else n_step (succ n)
- end
- in
- begin
- try
- self#do_backtrack (fun _ -> ()) (n_step 0);
- (* We may have backtracked too much: let's replay *)
- self#process_until_iter_or_error i
- with _ ->
- push_info
- ("WARNING: undo failed badly.\n" ^
- "Coq might be in an inconsistent state.\n" ^
- "Please restart and report.");
- end
+let export kind = cb_on_current_term (export kind)
- method backtrack_to i =
- if Mutex.try_lock coq_may_stop then
- (push_info "Undoing...";
- self#backtrack_to_no_lock i; Mutex.unlock coq_may_stop;
- pop_info ())
- else prerr_endline "backtrack_to : discarded (lock is busy)"
-
- method go_to_insert =
- let point = self#get_insert in
- if point#compare self#get_start_of_input>=0
- then self#process_until_iter_or_error point
- else self#backtrack_to point
-
- method undo_last_step =
- full_goal_done <- false;
- if Mutex.try_lock coq_may_stop then
- (push_info "Undoing last step...";
- (try
- let phrase = Stack.pop cmd_stack in
- let stop = input_buffer#get_iter_at_mark phrase.stop in
- let count =
- if stop#backward_char#has_tag Tags.Script.comment then 0 else 1
- in
- let finish where =
- input_buffer#place_cursor ~where;
- self#recenter_insert;
- in
- self#do_backtrack finish count
- with Stack.Empty -> ()
- );
- pop_info ();
- Mutex.unlock coq_may_stop)
- else prerr_endline "undo_last_step discarded"
-
-
- method insert_command cp ip =
- async(fun _ -> self#clear_message)();
- ignore (self#insert_this_phrase_on_success true false false cp ip)
-
- method tactic_wizard l =
- async(fun _ -> self#clear_message)();
- ignore
- (List.exists
- (fun p ->
- self#insert_this_phrase_on_success true false false
- ("progress "^p^".") (p^".")) l)
-
- method active_keypress_handler k =
- let state = GdkEvent.Key.state k in
- begin
- match state with
- | l ->
- if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
- prerr_endline "active_kp_handler for Tab";
- self#indent_current_line;
- true
- end else false
- end
+let print sn =
+ match sn.fileops#filename with
+ |None -> flash_info "Cannot print: this buffer has no name"
+ |Some f_name ->
+ let cmd =
+ local_cd f_name ^ prefs.cmd_coqdoc ^ " -ps " ^
+ Filename.quote (Filename.basename f_name) ^ " | " ^ prefs.cmd_print
+ in
+ let w = GWindow.window ~title:"Print" ~modal:true
+ ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" ()
+ in
+ let v = GPack.vbox ~spacing:10 ~border_width:10 ~packing:w#add ()
+ in
+ let _ = GMisc.label ~text:"Print using the following command:"
+ ~justify:`LEFT ~packing:v#add ()
+ in
+ let e = GEdit.entry ~text:cmd ~editable:true ~width_chars:80
+ ~packing:v#add ()
+ in
+ let h = GPack.hbox ~spacing:10 ~packing:v#add ()
+ in
+ let ko = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:h#add ()
+ in
+ let ok = GButton.button ~stock:`PRINT ~label:"Print" ~packing:h#add ()
+ in
+ let callback_print () =
+ w#destroy ();
+ let cmd = e#text in
+ let finally st = flash_info (cmd ^ pr_exit_status st) in
+ run_command ignore finally cmd
+ in
+ let _ = ko#connect#clicked ~callback:w#destroy in
+ let _ = ok#connect#clicked ~callback:callback_print in
+ w#misc#show ()
- val mutable act_id = None
+let print = cb_on_current_term print
+
+let highlight sn =
+ Sentence.tag_all sn.buffer;
+ sn.script#recenter_insert
+
+let highlight = cb_on_current_term highlight
- method activate () = if not is_active then begin
- is_active <- true;
- act_id <- Some
- (input_view#event#connect#key_press ~callback:self#active_keypress_handler);
- prerr_endline "CONNECTED active : ";
- print_id (match act_id with Some x -> x | None -> assert false);
- match filename with
- | None -> ()
- | Some f ->
- let dir = Filename.dirname f in
- let ct = !mycoqtop in
- match Coq.inloadpath ct dir with
- | Interface.Fail (_,str) ->
- self#set_message
- ("Could not determine lodpath, this might lead to problems:\n"^str)
- | Interface.Good true -> ()
- | Interface.Good false ->
- let cmd = Printf.sprintf "Add LoadPath \"%s\". " dir in
- match Coq.interp ct 0 cmd with
- | Interface.Fail (l,str) ->
- self#set_message ("Couln't add loadpath:\n"^str)
- | Interface.Good _ -> ()
- end
-
- method private electric_paren tag =
- let oparen_code = Glib.Utf8.to_unichar "(" ~pos:(ref 0) in
- let cparen_code = Glib.Utf8.to_unichar ")" ~pos:(ref 0) in
- ignore (input_buffer#connect#insert_text ~callback:
- (fun it x ->
- input_buffer#remove_tag
- ~start:input_buffer#start_iter
- ~stop:input_buffer#end_iter
- tag;
- if x = "" then () else
- match x.[String.length x - 1] with
- | ')' ->
- let hit = self#get_insert in
- let count = ref 0 in
- if hit#nocopy#backward_find_char
- (fun c ->
- if c = oparen_code && !count = 0 then true
- else if c = cparen_code then
- (incr count;false)
- else if c = oparen_code then
- (decr count;false)
- else false
- )
- then
- begin
- prerr_endline "Found matching parenthesis";
- input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
- end
- else ()
- | _ -> ())
- )
-
- method help_for_keyword () =
- browse_keyword (self#insert_message) (get_current_word ())
-
-(** NB: Events during text edition:
-
- - [begin_user_action]
- - [insert_text] (or [delete_range] when deleting)
- - [changed]
- - [end_user_action]
-
- When pasting a text containing tags (e.g. the sentence terminators),
- there is actually many [insert_text] and [changed]. For instance,
- for "a. b.":
-
- - [begin_user_action]
- - [insert_text] (for "a")
- - [changed]
- - [insert_text] (for ".")
- - [changed]
- - [apply_tag] (for the tag of ".")
- - [insert_text] (for " b")
- - [changed]
- - [insert_text] (for ".")
- - [changed]
- - [apply_tag] (for the tag of ".")
- - [end_user_action]
-
- Since these copy-pasted tags may interact badly with the retag mechanism,
- we now don't monitor the "changed" event, but rather the "begin_user_action"
- and "end_user_action". We begin by setting a mark at the initial cursor
- point. At the end, the zone between the mark and the cursor is to be
- untagged and then retagged. *)
-
- initializer
- ignore (message_buffer#connect#insert_text
- ~callback:(fun it s -> ignore
- (message_view#scroll_to_mark
- ~use_align:false
- ~within_margin:0.49
- `INSERT)));
- ignore (input_buffer#connect#insert_text
- ~callback:(fun it s ->
- if (it#compare self#get_start_of_input)<0
- then GtkSignal.stop_emit ();
- if String.length s > 1 then
- (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor ~where:it)));
- ignore (input_buffer#connect#after#apply_tag
- ~callback:(fun tag ~start ~stop ->
- if (start#compare self#get_start_of_input)>=0
- then
- begin
- input_buffer#remove_tag
- Tags.Script.processed
- ~start
- ~stop;
- input_buffer#remove_tag
- Tags.Script.unjustified
- ~start
- ~stop
- end
- )
- );
- ignore (input_buffer#connect#after#insert_text
- ~callback:(fun it s ->
- if auto_complete_on &&
- String.length s = 1 && s <> " " && s <> "\n"
- then
- let v = session_notebook#current_term.analyzed_view
- in
- let has_completed =
- v#complete_at_offset
- ((input_view#buffer#get_iter `SEL_BOUND)#offset)
- in
- if has_completed then
- input_buffer#move_mark `SEL_BOUND ~where:(input_buffer#get_iter `SEL_BOUND)#forward_char;
- )
- );
- ignore (input_buffer#connect#begin_user_action
- ~callback:(fun () ->
- let where = self#get_insert in
- input_buffer#move_mark (`NAME "prev_insert") ~where;
- let start = self#get_start_of_input in
- let stop = input_buffer#end_iter in
- input_buffer#remove_tag Tags.Script.error ~start ~stop)
- );
- ignore (input_buffer#connect#end_user_action
- ~callback:(fun () ->
- last_modification_time <- Unix.time ();
- tag_on_insert input_buffer
- )
- );
- ignore (input_buffer#add_selection_clipboard cb);
- ignore (proof_buffer#add_selection_clipboard cb);
- ignore (message_buffer#add_selection_clipboard cb);
- self#electric_paren Tags.Script.paren;
- ignore (input_buffer#connect#after#mark_set
- ~callback:(fun it (m:Gtk.text_mark) ->
- !set_location
- (Printf.sprintf
- "Line: %5d Char: %3d" (self#get_insert#line + 1)
- (self#get_insert#line_offset + 1));
- match GtkText.Mark.get_name m with
- | Some "insert" ->
- input_buffer#remove_tag
- ~start:input_buffer#start_iter
- ~stop:input_buffer#end_iter
- Tags.Script.paren;
- | Some s ->
- prerr_endline (s^" moved")
- | None -> () )
- );
- ignore (input_buffer#connect#insert_text
- ~callback:(fun it s ->
- prerr_endline "Should recenter ?";
- if String.contains s '\n' then begin
- prerr_endline "Should recenter : yes";
- self#recenter_insert
- end));
end
-let last_make = ref "";;
-let last_make_index = ref 0;;
+(** Timers *)
+
+let reset_revert_timer () =
+ FileOps.revert_timer.kill ();
+ if prefs.global_auto_revert then
+ FileOps.revert_timer.run
+ ~ms:prefs.global_auto_revert_delay
+ ~callback:(fun () -> File.revert_all (); true)
+
+let reset_autosave_timer () =
+ let autosave sn = try sn.fileops#auto_save with _ -> () in
+ let autosave_all () = List.iter autosave notebook#pages; true in
+ FileOps.autosave_timer.kill ();
+ if prefs.auto_save then
+ FileOps.autosave_timer.run ~ms:prefs.auto_save_delay ~callback:autosave_all
+
+(** Export of functions used in [coqide_main] : *)
+
+let forbid_quit () =
+ try FileAux.check_quit File.saveall; false
+ with FileAux.DontQuit -> true
+
+let close_and_quit = FileAux.close_and_quit
+let crash_save = FileAux.crash_save
+let do_load f = FileAux.load_file f
+
+(** Callbacks for external commands *)
+
+module External = struct
+
+let coq_makefile sn =
+ match sn.fileops#filename with
+ |None -> flash_info "Cannot make makefile: this buffer has no name"
+ |Some f ->
+ let cmd = local_cd f ^ prefs.cmd_coqmakefile in
+ let finally st = flash_info (current.cmd_coqmakefile ^ pr_exit_status st)
+ in
+ run_command ignore finally cmd
+
+let coq_makefile = cb_on_current_term coq_makefile
+
+let editor sn =
+ match sn.fileops#filename with
+ |None -> warning "Call to external editor available only on named files"
+ |Some f ->
+ File.save ();
+ let f = Filename.quote f in
+ let cmd = Util.subst_command_placeholder prefs.cmd_editor f in
+ run_command ignore (fun _ -> sn.fileops#revert) cmd
+
+let editor = cb_on_current_term editor
+
+let compile sn =
+ File.save ();
+ match sn.fileops#filename with
+ |None -> flash_info "Active buffer has no name"
+ |Some f ->
+ let cmd = prefs.cmd_coqc ^ " -I " ^ (Filename.quote (Filename.dirname f))
+ ^ " " ^ (Filename.quote f) ^ " 2>&1"
+ in
+ let buf = Buffer.create 1024 in
+ sn.messages#set ("Running: "^cmd);
+ let display s =
+ sn.messages#add s;
+ Buffer.add_string buf s
+ in
+ let finally st =
+ if st = Unix.WEXITED 0 then
+ flash_info (f ^ " successfully compiled")
+ else begin
+ flash_info (f ^ " failed to compile");
+ sn.messages#set "Compilation output:\n";
+ sn.messages#add (Buffer.contents buf);
+ end
+ in
+ run_command display finally cmd
+
+let compile = cb_on_current_term compile
+
+(** [last_make_buf] contains the output of the last make compilation.
+ [last_make] is the same, but as a string, refreshed only when searching
+ the next error. *)
+
+let last_make_buf = Buffer.create 1024
+let last_make = ref ""
+let last_make_index = ref 0
+let last_make_dir = ref ""
+
+let make sn =
+ match sn.fileops#filename with
+ |None -> flash_info "Cannot make: this buffer has no name"
+ |Some f ->
+ File.saveall ();
+ let cmd = local_cd f ^ prefs.cmd_make ^ " 2>&1" in
+ sn.messages#set "Compilation output:\n";
+ Buffer.reset last_make_buf;
+ last_make := "";
+ last_make_index := 0;
+ last_make_dir := Filename.dirname f;
+ let display s =
+ sn.messages#add s;
+ Buffer.add_string last_make_buf s
+ in
+ let finally st = flash_info (current.cmd_make ^ pr_exit_status st)
+ in
+ run_command display finally cmd
+
+let make = cb_on_current_term make
+
let search_compile_error_regexp =
Str.regexp
- "File \"\\([^\"]+\\)\", line \\([0-9]+\\), characters \\([0-9]+\\)-\\([0-9]+\\)";;
+ "File \"\\([^\"]+\\)\", line \\([0-9]+\\), characters \\([0-9]+\\)-\\([0-9]+\\)"
let search_next_error () =
- let _ = Str.search_forward search_compile_error_regexp !last_make !last_make_index in
+ if String.length !last_make <> Buffer.length last_make_buf
+ then last_make := Buffer.contents last_make_buf;
+ let _ =
+ Str.search_forward search_compile_error_regexp !last_make !last_make_index
+ in
let f = Str.matched_group 1 !last_make
and l = int_of_string (Str.matched_group 2 !last_make)
and b = int_of_string (Str.matched_group 3 !last_make)
@@ -1428,1527 +493,938 @@ let search_next_error () =
and msg_index = Str.match_beginning ()
in
last_make_index := Str.group_end 4;
- (f,l,b,e,
+ (Filename.concat !last_make_dir f, l, b, e,
String.sub !last_make msg_index (String.length !last_make - msg_index))
+let next_error sn =
+ try
+ let file,line,start,stop,error_msg = search_next_error () in
+ FileAux.load_file file;
+ let b = sn.buffer in
+ let starti = b#get_iter_at_byte ~line:(line-1) start in
+ let stopi = b#get_iter_at_byte ~line:(line-1) stop in
+ b#apply_tag Tags.Script.error ~start:starti ~stop:stopi;
+ b#place_cursor ~where:starti;
+ sn.messages#set error_msg;
+ sn.script#misc#grab_focus ()
+ with Not_found ->
+ last_make_index := 0;
+ sn.messages#set "No more errors.\n"
+
+let next_error = cb_on_current_term next_error
+end
-(**********************************************************************)
-(* session creation and primitive handling *)
-(**********************************************************************)
-
-let create_session file =
- let script =
- Undo.undoable_view
- ~buffer:(GText.buffer ~tag_table:Tags.Script.table ())
- ~wrap_mode:`NONE () in
- let proof =
- GText.view
- ~buffer:(GText.buffer ~tag_table:Tags.Proof.table ())
- ~editable:false ~wrap_mode:`CHAR () in
- let message =
- GText.view
- ~buffer:(GText.buffer ~tag_table:Tags.Message.table ())
- ~editable:false ~wrap_mode:`WORD () in
- let basename = GMisc.label ~text:(match file with
- |None -> "*scratch*"
- |Some f -> (Glib.Convert.filename_to_utf8 (Filename.basename f))
- ) () in
- let stack = Stack.create () in
- let coqtop_args = match file with
- |None -> !sup_args
- |Some the_file -> match !current.read_project with
- |Ignore_args -> !sup_args
- |Append_args -> (Project_file.args_from_project the_file !custom_project_files !current.project_file_name)
- @(!sup_args)
- |Subst_args -> Project_file.args_from_project the_file !custom_project_files !current.project_file_name
- in
- let ct = ref (Coq.spawn_coqtop coqtop_args) in
- let command = new Command_windows.command_window ct current in
- let legacy_av = new analyzed_view script proof message stack ct file in
- let () = legacy_av#update_stats in
- let _ =
- script#buffer#create_mark ~name:"start_of_input" script#buffer#start_iter in
- let _ =
- script#buffer#create_mark ~name:"prev_insert" script#buffer#start_iter in
- let _ =
- proof#buffer#create_mark ~name:"end_of_conclusion" proof#buffer#start_iter in
- let _ =
- GtkBase.Widget.add_events proof#as_widget [`ENTER_NOTIFY;`POINTER_MOTION] in
- let () =
- List.iter (fun (opts,_,_,_,dflt) -> setopts !ct opts dflt) print_items in
- let _ = legacy_av#activate () in
- let _ =
- proof#event#connect#motion_notify ~callback:
- (fun e ->
- let win = match proof#get_window `WIDGET with
- | None -> assert false
- | Some w -> w in
- let x,y = Gdk.Window.get_pointer_location win in
- let b_x,b_y = proof#window_to_buffer_coords ~tag:`WIDGET ~x ~y in
- let it = proof#get_iter_at_location ~x:b_x ~y:b_y in
- let tags = it#tags in
- List.iter
- (fun t ->
- ignore (GtkText.Tag.event t#as_tag proof#as_widget e it#as_iter))
- tags;
- false) in
- script#misc#set_name "ScriptWindow";
- script#buffer#place_cursor ~where:(script#buffer#start_iter);
- proof#misc#set_can_focus true;
- message#misc#set_can_focus true;
- (* setting fonts *)
- script#misc#modify_font !current.text_font;
- proof#misc#modify_font !current.text_font;
- message#misc#modify_font !current.text_font;
- (* setting colors *)
- script#misc#modify_base [`NORMAL, `NAME !current.background_color];
- proof#misc#modify_base [`NORMAL, `NAME !current.background_color];
- message#misc#modify_base [`NORMAL, `NAME !current.background_color];
-
- { tab_label=basename;
- filename=begin match file with None -> "" |Some f -> f end;
- script=script;
- proof_view=proof;
- message_view=message;
- analyzed_view=legacy_av;
- encoding="";
- toplvl=ct;
- command=command
- }
-
-(* XXX - to be used later
- let load_session session filename encs =
- session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs;
- session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
- session.filename <- filename;
- session.script#buffer#set_modified false
-
-
- let save_session session filename encs =
- session.encoding <- List.find (IdeIO.save session.script#buffer filename) encs;
- session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
- session.filename <- filename;
- session.script#buffer#set_modified false
-
-
- let init_session session =
- session.script#buffer#set_modified false;
- session.script#clear_undo;
- session.script#buffer#place_cursor session.script#buffer#start_iter
-*)
-
+(** Callbacks for the Navigation menu *)
+let update_status sn =
+ let display msg = pop_info (); push_info msg in
+ let next = function
+ | Interface.Fail x -> sn.coqops#handle_failure x
+ | Interface.Good status ->
+ let path = match status.Interface.status_path with
+ | [] | _ :: [] -> "" (* Drop the topmost level, usually "Top" *)
+ | _ :: l -> " in " ^ String.concat "." l
+ in
+ let name = match status.Interface.status_proofname with
+ | None -> ""
+ | Some n -> ", proving " ^ n
+ in
+ display ("Ready"^ if current.nanoPG then ", [μPG]" else "" ^ path ^ name);
+ Coq.return ()
+ in
+ Coq.bind (Coq.status ~logger:sn.messages#push false) next
+
+let find_next_occurrence ~backward sn =
+ (** go to the next occurrence of the current word, forward or backward *)
+ let b = sn.buffer in
+ let start = find_word_start (b#get_iter_at_mark `INSERT) in
+ let stop = find_word_end start in
+ let text = b#get_text ~start ~stop () in
+ let search = if backward then start#backward_search else stop#forward_search
+ in
+ match search text with
+ |None -> ()
+ |Some(where, _) -> b#place_cursor ~where; sn.script#recenter_insert
+
+let send_to_coq_aux f sn =
+ let info () = Minilib.log ("Coq busy, discarding query") in
+ let f = Coq.seq (f sn) (update_status sn) in
+ Coq.try_grab sn.coqtop f info
+
+let send_to_coq f = on_current_term (send_to_coq_aux f)
+
+module Nav = struct
+ let forward_one _ = send_to_coq (fun sn -> sn.coqops#process_next_phrase)
+ let backward_one _ = send_to_coq (fun sn -> sn.coqops#backtrack_last_phrase)
+ let goto _ = send_to_coq (fun sn -> sn.coqops#go_to_insert)
+ let goto_end _ = send_to_coq (fun sn -> sn.coqops#process_until_end_or_error)
+ let previous_occ = cb_on_current_term (find_next_occurrence ~backward:true)
+ let next_occ = cb_on_current_term (find_next_occurrence ~backward:false)
+ let restart sn =
+ Minilib.log "Reset Initial";
+ Coq.reset_coqtop sn.coqtop
+ let restart _ = on_current_term restart
+ let interrupt sn =
+ Minilib.log "User break received";
+ Coq.break_coqtop sn.coqtop
+ let interrupt = cb_on_current_term interrupt
+ let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document)
+end
+let tactic_wizard_callback l _ =
+ send_to_coq (fun sn -> sn.coqops#tactic_wizard l)
+
+let printopts_callback opts v =
+ let b = v#get_active in
+ let () = List.iter (fun o -> Coq.PrintOpt.set o b) opts in
+ send_to_coq (fun sn -> sn.coqops#show_goals)
+
+(** Templates menu *)
+
+let get_current_word term =
+ (** First look to find if autocompleting *)
+ match term.script#complete_popup#proposal with
+ | Some p -> p
+ | None ->
+ (** Then look at the current selected word *)
+ if term.script#buffer#has_selection then
+ let (start, stop) = term.script#buffer#selection_bounds in
+ term.script#buffer#get_text ~slice:true ~start ~stop ()
+ (** Otherwise try to recover the clipboard *)
+ else match Ideutils.cb#text with
+ | Some t -> t
+ | None -> ""
+
+let print_branch c l =
+ Format.fprintf c " | @[<hov 1>%a@]=> _@\n"
+ (Minilib.print_list (fun c s -> Format.fprintf c "%s@ " s)) l
+
+let print_branches c cases =
+ Format.fprintf c "@[match var with@\n%aend@]@."
+ (Minilib.print_list print_branch) cases
+
+let display_match sn = function
+ |Interface.Fail _ ->
+ flash_info "Not an inductive type"; Coq.return ()
+ |Interface.Good cases ->
+ let text =
+ let buf = Buffer.create 1024 in
+ let () = print_branches (Format.formatter_of_buffer buf) cases in
+ Buffer.contents buf
+ in
+ Minilib.log ("match template :\n" ^ text);
+ let b = sn.buffer in
+ let _ = b#delete_selection () in
+ let m = b#create_mark (b#get_iter_at_mark `INSERT) in
+ if b#insert_interactive text then begin
+ let i = b#get_iter (`MARK m) in
+ let _ = i#nocopy#forward_chars 9 in
+ let _ = b#place_cursor ~where:i in
+ b#move_mark ~where:(i#backward_chars 3) `SEL_BOUND
+ end;
+ b#delete_mark (`MARK m);
+ Coq.return ()
+
+let match_callback sn =
+ let w = get_current_word sn in
+ let coqtop = sn.coqtop in
+ let query = Coq.bind (Coq.mkcases w) (display_match sn) in
+ Coq.try_grab coqtop query ignore
+
+let match_callback = cb_on_current_term match_callback
+
+(** Queries *)
+
+module Query = struct
+
+let searchabout sn =
+ let word = get_current_word sn in
+ let buf = sn.messages#buffer in
+ let insert result =
+ let qualid = result.Interface.coq_object_qualid in
+ let name = String.concat "." qualid in
+ let tpe = result.Interface.coq_object_object in
+ buf#insert ~tags:[Tags.Message.item] name;
+ buf#insert "\n";
+ buf#insert tpe;
+ buf#insert "\n";
+ in
+ let display_results r =
+ sn.messages#clear;
+ List.iter insert (match r with Interface.Good l -> l | _ -> []);
+ Coq.return ()
+ in
+ let launch_query =
+ let search = Coq.search [Interface.SubType_Pattern word, true] in
+ Coq.bind search display_results
+ in
+ Coq.try_grab sn.coqtop launch_query ignore
-(*********************************************************************)
-(* functions called by the user interface *)
-(*********************************************************************)
-(* XXX - to be used later
- let do_open session filename =
- try
- load_session session filename ["UTF-8";"ISO-8859-1";"ISO-8859-15"];
- init_session session;
- ignore (session_notebook#append_term session)
- with _ -> ()
-
-
- let do_save session =
- try
- if session.script#buffer#modified then
- save_session session session.filename [session.encoding]
- with _ -> ()
-
-
- let choose_open =
- let last_filename = ref "" in fun session ->
- let open_dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Open file" ~modal:true () in
- let enc_frame = GBin.frame ~label:"File encoding" ~packing:(open_dialog#vbox#pack ~fill:false) () in
- let enc_entry = GEdit.entry ~text:(String.concat " " ["UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in
- let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok
- ~message:"Invalid encoding, please indicate the encoding to use." () in
- let open_response = function
- | `OPEN -> begin
- match open_dialog#filename with
- | Some fn -> begin
- try
- load_session session fn (Util.split_string_at ' ' enc_entry#text);
- session.analyzed_view <- Some (new analyzed_view session);
- init_session session;
- session_notebook#goto_page (session_notebook#append_term session);
- last_filename := fn
- with
- | Not_found -> open_dialog#misc#hide (); error_dialog#show ()
- | _ ->
- error_dialog#set_markup "Unknown error while loading file, aborting.";
- open_dialog#destroy (); error_dialog#destroy ()
- end
- | None -> ()
- end
- | `DELETE_EVENT -> open_dialog#destroy (); error_dialog#destroy ()
- in
- let _ = open_dialog#connect#response open_response in
- let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); open_dialog#show ()) in
- let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in
- let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in
- open_dialog#add_select_button_stock `OPEN `OPEN;
- open_dialog#add_button_stock `CANCEL `DELETE_EVENT;
- open_dialog#add_filter filter_any;
- open_dialog#add_filter filter_coq;
- ignore(open_dialog#set_filename !last_filename);
- open_dialog#show ()
-
-
- let choose_save session =
- let save_dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save file" ~modal:true () in
- let enc_frame = GBin.frame ~label:"File encoding" ~packing:(save_dialog#vbox#pack ~fill:false) () in
- let enc_entry = GEdit.entry ~text:(String.concat " " [session.encoding;"UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in
- let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok
- ~message:"Invalid encoding, please indicate the encoding to use." () in
- let save_response = function
- | `SAVE -> begin
- match save_dialog#filename with
- | Some fn -> begin
- try
- save_session session fn (Util.split_string_at ' ' enc_entry#text)
- with
- | Not_found -> save_dialog#misc#hide (); error_dialog#show ()
- | _ ->
- error_dialog#set_markup "Unknown error while saving file, aborting.";
- save_dialog#destroy (); error_dialog#destroy ()
- end
- | None -> ()
- end
- | `DELETE_EVENT -> save_dialog#destroy (); error_dialog#destroy ()
- in
- let _ = save_dialog#connect#response save_response in
- let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); save_dialog#show ()) in
- let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in
- let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in
- save_dialog#add_select_button_stock `SAVE `SAVE;
- save_dialog#add_button_stock `CANCEL `DELETE_EVENT;
- save_dialog#add_filter filter_any;
- save_dialog#add_filter filter_coq;
- ignore(save_dialog#set_filename session.filename);
- save_dialog#show ()
-*)
+let searchabout () = on_current_term searchabout
-(* Nota: using && here has the advantage of working both under win32 and unix.
- If someday we want the main command to be tried even if the "cd" has failed,
- then we should use " ; " under unix but " & " under win32 (cf. #2363).
-*)
+let otherquery command sn =
+ let word = get_current_word sn in
+ if word <> "" then
+ let query = command ^ " " ^ word ^ "." in
+ sn.messages#clear;
+ Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore
-let local_cd file =
- "cd " ^ Filename.quote (Filename.dirname file) ^ " && "
+let otherquery command = cb_on_current_term (otherquery command)
-let do_print session =
- let av = session.analyzed_view in
- match av#filename with
- |None -> flash_info "Cannot print: this buffer has no name"
- |Some f_name -> begin
- let cmd =
- local_cd f_name ^
- !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename f_name) ^
- " | " ^ !current.cmd_print
- in
- let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () in
- let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in
- let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in
- let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in
- let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in
- let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in
- let print_button = GButton.button ~stock:`PRINT ~label:"Print" ~packing:hbox_print#add () in
- let callback_print () =
- let cmd = print_entry#text in
- let s,_ = run_command av#insert_message cmd in
- flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed");
- print_window#destroy ()
- in
- ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ;
- ignore (print_button#connect#clicked ~callback:callback_print);
- print_window#misc#show ()
- end
+let query command _ =
+ if command = "Search" || command = "SearchAbout"
+ then searchabout ()
+ else otherquery command ()
-let load_file handler f =
- let f = absolute_filename f in
- try
- prerr_endline "Loading file starts";
- let is_f = Minilib.same_file f in
- if not (Minilib.list_fold_left_i
- (fun i found x -> if found then found else
- let {analyzed_view=av} = x in
- (match av#filename with
- | None -> false
- | Some fn ->
- if is_f fn
- then (session_notebook#goto_page i; true)
- else false))
- 0 false session_notebook#pages)
- then begin
- prerr_endline "Loading: must open";
- let b = Buffer.create 1024 in
- prerr_endline "Loading: get raw content";
- with_file handler f ~f:(input_channel b);
- prerr_endline "Loading: convert content";
- let s = do_convert (Buffer.contents b) in
- prerr_endline "Loading: create view";
- let session = create_session (Some f) in
- prerr_endline "Loading: adding view";
- let index = session_notebook#append_term session in
- let av = session.analyzed_view in
- prerr_endline "Loading: stats";
- av#update_stats;
- let input_buffer = session.script#buffer in
- prerr_endline "Loading: fill buffer";
- input_buffer#set_text s;
- input_buffer#place_cursor ~where:input_buffer#start_iter;
- force_retag input_buffer;
- prerr_endline ("Loading: switch to view "^ string_of_int index);
- session_notebook#goto_page index;
- prerr_endline "Loading: highlight";
- input_buffer#set_modified false;
- prerr_endline "Loading: clear undo";
- session.script#clear_undo;
- prerr_endline "Loading: success"
- end
- with
- | e -> handler ("Load failed: "^(Printexc.to_string e))
-
-let do_load = load_file flash_info
-
-let saveall_f () =
- List.iter
- (function
- | {script = view ; analyzed_view = av} ->
- begin match av#filename with
- | None -> ()
- | Some f ->
- ignore (av#save f)
- end
- ) session_notebook#pages
-
-let forbid_quit_to_save () =
- begin try save_pref() with e -> flash_info "Cannot save preferences" end;
- (if List.exists
- (function
- | {script=view} -> view#buffer#modified
- )
- session_notebook#pages then
- match (GToolbox.question_box ~title:"Quit"
- ~buttons:["Save Named Buffers and Quit";
- "Quit without Saving";
- "Don't Quit"]
- ~default:0
- ~icon:
- (let img = GMisc.image () in
- img#set_stock `DIALOG_WARNING;
- img#set_icon_size `DIALOG;
- img#coerce)
- "There are unsaved buffers"
- )
- with 1 -> saveall_f () ; false
- | 2 -> false
- | _ -> true
- else false)||
- (let wait_window =
- GWindow.window ~modal:true ~wm_class:"CoqIde" ~wm_name:"CoqIde" ~kind:`POPUP
- ~title:"Terminating coqtops" () in
- let _ =
- GMisc.label ~text:"Terminating coqtops processes, please wait ..."
- ~packing:wait_window#add () in
- let warning_window =
- GWindow.message_dialog ~message_type:`WARNING ~buttons:GWindow.Buttons.yes_no
- ~message:
- ("Some coqtops processes are still running.\n" ^
- "If you quit CoqIDE right now, you may have to kill them manually.\n" ^
- "Do you want to wait for those processes to terminate ?") () in
- let () = List.iter (fun _ -> session_notebook#remove_page 0) session_notebook#pages in
- let nb_try=ref (0) in
- let () = wait_window#show () in
- let () = while (Coq.coqtop_zombies () <> 0)&&(!nb_try <= 50) do
- incr nb_try;
- Thread.delay 0.1 ;
- done in
- if (!nb_try = 50) then begin
- wait_window#misc#hide ();
- match warning_window#run () with
- | `YES -> warning_window#misc#hide (); true
- | `NO | `DELETE_EVENT -> false
- end
- else false)
+end
-let logfile = ref None
+(** Misc *)
-let main files =
+module MiscMenu = struct
- (* Main window *)
- let w = GWindow.window
- ~wm_class:"CoqIde" ~wm_name:"CoqIde"
- ~allow_grow:true ~allow_shrink:true
- ~width:!current.window_width ~height:!current.window_height
- ~title:"CoqIde" ()
- in
- (try
- let icon_image = Filename.concat (List.find
- (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
- Minilib.xdg_data_dirs) "coq.png" in
- let icon = GdkPixbuf.from_file icon_image in
- w#set_icon (Some icon)
- with _ -> ());
+let detach_view sn = sn.control#detach ()
- let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
+let detach_view = cb_on_current_term detach_view
- let new_f _ =
- let session = create_session None in
- let index = session_notebook#append_term session in
- session_notebook#goto_page index
- in
- let load_f _ =
- match select_file_for_open ~title:"Load file" () with
- | None -> ()
- | Some f -> do_load f
- in
- let save_f _ =
- let current = session_notebook#current_term in
- try
- (match current.analyzed_view#filename with
- | None ->
- begin match select_file_for_save ~title:"Save file" ()
- with
- | None -> ()
- | Some f ->
- if current.analyzed_view#save_as f then begin
- current.tab_label#set_text (Filename.basename f);
- flash_info ("File " ^ f ^ " saved")
- end
- else warning ("Save Failed (check if " ^ f ^ " is writable)")
- end
- | Some f ->
- if current.analyzed_view#save f then
- flash_info ("File " ^ f ^ " saved")
- else warning ("Save Failed (check if " ^ f ^ " is writable)")
-
- )
- with
- | e -> warning "Save: unexpected error"
- in
- let saveas_f _ =
- let current = session_notebook#current_term in
- try (match current.analyzed_view#filename with
- | None ->
- begin match select_file_for_save ~title:"Save file as" ()
- with
- | None -> ()
- | Some f ->
- if current.analyzed_view#save_as f then begin
- current.tab_label#set_text (Filename.basename f);
- flash_info "Saved"
- end
- else flash_info "Save Failed"
- end
- | Some f ->
- begin match select_file_for_save
- ~dir:(ref (Filename.dirname f))
- ~filename:(Filename.basename f)
- ~title:"Save file as" ()
- with
- | None -> ()
- | Some f ->
- if current.analyzed_view#save_as f then begin
- current.tab_label#set_text (Filename.basename f);
- flash_info "Saved"
- end else flash_info "Save Failed"
- end);
- with e -> flash_info "Save Failed"
- in
- let revert_f {analyzed_view = av} =
- (try
- match av#filename,av#stats with
- | Some f,Some stats ->
- let new_stats = Unix.stat f in
- if new_stats.Unix.st_mtime > stats.Unix.st_mtime
- then av#revert
- | Some _, None -> av#revert
- | _ -> ()
- with _ -> av#revert)
- in
- let export_f kind _ =
- let v = session_notebook#current_term in
- let av = v.analyzed_view in
- match av#filename with
- | None ->
- flash_info "Cannot print: this buffer has no name"
- | Some f ->
- let basef = Filename.basename f in
- let output =
- let basef_we = try Filename.chop_extension basef with _ -> basef in
- match kind with
- | "latex" -> basef_we ^ ".tex"
- | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
- | _ -> assert false
- in
- let cmd =
- local_cd f ^ !current.cmd_coqdoc ^ " --" ^ kind ^
- " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef)
- in
- let s,_ = run_command av#insert_message cmd in
- flash_info (cmd ^
- if s = Unix.WEXITED 0
- then " succeeded"
- else " failed")
- in
- let quit_f _ = if not (forbid_quit_to_save ()) then exit 0 in
- let get_active_view_for_cp () =
- let has_sel (i0,i1) = i0#compare i1 <> 0 in
- let current = session_notebook#current_term in
- if has_sel current.script#buffer#selection_bounds
- then current.script#as_view
- else if has_sel current.proof_view#buffer#selection_bounds
- then current.proof_view#as_view
- else current.message_view#as_view
- in
- (*
- let toggle_auto_complete_i =
- edit_f#add_check_item "_Auto Completion"
- ~active:!current.auto_complete
- ~callback:
- in
- *)
- (*
- auto_complete :=
- (fun b -> match session_notebook#current_term.analyzed_view with
- | Some av -> av#set_auto_complete b
- | None -> ());
- *)
-
-(* begin of find/replace mechanism *)
- let last_found = ref None in
- let search_backward = ref false in
- let find_w = GWindow.window
- (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
- (* ~allow_grow:true ~allow_shrink:true *)
- (* ~width:!current.window_width ~height:!current.window_height *)
- ~position:`CENTER
- ~title:"CoqIde search/replace" ()
- in
- let find_box = GPack.table
- ~columns:3 ~rows:5
- ~col_spacings:10 ~row_spacings:10 ~border_width:10
- ~homogeneous:false ~packing:find_w#add () in
+let log_file_message () =
+ if !Minilib.debug then
+ let file = match !logfile with None -> "stderr" | Some f -> f in
+ "\nDebug mode is on, log file is "^file
+ else ""
- let _ =
- GMisc.label ~text:"Find:"
- ~xalign:1.0
- ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) ()
+let initial_about () =
+ let initial_string =
+ "Welcome to CoqIDE, an Integrated Development Environment for Coq"
in
- let find_entry = GEdit.entry
- ~editable: true
- ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X)
- ()
+ let coq_version = Coq.short_version () in
+ let version_info =
+ if Glib.Utf8.validate coq_version then
+ "\nYou are running " ^ coq_version
+ else ""
in
+ let msg = initial_string ^ version_info ^ log_file_message () in
+ on_current_term (fun term -> term.messages#add msg)
+
+let coq_icon () =
+ (* May raise Nof_found *)
+ let name = "coq.png" in
+ let chk d = Sys.file_exists (Filename.concat d name) in
+ let dir = List.find chk (Minilib.coqide_data_dirs ()) in
+ Filename.concat dir name
+
+let about _ =
+ let dialog = GWindow.about_dialog () in
+ let _ = dialog#connect#response ~callback:(fun _ -> dialog#destroy ()) in
let _ =
- GMisc.label ~text:"Replace with:"
- ~xalign:1.0
- ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) ()
- in
- let replace_entry = GEdit.entry
- ~editable: true
- ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
- ()
- in
- (* let _ =
- GButton.check_button
- ~label:"case sensitive"
- ~active:true
- ~packing: (find_box#attach ~left:1 ~top:2)
- ()
- in
- *)
- let find_backwards_check =
- GButton.check_button
- ~label:"search backwards"
- ~active:!search_backward
- ~packing: (find_box#attach ~left:1 ~top:3)
- ()
- in
- let close_find_button =
- GButton.button
- ~label:"Close"
- ~packing: (find_box#attach ~left:2 ~top:2)
- ()
- in
- let replace_find_button =
- GButton.button
- ~label:"Replace and find"
- ~packing: (find_box#attach ~left:2 ~top:1)
- ()
- in
- let find_again_button =
- GButton.button
- ~label:"_Find again"
- ~packing: (find_box#attach ~left:2 ~top:0)
- ()
- in
- let last_find () =
- let v = session_notebook#current_term.script in
- let b = v#buffer in
- let start,stop =
- match !last_found with
- | None -> let i = b#get_iter_at_mark `INSERT in (i,i)
- | Some(start,stop) ->
- let start = b#get_iter_at_mark start
- and stop = b#get_iter_at_mark stop
- in
- b#remove_tag Tags.Script.found ~start ~stop;
- last_found:=None;
- start,stop
- in
- (v,b,start,stop)
+ try dialog#set_logo (GdkPixbuf.from_file (coq_icon ()))
+ with _ -> ()
in
- let do_replace () =
- let v = session_notebook#current_term.script in
- let b = v#buffer in
- match !last_found with
- | None -> ()
- | Some(start,stop) ->
- let start = b#get_iter_at_mark start
- and stop = b#get_iter_at_mark stop
- in
- b#delete ~start ~stop;
- b#insert ~iter:start replace_entry#text;
- last_found:=None
+ let copyright =
+ "Coq is developed by the Coq Development Team\n\
+ (INRIA - CNRS - LIX - LRI - PPS)"
in
- let find_from (v : Undo.undoable_view)
- (b : GText.buffer) (starti : GText.iter) text =
- prerr_endline ("Searching for " ^ text);
- match (if !search_backward then starti#backward_search text
- else starti#forward_search text)
- with
- | None -> ()
- | Some(start,stop) ->
- b#apply_tag Tags.Script.found ~start ~stop;
- let start = `MARK (b#create_mark start)
- and stop = `MARK (b#create_mark stop)
- in
- v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25
- stop;
- last_found := Some(start,stop)
+ let authors = [
+ "Benjamin Monate";
+ "Jean-Christophe Filliâtre";
+ "Pierre Letouzey";
+ "Claude Marché";
+ "Bruno Barras";
+ "Pierre Corbineau";
+ "Julien Narboux";
+ "Hugo Herbelin";
+ "Enrico Tassi";
+ ]
in
- let do_find () =
- let (v,b,starti,_) = last_find () in
- find_from v b starti find_entry#text
+ dialog#set_name "CoqIDE";
+ dialog#set_comments "The Coq Integrated Development Environment";
+ dialog#set_website Coq_config.wwwcoq;
+ dialog#set_version Coq_config.version;
+ dialog#set_copyright copyright;
+ dialog#set_authors authors;
+ dialog#show ()
+
+let comment = cb_on_current_term (fun t -> t.script#comment ())
+let uncomment = cb_on_current_term (fun t -> t.script#uncomment ())
+
+let coqtop_arguments sn =
+ let dialog = GWindow.dialog ~title:"Coqtop arguments" () in
+ let coqtop = sn.coqtop in
+ (** Text entry *)
+ let args = Coq.get_arguments coqtop in
+ let text = String.concat " " args in
+ let entry = GEdit.entry ~text ~packing:dialog#vbox#add () in
+ (** Buttons *)
+ let box = dialog#action_area in
+ let ok = GButton.button ~stock:`OK ~packing:box#add () in
+ let ok_cb () =
+ let nargs = CString.split ' ' entry#text in
+ if nargs <> args then
+ let failed = Coq.filter_coq_opts nargs in
+ match failed with
+ | [] ->
+ let () = Coq.set_arguments coqtop nargs in
+ dialog#destroy ()
+ | args ->
+ let args = String.concat " " args in
+ let msg = Printf.sprintf "Invalid arguments: %s" args in
+ let () = sn.messages#clear in
+ sn.messages#push Pp.Error msg
+ else dialog#destroy ()
in
- let do_replace_find () =
- do_replace();
- do_find()
+ let _ = entry#connect#activate ok_cb in
+ let _ = ok#connect#clicked ok_cb in
+ let cancel = GButton.button ~stock:`CANCEL ~packing:box#add () in
+ let cancel_cb () = dialog#destroy () in
+ let _ = cancel#connect#clicked cancel_cb in
+ dialog#show ()
+
+let coqtop_arguments = cb_on_current_term coqtop_arguments
+
+let show_hide_query_pane sn =
+ let ccw = sn.command in
+ if ccw#visible then ccw#hide else ccw#show
+
+let zoom_fit sn =
+ let script = sn.script in
+ let space = script#misc#allocation.Gtk.width in
+ let cols = script#right_margin_position in
+ let pango_ctx = script#misc#pango_context in
+ let layout = pango_ctx#create_layout in
+ let fsize = Pango.Font.get_size current.text_font in
+ Pango.Layout.set_text layout (String.make cols 'X');
+ let tlen = fst (Pango.Layout.get_pixel_size layout) in
+ Pango.Font.set_size current.text_font
+ (fsize * space / tlen / Pango.scale * Pango.scale);
+ save_pref ();
+ !refresh_editor_hook ()
+
+end
+
+(** Refresh functions *)
+
+let refresh_editor_prefs () =
+ let wrap_mode = if prefs.dynamic_word_wrap then `WORD else `NONE in
+ let show_spaces =
+ if prefs.show_spaces then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *)
+ else 0
in
- let close_find () =
- let (v,b,_,stop) = last_find () in
- b#place_cursor ~where:stop;
- find_w#misc#hide();
- v#coerce#misc#grab_focus()
+ let fd = prefs.text_font in
+ let clr = Tags.color_of_string prefs.background_color
in
- to_do_on_page_switch :=
- (fun i -> if find_w#misc#visible then close_find())::
- !to_do_on_page_switch;
- let find_again () =
- let (v,b,start,_) = last_find () in
- let start =
- if !search_backward
- then start#backward_chars 1
- else start#forward_chars 1
+ let iter_session sn =
+ (* Editor settings *)
+ sn.script#set_wrap_mode wrap_mode;
+ sn.script#set_show_line_numbers prefs.show_line_number;
+ sn.script#set_auto_indent prefs.auto_indent;
+ sn.script#set_highlight_current_line prefs.highlight_current_line;
+
+ (* Hack to handle missing binding in lablgtk *)
+ let conv = { Gobject.name = "draw-spaces"; Gobject.conv = Gobject.Data.int }
in
- find_from v b start find_entry#text
+ Gobject.set conv sn.script#as_widget show_spaces;
+
+ sn.script#set_show_right_margin prefs.show_right_margin;
+ if prefs.show_progress_bar then sn.segment#misc#show () else sn.segment#misc#hide ();
+ sn.script#set_insert_spaces_instead_of_tabs
+ prefs.spaces_instead_of_tabs;
+ sn.script#set_tab_width prefs.tab_length;
+ sn.script#set_auto_complete prefs.auto_complete;
+
+ (* Fonts *)
+ sn.script#misc#modify_font fd;
+ sn.proof#misc#modify_font fd;
+ sn.messages#modify_font fd;
+ sn.command#refresh_font ();
+
+ (* Colors *)
+ sn.script#misc#modify_base [`NORMAL, `COLOR clr];
+ sn.proof#misc#modify_base [`NORMAL, `COLOR clr];
+ sn.messages#misc#modify_base [`NORMAL, `COLOR clr];
+ sn.command#refresh_color ()
+
in
- let click_on_backward () =
- search_backward := not !search_backward
+ List.iter iter_session notebook#pages
+
+let refresh_notebook_pos () =
+ let pos = match prefs.vertical_tabs, prefs.opposite_tabs with
+ | false, false -> `TOP
+ | false, true -> `BOTTOM
+ | true , false -> `LEFT
+ | true , true -> `RIGHT
in
- let key_find ev =
- let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in
- if k = GdkKeysyms._Escape then
- begin
- let (v,b,_,stop) = last_find () in
- find_w#misc#hide();
- v#coerce#misc#grab_focus();
- true
- end
- else if k = GdkKeysyms._Escape then
- begin
- close_find();
- true
- end
- else if k = GdkKeysyms._Return ||
- List.mem `CONTROL s && k = GdkKeysyms._f then
- begin
- find_again ();
- true
- end
- else if List.mem `CONTROL s && k = GdkKeysyms._b then
- begin
- find_backwards_check#set_active (not !search_backward);
- true
- end
- else false (* to let default callback execute *)
+ notebook#set_tab_pos pos
+
+(** Wrappers around GAction functions for creating menus *)
+
+let menu = GAction.add_actions
+let item = GAction.add_action
+
+(** Toggle items in menus for printing options *)
+
+let toggle_item = GAction.add_toggle_action
+
+(** Search the first '_' in a label string and return the following
+ character as shortcut, plus the string without the '_' *)
+
+let get_shortcut s =
+ try
+ let n = String.length s in
+ let i = String.index s '_' in
+ let k = String.make 1 s.[i+1] in
+ let s' = (String.sub s 0 i) ^ (String.sub s (i+1) (n-i-1)) in
+ Some k, s'
+ with _ -> None,s
+
+module Opt = Coq.PrintOpt
+
+let toggle_items menu_name l =
+ let f d =
+ let label = d.Opt.label in
+ let k, name = get_shortcut label in
+ let accel = Option.map ((^) prefs.modifier_for_display) k in
+ toggle_item name ~label ?accel ~active:d.Opt.init
+ ~callback:(printopts_callback d.Opt.opts)
+ menu_name
in
- let find_f ~backward () =
- let save_dir = !search_backward in
- search_backward := backward;
- find_w#show ();
- find_w#present ();
- find_entry#misc#grab_focus ();
- search_backward := save_dir
+ List.iter f l
+
+(** Create alphabetical menu items with elements in sub-items.
+ [l] is a list of lists, one per initial letter *)
+
+let alpha_items menu_name item_name l =
+ let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
in
- let _ = find_again_button#connect#clicked find_again in
- let _ = close_find_button#connect#clicked close_find in
- let _ = replace_find_button#connect#clicked do_replace_find in
- let _ = find_backwards_check#connect#clicked click_on_backward in
- let _ = find_entry#connect#changed do_find in
- let _ = find_entry#event#connect#key_press ~callback:key_find in
- let _ = find_w#event#connect#delete ~callback:(fun _ -> find_w#misc#hide(); true) in
- (*
- let search_if = edit_f#add_item "Search _forward"
- ~key:GdkKeysyms._greater
- in
- let search_ib = edit_f#add_item "Search _backward"
- ~key:GdkKeysyms._less
+ let mk_item text =
+ let text' =
+ let last = String.length text - 1 in
+ if text.[last] = '.'
+ then text ^"\n"
+ else text ^" "
in
- *)
- (*
- let complete_i = edit_f#add_item "_Complete"
- ~key:GdkKeysyms._comma
- ~callback:
- (do_if_not_computing
- (fun b ->
- let v = session_notebook#current_term.analyzed_view
-
- in v#complete_at_offset
- ((v#view#buffer#get_iter `SEL_BOUND)#offset)
- ))
+ let callback _ =
+ on_current_term (fun sn -> sn.buffer#insert_interactive text')
in
- complete_i#misc#set_state `INSENSITIVE;
- *)
-(* end of find/replace mechanism *)
-(* begin Preferences *)
- let reset_revert_timer () =
- disconnect_revert_timer ();
- if !current.global_auto_revert then
- revert_timer := Some
- (GMain.Timeout.add ~ms:!current.global_auto_revert_delay
- ~callback:
- (fun () ->
- do_if_not_computing "revert" (sync revert_f) session_notebook#pages;
- true))
- in reset_revert_timer (); (* to enable statup preferences timer *)
- (* XXX *)
- let auto_save_f {analyzed_view = av} =
- (try
- av#auto_save
- with _ -> ())
- in
-
- let reset_auto_save_timer () =
- disconnect_auto_save_timer ();
- if !current.auto_save then
- auto_save_timer := Some
- (GMain.Timeout.add ~ms:!current.auto_save_delay
- ~callback:
- (fun () ->
- do_if_not_computing "autosave" (sync auto_save_f) session_notebook#pages;
- true))
- in reset_auto_save_timer (); (* to enable statup preferences timer *)
-(* end Preferences *)
-
- let do_or_activate f () =
- do_if_not_computing "do_or_activate"
- (fun current ->
- let av = current.analyzed_view in
- ignore (f av);
- pop_info ();
- let msg = match Coq.status !(current.toplvl) with
- | Interface.Fail (l, str) ->
- "Oops, problem while fetching coq status."
- | Interface.Good status ->
- let path = match status.Interface.status_path with
- | [] | _ :: [] -> "" (* Drop the topmost level, usually "Top" *)
- | _ :: l -> " in " ^ String.concat "." l
- in
- let name = match status.Interface.status_proofname with
- | None -> ""
- | Some n -> ", proving " ^ n
- in
- "Ready" ^ path ^ name
- in
- push_info msg
- )
- [session_notebook#current_term]
- in
- let do_if_active f _ =
- do_if_not_computing "do_if_active"
- (fun sess -> ignore (f sess.analyzed_view))
- [session_notebook#current_term] in
- let match_callback _ =
- let w = get_current_word () in
- let cur_ct = !(session_notebook#current_term.toplvl) in
- try
- match Coq.mkcases cur_ct w with
- | Interface.Fail _ -> raise Not_found
- | Interface.Good cases ->
- let print_branch c l =
- Format.fprintf c " | @[<hov 1>%a@]=> _@\n"
- (print_list (fun c s -> Format.fprintf c "%s@ " s)) l
- in
- let b = Buffer.create 1024 in
- let fmt = Format.formatter_of_buffer b in
- Format.fprintf fmt "@[match var with@\n%aend@]@."
- (print_list print_branch) cases;
- let s = Buffer.contents b in
- prerr_endline s;
- let {script = view } = session_notebook#current_term in
- ignore (view#buffer#delete_selection ());
- let m = view#buffer#create_mark
- (view#buffer#get_iter `INSERT)
- in
- if view#buffer#insert_interactive s then
- let i = view#buffer#get_iter (`MARK m) in
- let _ = i#nocopy#forward_chars 9 in
- view#buffer#place_cursor ~where:i;
- view#buffer#move_mark ~where:(i#backward_chars 3)
- `SEL_BOUND
- with Not_found -> flash_info "Not an inductive type"
- in
-(* External command callback *)
- let compile_f _ =
- let v = session_notebook#current_term in
- let av = v.analyzed_view in
- save_f ();
- match av#filename with
- | None ->
- flash_info "Active buffer has no name"
- | Some f ->
- let cmd = !current.cmd_coqc ^ " -I "
- ^ (Filename.quote (Filename.dirname f))
- ^ " " ^ (Filename.quote f) in
- let s,res = run_command av#insert_message cmd in
- if s = Unix.WEXITED 0 then
- flash_info (f ^ " successfully compiled")
- else begin
- flash_info (f ^ " failed to compile");
- av#process_until_end_or_error;
- av#insert_message "Compilation output:\n";
- av#insert_message res
- end
- in
- let make_f _ =
- let v = session_notebook#current_term in
- let av = v.analyzed_view in
- match av#filename with
- | None ->
- flash_info "Cannot make: this buffer has no name"
- | Some f ->
- let cmd = local_cd f ^ !current.cmd_make in
-
- (*
- save_f ();
- *)
- av#insert_message "Command output:\n";
- let s,res = run_command av#insert_message cmd in
- last_make := res;
- last_make_index := 0;
- flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+ item (item_name^" "^(no_under text)) ~label:text ~callback menu_name
in
- let next_error _ =
- try
- let file,line,start,stop,error_msg = search_next_error () in
- do_load file;
- let v = session_notebook#current_term in
- let av = v.analyzed_view in
- let input_buffer = v.script#buffer in
- (*
- let init = input_buffer#start_iter in
- let i = init#forward_lines (line-1) in
- *)
- (*
- let convert_pos = byte_offset_to_char_offset phrase in
- let start = convert_pos start in
- let stop = convert_pos stop in
- *)
- (*
- let starti = i#forward_chars start in
- let stopi = i#forward_chars stop in
- *)
- let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
- let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
- input_buffer#apply_tag Tags.Script.error
- ~start:starti
- ~stop:stopi;
- input_buffer#place_cursor ~where:starti;
- av#set_message error_msg;
- v.script#misc#grab_focus ()
- with Not_found ->
- last_make_index := 0;
- let v = session_notebook#current_term in
- let av = v.analyzed_view in
- av#set_message "No more errors.\n"
+ let mk_items = function
+ | [] -> ()
+ | [s] -> mk_item s
+ | s::_ as ll ->
+ let name = item_name^" "^(String.make 1 s.[0]) in
+ let label = "_@..." in label.[1] <- s.[0];
+ item name ~label menu_name;
+ List.iter mk_item ll
in
- let coq_makefile_f _ =
- let v = session_notebook#current_term in
- let av = v.analyzed_view in
- match av#filename with
- | None ->
- flash_info "Cannot make makefile: this buffer has no name"
- | Some f ->
- let cmd = local_cd f ^ !current.cmd_coqmakefile in
- let s,res = run_command av#insert_message cmd in
- flash_info
- (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+ List.iter mk_items l
+
+(** Create a menu item that will insert a given text,
+ and select the zone given by (offset,len).
+ The first word in the text is used as item keyword.
+ Caveat: the offset is now from the start of the text. *)
+
+let template_item (text, offset, len, key) =
+ let modifier = prefs.modifier_for_templates in
+ let idx = String.index text ' ' in
+ let name = String.sub text 0 idx in
+ let label = "_"^name^" __" in
+ let negoffset = String.length text - offset - len in
+ let callback sn =
+ let b = sn.buffer in
+ if b#insert_interactive text then begin
+ let iter = b#get_iter_at_mark `INSERT in
+ ignore (iter#nocopy#backward_chars negoffset);
+ b#move_mark `INSERT ~where:iter;
+ ignore (iter#nocopy#backward_chars len);
+ b#move_mark `SEL_BOUND ~where:iter;
+ end
in
+ item name ~label ~callback:(cb_on_current_term callback) ~accel:(modifier^key)
- let file_actions = GAction.action_group ~name:"File" () in
- let edit_actions = GAction.action_group ~name:"Edit" () in
- let view_actions = GAction.action_group ~name:"View" () in
- let export_actions = GAction.action_group ~name:"Export" () in
- let navigation_actions = GAction.action_group ~name:"Navigation" () in
- let tactics_actions = GAction.action_group ~name:"Tactics" () in
- let templates_actions = GAction.action_group ~name:"Templates" () in
- let queries_actions = GAction.action_group ~name:"Queries" () in
- let compile_actions = GAction.action_group ~name:"Compile" () in
- let windows_actions = GAction.action_group ~name:"Windows" () in
- let help_actions = GAction.action_group ~name:"Help" () in
- let add_gen_actions menu_name act_grp l =
- let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x) in
- let add_simple_template menu_name act_grp text =
- let text' =
- let l = String.length text - 1 in
- if String.get text l = '.'
- then text ^"\n"
- else text ^" "
- in
- GAction.add_action (menu_name^" "^(no_under text)) ~label:text
- ~callback:(fun _ -> let {script = view } = session_notebook#current_term in
- ignore (view#buffer#insert_interactive text')) act_grp
- in
- List.iter (function
- | [] -> ()
- | [s] -> add_simple_template menu_name act_grp s
- | s::_ as ll -> let label = "_@..." in label.[1] <- s.[0];
- GAction.add_action (menu_name^" "^(String.make 1 s.[0])) ~label act_grp;
- List.iter (add_simple_template menu_name act_grp) ll
- ) l
- in
- let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s)
- ~accel:(!current.modifier_for_tactics^sc)
- ~callback:(do_if_active (fun a -> a#insert_command
- ("progress "^s^".") (s^"."))) in
- let query_callback command _ =
- let word = get_current_word () in
- if not (word = "") then
- let term = session_notebook#current_term in
- let query = command ^ " " ^ word ^ "." in
- term.message_view#buffer#set_text "";
- term.analyzed_view#raw_coq_query query
- in
- let query_shortcut s accel =
- GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s)
- in
- let add_complex_template (name, label, text, offset, len, key) =
- (* Templates/Lemma *)
- let callback _ =
- let {script = view } = session_notebook#current_term in
- if view#buffer#insert_interactive text then begin
- let iter = view#buffer#get_iter_at_mark `INSERT in
- ignore (iter#nocopy#backward_chars offset);
- view#buffer#move_mark `INSERT ~where:iter;
- ignore (iter#nocopy#backward_chars len);
- view#buffer#move_mark `SEL_BOUND ~where:iter;
- end in
- match key with
- |Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac)
- |None -> GAction.add_action name ~label ~callback ?accel:None
+let emit_to_focus window sgn =
+ let focussed_widget = GtkWindow.Window.get_focus window#as_window in
+ let obj = Gobject.unsafe_cast focussed_widget in
+ try GtkSignal.emit_unit obj ~sgn with _ -> ()
+
+(** {2 Creation of the main coqide window } *)
+
+let build_ui () =
+ let w = GWindow.window
+ ~wm_class:"CoqIde" ~wm_name:"CoqIde"
+ ~allow_grow:true ~allow_shrink:true
+ ~width:prefs.window_width ~height:prefs.window_height
+ ~title:"CoqIde" ()
in
- let detach_view _ =
- (* Open a separate window containing the current buffer *)
- let trm = session_notebook#current_term in
- let w = GWindow.window ~show:true
- ~width:(!current.window_width*2/3)
- ~height:(!current.window_height*2/3)
- ~position:`CENTER
- ~title:(if trm.filename = "" then "*scratch*" else trm.filename)
- ()
- in
- let sb = GBin.scrolled_window ~packing:w#add ()
- in
- let nv = GText.view ~buffer:trm.script#buffer ~packing:sb#add ()
- in
- nv#misc#modify_font !current.text_font;
- (* If the buffer in the main window is closed, destroy this detached view *)
- ignore (trm.script#connect#destroy ~callback:w#destroy)
+ let () =
+ try w#set_icon (Some (GdkPixbuf.from_file (MiscMenu.coq_icon ())))
+ with _ -> ()
in
- GAction.add_actions file_actions [
- GAction.add_action "File" ~label:"_File";
- GAction.add_action "New" ~callback:new_f ~stock:`NEW;
- GAction.add_action "Open" ~callback:load_f ~stock:`OPEN;
- GAction.add_action "Save" ~callback:save_f ~stock:`SAVE ~tooltip:"Save current buffer";
- GAction.add_action "Save as" ~label:"S_ave as" ~callback:saveas_f ~stock:`SAVE_AS;
- GAction.add_action "Save all" ~label:"Sa_ve all" ~callback:(fun _ -> saveall_f ());
- GAction.add_action "Revert all buffers" ~label:"_Revert all buffers" ~callback:(fun _ -> List.iter revert_f session_notebook#pages) ~stock:`REVERT_TO_SAVED;
- GAction.add_action "Close buffer" ~label:"_Close buffer" ~callback:(fun _ -> remove_current_view_page ()) ~stock:`CLOSE ~tooltip:"Close current buffer";
- GAction.add_action "Print..." ~label:"_Print..." ~callback:(fun _ -> do_print session_notebook#current_term) ~stock:`PRINT ~accel:"<Ctrl>p";
- GAction.add_action "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l"
- ~callback:(fun _ -> force_retag
- session_notebook#current_term.script#buffer;
- session_notebook#current_term.analyzed_view#recenter_insert)
- ~stock:`REFRESH;
- GAction.add_action "Quit" ~callback:quit_f ~stock:`QUIT;
- ];
- GAction.add_actions export_actions [
- GAction.add_action "Export to" ~label:"E_xport to";
- GAction.add_action "Html" ~label:"_Html" ~callback:(export_f "html");
- GAction.add_action "Latex" ~label:"_LaTeX" ~callback:(export_f "latex");
- GAction.add_action "Dvi" ~label:"_Dvi" ~callback:(export_f "dvi");
- GAction.add_action "Pdf" ~label:"_Pdf" ~callback:(export_f "pdf");
- GAction.add_action "Ps" ~label:"_Ps" ~callback:(export_f "ps");
- ];
- GAction.add_actions edit_actions [
- GAction.add_action "Edit" ~label:"_Edit";
- GAction.add_action "Undo" ~accel:"<Ctrl>u"
- ~callback:(fun _ -> do_if_not_computing "undo"
- (fun sess ->
- ignore (sess.analyzed_view#without_auto_complete
- (fun () -> session_notebook#current_term.script#undo) ()))
- [session_notebook#current_term]) ~stock:`UNDO;
- GAction.add_action "Clear Undo Stack" ~label:"_Clear Undo Stack"
- ~callback:(fun _ -> ignore session_notebook#current_term.script#clear_undo);
- GAction.add_action "Cut" ~callback:(fun _ -> GtkSignal.emit_unit
- (get_active_view_for_cp ())
- ~sgn:GtkText.View.S.cut_clipboard
- ) ~stock:`CUT;
- GAction.add_action "Copy" ~callback:(fun _ -> GtkSignal.emit_unit
- (get_active_view_for_cp ())
- ~sgn:GtkText.View.S.copy_clipboard) ~stock:`COPY;
- GAction.add_action "Paste" ~callback:(fun _ ->
- try GtkSignal.emit_unit
- session_notebook#current_term.script#as_view
- ~sgn:GtkText.View.S.paste_clipboard
- with _ -> prerr_endline "EMIT PASTE FAILED") ~stock:`PASTE;
- GAction.add_action "Find in buffer" ~label:"_Find in buffer" ~callback:(fun _ -> find_f ~backward:false ()) ~stock:`FIND;
- GAction.add_action "Find backwards" ~label:"Find _backwards" ~callback:(fun _ -> find_f ~backward:true ()) ~accel:"<Ctrl>b";
- GAction.add_action "Complete Word" ~label:"Complete Word" ~callback:(fun _ ->
- ignore (
- let av = session_notebook#current_term.analyzed_view in
- av#complete_at_offset (av#get_insert)#offset
- )) ~accel:"<Ctrl>slash";
- GAction.add_action "External editor" ~label:"External editor" ~callback:(fun _ ->
- let av = session_notebook#current_term.analyzed_view in
- match av#filename with
- | None -> warning "Call to external editor available only on named files"
- | Some f ->
- save_f ();
- let com = Minilib.subst_command_placeholder !current.cmd_editor (Filename.quote f) in
- let _ = run_command av#insert_message com in
- av#revert) ~stock:`EDIT;
- GAction.add_action "Preferences" ~callback:(fun _ ->
- begin
- try configure ~apply:update_notebook_pos ()
+ let _ = w#event#connect#delete ~callback:(fun _ -> File.quit (); true) in
+ let _ = set_drag w#drag in
+
+ let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
+
+ let file_menu = GAction.action_group ~name:"File" () in
+ let edit_menu = GAction.action_group ~name:"Edit" () in
+ let view_menu = GAction.action_group ~name:"View" () in
+ let export_menu = GAction.action_group ~name:"Export" () in
+ let navigation_menu = GAction.action_group ~name:"Navigation" () in
+ let tactics_menu = GAction.action_group ~name:"Tactics" () in
+ let templates_menu = GAction.action_group ~name:"Templates" () in
+ let tools_menu = GAction.action_group ~name:"Tools" () in
+ let queries_menu = GAction.action_group ~name:"Queries" () in
+ let compile_menu = GAction.action_group ~name:"Compile" () in
+ let windows_menu = GAction.action_group ~name:"Windows" () in
+ let help_menu = GAction.action_group ~name:"Help" () in
+ let all_menus = [
+ file_menu; edit_menu; view_menu; export_menu; navigation_menu; tactics_menu;
+ templates_menu; tools_menu; queries_menu; compile_menu; windows_menu;
+ help_menu; ] in
+
+ menu file_menu [
+ item "File" ~label:"_File";
+ item "New" ~callback:File.newfile ~stock:`NEW;
+ item "Open" ~callback:File.load ~stock:`OPEN;
+ item "Save" ~callback:File.save ~stock:`SAVE ~tooltip:"Save current buffer";
+ item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:File.saveas;
+ item "Save all" ~label:"Sa_ve all" ~callback:File.saveall;
+ item "Revert all buffers" ~label:"_Revert all buffers"
+ ~callback:File.revert_all ~stock:`REVERT_TO_SAVED;
+ item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE
+ ~callback:File.close_buffer ~tooltip:"Close current buffer";
+ item "Print..." ~label:"_Print..."
+ ~callback:File.print ~stock:`PRINT ~accel:"<Ctrl>p";
+ item "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l"
+ ~callback:File.highlight ~stock:`REFRESH;
+ item "Quit" ~stock:`QUIT ~callback:File.quit;
+ ];
+
+ menu export_menu [
+ item "Export to" ~label:"E_xport to";
+ item "Html" ~label:"_Html" ~callback:(File.export "html");
+ item "Latex" ~label:"_LaTeX" ~callback:(File.export "latex");
+ item "Dvi" ~label:"_Dvi" ~callback:(File.export "dvi");
+ item "Pdf" ~label:"_Pdf" ~callback:(File.export "pdf");
+ item "Ps" ~label:"_Ps" ~callback:(File.export "ps");
+ ];
+
+ menu edit_menu [
+ item "Edit" ~label:"_Edit";
+ item "Undo" ~accel:"<Ctrl>u" ~stock:`UNDO
+ ~callback:(cb_on_current_term (fun t -> t.script#undo ()));
+ item "Redo" ~stock:`REDO
+ ~callback:(cb_on_current_term (fun t -> t.script#redo ()));
+ item "Cut" ~stock:`CUT
+ ~callback:(fun _ -> emit_to_focus w GtkText.View.S.cut_clipboard);
+ item "Copy" ~stock:`COPY
+ ~callback:(fun _ -> emit_to_focus w GtkText.View.S.copy_clipboard);
+ item "Paste" ~stock:`PASTE
+ ~callback:(fun _ -> emit_to_focus w GtkText.View.S.paste_clipboard);
+ item "Find" ~stock:`FIND ~label:"Find / Replace"
+ ~callback:(cb_on_current_term (fun t -> t.finder#show ()));
+ item "Find Next" ~label:"Find _Next" ~stock:`GO_DOWN ~accel:"F3"
+ ~callback:(cb_on_current_term (fun t -> t.finder#find_forward ()));
+ item "Find Previous" ~label:"Find _Previous" ~stock:`GO_UP
+ ~accel:"<Shift>F3"
+ ~callback:(cb_on_current_term (fun t -> t.finder#find_backward ()));
+ item "Complete Word" ~label:"Complete Word" ~accel:"<Ctrl>slash"
+ ~callback:(fun _ -> ());
+ item "External editor" ~label:"External editor" ~stock:`EDIT
+ ~callback:External.editor;
+ item "Preferences" ~accel:"<Ctrl>comma" ~stock:`PREFERENCES
+ ~callback:(fun _ ->
+ begin
+ try Preferences.configure ~apply:refresh_notebook_pos ()
with _ -> flash_info "Cannot save preferences"
- end;
- reset_revert_timer ()) ~accel:"<Ctrl>comma" ~stock:`PREFERENCES;
- (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ];
- GAction.add_actions view_actions [
- GAction.add_action "View" ~label:"_View";
- GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("<ALT>Left") ~stock:`GO_BACK
- ~callback:(fun _ -> session_notebook#previous_page ());
- GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("<ALT>Right") ~stock:`GO_FORWARD
- ~callback:(fun _ -> session_notebook#next_page ());
- GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar"
- ~active:(!current.show_toolbar) ~callback:
- (fun _ -> !current.show_toolbar <- not !current.show_toolbar;
- !refresh_toolbar_hook ());
- GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane"
- ~callback:(fun _ -> let ccw = session_notebook#current_term.command in
- if ccw#frame#misc#visible
- then ccw#frame#misc#hide ()
- else ccw#frame#misc#show ())
- ~accel:"Escape";
- ];
- List.iter
- (fun (opts,name,label,key,dflt) ->
- GAction.add_toggle_action name ~active:dflt ~label
- ~accel:(!current.modifier_for_display^key)
- ~callback:(fun v -> do_or_activate (fun a ->
- let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in
- a#show_goals) ()) view_actions)
- print_items;
- GAction.add_actions navigation_actions [
- GAction.add_action "Navigation" ~label:"_Navigation";
- GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN
- ~callback:(fun _ -> do_or_activate (fun a -> a#process_next_phrase true) ())
- ~tooltip:"Forward one command" ~accel:(!current.modifier_for_navigation^"Down");
- GAction.add_action "Backward" ~label:"_Backward" ~stock:`GO_UP
- ~callback:(fun _ -> do_or_activate (fun a -> a#undo_last_step) ())
- ~tooltip:"Backward one command" ~accel:(!current.modifier_for_navigation^"Up");
- GAction.add_action "Go to" ~label:"_Go to" ~stock:`JUMP_TO
- ~callback:(fun _ -> do_or_activate (fun a -> a#go_to_insert) ())
- ~tooltip:"Go to cursor" ~accel:(!current.modifier_for_navigation^"Right");
- GAction.add_action "Start" ~label:"_Start" ~stock:`GOTO_TOP
- ~callback:(fun _ -> force_reset_initial ())
- ~tooltip:"Restart coq" ~accel:(!current.modifier_for_navigation^"Home");
- GAction.add_action "End" ~label:"_End" ~stock:`GOTO_BOTTOM
- ~callback:(fun _ -> do_or_activate (fun a -> a#process_until_end_or_error) ())
- ~tooltip:"Go to end" ~accel:(!current.modifier_for_navigation^"End");
- GAction.add_action "Interrupt" ~label:"_Interrupt" ~stock:`STOP
- ~callback:(fun _ -> break ()) ~tooltip:"Interrupt computations"
- ~accel:(!current.modifier_for_navigation^"Break");
- GAction.add_action "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
- ~callback:(fun _ -> let sess = session_notebook#current_term in
- toggle_proof_visibility sess.script#buffer
+ end;
+ reset_revert_timer ());
+ ];
+
+ menu view_menu [
+ item "View" ~label:"_View";
+ item "Previous tab" ~label:"_Previous tab" ~accel:"<Alt>Left"
+ ~stock:`GO_BACK
+ ~callback:(fun _ -> notebook#previous_page ());
+ item "Next tab" ~label:"_Next tab" ~accel:"<Alt>Right"
+ ~stock:`GO_FORWARD
+ ~callback:(fun _ -> notebook#next_page ());
+ item "Zoom in" ~label:"_Zoom in" ~accel:("<Control>plus")
+ ~stock:`ZOOM_IN ~callback:(fun _ ->
+ Pango.Font.set_size current.text_font
+ (Pango.Font.get_size current.text_font + Pango.scale);
+ save_pref ();
+ !refresh_editor_hook ());
+ item "Zoom out" ~label:"_Zoom out" ~accel:("<Control>minus")
+ ~stock:`ZOOM_OUT ~callback:(fun _ ->
+ Pango.Font.set_size current.text_font
+ (Pango.Font.get_size current.text_font - Pango.scale);
+ save_pref ();
+ !refresh_editor_hook ());
+ item "Zoom fit" ~label:"_Zoom fit" ~accel:("<Control>0")
+ ~stock:`ZOOM_FIT ~callback:(cb_on_current_term MiscMenu.zoom_fit);
+ toggle_item "Show Toolbar" ~label:"Show _Toolbar"
+ ~active:(prefs.show_toolbar)
+ ~callback:(fun _ ->
+ prefs.show_toolbar <- not prefs.show_toolbar;
+ !refresh_toolbar_hook ());
+ item "Query Pane" ~label:"_Query Pane"
+ ~accel:"F1"
+ ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane)
+ ];
+ toggle_items view_menu Coq.PrintOpt.bool_items;
+
+ menu navigation_menu [
+ item "Navigation" ~label:"_Navigation";
+ item "Forward" ~label:"_Forward" ~stock:`GO_DOWN ~callback:Nav.forward_one
+ ~tooltip:"Forward one command"
+ ~accel:(prefs.modifier_for_navigation^"Down");
+ item "Backward" ~label:"_Backward" ~stock:`GO_UP ~callback:Nav.backward_one
+ ~tooltip:"Backward one command"
+ ~accel:(prefs.modifier_for_navigation^"Up");
+ item "Go to" ~label:"_Go to" ~stock:`JUMP_TO ~callback:Nav.goto
+ ~tooltip:"Go to cursor"
+ ~accel:(prefs.modifier_for_navigation^"Right");
+ item "Start" ~label:"_Start" ~stock:`GOTO_TOP ~callback:Nav.restart
+ ~tooltip:"Restart coq"
+ ~accel:(prefs.modifier_for_navigation^"Home");
+ item "End" ~label:"_End" ~stock:`GOTO_BOTTOM ~callback:Nav.goto_end
+ ~tooltip:"Go to end"
+ ~accel:(prefs.modifier_for_navigation^"End");
+ item "Interrupt" ~label:"_Interrupt" ~stock:`STOP ~callback:Nav.interrupt
+ ~tooltip:"Interrupt computations"
+ ~accel:(prefs.modifier_for_navigation^"Break");
+(* wait for this available in GtkSourceView !
+ item "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
+ ~callback:(fun _ -> let sess = notebook#current_term in
+ toggle_proof_visibility sess.buffer
sess.analyzed_view#get_insert) ~tooltip:"Hide proof"
- ~accel:(!current.modifier_for_navigation^"h");
- GAction.add_action "Previous" ~label:"_Previous" ~stock:`GO_BACK
- ~callback:(fun _ -> do_or_activate (fun a -> a#go_to_prev_occ_of_cur_word) ())
- ~tooltip:"Previous occurence" ~accel:(!current.modifier_for_navigation^"less");
- GAction.add_action "Next" ~label:"_Next" ~stock:`GO_FORWARD
- ~callback:(fun _ -> do_or_activate (fun a -> a#go_to_next_occ_of_cur_word) ())
- ~tooltip:"Next occurence" ~accel:(!current.modifier_for_navigation^"greater");
- ];
- GAction.add_actions tactics_actions [
- GAction.add_action "Try Tactics" ~label:"_Try Tactics";
- GAction.add_action "Wizard" ~tooltip:"Proof Wizard" ~label:"<Proof Wizard>"
- ~stock:`DIALOG_INFO ~callback:(do_if_active (fun a -> a#tactic_wizard
- !current.automatic_tactics))
- ~accel:(!current.modifier_for_tactics^"dollar");
- tactic_shortcut "auto" "a";
- tactic_shortcut "auto with *" "asterisk";
- tactic_shortcut "eauto" "e";
- tactic_shortcut "eauto with *" "ampersand";
- tactic_shortcut "intuition" "i";
- tactic_shortcut "omega" "o";
- tactic_shortcut "simpl" "s";
- tactic_shortcut "tauto" "p";
- tactic_shortcut "trivial" "v";
- ];
- add_gen_actions "Tactic" tactics_actions Coq_commands.tactics;
- GAction.add_actions templates_actions [
- GAction.add_action "Templates" ~label:"Te_mplates";
- add_complex_template
- ("Lemma", "_Lemma __", "Lemma new_lemma : .\nIdeproof.\n\nSave.\n",
- 19, 9, Some "L");
- add_complex_template
- ("Theorem", "_Theorem __", "Theorem new_theorem : .\nIdeproof.\n\nSave.\n",
- 19, 11, Some "T");
- add_complex_template
- ("Definition", "_Definition __", "Definition ident := .\n",
- 6, 5, Some "D");
- add_complex_template
- ("Inductive", "_Inductive __", "Inductive ident : :=\n | : .\n",
- 14, 5, Some "I");
- add_complex_template
- ("Fixpoint", "_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
- 29, 5, Some "F");
- add_complex_template ("Scheme", "_Scheme __",
- "Scheme new_scheme := Induction for _ Sort _\
-\nwith _ := Induction for _ Sort _.\n",61,10, Some "S");
- GAction.add_action "match" ~label:"match ..." ~callback:match_callback
- ~accel:(!current.modifier_for_templates^"C");
- ];
- add_gen_actions "Template" templates_actions Coq_commands.commands;
- GAction.add_actions queries_actions [
- GAction.add_action "Queries" ~label:"_Queries";
- query_shortcut "SearchAbout" (Some "F2");
- query_shortcut "Check" (Some "F3");
- query_shortcut "Print" (Some "F4");
- query_shortcut "About" (Some "F5");
- query_shortcut "Locate" None;
- query_shortcut "Whelp Locate" None;
- ];
- GAction.add_actions compile_actions [
- GAction.add_action "Compile" ~label:"_Compile";
- GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f;
- GAction.add_action "Make" ~label:"_Make" ~callback:make_f ~accel:"F6";
- GAction.add_action "Next error" ~label:"_Next error" ~callback:next_error
- ~accel:"F7";
- GAction.add_action "Make makefile" ~label:"Make makefile" ~callback:coq_makefile_f;
- ];
- GAction.add_actions windows_actions [
- GAction.add_action "Windows" ~label:"_Windows";
- GAction.add_action "Detach View" ~label:"Detach _View" ~callback:detach_view
- ];
- GAction.add_actions help_actions [
- GAction.add_action "Help" ~label:"_Help";
- GAction.add_action "Browse Coq Manual" ~label:"Browse Coq _Manual"
- ~callback:(fun _ ->
- let av = session_notebook#current_term.analyzed_view in
- browse av#insert_message (doc_url ()));
- GAction.add_action "Browse Coq Library" ~label:"Browse Coq _Library"
- ~callback:(fun _ ->
- let av = session_notebook#current_term.analyzed_view in
- browse av#insert_message !current.library_url);
- GAction.add_action "Help for keyword" ~label:"Help for _keyword"
- ~callback:(fun _ -> let av = session_notebook#current_term.analyzed_view in
- av#help_for_keyword ()) ~stock:`HELP;
- GAction.add_action "About Coq" ~label:"_About" ~stock:`ABOUT;
- ];
- Coqide_ui.init ();
- Coqide_ui.ui_m#insert_action_group file_actions 0;
- Coqide_ui.ui_m#insert_action_group export_actions 0;
- Coqide_ui.ui_m#insert_action_group edit_actions 0;
- Coqide_ui.ui_m#insert_action_group view_actions 0;
- Coqide_ui.ui_m#insert_action_group navigation_actions 0;
- Coqide_ui.ui_m#insert_action_group tactics_actions 0;
- Coqide_ui.ui_m#insert_action_group templates_actions 0;
- Coqide_ui.ui_m#insert_action_group queries_actions 0;
- Coqide_ui.ui_m#insert_action_group compile_actions 0;
- Coqide_ui.ui_m#insert_action_group windows_actions 0;
- Coqide_ui.ui_m#insert_action_group help_actions 0;
- w#add_accel_group Coqide_ui.ui_m#get_accel_group ;
- GtkMain.Rc.parse_string "gtk-can-change-accels = 1";
- if Coq_config.gtk_platform <> `QUARTZ
- then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar");
- let tbar = GtkButton.Toolbar.cast ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget)
- in let () = GtkButton.Toolbar.set ~orientation:`HORIZONTAL ~style:`ICONS
- ~tooltips:true tbar in
- let toolbar = new GObj.widget tbar in
- vbox#pack toolbar;
-
- ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true));
-
- (* The vertical Separator between Scripts and Goals *)
- vbox#pack ~expand:true session_notebook#coerce;
- update_notebook_pos ();
- let nb = session_notebook in
- let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
- lower_hbox#pack ~expand:true status#coerce;
- let search_lbl = GMisc.label ~text:"Search:"
- ~show:false
- ~packing:(lower_hbox#pack ~expand:false) ()
+ ~accel:(prefs.modifier_for_navigation^"h");*)
+ item "Previous" ~label:"_Previous" ~stock:`GO_BACK
+ ~callback:Nav.previous_occ
+ ~tooltip:"Previous occurence"
+ ~accel:(prefs.modifier_for_navigation^"less");
+ item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ
+ ~tooltip:"Next occurence"
+ ~accel:(prefs.modifier_for_navigation^"greater");
+ item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document
+ ~tooltip:"Fully check the document"
+ ~accel:(current.modifier_for_navigation^"f");
+ ];
+
+ let tacitem s sc =
+ item s ~label:("_"^s)
+ ~accel:(prefs.modifier_for_tactics^sc)
+ ~callback:(tactic_wizard_callback [s])
+ in
+ menu tactics_menu [
+ item "Try Tactics" ~label:"_Try Tactics";
+ item "Wizard" ~label:"<Proof Wizard>" ~stock:`DIALOG_INFO
+ ~tooltip:"Proof Wizard" ~accel:(prefs.modifier_for_tactics^"dollar")
+ ~callback:(tactic_wizard_callback prefs.automatic_tactics);
+ tacitem "auto" "a";
+ tacitem "auto with *" "asterisk";
+ tacitem "eauto" "e";
+ tacitem "eauto with *" "ampersand";
+ tacitem "intuition" "i";
+ tacitem "omega" "o";
+ tacitem "simpl" "s";
+ tacitem "tauto" "p";
+ tacitem "trivial" "v";
+ ];
+ alpha_items tactics_menu "Tactic" Coq_commands.tactics;
+
+ menu templates_menu [
+ item "Templates" ~label:"Te_mplates";
+ template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "L");
+ template_item ("Theorem new_theorem : .\nProof.\n\nSave.\n", 8,11, "T");
+ template_item ("Definition ident := .\n", 11,5, "E");
+ template_item ("Inductive ident : :=\n | : .\n", 10,5, "I");
+ template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F");
+ template_item ("Scheme new_scheme := Induction for _ Sort _\n" ^
+ "with _ := Induction for _ Sort _.\n", 7,10, "S");
+ item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"C")
+ ~callback:match_callback
+ ];
+ alpha_items templates_menu "Template" Coq_commands.commands;
+
+ let qitem s accel = item s ~label:("_"^s) ?accel ~callback:(Query.query s) in
+ menu queries_menu [
+ item "Queries" ~label:"_Queries";
+ qitem "Search" (Some "F2");
+ qitem "Check" (Some "F3");
+ qitem "Print" (Some "F4");
+ qitem "About" (Some "F5");
+ qitem "Locate" None;
+ qitem "Print Assumptions" None;
+ qitem "Whelp Locate" None;
+ ];
+
+ menu tools_menu [
+ item "Tools" ~label:"_Tools";
+ item "Comment" ~label:"_Comment" ~accel:"<CTRL>D"
+ ~callback:MiscMenu.comment;
+ item "Uncomment" ~label:"_Uncomment" ~accel:"<CTRL><SHIFT>D"
+ ~callback:MiscMenu.uncomment;
+ item "Coqtop arguments" ~label:"Coqtop _arguments"
+ ~callback:MiscMenu.coqtop_arguments;
+ ];
+
+ menu compile_menu [
+ item "Compile" ~label:"_Compile";
+ item "Compile buffer" ~label:"_Compile buffer" ~callback:External.compile;
+ item "Make" ~label:"_Make" ~accel:"F6"
+ ~callback:External.make;
+ item "Next error" ~label:"_Next error" ~accel:"F7"
+ ~callback:External.next_error;
+ item "Make makefile" ~label:"Make makefile" ~callback:External.coq_makefile;
+ ];
+
+ menu windows_menu [
+ item "Windows" ~label:"_Windows";
+ item "Detach View" ~label:"Detach _View" ~callback:MiscMenu.detach_view
+ ];
+
+ menu help_menu [
+ item "Help" ~label:"_Help";
+ item "Browse Coq Manual" ~label:"Browse Coq _Manual"
+ ~callback:(fun _ ->
+ browse notebook#current_term.messages#add (doc_url ()));
+ item "Browse Coq Library" ~label:"Browse Coq _Library"
+ ~callback:(fun _ ->
+ browse notebook#current_term.messages#add prefs.library_url);
+ item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP
+ ~callback:(fun _ -> on_current_term (fun sn ->
+ browse_keyword sn.messages#add (get_current_word sn)));
+ item "Help for μPG mode" ~label:"Help for μPG mode"
+ ~callback:(fun _ -> on_current_term (fun sn ->
+ sn.messages#clear;
+ sn.messages#add (NanoPG.get_documentation ())));
+ item "About Coq" ~label:"_About" ~stock:`ABOUT
+ ~callback:MiscMenu.about
+ ];
+
+ Coqide_ui.init ();
+ Coqide_ui.ui_m#insert_action_group file_menu 0;
+ Coqide_ui.ui_m#insert_action_group export_menu 0;
+ Coqide_ui.ui_m#insert_action_group edit_menu 0;
+ Coqide_ui.ui_m#insert_action_group view_menu 0;
+ Coqide_ui.ui_m#insert_action_group navigation_menu 0;
+ Coqide_ui.ui_m#insert_action_group tactics_menu 0;
+ Coqide_ui.ui_m#insert_action_group templates_menu 0;
+ Coqide_ui.ui_m#insert_action_group tools_menu 0;
+ Coqide_ui.ui_m#insert_action_group queries_menu 0;
+ Coqide_ui.ui_m#insert_action_group compile_menu 0;
+ Coqide_ui.ui_m#insert_action_group windows_menu 0;
+ Coqide_ui.ui_m#insert_action_group help_menu 0;
+ w#add_accel_group Coqide_ui.ui_m#get_accel_group ;
+ GtkMain.Rc.parse_string "gtk-can-change-accels = 1";
+ if Coq_config.gtk_platform <> `QUARTZ
+ then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar");
+
+ (* Toolbar *)
+ let tbar = GtkButton.Toolbar.cast
+ ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget)
in
- let search_history = ref [] in
- let (search_input,_) = GEdit.combo_box_entry_text ~strings:!search_history ~show:false
- ~packing:(lower_hbox#pack ~expand:false) ()
+ let () = GtkButton.Toolbar.set
+ ~orientation:`HORIZONTAL ~style:`ICONS ~tooltips:true tbar
in
- let ready_to_wrap_search = ref false in
+ let toolbar = new GObj.widget tbar in
+ let () = vbox#pack toolbar in
- let start_of_search = ref None in
- let start_of_found = ref None in
- let end_of_found = ref None in
- let search_forward = ref true in
- let matched_word = ref None in
+ (* Emacs/PG mode *)
+ NanoPG.init w notebook all_menus;
- let memo_search () =
- matched_word := Some search_input#entry#text
+ (* Reset on tab switch *)
+ let _ = notebook#connect#switch_page ~callback:(fun _ ->
+ if prefs.reset_on_tab_switch then Nav.restart ())
in
- let end_search () =
- prerr_endline "End Search";
- memo_search ();
- let v = session_notebook#current_term.script in
- v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT);
- v#coerce#misc#grab_focus ();
- search_input#entry#set_text "";
- search_lbl#misc#hide ();
- search_input#misc#hide ()
- in
- let end_search_focus_out () =
- prerr_endline "End Search(focus out)";
- memo_search ();
- let v = session_notebook#current_term.script in
- v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT);
- search_input#entry#set_text "";
- search_lbl#misc#hide ();
- search_input#misc#hide ()
- in
- ignore (search_input#entry#connect#activate ~callback:end_search);
- ignore (search_input#entry#event#connect#key_press
- ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
- if
- kv = GdkKeysyms._Right
- || kv = GdkKeysyms._Up
- || kv = GdkKeysyms._Left
- || (kv = GdkKeysyms._g
- && (List.mem `CONTROL (GdkEvent.Key.state k)))
- then end_search ();
- false));
- ignore (search_input#entry#event#connect#focus_out
- ~callback:(fun _ -> end_search_focus_out (); false));
- to_do_on_page_switch :=
- (fun i ->
- start_of_search := None;
- ready_to_wrap_search:=false)::!to_do_on_page_switch;
-
- (* TODO : make it work !!! *)
- let rec search_f () =
- search_lbl#misc#show ();
- search_input#misc#show ();
-
- prerr_endline "search_f called";
- if !start_of_search = None then begin
- (* A full new search is starting *)
- start_of_search :=
- Some (session_notebook#current_term.script#buffer#create_mark
- (session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT));
- start_of_found := !start_of_search;
- end_of_found := !start_of_search;
- matched_word := Some "";
- end;
- let txt = search_input#entry#text in
- let v = session_notebook#current_term.script in
- let iit = v#buffer#get_iter_at_mark `SEL_BOUND
- and insert_iter = v#buffer#get_iter_at_mark `INSERT
- in
- prerr_endline ("SELBOUND="^(string_of_int iit#offset));
- prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
-
- (match
- if !search_forward then iit#forward_search txt
- else let npi = iit#forward_chars (Glib.Utf8.length txt) in
- match
- (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
- (let t = iit#get_text ~stop:npi in
- flash_info (t^"\n"^txt);
- t = txt)
- with
- | true,true ->
- (flash_info "T,T";iit#backward_search txt)
- | false,true -> flash_info "F,T";Some (iit,npi)
- | _,false ->
- (iit#backward_search txt)
-
- with
- | None ->
- if !ready_to_wrap_search then begin
- ready_to_wrap_search := false;
- flash_info "Search wrapped";
- v#buffer#place_cursor
- ~where:(if !search_forward then v#buffer#start_iter else
- v#buffer#end_iter);
- search_f ()
- end else begin
- if !search_forward then flash_info "Search at end"
- else flash_info "Search at start";
- ready_to_wrap_search := true
- end
- | Some (start,stop) ->
- prerr_endline "search: before moving marks";
- prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
- prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-
- v#buffer#move_mark `SEL_BOUND ~where:start;
- v#buffer#move_mark `INSERT ~where:stop;
- prerr_endline "search: after moving marks";
- prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
- prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
- v#scroll_to_mark `SEL_BOUND
- )
- in
- ignore (search_input#entry#event#connect#key_release
- ~callback:
- (fun ev ->
- if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
- let v = session_notebook#current_term.script in
- (match !start_of_search with
- | None ->
- prerr_endline "search_key_rel: Placing sel_bound";
- v#buffer#move_mark
- `SEL_BOUND
- ~where:(v#buffer#get_iter_at_mark `INSERT)
- | Some mk -> let it = v#buffer#get_iter_at_mark
- (`MARK mk) in
- prerr_endline "search_key_rel: Placing cursor";
- v#buffer#place_cursor ~where:it;
- start_of_search := None
- );
- search_input#entry#set_text "";
- v#coerce#misc#grab_focus ();
- end;
- false
- ));
- ignore (search_input#entry#connect#changed ~callback:search_f);
- push_info "Ready";
+
+ (* Vertical Separator between Scripts and Goals *)
+ let () = vbox#pack ~expand:true notebook#coerce in
+ let () = refresh_notebook_pos () in
+ let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
+ let () = lower_hbox#pack ~expand:true status#coerce in
+ let () = push_info ("Ready"^ if current.nanoPG then ", [μPG]" else "") in
+
(* Location display *)
let l = GMisc.label
~text:"Line: 1 Char: 1"
- ~packing:lower_hbox#pack () in
- l#coerce#misc#set_name "location";
- set_location := l#set_text;
+ ~packing:lower_hbox#pack ()
+ in
+ let () = l#coerce#misc#set_name "location" in
+ let () = set_location := l#set_text in
+
(* Progress Bar *)
- lower_hbox#pack pbar#coerce;
- pbar#set_text "CoqIde started";
+ let pbar = GRange.progress_bar ~pulse_step:0.1 () in
+ let () = lower_hbox#pack pbar#coerce in
+ let ready () = pbar#set_fraction 0.0; pbar#set_text "Coq is ready" in
+ let pulse sn =
+ if Coq.is_computing sn.coqtop then
+ (pbar#set_text "Coq is computing"; pbar#pulse ())
+ else ready () in
+ let callback () = on_current_term pulse; true in
+ let _ = Glib.Timeout.add ~ms:300 ~callback in
+
+ (* Pending proofs. It should be with a GtkSpinner... not bound *)
+ let slaveinfo = GMisc.label ~xalign:0.5 ~width:50 () in
+ let () = lower_hbox#pack slaveinfo#coerce in
+ let () = slaveinfo#misc#set_has_tooltip true in
+ let () = slaveinfo#misc#set_tooltip_markup
+ "Proofs to be checked / Errors" in
+ let update sn =
+ let processed, to_process, jobs = sn.coqops#get_slaves_status in
+ let missing = to_process - processed in
+ let n_err = sn.coqops#get_n_errors in
+ if n_err > 0 then
+ slaveinfo#set_text (Printf.sprintf
+ "%d / <span foreground=\"#FF0000\">%d</span>" missing n_err)
+ else
+ slaveinfo#set_text (Printf.sprintf "%d / %d" missing n_err);
+ slaveinfo#set_use_markup true;
+ sn.errpage#update sn.coqops#get_errors;
+ sn.jobpage#update (Util.pi3 sn.coqops#get_slaves_status) in
+ let callback () = on_current_term update; true in
+ let _ = Glib.Timeout.add ~ms:300 ~callback in
(* Initializing hooks *)
-
- refresh_toolbar_hook :=
- (fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ());
- refresh_font_hook :=
- (fun () ->
- let fd = !current.text_font in
- let iter_page p =
- p.script#misc#modify_font fd;
- p.proof_view#misc#modify_font fd;
- p.message_view#misc#modify_font fd;
- p.command#refresh_font ()
- in
- List.iter iter_page session_notebook#pages;
- );
- refresh_background_color_hook :=
- (fun () ->
- let clr = Tags.color_of_string !current.background_color in
- let iter_page p =
- p.script#misc#modify_base [`NORMAL, `COLOR clr];
- p.proof_view#misc#modify_base [`NORMAL, `COLOR clr];
- p.message_view#misc#modify_base [`NORMAL, `COLOR clr];
- p.command#refresh_color ()
- in
- List.iter iter_page session_notebook#pages;
- );
- resize_window_hook := (fun () ->
- w#resize
- ~width:!current.window_width
- ~height:!current.window_height);
- refresh_tabs_hook := update_notebook_pos;
-
- let about_full_string =
- "\nCoq is developed by the Coq Development Team\
- \n(INRIA - CNRS - LIX - LRI - PPS)\
- \nWeb site: " ^ Coq_config.wwwcoq ^
- "\nFeature wish or bug report: http://coq.inria.fr/bugs/\
- \n\
- \nCredits for CoqIDE, the Integrated Development Environment for Coq:\
- \n\
- \nMain author : Benjamin Monate\
- \nContributors : Jean-Christophe Filliâtre\
- \n Pierre Letouzey, Claude Marché\
- \n Bruno Barras, Pierre Corbineau\
- \n Julien Narboux, Hugo Herbelin, ... \
- \n\
- \nVersion information\
- \n-------------------\
- \n"
+ let refresh_toolbar () =
+ if prefs.show_toolbar
+ then toolbar#misc#show ()
+ else toolbar#misc#hide ()
in
- let display_log_file (b:GText.buffer) =
- if !debug then
- let file = match !logfile with None -> "stderr" | Some f -> f in
- b#insert ("Debug mode is on, log file is "^file)
+ let refresh_style () =
+ let style = style_manager#style_scheme prefs.source_style in
+ let iter_session v = v.script#source_buffer#set_style_scheme style in
+ List.iter iter_session notebook#pages
in
- let initial_about (b:GText.buffer) =
- let initial_string =
- "Welcome to CoqIDE, an Integrated Development Environment for Coq\n"
- in
- let coq_version = Coq.short_version () in
- display_log_file b;
- if Glib.Utf8.validate ("You are running " ^ coq_version) then
- b#insert ~iter:b#start_iter ("You are running " ^ coq_version);
- if Glib.Utf8.validate initial_string then
- b#insert ~iter:b#start_iter initial_string;
- (try
- let image = Filename.concat (List.find
- (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
- Minilib.xdg_data_dirs) "coq.png" in
- let startup_image = GdkPixbuf.from_file image in
- b#insert ~iter:b#start_iter "\n\n";
- b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
- b#insert ~iter:b#start_iter "\n\n\t\t "
- with _ -> ())
+ let refresh_language () =
+ let lang = lang_manager#language prefs.source_language in
+ let iter_session v = v.script#source_buffer#set_language lang in
+ List.iter iter_session notebook#pages
in
-
- let about (b:GText.buffer) =
- (try
- let image = Filename.concat (List.find
- (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
- Minilib.xdg_data_dirs) "coq.png" in
- let startup_image = GdkPixbuf.from_file image in
- b#insert ~iter:b#start_iter "\n\n";
- b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
- b#insert ~iter:b#start_iter "\n\n\t\t "
- with _ -> ());
- if Glib.Utf8.validate about_full_string
- then b#insert about_full_string;
- let coq_version = Coq.version () in
- if Glib.Utf8.validate coq_version
- then b#insert coq_version;
- display_log_file b;
+ let resize_window () =
+ w#resize ~width:prefs.window_width ~height:prefs.window_height
in
- (* Remove default pango menu for textviews *)
- w#show ();
- ignore ((help_actions#get_action "About Coq")#connect#activate
- ~callback:(fun _ -> let prf_v = session_notebook#current_term.proof_view in
- prf_v#buffer#set_text ""; about prf_v#buffer));
- (*
-
- *)
-(* Begin Color configuration *)
-
- Tags.set_processing_color (Tags.color_of_string !current.processing_color);
- Tags.set_processed_color (Tags.color_of_string !current.processed_color);
-
-(* End of color configuration *)
- ignore(nb#connect#switch_page
- ~callback:
- (fun i ->
- prerr_endline ("switch_page: starts " ^ string_of_int i);
- List.iter (function f -> f i) !to_do_on_page_switch;
- prerr_endline "switch_page: success")
- );
- if List.length files >=1 then
- begin
- List.iter (fun f ->
- if Sys.file_exists f then do_load f else
- let f = if Filename.check_suffix f ".v" then f else f^".v" in
- load_file (fun s -> print_endline s; exit 1) f)
- files;
- session_notebook#goto_page 0;
- end
- else
- begin
- let session = create_session None in
- let index = session_notebook#append_term session in
- session_notebook#goto_page index;
- end;
- initial_about session_notebook#current_term.proof_view#buffer;
- !refresh_toolbar_hook ();
- session_notebook#current_term.script#misc#grab_focus ();;
+ refresh_toolbar ();
+ refresh_toolbar_hook := refresh_toolbar;
+ refresh_style_hook := refresh_style;
+ refresh_language_hook := refresh_language;
+ refresh_editor_hook := refresh_editor_prefs;
+ resize_window_hook := resize_window;
+ refresh_tabs_hook := refresh_notebook_pos;
+
+ (* Color configuration *)
+ Tags.set_processing_color (Tags.color_of_string prefs.processing_color);
+ Tags.set_processed_color (Tags.color_of_string prefs.processed_color);
+ Tags.Script.incomplete#set_property
+ (`BACKGROUND_STIPPLE
+ (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02"));
+ Tags.Script.incomplete#set_property
+ (`BACKGROUND_GDK (Tags.get_processed_color ()));
+
+ (* Showtime ! *)
+ w#show ()
+
+
+(** {2 Coqide main function } *)
+
+let make_file_buffer f =
+ let f = if Filename.check_suffix f ".v" then f else f^".v" in
+ FileAux.load_file ~maycreate:true f
+
+let make_scratch_buffer () =
+ let session = create_session None in
+ let _ = notebook#append_term session in
+ !refresh_editor_hook ()
+
+let main files =
+ build_ui ();
+ reset_revert_timer ();
+ reset_autosave_timer ();
+ (match files with
+ | [] -> make_scratch_buffer ()
+ | _ -> List.iter make_file_buffer files);
+ notebook#goto_page 0;
+ MiscMenu.initial_about ();
+ on_current_term (fun t -> t.script#misc#grab_focus ());
+ Minilib.log "End of Coqide.main"
+
+
+(** {2 Geoproof } *)
-(* This function check every half of second if GeoProof has send
- something on his private clipboard *)
+(** This function check every tenth of second if GeoProof has send
+ something on his private clipboard *)
-let rec check_for_geoproof_input () =
+let check_for_geoproof_input () =
let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in
- while true do
- Thread.delay 0.1;
- let s = cb_Dr#text in
- (match s with
- Some s ->
- if s <> "Ack" then
- session_notebook#current_term.script#buffer#insert (s^"\n");
- cb_Dr#set_text "Ack"
- | None -> ()
- );
- (* cb_Dr#clear does not work so i use : *)
- (* cb_Dr#set_text "Ack" *)
- done
+ let handler () = match cb_Dr#text with
+ |None -> true
+ |Some "Ack" -> true
+ |Some s ->
+ on_current_term (fun sn -> sn.buffer#insert (s ^ "\n"));
+ (* cb_Dr#clear does not work so i use : *)
+ cb_Dr#set_text "Ack";
+ true
+ in
+ ignore (GMain.Timeout.add ~ms:100 ~callback:handler)
+
+
+(** {2 Argument parsing } *)
(** By default, the coqtop we try to launch is exactly the current coqide
full name, with the last occurrence of "coqide" replaced by "coqtop".
This should correctly handle the ".opt", ".byte", ".exe" situations.
If the replacement fails, we default to "coqtop", hoping it's somewhere
- in the path. Note that the -coqtop option to coqide allows to override
+ in the path. Note that the -coqtop option to coqide overrides
this default coqtop path *)
let read_coqide_args argv =
let rec filter_coqtop coqtop project_files out = function
- | "-coqtop" :: prog :: args ->
+ |"-coqtop" :: prog :: args ->
if coqtop = None then filter_coqtop (Some prog) project_files out args
- else
- (output_string stderr "Error: multiple -coqtop options"; exit 1)
- | "-f" :: file :: args ->
- filter_coqtop coqtop
- ((Minilib.canonical_path_name (Filename.dirname file),
- Project_file.read_project_file file) :: project_files) out args
- | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1
- | "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1
- | "-debug"::args -> Ideutils.debug := true;
+ else (output_string stderr "Error: multiple -coqtop options"; exit 1)
+ |"-f" :: file :: args ->
+ let d = CUnix.canonical_path_name (Filename.dirname file) in
+ let p = Project_file.read_project_file file in
+ filter_coqtop coqtop ((d,p) :: project_files) out args
+ |"-f" :: [] ->
+ output_string stderr "Error: missing project file name"; exit 1
+ |"-coqtop" :: [] ->
+ output_string stderr "Error: missing argument after -coqtop"; exit 1
+ |"-debug"::args ->
+ Minilib.debug := true;
+ Flags.debug := true;
+ Backtrace.record_backtrace true;
filter_coqtop coqtop project_files ("-debug"::out) args
- | arg::args -> filter_coqtop coqtop project_files (arg::out) args
- | [] -> (coqtop,List.rev project_files,List.rev out)
+ |"-coqtop-flags" :: flags :: args->
+ Flags.ideslave_coqtop_flags := Some flags;
+ filter_coqtop coqtop project_files out args
+ |arg::args when out = [] && Minilib.is_prefix_of "-psn_" arg ->
+ (* argument added by MacOS during .app launch *)
+ filter_coqtop coqtop project_files out args
+ |arg::args -> filter_coqtop coqtop project_files (arg::out) args
+ |[] -> (coqtop,List.rev project_files,List.rev out)
in
let coqtop,project_files,argv = filter_coqtop None [] [] argv in
- Ideutils.custom_coqtop := coqtop;
- custom_project_files := project_files;
+ Ideutils.custom_coqtop := coqtop;
+ custom_project_files := project_files;
argv
+
+
+(** {2 Signal handling } *)
+
+(** The Ctrl-C (sigint) is handled as a interactive quit.
+ For most of the other catchable signals we launch
+ an emergency save of opened files and then exit. *)
+
+let signals_to_crash =
+ [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
+ Sys.sigill; Sys.sigpipe; Sys.sigquit; Sys.sigusr1; Sys.sigusr2]
+
+let set_signal_handlers () =
+ try
+ Sys.set_signal Sys.sigint (Sys.Signal_handle File.quit);
+ List.iter
+ (fun i -> Sys.set_signal i (Sys.Signal_handle FileAux.crash_save))
+ signals_to_crash
+ with _ -> Minilib.log "Signal ignored (normal if Win32)"
diff --git a/ide/coqide.mli b/ide/coqide.mli
index 811535d5..66915128 100644
--- a/ide/coqide.mli
+++ b/ide/coqide.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -24,14 +24,18 @@ val main : string list -> unit
(** Function to save anything and kill all coqtops
@return [false] if you're allowed to quit. *)
-val forbid_quit_to_save : unit -> bool
+val forbid_quit : unit -> bool
+
+(** Terminate coqide after closing all coqtops and waiting
+ for their death *)
+val close_and_quit : unit -> unit
(** Function to load of a file. *)
val do_load : string -> unit
-(** Set coqide to ignore Ctrl-C, while launching [crash_save] and
- exiting for others received signals *)
-val ignore_break : unit -> unit
+(** Set coqide to perform a clean quit at Ctrl-C, while launching
+ [crash_save] and exiting for others received signals *)
+val set_signal_handlers : unit -> unit
(** Emergency saving of opened files as "foo.v.crashcoqide",
and exit (if the integer isn't 127). *)
diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4
index 1466060c..db69ec66 100644
--- a/ide/coqide_main.ml4
+++ b/ide/coqide_main.ml4
@@ -1,12 +1,12 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-let _ = Coqide.ignore_break ()
+let _ = Coqide.set_signal_handlers ()
let _ = GtkMain.Main.init ()
(* We handle Gtk warning messages ourselves :
@@ -18,18 +18,27 @@ let catch_gtk_messages () =
[`FLAG_RECURSION;`FLAG_FATAL;`ERROR;`CRITICAL;`WARNING;
`MESSAGE;`INFO;`DEBUG]
in
+ let log_level lvl =
+ let level_is tag = (lvl land Glib.Message.log_level tag) <> 0 in
+ if level_is `ERROR then `FATAL
+ else if level_is `CRITICAL then `ERROR
+ else if level_is `DEBUG then `DEBUG
+ else if level_is `WARNING then `WARNING
+ else if level_is `MESSAGE then `NOTICE
+ else `INFO
+ in
let handler ~level msg =
let header = "Coqide internal error: " in
- let level_is tag = (level land Glib.Message.log_level tag) <> 0 in
- if level_is `ERROR then
- let () = GToolbox.message_box ~title:"Error" (header ^ msg) in
- Coqide.crash_save 1
- else if level_is `CRITICAL then
- GToolbox.message_box ~title:"Error" (header ^ msg)
- else if level_is `DEBUG || Sys.os_type = "Win32" then
- Ideutils.prerr_endline msg (* no-op unless in debug mode *)
- else
- Printf.eprintf "%s\n" msg
+ match log_level level with
+ |`FATAL ->
+ let () = GToolbox.message_box ~title:"Error" (header ^ msg) in
+ Coqide.crash_save 1
+ |`ERROR ->
+ if !Flags.debug then GToolbox.message_box ~title:"Error" (header ^ msg)
+ else Printf.eprintf "%s\n" (header ^ msg)
+ |`DEBUG -> Minilib.log msg
+ |level when Sys.os_type = "Win32" -> Minilib.log ~level msg
+ |_ -> Printf.eprintf "%s\n" msg
in
let catch domain =
ignore (Glib.Message.set_log_handler ~domain ~levels:all_levels handler)
@@ -38,10 +47,13 @@ let catch_gtk_messages () =
let () = catch_gtk_messages ()
-(* We anticipate a bit the argument parsing and look for -debug *)
-let early_set_debug () =
- Ideutils.debug := List.mem "-debug" (Array.to_list Sys.argv)
+
+(** System-dependent settings *)
+
+let os_specific_init () = ()
+
+(** Win32 *)
(* On win32, we add the directory of coqide to the PATH at launch-time
(this used to be done in a .bat script). *)
@@ -51,12 +63,23 @@ let set_win32_path () =
(Filename.dirname Sys.executable_name ^ ";" ^
(try Sys.getenv "PATH" with _ -> ""))
-(* On win32, in debug mode we duplicate stdout/stderr in a log file. *)
-
-let log_stdout_stderr () =
- let (name,chan) = Filename.open_temp_file "coqide_" ".log" in
- Coqide.logfile := Some name;
- let out_descr = Unix.descr_of_out_channel chan in
+(* On win32, since coqide is now console-free, we re-route stdout/stderr
+ to avoid Sys_error if someone writes to them. We write to a pipe which
+ is never read (by default) or to a temp log file (when in debug mode).
+*)
+
+let reroute_stdout_stderr () =
+ (* We anticipate a bit the argument parsing and look for -debug *)
+ let debug = List.mem "-debug" (Array.to_list Sys.argv) in
+ Minilib.debug := debug;
+ let out_descr =
+ if debug then
+ let (name,chan) = Filename.open_temp_file "coqide_" ".log" in
+ Coqide.logfile := Some name;
+ Unix.descr_of_out_channel chan
+ else
+ snd (Unix.pipe ())
+ in
Unix.set_close_on_exec out_descr;
Unix.dup2 out_descr Unix.stdout;
Unix.dup2 out_descr Unix.stderr
@@ -65,71 +88,65 @@ let log_stdout_stderr () =
IFDEF WIN32 THEN
external win32_kill : int -> unit = "win32_kill"
-external win32_interrupt_all : unit -> unit = "win32_interrupt_all"
-external win32_hide_console : unit -> unit = "win32_hide_console"
-
+external win32_interrupt : int -> unit = "win32_interrupt"
let () =
+ Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket;
set_win32_path ();
- Coq.killer := win32_kill;
- Coq.interrupter := (fun pid -> win32_interrupt_all ());
- early_set_debug ();
- if !Ideutils.debug then
- log_stdout_stderr ()
- else
- win32_hide_console ()
+ Coq.interrupter := win32_interrupt;
+ reroute_stdout_stderr ()
END
+(** MacOSX *)
+
IFDEF QUARTZ THEN
- let osx = GosxApplication.osxapplication ()
+let osx = GosxApplication.osxapplication ()
- let _ =
- osx#connect#ns_application_open_file ~callback:(fun x -> Coqide.do_load x; true) in
- let _ =
- osx#connect#ns_application_block_termination ~callback:Coqide.forbid_quit_to_save in
- ()
+let () =
+ let _ = osx#connect#ns_application_open_file
+ ~callback:(fun x -> Coqide.do_load x; true)
+ in
+ let _ = osx#connect#ns_application_block_termination
+ ~callback:Coqide.forbid_quit
+ in
+ let _ = osx#connect#ns_application_will_terminate
+ ~callback:Coqide.close_and_quit
+ in ()
+
+let os_specific_init () =
+ let () = GtkosxApplication.Application.set_menu_bar osx#as_osxapplication
+ (GtkMenu.MenuShell.cast
+ (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget)
+ in
+ let () = GtkosxApplication.Application.insert_app_menu_item
+ osx#as_osxapplication
+ (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1
+ in
+ let () = GtkosxApplication.Application.set_help_menu osx#as_osxapplication
+ (Some (GtkMenu.MenuItem.cast
+ (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget))
+ in
+ osx#ready ()
END
+let load_prefs () =
+ try Preferences.load_pref ()
+ with e -> Ideutils.flash_info
+ ("Could not load preferences ("^Printexc.to_string e^").")
+
let () =
- (try
- let gtkrcdir = List.find
- (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc"))
- Minilib.xdg_config_dirs in
- GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc");
- with Not_found -> ());
- (* Statup preferences *)
- begin
- try Preferences.load_pref ()
- with e ->
- Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^").");
- end;
-(* GtkData.AccelGroup.set_default_mod_mask
- (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*)
- let argl = Array.to_list Sys.argv in
+ load_prefs ();
+ let argl = List.tl (Array.to_list Sys.argv) in
let argl = Coqide.read_coqide_args argl in
- let files = Coq.filter_coq_opts (List.tl argl) in
- let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in
+ let files = Coq.filter_coq_opts argl in
+ let args = List.filter (fun x -> not (List.mem x files)) argl in
Coq.check_connection args;
Coqide.sup_args := args;
Coqide.main files;
- if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ())
-
-IFDEF QUARTZ THEN
- let () =
- GtkosxApplication.Application.set_menu_bar osx#as_osxapplication (GtkMenu.MenuShell.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) in
- let () =
- GtkosxApplication.Application.insert_app_menu_item osx#as_osxapplication (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 in
- let () =
- GtkosxApplication.Application.set_help_menu osx#as_osxapplication (Some (GtkMenu.MenuItem.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) in
- osx#ready ()
-END
-
- while true do
- try
- GtkThread.main ()
- with
- | Sys.Break -> Ideutils.prerr_endline "Interrupted."
- | e ->
- Minilib.safe_prerr_endline
- ("CoqIde unexpected error:" ^ (Printexc.to_string e));
- Coqide.crash_save 127
- done
+ if !Coq_config.with_geoproof then Coqide.check_for_geoproof_input ();
+ os_specific_init ();
+ try
+ GMain.main ();
+ failwith "Gtk loop ended"
+ with e ->
+ Minilib.log ("CoqIde unexpected error:" ^ Printexc.to_string e);
+ Coqide.crash_save 127
diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml
index eaf1e934..af71b1e7 100644
--- a/ide/coqide_ui.ml
+++ b/ide/coqide_ui.ml
@@ -1,6 +1,6 @@
let ui_m = GAction.ui_manager ();;
-let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x)
+let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
let list_items menu li =
let res_buf = Buffer.create 500 in
@@ -42,14 +42,15 @@ let init () =
</menu>
<menu name='Edit' action='Edit'>
<menuitem action='Undo' />
- <menuitem action='Clear Undo Stack' />
+ <menuitem action='Redo' />
<separator />
<menuitem action='Cut' />
<menuitem action='Copy' />
<menuitem action='Paste' />
<separator />
- <menuitem action='Find in buffer' />
- <menuitem action='Find backwards' />
+ <menuitem action='Find' />
+ <menuitem action='Find Next' />
+ <menuitem action='Find Previous' />
<menuitem action='Complete Word' />
<separator />
<menuitem action='External editor' />
@@ -60,8 +61,12 @@ let init () =
<menuitem action='Previous tab' />
<menuitem action='Next tab' />
<separator/>
+ <menuitem action='Zoom in' />
+ <menuitem action='Zoom out' />
+ <menuitem action='Zoom fit' />
+ <separator/>
<menuitem action='Show Toolbar' />
- <menuitem action='Show Query Pane' />
+ <menuitem action='Query Pane' />
<separator/>
<menuitem action='Display implicit arguments' />
<menuitem action='Display coercions' />
@@ -79,7 +84,6 @@ let init () =
<menuitem action='Start' />
<menuitem action='End' />
<menuitem action='Interrupt' />
- <menuitem action='Hide' />
<menuitem action='Previous' />
<menuitem action='Next' />
</menu>
@@ -109,13 +113,20 @@ let init () =
%s
</menu>
<menu action='Queries'>
- <menuitem action='SearchAbout' />
+ <menuitem action='Search' />
<menuitem action='Check' />
<menuitem action='Print' />
<menuitem action='About' />
<menuitem action='Locate' />
+ <menuitem action='Print Assumptions' />
<menuitem action='Whelp Locate' />
</menu>
+ <menu name='Tools' action='Tools'>
+ <menuitem action='Comment' />
+ <menuitem action='Uncomment' />
+ <separator />
+ <menuitem action='Coqtop arguments' />
+ </menu>
<menu action='Compile'>
<menuitem action='Compile buffer' />
<menuitem action='Make' />
@@ -129,6 +140,7 @@ let init () =
<menuitem action='Browse Coq Manual' />
<menuitem action='Browse Coq Library' />
<menuitem action='Help for keyword' />
+ <menuitem action='Help for μPG mode' />
<separator />
<menuitem name='Abt' action='About Coq' />
</menu>
@@ -141,8 +153,8 @@ let init () =
<toolitem action='Go to' />
<toolitem action='Start' />
<toolitem action='End' />
+ <toolitem action='Force' />
<toolitem action='Interrupt' />
- <toolitem action='Hide' />
<toolitem action='Previous' />
<toolitem action='Next' />
<toolitem action='Wizard' />
diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib
new file mode 100644
index 00000000..92301dc3
--- /dev/null
+++ b/ide/coqidetop.mllib
@@ -0,0 +1,2 @@
+Xmlprotocol
+Ide_slave
diff --git a/ide/document.ml b/ide/document.ml
new file mode 100644
index 00000000..9823e757
--- /dev/null
+++ b/ide/document.ml
@@ -0,0 +1,186 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+exception Empty
+
+let invalid_arg s = raise (Invalid_argument ("Document."^s))
+
+type 'a sentence = { mutable state_id : Stateid.t option; data : 'a }
+
+type id = Stateid.t
+
+class type ['a] signals =
+ object
+ method popped : callback:('a -> unit) -> unit
+ method pushed : callback:('a -> unit) -> unit
+ end
+
+class ['a] signal () =
+object
+ val mutable attached : ('a -> unit) list = []
+ method call (x : 'a) =
+ let iter f = try f x with _ -> () in
+ List.iter iter attached
+ method connect f = attached <- f :: attached
+end
+
+type 'a document = {
+ mutable stack : 'a sentence list;
+ mutable context : ('a sentence list * 'a sentence list) option;
+ pushed_sig : 'a signal;
+ popped_sig : 'a signal;
+}
+
+let connect d =
+ object
+ method pushed ~callback = d.pushed_sig#connect callback
+ method popped ~callback = d.popped_sig#connect callback
+ end
+
+let create () = {
+ stack = [];
+ context = None;
+ pushed_sig = new signal ();
+ popped_sig = new signal ();
+}
+
+(* Invariant, only the tip is a allowed to have state_id = None *)
+let invariant l = l = [] || (List.hd l).state_id <> None
+
+let tip = function
+ | { stack = [] } -> raise Empty
+ | { stack = { state_id = Some id }::_ } -> id
+ | { stack = { state_id = None }::_ } -> invalid_arg "tip"
+
+let tip_data = function
+ | { stack = [] } -> raise Empty
+ | { stack = { data }::_ } -> data
+
+let push d x =
+ assert(invariant d.stack);
+ d.stack <- { data = x; state_id = None } :: d.stack;
+ d.pushed_sig#call x
+
+let pop = function
+ | { stack = [] } -> raise Empty
+ | { stack = { data }::xs } as s -> s.stack <- xs; s.popped_sig#call data; data
+
+let focus d ~cond_top:c_start ~cond_bot:c_stop =
+ assert(invariant d.stack);
+ if d.context <> None then invalid_arg "focus";
+ let rec aux (a,s,b) grab = function
+ | [] -> invalid_arg "focus"
+ | { state_id = Some id; data } as x :: xs when not grab ->
+ if c_start id data then aux (a,s,b) true (x::xs)
+ else aux (x::a,s,b) grab xs
+ | { state_id = Some id; data } as x :: xs ->
+ if c_stop id data then List.rev a, List.rev (x::s), xs
+ else aux (a,x::s,b) grab xs
+ | _ -> assert false in
+ let a, s, b = aux ([],[],[]) false d.stack in
+ d.stack <- s;
+ d.context <- Some (a, b)
+
+let unfocus = function
+ | { context = None } -> invalid_arg "unfocus"
+ | { context = Some (a,b); stack } as d ->
+ assert(invariant stack);
+ d.context <- None;
+ d.stack <- a @ stack @ b
+
+let focused { context } = context <> None
+
+let to_lists = function
+ | { context = None; stack = s } -> [],s,[]
+ | { context = Some (a,b); stack = s } -> a,s,b
+
+let flat f b = fun x -> f b x.state_id x.data
+
+let find d f =
+ let a, s, b = to_lists d in
+ (
+ try List.find (flat f false) a with Not_found ->
+ try List.find (flat f true) s with Not_found ->
+ List.find (flat f false) b
+ ).data
+
+let find_map d f =
+ let a, s, b = to_lists d in
+ try CList.find_map (flat f false) a with Not_found ->
+ try CList.find_map (flat f true) s with Not_found ->
+ CList.find_map (flat f false) b
+
+let is_empty = function
+ | { stack = []; context = None } -> true
+ | _ -> false
+
+let context d =
+ let top, _, bot = to_lists d in
+ let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in
+ List.map (flat pair true) top, List.map (flat pair true) bot
+
+let iter d f =
+ let a, s, b = to_lists d in
+ List.iter (flat f false) a;
+ List.iter (flat f true) s;
+ List.iter (flat f false) b
+
+let stateid_opt_equal = Option.equal Stateid.equal
+
+let is_in_focus d id =
+ let _, focused, _ = to_lists d in
+ List.exists (fun { state_id } -> stateid_opt_equal state_id (Some id)) focused
+
+let print d f =
+ let top, mid, bot = to_lists d in
+ let open Pp in
+ v 0
+ (List.fold_right (fun i acc -> acc ++ cut() ++ flat f false i) top
+ (List.fold_right (fun i acc -> acc ++ cut() ++ flat f true i) mid
+ (List.fold_right (fun i acc -> acc ++ cut() ++ flat f false i) bot (mt()))))
+
+let assign_tip_id d id =
+ match d with
+ | { stack = { state_id = None } as top :: _ } -> top.state_id <- Some id
+ | _ -> invalid_arg "assign_tip_id"
+
+let cut_at d id =
+ let aux (n, zone) { state_id; data } =
+ if stateid_opt_equal state_id (Some id) then CSig.Stop (n, zone)
+ else CSig.Cont (n + 1, data :: zone) in
+ let n, zone = CList.fold_left_until aux (0, []) d.stack in
+ for i = 1 to n do ignore(pop d) done;
+ List.rev zone
+
+let find_id d f =
+ let top, focus, bot = to_lists d in
+ let pred = function
+ | { state_id = Some id; data } when f id data -> Some id
+ | _ -> None in
+ try CList.find_map pred top, true with Not_found ->
+ try CList.find_map pred focus, false with Not_found ->
+ CList.find_map pred bot, true
+
+let before_tip d =
+ let _, focused, rest = to_lists d in
+ match focused with
+ | _:: { state_id = Some id } :: _ -> id, false
+ | _:: { state_id = None } :: _ -> assert false
+ | [] -> raise Not_found
+ | [_] ->
+ match rest with
+ | { state_id = Some id } :: _ -> id, true
+ | { state_id = None } :: _ -> assert false
+ | [] -> raise Not_found
+
+let fold_all d a f =
+ let top, focused, bot = to_lists d in
+ let a = List.fold_left (fun a -> flat (f a) false) a top in
+ let a = List.fold_left (fun a -> flat (f a) true) a focused in
+ let a = List.fold_left (fun a -> flat (f a) false) a bot in
+ a
diff --git a/ide/document.mli b/ide/document.mli
new file mode 100644
index 00000000..0d803ff0
--- /dev/null
+++ b/ide/document.mli
@@ -0,0 +1,115 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* An 'a document is a structure to hold and manipulate list of sentences.
+ Sentences are equipped with an id = Stateid.t and can carry arbitrary
+ data ('a).
+
+ When added (push) to the document, a sentence has no id, it has
+ be manually assigned just afterward or the sentence has to be removed
+ (pop) before any other sentence can be pushed.
+ This exception is useful since the process of assigning an id to
+ a sentence may fail (parse error) and an error handler may want to annotate
+ a script buffer with the error message. This handler needs to find the
+ sentence in question, and it is simpler if the sentence is in the document.
+ Only the functions pop, find, fold_all and find_map can be called on a
+ document with a tip that has no id (and assign_tip_id of course).
+
+ The document can be focused (non recursively) to a zone. After that
+ some functions operate on the focused zone only. When unfocused the
+ context (the part of the document out of focus) is restored.
+*)
+
+exception Empty
+
+type 'a document
+type id = Stateid.t
+
+val create : unit -> 'a document
+
+(* Functions that work on the focused part of the document ******************* *)
+
+(** The last sentence. @raise Invalid_argument if tip has no id. @raise Empty *)
+val tip : 'a document -> id
+
+(** The last sentence. @raise Empty *)
+val tip_data : 'a document -> 'a
+
+(** Add a sentence on the top (with no state_id) *)
+val push : 'a document -> 'a -> unit
+
+(** Remove the tip setence. @raise Empty *)
+val pop : 'a document -> 'a
+
+(** Assign the state_id of the tip. @raise Empty *)
+val assign_tip_id : 'a document -> id -> unit
+
+(** [cut_at d id] cuts the document at [id] that is the new tip.
+ Returns the list of sentences that were cut.
+ @raise Not_found *)
+val cut_at : 'a document -> id -> 'a list
+
+(* Functions that work on the whole document ********************************* *)
+
+(** returns the id of the topmost sentence validating the predicate and
+ a boolean that is true if one needs to unfocus the document to access
+ such sentence. @raise Not_found *)
+val find_id : 'a document -> (id -> 'a -> bool) -> id * bool
+
+(** look for a sentence validating the predicate. The boolean is true
+ if the sentence is in the zone currently focused. @raise Not_found *)
+val find : 'a document -> (bool -> id option -> 'a -> bool) -> 'a
+val find_map : 'a document -> (bool -> id option -> 'a -> 'b option) -> 'b
+
+(** After [focus s c1 c2] the top of [s] is the topmost element [x] such that
+ [c1 x] is [true] and the bottom is the first element [y] following [x]
+ such that [c2 y] is [true].
+ @raise Invalid_argument if there is no such [x] and [y] or already focused *)
+val focus :
+ 'a document ->
+ cond_top:(id -> 'a -> bool) -> cond_bot:(id -> 'a -> bool) -> unit
+
+(** Undoes a [focus].
+ @raise Invalid_argument "CStack.unfocus" if the stack is not focused *)
+val unfocus : 'a document -> unit
+
+(** Is the document focused *)
+val focused : 'a document -> bool
+
+(** No sentences at all *)
+val is_empty : 'a document -> bool
+
+(** returns the 1 to-last sentence, and true if we need to unfocus to reach it.
+ @raise Not_found *)
+val before_tip : 'a document -> id * bool
+
+(** Is the id in the focused zone? *)
+val is_in_focus : 'a document -> id -> bool
+
+(** Folds over the whole document starting from the topmost (maybe unfocused)
+ sentence. *)
+val fold_all :
+ 'a document -> 'c -> ('c -> bool -> id option -> 'a -> 'c) -> 'c
+
+(** Returns (top,bot) such that the document is morally (top @ s @ bot) where
+ s is the focused part. @raise Invalid_argument *)
+val context : 'a document -> (id * 'a) list * (id * 'a) list
+
+(** debug print *)
+val print :
+ 'a document -> (bool -> id option -> 'a -> Pp.std_ppcmds) -> Pp.std_ppcmds
+
+(** Callbacks on documents *)
+
+class type ['a] signals =
+ object
+ method popped : callback:('a -> unit) -> unit
+ method pushed : callback:('a -> unit) -> unit
+ end
+
+val connect : 'a document -> 'a signals
diff --git a/ide/fileOps.ml b/ide/fileOps.ml
new file mode 100644
index 00000000..03b3fcd4
--- /dev/null
+++ b/ide/fileOps.ml
@@ -0,0 +1,154 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Ideutils
+
+let prefs = Preferences.current
+
+let revert_timer = mktimer ()
+let autosave_timer = mktimer ()
+
+class type ops =
+object
+ method filename : string option
+ method update_stats : unit
+ method changed_on_disk : bool
+ method revert : unit
+ method auto_save : unit
+ method save : string -> bool
+ method saveas : string -> bool
+end
+
+class fileops (buffer:GText.buffer) _fn (reset_handler:unit->unit) =
+object(self)
+
+ val mutable filename = _fn
+ val mutable last_stats = NoSuchFile
+ val mutable last_modification_time = 0.
+ val mutable last_auto_save_time = 0.
+
+ method filename = filename
+
+ method update_stats = match filename with
+ |Some f -> last_stats <- Ideutils.stat f
+ |_ -> ()
+
+ method changed_on_disk = match filename with
+ |None -> false
+ |Some f -> match Ideutils.stat f, last_stats with
+ |MTime cur_mt, MTime last_mt -> cur_mt > last_mt
+ |MTime _, (NoSuchFile|OtherError) -> true
+ |NoSuchFile, MTime _ ->
+ flash_info ("Warning, file not on disk anymore : "^f);
+ false
+ |_ -> false
+
+ method revert =
+ let do_revert f =
+ push_info "Reverting buffer";
+ try
+ reset_handler ();
+ let b = Buffer.create 1024 in
+ Ideutils.read_file f b;
+ let s = try_convert (Buffer.contents b) in
+ buffer#set_text s;
+ self#update_stats;
+ buffer#place_cursor ~where:buffer#start_iter;
+ buffer#set_modified false;
+ pop_info ();
+ flash_info "Buffer reverted";
+ Sentence.tag_all buffer;
+ with _ ->
+ pop_info ();
+ flash_info "Warning: could not revert buffer";
+ in
+ match filename with
+ | None -> ()
+ | Some f ->
+ if not buffer#modified then do_revert f
+ else
+ let answ = GToolbox.question_box
+ ~title:"Modified buffer changed on disk"
+ ~buttons:["Revert from File";
+ "Overwrite File";
+ "Disable Auto Revert"]
+ ~default:0
+ ~icon:(stock_to_widget `DIALOG_WARNING)
+ "Some unsaved buffers changed on disk"
+ in
+ match answ with
+ | 1 -> do_revert f
+ | 2 -> if self#save f then flash_info "Overwritten" else
+ flash_info "Could not overwrite file"
+ | _ ->
+ Minilib.log "Auto revert set to false";
+ prefs.Preferences.global_auto_revert <- false;
+ revert_timer.kill ()
+
+ method save f =
+ if try_export f (buffer#get_text ()) then begin
+ filename <- Some f;
+ self#update_stats;
+ buffer#set_modified false;
+ (match self#auto_save_name with
+ | None -> ()
+ | Some fn -> try Sys.remove fn with _ -> ());
+ true
+ end
+ else false
+
+ method saveas f =
+ if not (Sys.file_exists f) then self#save f
+ else
+ let answ = GToolbox.question_box ~title:"File exists on disk"
+ ~buttons:["Overwrite"; "Cancel";]
+ ~default:1
+ ~icon:(warn_image ())#coerce
+ ("File "^f^" already exists")
+ in
+ match answ with
+ | 1 -> self#save f
+ | _ -> false
+
+ method private auto_save_name =
+ match filename with
+ | None -> None
+ | Some f ->
+ let dir = Filename.dirname f in
+ let base = (fst prefs.Preferences.auto_save_name) ^
+ (Filename.basename f) ^
+ (snd prefs.Preferences.auto_save_name)
+ in Some (Filename.concat dir base)
+
+ method private need_auto_save =
+ buffer#modified &&
+ last_modification_time > last_auto_save_time
+
+ method auto_save =
+ if self#need_auto_save then begin
+ match self#auto_save_name with
+ | None -> ()
+ | Some fn ->
+ try
+ last_auto_save_time <- Unix.time();
+ Minilib.log ("Autosave time: "^(string_of_float (Unix.time())));
+ if try_export fn (buffer#get_text ()) then begin
+ flash_info ~delay:1000 "Autosaved"
+ end
+ else warning
+ ("Autosave failed (check if " ^ fn ^ " is writable)")
+ with _ ->
+ warning ("Autosave: unexpected error while writing "^fn)
+ end
+
+ initializer
+ let _ = buffer#connect#end_user_action
+ ~callback:(fun () -> last_modification_time <- Unix.time ())
+ in ()
+
+end
diff --git a/ide/undo_lablgtk_lt26.mli b/ide/fileOps.mli
index b13509e6..48b7c8f6 100644
--- a/ide/undo_lablgtk_lt26.mli
+++ b/ide/fileOps.mli
@@ -1,33 +1,23 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* An undoable view class *)
+val revert_timer : Ideutils.timer
+val autosave_timer : Ideutils.timer
-class undoable_view : Gtk.text_view Gtk.obj ->
+class type ops =
object
- inherit GText.view
- method undo : bool
- method redo : bool
- method clear_undo : unit
+ method filename : string option
+ method update_stats : unit
+ method changed_on_disk : bool
+ method revert : unit
+ method auto_save : unit
+ method save : string -> bool
+ method saveas : string -> bool
end
-val undoable_view :
- ?buffer:GText.buffer ->
- ?editable:bool ->
- ?cursor_visible:bool ->
- ?justification:GtkEnums.justification ->
- ?wrap_mode:GtkEnums.wrap_mode ->
- ?border_width:int ->
- ?width:int ->
- ?height:int ->
- ?packing:(GObj.widget -> unit) ->
- ?show:bool ->
- unit ->
- undoable_view
-
-
+class fileops : GText.buffer -> string option -> (unit -> unit) -> ops
diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml
index 172e4609..abbd7e6d 100644
--- a/ide/gtk_parsing.ml
+++ b/ide/gtk_parsing.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Ideutils
-
let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0)
let arobase = Glib.Utf8.to_unichar "@" ~pos:(ref 0)
let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0)
@@ -22,14 +20,12 @@ let is_word_char c =
let starts_word (it:GText.iter) =
- prerr_endline ("Starts word ? '"^(Glib.Utf8.from_unichar it#char)^"'");
- (not it#copy#nocopy#backward_char ||
- (let c = it#backward_char#char in
- not (is_word_char c)))
-
+ (it#is_start ||
+ (let c = it#backward_char#char in
+ not (is_word_char c)))
let ends_word (it:GText.iter) =
- (not it#copy#nocopy#forward_char ||
+ (it#is_end ||
let c = it#forward_char#char in
not (is_word_char c)
)
@@ -47,26 +43,25 @@ let is_on_word_limit (it:GText.iter) = inside_word it || ends_word it
let find_word_start (it:GText.iter) =
let rec step_to_start it =
- prerr_endline "Find word start";
+ Minilib.log "Find word start";
if not it#nocopy#backward_char then
- (prerr_endline "find_word_start: cannot backward"; it)
+ (Minilib.log "find_word_start: cannot backward"; it)
else if is_word_char it#char
then step_to_start it
else (it#nocopy#forward_char;
- prerr_endline ("Word start at: "^(string_of_int it#offset));it)
+ Minilib.log ("Word start at: "^(string_of_int it#offset));it)
in
step_to_start it#copy
-
let find_word_end (it:GText.iter) =
let rec step_to_end (it:GText.iter) =
- prerr_endline "Find word end";
+ Minilib.log "Find word end";
let c = it#char in
if c<>0 && is_word_char c then (
ignore (it#nocopy#forward_char);
step_to_end it
) else (
- prerr_endline ("Word end at: "^(string_of_int it#offset));
+ Minilib.log ("Word end at: "^(string_of_int it#offset));
it)
in
step_to_end it#copy
@@ -79,11 +74,11 @@ let get_word_around (it:GText.iter) =
let rec complete_backward w (it:GText.iter) =
- prerr_endline "Complete backward...";
+ Minilib.log "Complete backward...";
match it#backward_search w with
- | None -> (prerr_endline "backward_search failed";None)
+ | None -> (Minilib.log "backward_search failed";None)
| Some (start,stop) ->
- prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
+ Minilib.log ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
if starts_word start then
let ne = find_word_end stop in
if ne#compare stop = 0
@@ -93,7 +88,7 @@ let rec complete_backward w (it:GText.iter) =
let rec complete_forward w (it:GText.iter) =
- prerr_endline "Complete forward...";
+ Minilib.log "Complete forward...";
match it#forward_search w with
| None -> None
| Some (start,stop) ->
diff --git a/ide/ide.mllib b/ide/ide.mllib
index 9bbf9b0d..e082bd18 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -9,18 +9,30 @@ Configwin
Editable_cells
Config_parser
Tags
-Typed_notebook
+Wg_Segment
+Wg_Notebook
Config_lexer
Utf8_convert
Preferences
Project_file
Ideutils
-Ideproof
+Xmlprotocol
+Coq
Coq_lex
+Sentence
Gtk_parsing
-Undo
-Coq
+Wg_ProofView
+Wg_MessageView
+Wg_Detachable
+Wg_Find
+Wg_Completion
+Wg_ScriptView
Coq_commands
-Command_windows
+Wg_Command
+FileOps
+Document
+CoqOps
+Session
Coqide_ui
+NanoPG
Coqide
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
new file mode 100644
index 00000000..ac38f1ea
--- /dev/null
+++ b/ide/ide_slave.ml
@@ -0,0 +1,505 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Vernacexpr
+open Errors
+open Util
+open Pp
+open Printer
+
+(** Ide_slave : an implementation of [Interface], i.e. mainly an interp
+ function and a rewind function. This specialized loop is triggered
+ when the -ideslave option is passed to Coqtop. Currently CoqIDE is
+ the only one using this mode, but we try here to be as generic as
+ possible, so this may change in the future... *)
+
+(** Signal handling: we postpone ^C during input and output phases,
+ but make it directly raise a Sys.Break during evaluation of the request. *)
+
+let catch_break = ref false
+
+let init_signal_handler () =
+ let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in
+ Sys.set_signal Sys.sigint (Sys.Signal_handle f)
+
+
+(** Redirection of standard output to a printable buffer *)
+
+let init_stdout, read_stdout =
+ let out_buff = Buffer.create 100 in
+ let out_ft = Format.formatter_of_buffer out_buff in
+ let deep_out_ft = Format.formatter_of_buffer out_buff in
+ let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
+ (fun () ->
+ flush_all ();
+ Pp_control.std_ft := out_ft;
+ Pp_control.err_ft := out_ft;
+ Pp_control.deep_ft := deep_out_ft;
+ ),
+ (fun () -> Format.pp_print_flush out_ft ();
+ let r = Buffer.contents out_buff in
+ Buffer.clear out_buff; r)
+
+let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
+
+let pr_debug s =
+ if !Flags.debug then pr_with_pid s
+let pr_debug_call q =
+ if !Flags.debug then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q)
+let pr_debug_answer q r =
+ if !Flags.debug then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r)
+
+(** Categories of commands *)
+
+let coqide_known_option table = List.mem table [
+ ["Printing";"Implicit"];
+ ["Printing";"Coercions"];
+ ["Printing";"Matching"];
+ ["Printing";"Synth"];
+ ["Printing";"Notations"];
+ ["Printing";"All"];
+ ["Printing";"Records"];
+ ["Printing";"Existential";"Instances"];
+ ["Printing";"Universes"]]
+
+let is_known_option cmd = match cmd with
+ | VernacSetOption (o,BoolValue true)
+ | VernacUnsetOption o -> coqide_known_option o
+ | _ -> false
+
+let is_debug cmd = match cmd with
+ | VernacSetOption (["Ltac";"Debug"], _) -> true
+ | _ -> false
+
+let is_query cmd = match cmd with
+ | VernacChdir None
+ | VernacMemOption _
+ | VernacPrintOption _
+ | VernacCheckMayEval _
+ | VernacGlobalCheck _
+ | VernacPrint _
+ | VernacSearch _
+ | VernacLocate _ -> true
+ | _ -> false
+
+let is_undo cmd = match cmd with
+ | VernacUndo _ | VernacUndoTo _ -> true
+ | _ -> false
+
+(** Check whether a command is forbidden by CoqIDE *)
+
+let coqide_cmd_checks (loc,ast) =
+ let user_error s = Errors.user_err_loc (loc, "CoqIde", str s) in
+ if is_debug ast then
+ user_error "Debug mode not available within CoqIDE";
+ if is_known_option ast then
+ msg_warning (strbrk"This will not work. Use CoqIDE display menu instead");
+ if Vernac.is_navigation_vernac ast || is_undo ast then
+ msg_warning (strbrk "Rather use CoqIDE navigation instead");
+ if is_query ast then
+ msg_warning (strbrk "Query commands should not be inserted in scripts")
+
+(** Interpretation (cf. [Ide_intf.interp]) *)
+
+let add ((s,eid),(sid,verbose)) =
+ let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in
+ let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in
+ newid, (rc, read_stdout ())
+
+let edit_at id =
+ match Stm.edit_at id with
+ | `NewTip -> CSig.Inl ()
+ | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip))
+
+let query (s,id) = Stm.query ~at:id s; read_stdout ()
+
+let annotate phrase =
+ let (loc, ast) =
+ let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in
+ Vernac.parse_sentence (pa,None)
+ in
+ let (_, _, xml) =
+ Richprinter.richpp_vernac ast
+ in
+ xml
+
+(** Goal display *)
+
+let hyp_next_tac sigma env (id,_,ast) =
+ let id_s = Names.Id.to_string id in
+ let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in
+ [
+ ("clear "^id_s),("clear "^id_s^".");
+ ("apply "^id_s),("apply "^id_s^".");
+ ("exact "^id_s),("exact "^id_s^".");
+ ("generalize "^id_s),("generalize "^id_s^".");
+ ("absurd <"^id_s^">"),("absurd "^type_s^".")
+ ] @ [
+ ("discriminate "^id_s),("discriminate "^id_s^".");
+ ("injection "^id_s),("injection "^id_s^".")
+ ] @ [
+ ("rewrite "^id_s),("rewrite "^id_s^".");
+ ("rewrite <- "^id_s),("rewrite <- "^id_s^".")
+ ] @ [
+ ("elim "^id_s), ("elim "^id_s^".");
+ ("inversion "^id_s), ("inversion "^id_s^".");
+ ("inversion clear "^id_s), ("inversion_clear "^id_s^".")
+ ]
+
+let concl_next_tac sigma concl =
+ let expand s = (s,s^".") in
+ List.map expand ([
+ "intro";
+ "intros";
+ "intuition"
+ ] @ [
+ "reflexivity";
+ "discriminate";
+ "symmetry"
+ ] @ [
+ "assumption";
+ "omega";
+ "ring";
+ "auto";
+ "eauto";
+ "tauto";
+ "trivial";
+ "decide equality";
+ "simpl";
+ "subst";
+ "red";
+ "split";
+ "left";
+ "right"
+ ])
+
+let process_goal sigma g =
+ let env = Goal.V82.env sigma g in
+ let min_env = Environ.reset_context env in
+ let id = Goal.uid g in
+ let ccl =
+ let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
+ string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in
+ let process_hyp d =
+ let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in
+ (string_of_ppcmds (pr_var_list_decl min_env sigma d)) in
+ let hyps =
+ List.map process_hyp
+ (Termops.compact_named_context_reverse (Environ.named_context env)) in
+ { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
+
+let export_pre_goals pgs =
+ {
+ Interface.fg_goals = pgs.Proof.fg_goals;
+ Interface.bg_goals = pgs.Proof.bg_goals;
+ Interface.shelved_goals = pgs.Proof.shelved_goals;
+ Interface.given_up_goals = pgs.Proof.given_up_goals
+ }
+
+let goals () =
+ Stm.finish ();
+ let s = read_stdout () in
+ if not (String.is_empty s) then msg_info (str s);
+ try
+ let pfts = Proof_global.give_me_the_proof () in
+ Some (export_pre_goals (Proof.map_structured_proof pfts process_goal))
+ with Proof_global.NoCurrentProof -> None
+
+let evars () =
+ try
+ Stm.finish ();
+ let s = read_stdout () in
+ if not (String.is_empty s) then msg_info (str s);
+ let pfts = Proof_global.give_me_the_proof () in
+ let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+ let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in
+ let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in
+ let el = List.map map_evar exl in
+ Some el
+ with Proof_global.NoCurrentProof -> None
+
+let hints () =
+ try
+ let pfts = Proof_global.give_me_the_proof () in
+ let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+ match all_goals with
+ | [] -> None
+ | g :: _ ->
+ let env = Goal.V82.env sigma g in
+ let hint_goal = concl_next_tac sigma g in
+ let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
+ let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
+ Some (hint_hyps, hint_goal)
+ with Proof_global.NoCurrentProof -> None
+
+
+(** Other API calls *)
+
+let status force =
+ (** We remove the initial part of the current [DirPath.t]
+ (usually Top in an interactive session, cf "coqtop -top"),
+ and display the other parts (opened sections and modules) *)
+ Stm.finish ();
+ if force then Stm.join ();
+ let s = read_stdout () in
+ if not (String.is_empty s) then msg_info (str s);
+ let path =
+ let l = Names.DirPath.repr (Lib.cwd ()) in
+ List.rev_map Names.Id.to_string l
+ in
+ let proof =
+ try Some (Names.Id.to_string (Proof_global.get_current_proof_name ()))
+ with Proof_global.NoCurrentProof -> None
+ in
+ let allproofs =
+ let l = Proof_global.get_all_proof_names () in
+ List.map Names.Id.to_string l
+ in
+ {
+ Interface.status_path = path;
+ Interface.status_proofname = proof;
+ Interface.status_allproofs = allproofs;
+ Interface.status_proofnum = Stm.current_proof_depth ();
+ }
+
+let export_coq_object t = {
+ Interface.coq_object_prefix = t.Search.coq_object_prefix;
+ Interface.coq_object_qualid = t.Search.coq_object_qualid;
+ Interface.coq_object_object = t.Search.coq_object_object
+}
+
+let import_search_constraint = function
+ | Interface.Name_Pattern s -> Search.Name_Pattern s
+ | Interface.Type_Pattern s -> Search.Type_Pattern s
+ | Interface.SubType_Pattern s -> Search.SubType_Pattern s
+ | Interface.In_Module ms -> Search.In_Module ms
+ | Interface.Include_Blacklist -> Search.Include_Blacklist
+
+let search flags =
+ List.map export_coq_object (Search.interface_search (
+ List.map (fun (c, b) -> (import_search_constraint c, b)) flags)
+ )
+
+let export_option_value = function
+ | Goptions.BoolValue b -> Interface.BoolValue b
+ | Goptions.IntValue x -> Interface.IntValue x
+ | Goptions.StringValue s -> Interface.StringValue s
+
+let import_option_value = function
+ | Interface.BoolValue b -> Goptions.BoolValue b
+ | Interface.IntValue x -> Goptions.IntValue x
+ | Interface.StringValue s -> Goptions.StringValue s
+
+let export_option_state s = {
+ Interface.opt_sync = s.Goptions.opt_sync;
+ Interface.opt_depr = s.Goptions.opt_depr;
+ Interface.opt_name = s.Goptions.opt_name;
+ Interface.opt_value = export_option_value s.Goptions.opt_value;
+}
+
+let get_options () =
+ let table = Goptions.get_tables () in
+ let fold key state accu = (key, export_option_state state) :: accu in
+ Goptions.OptionMap.fold fold table []
+
+let set_options options =
+ let iter (name, value) = match import_option_value value with
+ | BoolValue b -> Goptions.set_bool_option_value name b
+ | IntValue i -> Goptions.set_int_option_value name i
+ | StringValue s -> Goptions.set_string_option_value name s
+ in
+ List.iter iter options
+
+let about () = {
+ Interface.coqtop_version = Coq_config.version;
+ Interface.protocol_version = Xmlprotocol.protocol_version;
+ Interface.release_date = Coq_config.date;
+ Interface.compile_date = Coq_config.compile_date;
+}
+
+let handle_exn (e, info) =
+ let dummy = Stateid.dummy in
+ let loc_of e = match Loc.get_loc e with
+ | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc)
+ | _ -> None in
+ let mk_msg e = read_stdout ()^"\n"^string_of_ppcmds (Errors.print e) in
+ match e with
+ | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!"
+ | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!"
+ | e ->
+ match Stateid.get info with
+ | Some (valid, _) -> valid, loc_of info, mk_msg e
+ | None -> dummy, loc_of info, mk_msg e
+
+let init =
+ let initialized = ref false in
+ fun file ->
+ if !initialized then anomaly (str "Already initialized")
+ else begin
+ initialized := true;
+ match file with
+ | None -> Stm.get_current_state ()
+ | Some file ->
+ if not (Filename.check_suffix file ".v") then
+ error "A file with suffix .v is expected.";
+ let dir = Filename.dirname file in
+ let open Loadpath in let open CUnix in
+ let initial_id, _ =
+ if not (is_in_load_paths (physical_path_of_string dir)) then
+ Stm.add false ~ontop:(Stm.get_current_state ())
+ 0 (Printf.sprintf "Add LoadPath \"%s\". " dir)
+ else Stm.get_current_state (), `NewTip in
+ Stm.set_compilation_hints file;
+ initial_id
+ end
+
+(* Retrocompatibility stuff *)
+let interp ((_raw, verbose), s) =
+ let vernac_parse s =
+ let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+ Flags.with_option Flags.we_are_parsing (fun () ->
+ match Pcoq.Gram.entry_parse Pcoq.main_entry pa with
+ | None -> raise (Invalid_argument "vernac_parse")
+ | Some ast -> ast)
+ () in
+ Stm.interp verbose (vernac_parse s);
+ Stm.get_current_state (), CSig.Inl (read_stdout ())
+
+(** When receiving the Quit call, we don't directly do an [exit 0],
+ but rather set this reference, in order to send a final answer
+ before exiting. *)
+
+let quit = ref false
+
+(** Grouping all call handlers together + error handling *)
+
+let eval_call xml_oc log c =
+ let interruptible f x =
+ catch_break := true;
+ Control.check_for_interrupt ();
+ let r = f x in
+ catch_break := false;
+ let out = read_stdout () in
+ if not (String.is_empty out) then log (str out);
+ r
+ in
+ let handler = {
+ Interface.add = interruptible add;
+ Interface.edit_at = interruptible edit_at;
+ Interface.query = interruptible query;
+ Interface.goals = interruptible goals;
+ Interface.evars = interruptible evars;
+ Interface.hints = interruptible hints;
+ Interface.status = interruptible status;
+ Interface.search = interruptible search;
+ Interface.get_options = interruptible get_options;
+ Interface.set_options = interruptible set_options;
+ Interface.mkcases = interruptible Vernacentries.make_cases;
+ Interface.quit = (fun () -> quit := true);
+ Interface.init = interruptible init;
+ Interface.about = interruptible about;
+ Interface.interp = interruptible interp;
+ Interface.handle_exn = handle_exn;
+ Interface.stop_worker = Stm.stop_worker;
+ Interface.print_ast = Stm.print_ast;
+ Interface.annotate = interruptible annotate;
+ } in
+ Xmlprotocol.abstract_eval_call handler c
+
+(** Message dispatching.
+ Since coqtop -ideslave starts 1 thread per slave, and each
+ thread forwards feedback messages from the slave to the GUI on the same
+ xml channel, we need mutual exclusion. The mutex should be per-channel, but
+ here we only use 1 channel. *)
+let print_xml =
+ let m = Mutex.create () in
+ fun oc xml ->
+ Mutex.lock m;
+ try Xml_printer.print oc xml; Mutex.unlock m
+ with e -> let e = Errors.push e in Mutex.unlock m; iraise e
+
+
+let slave_logger xml_oc level message =
+ (* convert the message into XML *)
+ let msg = string_of_ppcmds (hov 0 message) in
+ let message = {
+ Pp.message_level = level;
+ Pp.message_content = msg;
+ } in
+ let () = pr_debug (Printf.sprintf "-> %S" msg) in
+ let xml = Pp.of_message message in
+ print_xml xml_oc xml
+
+let slave_feeder xml_oc msg =
+ let xml = Feedback.of_feedback msg in
+ print_xml xml_oc xml
+
+(** The main loop *)
+
+(** Exceptions during eval_call should be converted into [Interface.Fail]
+ messages by [handle_exn] above. Otherwise, we die badly, without
+ trying to answer malformed requests. *)
+
+let loop () =
+ init_signal_handler ();
+ catch_break := false;
+ let in_ch, out_ch = Spawned.get_channels () in
+ let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in
+ let in_lb = Lexing.from_function (fun s len ->
+ CThread.thread_friendly_read in_ch s ~off:0 ~len) in
+ let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in
+ let () = Xml_parser.check_eof xml_ic false in
+ set_logger (slave_logger xml_oc);
+ set_feeder (slave_feeder xml_oc);
+ (* We'll handle goal fetching and display in our own way *)
+ Vernacentries.enable_goal_printing := false;
+ Vernacentries.qed_display_script := false;
+ while not !quit do
+ try
+ let xml_query = Xml_parser.parse xml_ic in
+(* pr_with_pid (Xml_printer.to_string_fmt xml_query); *)
+ let q = Xmlprotocol.to_call xml_query in
+ let () = pr_debug_call q in
+ let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in
+ let () = pr_debug_answer q r in
+(* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *)
+ print_xml xml_oc (Xmlprotocol.of_answer q r);
+ flush out_ch
+ with
+ | Xml_parser.Error (Xml_parser.Empty, _) ->
+ pr_debug "End of input, exiting gracefully.";
+ exit 0
+ | Xml_parser.Error (err, loc) ->
+ pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err);
+ exit 1
+ | Serialize.Marshal_error ->
+ pr_debug "Incorrect query.";
+ exit 1
+ | any ->
+ pr_debug ("Fatal exception in coqtop:\n" ^ Printexc.to_string any);
+ exit 1
+ done;
+ pr_debug "Exiting gracefully.";
+ exit 0
+
+let rec parse = function
+ | "--help-XML-protocol" :: rest ->
+ Xmlprotocol.document Xml_printer.to_string_fmt; exit 0
+ | x :: rest -> x :: parse rest
+ | [] -> []
+
+let () = Coqtop.toploop_init := (fun args ->
+ let args = parse args in
+ Flags.make_silent true;
+ init_stdout ();
+ CoqworkmgrApi.(init Flags.High);
+ args)
+
+let () = Coqtop.toploop_run := loop
+
+let () = Usage.add_to_usage "coqidetop" " --help-XML-protocol print the documentation of the XML protocol used by CoqIDE\n"
diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c
index c170b1a9..c09bf37d 100644
--- a/ide/ide_win32_stubs.c
+++ b/ide/ide_win32_stubs.c
@@ -19,33 +19,31 @@ CAMLprim value win32_kill(value pseudopid) {
CAMLreturn(Val_unit);
}
-/* Win32 emulation of a kill -2 (SIGINT) */
-/* For simplicity, we signal all processes sharing a console with coqide.
- This shouldn't be an issue since currently at most one coqtop is busy
- at a given time. Earlier, we tried to be more precise via
- FreeConsole and AttachConsole before generating the Ctrl-C, but
- that wasn't working so well (see #2869).
- This code rely now on the fact that coqide is a console app,
- and that coqide itself ignores Ctrl-C.
-*/
+/* Win32 emulation of a kill -2 (SIGINT) */
-CAMLprim value win32_interrupt_all(value unit) {
- CAMLparam1(unit);
- GenerateConsoleCtrlEvent(CTRL_C_EVENT,0);
- CAMLreturn(Val_unit);
-}
+/* This code rely of the fact that coqide is now without initial console.
+ Otherwise, no console creation in win32unix/createprocess.c, hence
+ the same console for coqide and all coqtop, and everybody will be
+ signaled at the same time by the code below. */
-/* Get rid of the nasty console window (only if we created it) */
+/* Moreover, AttachConsole exists only since WinXP, and GetProcessId
+ since WinXP SP1. For avoiding the GetProcessId, we could adapt code
+ from win32unix/createprocess.c to make it return both the pid and the
+ handle. For avoiding the AttachConsole, I don't know, maybe having
+ an intermediate process between coqide and coqtop ? */
-CAMLprim value win32_hide_console (value unit) {
- CAMLparam1(unit);
+CAMLprim value win32_interrupt(value pseudopid) {
+ CAMLparam1(pseudopid);
+ HANDLE h;
DWORD pid;
- HWND hw = GetConsoleWindow();
- if (hw != NULL) {
- GetWindowThreadProcessId(hw, &pid);
- if (pid == GetCurrentProcessId())
- ShowWindow(hw, SW_HIDE);
- }
+ FreeConsole(); /* Normally unnecessary, just to be sure... */
+ h = (HANDLE)(Long_val(pseudopid));
+ pid = GetProcessId(h);
+ AttachConsole(pid);
+ /* We want to survive the Ctrl-C that will also concerns us */
+ SetConsoleCtrlHandler(NULL,TRUE); /* NULL + TRUE means ignore */
+ GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); /* signal our co-console */
+ FreeConsole();
CAMLreturn(Val_unit);
}
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index 1b4941b6..d2305b58 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -11,13 +11,27 @@ open Preferences
exception Forbidden
+let warn_image () =
+ let img = GMisc.image () in
+ img#set_stock `DIALOG_WARNING;
+ img#set_icon_size `DIALOG;
+ img
+
+let warning msg =
+ GToolbox.message_box ~title:"Warning" ~icon:(warn_image ())#coerce msg
+
+let cb = GData.clipboard Gdk.Atom.primary
+
(* status bar and locations *)
let status = GMisc.statusbar ()
-let push_info,pop_info =
+let push_info,pop_info,clear_info =
let status_context = status#new_context ~name:"Messages" in
- (fun s -> ignore (status_context#push s)),status_context#pop
+ let size = ref 0 in
+ (fun s -> incr size; ignore (status_context#push s)),
+ (fun () -> decr size; status_context#pop ()),
+ (fun () -> for i = 1 to !size do status_context#pop () done; size := 0)
let flash_info =
let flash_context = status#new_context ~name:"Flash" in
@@ -27,61 +41,44 @@ let flash_info =
let set_location = ref (function s -> failwith "not ready")
-let pbar = GRange.progress_bar ~pulse_step:0.2 ()
-
-let debug = ref (false)
+(** A utf8 char is either a single byte (ascii char, 0xxxxxxx)
+ or multi-byte (with a leading byte 11xxxxxx and extra bytes 10xxxxxx) *)
-let prerr_endline s =
- if !debug then try prerr_endline s;flush stderr with _ -> ()
+let is_extra_byte c = ((Char.code c) lsr 6 = 2)
-let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT
-
-let is_char_start c = let code = Char.code c in code < 0x80 || code >= 0xc0
+(** For a string buffer that may contain utf8 chars,
+ we convert a byte offset into a char offset
+ by only counting char-starting bytes.
+ Normally the string buffer starts with a char-starting byte
+ (buffer produced by a [#get_text]) *)
let byte_offset_to_char_offset s byte_offset =
- if (byte_offset < String.length s) then begin
- let count_delta = ref 0 in
- for i = 0 to byte_offset do
- let code = Char.code s.[i] in
- if code >= 0x80 && code < 0xc0 then incr count_delta
- done;
- byte_offset - !count_delta
- end
- else begin
- let count_delta = ref 0 in
- for i = 0 to String.length s - 1 do
- let code = Char.code s.[i] in
- if code >= 0x80 && code < 0xc0 then incr count_delta
- done;
- byte_offset - !count_delta
- end
-
-let print_id id =
- prerr_endline ("GOT sig id :"^(string_of_int (Obj.magic id)))
+ let extra_bytes = ref 0 in
+ for i = 0 to min byte_offset (String.length s - 1) do
+ if is_extra_byte s.[i] then incr extra_bytes
+ done;
+ byte_offset - !extra_bytes
+let glib_utf8_pos_to_offset s ~off = byte_offset_to_char_offset s off
let do_convert s =
- Utf8_convert.f
- (if Glib.Utf8.validate s then begin
- prerr_endline "Input is UTF-8";s
- end else
- let from_loc () =
- let _,char_set = Glib.Convert.get_charset () in
- flash_info
- ("Converting from locale ("^char_set^")");
- Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
- in
- let from_manual enc =
- flash_info
- ("Converting from "^ enc);
- Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc
- in
- match !current.encoding with
- |Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
- |Emanual enc ->
- try
- from_manual enc
- with _ -> from_loc ())
+ let from_loc () =
+ let _,char_set = Glib.Convert.get_charset () in
+ flash_info ("Converting from locale ("^char_set^")");
+ Glib.Convert.convert_with_fallback
+ ~to_codeset:"UTF-8" ~from_codeset:char_set s
+ in
+ let from_manual enc =
+ flash_info ("Converting from "^ enc);
+ Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc
+ in
+ let s =
+ if Glib.Utf8.validate s then (Minilib.log "Input is UTF-8"; s)
+ else match current.encoding with
+ |Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
+ |Emanual enc -> try from_manual enc with _ -> from_loc ()
+ in
+ Utf8_convert.f s
let try_convert s =
try
@@ -92,54 +89,48 @@ Please choose a correct encoding in the preference panel.*)";;
let try_export file_name s =
- try let s =
- try match !current.encoding with
- |Eutf8 -> begin
- (prerr_endline "UTF-8 is enforced" ;s)
- end
- |Elocale -> begin
+ let s =
+ try match current.encoding with
+ |Eutf8 -> Minilib.log "UTF-8 is enforced" ; s
+ |Elocale ->
let is_unicode,char_set = Glib.Convert.get_charset () in
if is_unicode then
- (prerr_endline "Locale is UTF-8" ;s)
+ (Minilib.log "Locale is UTF-8" ; s)
else
- (prerr_endline ("Locale is "^char_set);
- Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
- end
+ (Minilib.log ("Locale is "^char_set);
+ Glib.Convert.convert_with_fallback
+ ~from_codeset:"UTF-8" ~to_codeset:char_set s)
|Emanual enc ->
- (prerr_endline ("Manual charset is "^ enc);
- Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s)
- with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s)
+ (Minilib.log ("Manual charset is "^ enc);
+ Glib.Convert.convert_with_fallback
+ ~from_codeset:"UTF-8" ~to_codeset:enc s)
+ with e ->
+ let str = Printexc.to_string e in
+ Minilib.log ("Error ("^str^") in transcoding: falling back to UTF-8");
+ s
in
- let oc = open_out file_name in
- output_string oc s;
- close_out oc;
- true
- with e -> prerr_endline (Printexc.to_string e);false
-
-let my_stat f = try Some (Unix.stat f) with _ -> None
-
-let revert_timer = ref None
-let disconnect_revert_timer () = match !revert_timer with
- | None -> ()
- | Some id -> GMain.Timeout.remove id; revert_timer := None
-
-let auto_save_timer = ref None
-let disconnect_auto_save_timer () = match !auto_save_timer with
- | None -> ()
- | Some id -> GMain.Timeout.remove id; auto_save_timer := None
-
-let highlight_timer = ref None
-let set_highlight_timer f =
- match !highlight_timer with
- | None ->
- revert_timer :=
- Some (GMain.Timeout.add ~ms:2000
- ~callback:(fun () -> f (); highlight_timer := None; true))
- | Some id ->
- GMain.Timeout.remove id;
- revert_timer :=
- Some (GMain.Timeout.add ~ms:2000
- ~callback:(fun () -> f (); highlight_timer := None; true))
+ try
+ let oc = open_out file_name in
+ output_string oc s;
+ close_out oc;
+ true
+ with e -> Minilib.log (Printexc.to_string e);false
+
+type timer = { run : ms:int -> callback:(unit->bool) -> unit;
+ kill : unit -> unit }
+
+let mktimer () =
+ let timer = ref None in
+ { run =
+ (fun ~ms ~callback ->
+ timer := Some (GMain.Timeout.add ~ms ~callback));
+ kill =
+ (fun () -> match !timer with
+ | None -> ()
+ | Some id ->
+ (try GMain.Timeout.remove id
+ with Glib.GError _ -> ());
+ timer := None) }
let last_dir = ref ""
@@ -151,55 +142,62 @@ let filter_coq_files () = GFile.filter
~name:"Coq source code"
~patterns:[ "*.v"] ()
-let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () =
+let select_file_for_open ~title () =
let file = ref None in
- let file_chooser = GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () in
- file_chooser#add_button_stock `CANCEL `CANCEL ;
- file_chooser#add_select_button_stock `OPEN `OPEN ;
- file_chooser#add_filter (filter_coq_files ());
- file_chooser#add_filter (filter_all_files ());
- file_chooser#set_default_response `OPEN;
- ignore (file_chooser#set_current_folder !dir);
- begin match file_chooser#run () with
- | `OPEN ->
- begin
- file := file_chooser#filename;
- match !file with
- None -> ()
- | Some s -> dir := Filename.dirname s;
- end
- | `DELETE_EVENT | `CANCEL -> ()
- end ;
- file_chooser#destroy ();
- !file
-
-
-let select_file_for_save ~title ?(dir = last_dir) ?(filename="") () =
+ let file_chooser =
+ GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ()
+ in
+ file_chooser#add_button_stock `CANCEL `CANCEL ;
+ file_chooser#add_select_button_stock `OPEN `OPEN ;
+ file_chooser#add_filter (filter_coq_files ());
+ file_chooser#add_filter (filter_all_files ());
+ file_chooser#set_default_response `OPEN;
+ ignore (file_chooser#set_current_folder !last_dir);
+ begin match file_chooser#run () with
+ | `OPEN ->
+ begin
+ file := file_chooser#filename;
+ match !file with
+ | None -> ()
+ | Some s -> last_dir := Filename.dirname s;
+ end
+ | `DELETE_EVENT | `CANCEL -> ()
+ end ;
+ file_chooser#destroy ();
+ !file
+
+let select_file_for_save ~title ?filename () =
let file = ref None in
- let file_chooser = GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () in
- file_chooser#add_button_stock `CANCEL `CANCEL ;
- file_chooser#add_select_button_stock `SAVE `SAVE ;
- file_chooser#add_filter (filter_coq_files ());
- file_chooser#add_filter (filter_all_files ());
- (* this line will be used when a lablgtk >= 2.10.0 is the default on most distributions
- file_chooser#set_do_overwrite_confirmation true;
- *)
- file_chooser#set_default_response `SAVE;
- ignore (file_chooser#set_current_folder !dir);
- ignore (file_chooser#set_current_name filename);
-
- begin match file_chooser#run () with
- | `SAVE ->
- begin
- file := file_chooser#filename;
- match !file with
- None -> ()
- | Some s -> dir := Filename.dirname s;
- end
- | `DELETE_EVENT | `CANCEL -> ()
- end ;
- file_chooser#destroy ();
- !file
+ let file_chooser =
+ GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ()
+ in
+ file_chooser#add_button_stock `CANCEL `CANCEL ;
+ file_chooser#add_select_button_stock `SAVE `SAVE ;
+ file_chooser#add_filter (filter_coq_files ());
+ file_chooser#add_filter (filter_all_files ());
+ (* this line will be used when a lablgtk >= 2.10.0 is the default
+ on most distributions:
+ file_chooser#set_do_overwrite_confirmation true;
+ *)
+ file_chooser#set_default_response `SAVE;
+ let dir,filename = match filename with
+ |None -> !last_dir, ""
+ |Some f -> Filename.dirname f, Filename.basename f
+ in
+ ignore (file_chooser#set_current_folder dir);
+ ignore (file_chooser#set_current_name filename);
+ begin match file_chooser#run () with
+ | `SAVE ->
+ begin
+ file := file_chooser#filename;
+ match !file with
+ None -> ()
+ | Some s -> last_dir := Filename.dirname s;
+ end
+ | `DELETE_EVENT | `CANCEL -> ()
+ end ;
+ file_chooser#destroy ();
+ !file
let find_tag_start (tag :GText.tag) (it:GText.iter) =
let it = it#copy in
@@ -218,38 +216,19 @@ let find_tag_stop (tag :GText.tag) (it:GText.iter) =
let find_tag_limits (tag :GText.tag) (it:GText.iter) =
(find_tag_start tag it , find_tag_stop tag it)
-(* explanations: Win32 threads won't work if events are produced
- in a thread different from the thread of the Gtk loop. In this
- case we must use GtkThread.async to push a callback in the
- main thread. Beware that the synchronus version may produce
- deadlocks. *)
-let async =
- if Sys.os_type = "Win32" then GtkThread.async else (fun x -> x)
-let sync =
- if Sys.os_type = "Win32" then GtkThread.sync else (fun x -> x)
-
-let mutex text f =
- let m = Mutex.create() in
- fun x ->
- if Mutex.try_lock m
- then
- (try
- prerr_endline ("Got lock on "^text);
- f x;
- Mutex.unlock m;
- prerr_endline ("Released lock on "^text)
- with e ->
- Mutex.unlock m;
- prerr_endline ("Released lock on "^text^" (on error)");
- raise e)
- else
- prerr_endline
- ("Discarded call for "^text^": computations ongoing")
-
-
-let stock_to_widget ?(size=`DIALOG) s =
- let img = GMisc.image ()
- in img#set_stock s;
+let stock_to_widget ?(size=`BUTTON) s =
+ let img = GMisc.image () in
+ (match size with
+ | `CUSTOM(width,height) ->
+ let opb = img#misc#render_icon ~size:`BUTTON s in
+ let pb = GdkPixbuf.create ~width ~height
+ ~bits:(GdkPixbuf.get_bits_per_sample opb)
+ ~has_alpha:(GdkPixbuf.get_has_alpha opb) () in
+ GdkPixbuf.scale ~width ~height ~dest:pb opb;
+ img#set_pixbuf pb
+ | #Gtk.Tags.icon_size as icon_size ->
+ img#set_stock s;
+ img#set_icon_size icon_size);
img#coerce
let custom_coqtop = ref None
@@ -258,23 +237,19 @@ let coqtop_path () =
let file = match !custom_coqtop with
| Some s -> s
| None ->
- match !current.cmd_coqtop with
+ match current.cmd_coqtop with
| Some s -> s
| None ->
let prog = String.copy Sys.executable_name in
try
let pos = String.length prog - 6 in
- let i = Str.search_backward (Str.regexp_string "coqide") prog pos in
+ let i = Str.search_backward (Str.regexp_string "coqide") prog pos
+ in
String.blit "coqtop" 0 prog i 6;
- prog
+ if Sys.file_exists prog then prog else "coqtop"
with Not_found -> "coqtop"
in file
-let rec print_list print fmt = function
- | [] -> ()
- | [x] -> print fmt x
- | x :: r -> print fmt x; print_list print fmt r
-
(* In win32, when a command-line is to be executed via cmd.exe
(i.e. Sys.command, Unix.open_process, ...), it cannot contain several
quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
@@ -282,76 +257,160 @@ let rec print_list print fmt = function
let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd
-(* TODO: allow to report output as soon as it comes (user-fiendlier
- for long commands like make...) *)
-let run_command f c =
- let c = requote c in
- let result = Buffer.create 127 in
- let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
- let buff = String.make 127 ' ' in
- let buffe = String.make 127 ' ' in
- let n = ref 0 in
- let ne = ref 0 in
- while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0
- do
- let r = try_convert (String.sub buff 0 !n) in
- f r;
- Buffer.add_string result r;
- let r = try_convert (String.sub buffe 0 !ne) in
- f r;
- Buffer.add_string result r
- done;
- (Unix.close_process_full (cin,cout,cerr), Buffer.contents result)
-
-let browse f url =
- let com = Minilib.subst_command_placeholder !current.cmd_browse url in
- let _ = Unix.open_process_out com in ()
-(* This beautiful message will wait for twt ...
- if s = 127 then
- f ("Could not execute\n\""^com^
- "\"\ncheck your preferences for setting a valid browser command\n")
-*)
+let textview_width (view : #GText.view_skel) =
+ let rect = view#visible_rect in
+ let pixel_width = Gdk.Rectangle.width rect in
+ let metrics = view#misc#pango_context#get_metrics () in
+ let char_width = GPango.to_pixels metrics#approx_char_width in
+ pixel_width / char_width
+
+type logger = Pp.message_level -> string -> unit
+
+let default_logger level message =
+ let level = match level with
+ | Pp.Debug _ -> `DEBUG
+ | Pp.Info -> `INFO
+ | Pp.Notice -> `NOTICE
+ | Pp.Warning -> `WARNING
+ | Pp.Error -> `ERROR
+ in
+ Minilib.log ~level message
+
+
+(** {6 File operations} *)
+
+(** A customized [stat] function. Exceptions are catched. *)
+
+type stats = MTime of float | NoSuchFile | OtherError
+
+let stat f =
+ try MTime (Unix.stat f).Unix.st_mtime
+ with
+ | Unix.Unix_error (Unix.ENOENT,_,_) -> NoSuchFile
+ | _ -> OtherError
+
+(** I/O utilities
+
+ Note: In a mono-thread coqide, we use the same buffer for
+ different read operations *)
+
+let maxread = 4096
+
+let read_string = String.create maxread
+let read_buffer = Buffer.create maxread
+
+(** Read the content of file [f] and add it to buffer [b].
+ I/O Exceptions are propagated. *)
+
+let read_file name buf =
+ let ic = open_in name in
+ let len = ref 0 in
+ try
+ while len := input ic read_string 0 maxread; !len > 0 do
+ Buffer.add_substring buf read_string 0 !len
+ done;
+ close_in ic
+ with e -> close_in ic; raise e
+
+(** Read what is available on a gtk channel. This channel should have been
+ set as non-blocking. When there's nothing more to read, the inner loop
+ will be exited via a GError exception concerning a EAGAIN unix error.
+ Anyway, any other exception also stops the read. *)
+
+let io_read_all chan =
+ Buffer.clear read_buffer;
+ let read_once () =
+ let len = Glib.Io.read_chars ~buf:read_string ~pos:0 ~len:maxread chan in
+ Buffer.add_substring read_buffer read_string 0 len
+ in
+ begin
+ try while true do read_once () done
+ with Glib.GError _ -> ()
+ end;
+ Buffer.contents read_buffer
+
+(** Run an external command asynchronously *)
+
+let run_command display finally cmd =
+ let cin = Unix.open_process_in cmd in
+ let fd = Unix.descr_of_in_channel cin in
+ let () = Unix.set_nonblock fd in
+ let io_chan = Glib.Io.channel_of_descr fd in
+ let all_conds = [`ERR; `HUP; `IN; `NVAL; `PRI] in (* all except `OUT *)
+ let rec has_errors = function
+ | [] -> false
+ | (`IN | `PRI) :: conds -> has_errors conds
+ | e :: _ -> true
+ in
+ let handle_end () = finally (Unix.close_process_in cin); false
+ in
+ let handle_input conds =
+ if has_errors conds then handle_end ()
+ else
+ let s = io_read_all io_chan in
+ if s = "" then handle_end ()
+ else (display (try_convert s); true)
+ in
+ ignore (Glib.Io.add_watch ~cond:all_conds ~callback:handle_input io_chan)
+
+(** Web browsing *)
+
+let browse prerr url =
+ let com = Util.subst_command_placeholder current.cmd_browse url in
+ let finally = function
+ | Unix.WEXITED 127 ->
+ prerr
+ ("Could not execute:\n"^com^"\n"^
+ "check your preferences for setting a valid browser command\n")
+ | _ -> ()
+ in
+ run_command (fun _ -> ()) finally com
+
let doc_url () =
- if !current.doc_url = use_default_doc_url || !current.doc_url = "" then
- let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in
+ if current.doc_url = use_default_doc_url || current.doc_url = ""
+ then
+ let addr = List.fold_left Filename.concat (Coq_config.docdir)
+ ["html";"refman";"index.html"]
+ in
if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman
- else !current.doc_url
+ else current.doc_url
let url_for_keyword =
let ht = Hashtbl.create 97 in
lazy (
begin try
- let cin =
- try let index_urls = Filename.concat (List.find
+ let cin =
+ try let index_urls = Filename.concat (List.find
(fun x -> Sys.file_exists (Filename.concat x "index_urls.txt"))
- Minilib.xdg_config_dirs) "index_urls.txt" in
- open_in index_urls
- with Not_found ->
- let doc_url = doc_url () in
- let n = String.length doc_url in
- if n > 8 && String.sub doc_url 0 7 = "file://" then
- open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt")
- else
- raise Exit
- in
- try while true do
- let s = input_line cin in
- try
- let i = String.index s ',' in
- let k = String.sub s 0 i in
- let u = String.sub s (i + 1) (String.length s - i - 1) in
- Hashtbl.add ht k u
- with _ ->
- Minilib.safe_prerr_endline "Warning: Cannot parse documentation index file."
- done with End_of_file ->
- close_in cin
+ (Minilib.coqide_data_dirs ())) "index_urls.txt" in
+ open_in index_urls
+ with Not_found ->
+ let doc_url = doc_url () in
+ let n = String.length doc_url in
+ if n > 8 && String.sub doc_url 0 7 = "file://" then
+ open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt")
+ else
+ raise Exit
+ in
+ try while true do
+ let s = input_line cin in
+ try
+ let i = String.index s ',' in
+ let k = String.sub s 0 i in
+ let u = String.sub s (i + 1) (String.length s - i - 1) in
+ Hashtbl.add ht k u
+ with _ ->
+ Minilib.log "Warning: Cannot parse documentation index file."
+ done with End_of_file ->
+ close_in cin
with _ ->
- Minilib.safe_prerr_endline "Warning: Cannot find documentation index file."
+ Minilib.log "Warning: Cannot find documentation index file."
end;
Hashtbl.find ht : string -> string)
-let browse_keyword f text =
- try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u)
- with Not_found -> f ("No documentation found for \""^text^"\".\n")
+let browse_keyword prerr text =
+ try
+ let u = Lazy.force url_for_keyword text in
+ browse prerr (doc_url() ^ u)
+ with Not_found -> prerr ("No documentation found for \""^text^"\".\n")
-let absolute_filename f = Minilib.correct_path f (Sys.getcwd ())
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index c8493825..8269582d 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -1,56 +1,42 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-val async : ('a -> unit) -> 'a -> unit
-val sync : ('a -> 'b) -> 'a -> 'b
+val warn_image : unit -> GMisc.image
+val warning : string -> unit
-(* avoid running two instances of a function concurrently *)
-val mutex : string -> ('a -> unit) -> 'a -> unit
+val cb : GData.clipboard
val doc_url : unit -> string
val browse : (string -> unit) -> string -> unit
val browse_keyword : (string -> unit) -> string -> unit
+
+(* These two functions are equivalent, the latter is named following
+ glib schema, and exists in glib but is not in lablgtk2 *)
val byte_offset_to_char_offset : string -> int -> int
-val debug : bool ref
-val disconnect_revert_timer : unit -> unit
-val disconnect_auto_save_timer : unit -> unit
+val glib_utf8_pos_to_offset : string -> off:int -> int
+
+type timer = { run : ms:int -> callback:(unit->bool) -> unit;
+ kill : unit -> unit }
+val mktimer : unit -> timer
+
val do_convert : string -> string
val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter
val find_tag_start : GText.tag -> GText.iter -> GText.iter
val find_tag_stop : GText.tag -> GText.iter -> GText.iter
-val get_insert : < get_iter_at_mark : [> `INSERT] -> 'a; .. > -> 'a
-
-val is_char_start : char -> bool
-
-val my_stat : string -> Unix.stats option
-
-(** debug printing *)
-val prerr_endline : string -> unit
-val print_id : 'a -> unit
-
-val revert_timer : GMain.Timeout.id option ref
-val auto_save_timer : GMain.Timeout.id option ref
-val select_file_for_open :
- title:string ->
- ?dir:string ref -> ?filename:string -> unit -> string option
+val select_file_for_open : title:string -> unit -> string option
val select_file_for_save :
- title:string ->
- ?dir:string ref -> ?filename:string -> unit -> string option
-val set_highlight_timer : (unit -> 'a) -> unit
+ title:string -> ?filename:string -> unit -> string option
val try_convert : string -> string
val try_export : string -> string -> bool
-val stock_to_widget : ?size:Gtk.Tags.icon_size -> GtkStock.id -> GObj.widget
-
-open Format
-val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
-
-val run_command : (string -> unit) -> string -> Unix.process_status*string
+val stock_to_widget :
+ ?size:[`CUSTOM of int * int | Gtk.Tags.icon_size] ->
+ GtkStock.id -> GObj.widget
val custom_coqtop : string option ref
(* @return command to call coqtop
@@ -63,20 +49,47 @@ val coqtop_path : unit -> string
val status : GMisc.statusbar
val push_info : string -> unit
val pop_info : unit -> unit
+val clear_info : unit -> unit
val flash_info : ?delay:int -> string -> unit
val set_location : (string -> unit) ref
-val pbar : GRange.progress_bar
-
-(*
- returns an absolute filename equivalent to given filename
-*)
-val absolute_filename : string -> string
-
(* In win32, when a command-line is to be executed via cmd.exe
(i.e. Sys.command, Unix.open_process, ...), it cannot contain several
quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
everything. Reference: http://ss64.com/nt/cmd.html *)
val requote : string -> string
+
+val textview_width : #GText.view_skel -> int
+(** Returns an approximate value of the character width of a textview *)
+
+type logger = Pp.message_level -> string -> unit
+
+val default_logger : Pp.message_level -> string -> unit
+(** Default logger. It logs messages that the casual user should not see. *)
+
+(** {6 I/O operations} *)
+
+(** A customized [stat] function. Exceptions are catched. *)
+
+type stats = MTime of float | NoSuchFile | OtherError
+val stat : string -> stats
+
+(** Read the content of file [f] and add it to buffer [b].
+ I/O Exceptions are propagated. *)
+
+val read_file : string -> Buffer.t -> unit
+
+(** Read what is available on a gtk input channel.
+ This channel should have been set as non-blocking. *)
+
+val io_read_all : Glib.Io.channel -> string
+
+(** [run_command display finally cmd] allow to run a command
+ asynchronously, calling [display] on any output of this command
+ and [finally] when the command has returned. *)
+
+val run_command :
+ (string -> unit) -> (Unix.process_status -> unit) -> string -> unit
+
diff --git a/ide/interface.mli b/ide/interface.mli
new file mode 100644
index 00000000..464e851f
--- /dev/null
+++ b/ide/interface.mli
@@ -0,0 +1,242 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** * Declarative part of the interface of CoqIde calls to Coq *)
+
+(** * Generic structures *)
+
+type raw = bool
+type verbose = bool
+
+(** The type of coqtop goals *)
+type goal = {
+ goal_id : string;
+ (** Unique goal identifier *)
+ goal_hyp : string list;
+ (** List of hypotheses *)
+ goal_ccl : string;
+ (** Goal conclusion *)
+}
+
+type evar = {
+ evar_info : string;
+ (** A string describing an evar: type, number, environment *)
+}
+
+type status = {
+ status_path : string list;
+ (** Module path of the current proof *)
+ status_proofname : string option;
+ (** Current proof name. [None] if no focussed proof is in progress *)
+ status_allproofs : string list;
+ (** List of all pending proofs. Order is not significant *)
+ status_proofnum : int;
+ (** An id describing the state of the current proof. *)
+}
+
+type 'a pre_goals = {
+ fg_goals : 'a list;
+ (** List of the focussed goals *)
+ bg_goals : ('a list * 'a list) list;
+ (** Zipper representing the unfocused background goals *)
+ shelved_goals : 'a list;
+ (** List of the goals on the shelf. *)
+ given_up_goals : 'a list;
+ (** List of the goals that have been given up *)
+}
+
+type goals = goal pre_goals
+
+type hint = (string * string) list
+(** A list of tactics applicable and their appearance *)
+
+type option_name = string list
+
+type option_value =
+ | BoolValue of bool
+ | IntValue of int option
+ | StringValue of string
+
+(** Summary of an option status *)
+type option_state = {
+ opt_sync : bool;
+ (** Whether an option is synchronous *)
+ opt_depr : bool;
+ (** Wheter an option is deprecated *)
+ opt_name : string;
+ (** A short string that is displayed when using [Test] *)
+ opt_value : option_value;
+ (** The current value of the option *)
+}
+
+type search_constraint =
+(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
+| Name_Pattern of string
+(** Whether the object type satisfies a pattern *)
+| Type_Pattern of string
+(** Whether some subtype of object type satisfies a pattern *)
+| SubType_Pattern of string
+(** Whether the object pertains to a module *)
+| In_Module of string list
+(** Bypass the Search blacklist *)
+| Include_Blacklist
+
+(** A list of search constraints; the boolean flag is set to [false] whenever
+ the flag should be negated. *)
+type search_flags = (search_constraint * bool) list
+
+(** A named object in Coq. [coq_object_qualid] is the shortest path defined for
+ the user. [coq_object_prefix] is the missing part to recover the fully
+ qualified name, i.e [fully_qualified = coq_object_prefix + coq_object_qualid].
+ [coq_object_object] is the actual content of the object. *)
+type 'a coq_object = {
+ coq_object_prefix : string list;
+ coq_object_qualid : string list;
+ coq_object_object : 'a;
+}
+
+type coq_info = {
+ coqtop_version : string;
+ protocol_version : string;
+ release_date : string;
+ compile_date : string;
+}
+
+(** Calls result *)
+
+type location = (int * int) option (* start and end of the error *)
+type state_id = Feedback.state_id
+type edit_id = Feedback.edit_id
+
+(* The fail case carries the current state_id of the prover, the GUI
+ should probably retract to that point *)
+type 'a value =
+ | Good of 'a
+ | Fail of (state_id * location * string)
+
+type ('a, 'b) union = ('a, 'b) Util.union
+
+(* Request/Reply message protocol between Coq and CoqIde *)
+
+(** [add ((s,eid),(sid,v))] adds the phrase [s] with edit id [eid]
+ on top of the current edit position (that is asserted to be [sid])
+ verbosely if [v] is true. The response [(id,(rc,s)] is the new state
+ [id] assigned to the phrase, some output [s]. [rc] is [Inl] if the new
+ state id is the tip of the edit point, or [Inr tip] if the new phrase
+ closes a focus and [tip] is the new edit tip *)
+type add_sty = (string * edit_id) * (state_id * verbose)
+type add_rty = state_id * ((unit, state_id) union * string)
+
+(** [edit_at id] declares the user wants to edit just after [id].
+ The response is [Inl] if the document has been rewound to that point,
+ [Inr (start,(stop,tip))] if [id] is in a zone that can be focused.
+ In that case the zone is delimited by [start] and [stop] while [tip]
+ is the new document [tip]. Edits made by subsequent [add] are always
+ performend on top of [id]. *)
+type edit_at_sty = state_id
+type edit_at_rty = (unit, state_id * (state_id * state_id)) union
+
+(** [query s id] executes [s] at state [id] and does not record any state
+ change but for the printings that are sent in response *)
+type query_sty = string * state_id
+type query_rty = string
+
+(** Fetching the list of current goals. Return [None] if no proof is in
+ progress, [Some gl] otherwise. *)
+type goals_sty = unit
+type goals_rty = goals option
+
+(** Retrieve the list of unintantiated evars in the current proof. [None] if no
+ proof is in progress. *)
+type evars_sty = unit
+type evars_rty = evar list option
+
+(** Retrieving the tactics applicable to the current goal. [None] if there is
+ no proof in progress. *)
+type hints_sty = unit
+type hints_rty = (hint list * hint) option
+
+(** The status, for instance "Ready in SomeSection, proving Foo", the
+ input boolean (if true) forces the evaluation of all unevaluated
+ statements *)
+type status_sty = bool
+type status_rty = status
+
+(** Search for objects satisfying the given search flags. *)
+type search_sty = search_flags
+type search_rty = string coq_object list
+
+(** Retrieve the list of options of the current toplevel *)
+type get_options_sty = unit
+type get_options_rty = (option_name * option_state) list
+
+(** Set the options to the given value. Warning: this is not atomic, so whenever
+ the call fails, the option state can be messed up... This is the caller duty
+ to check that everything is correct. *)
+type set_options_sty = (option_name * option_value) list
+type set_options_rty = unit
+
+(** Create a "match" template for a given inductive type.
+ For each branch of the match, we list the constructor name
+ followed by enough pattern variables. *)
+type mkcases_sty = string
+type mkcases_rty = string list list
+
+(** Quit gracefully the interpreter. *)
+type quit_sty = unit
+type quit_rty = unit
+
+(* Initialize, and return the initial state id. The argument is the filename.
+ * If its directory is not in dirpath, it adds it. It also loads
+ * compilation hints for the filename. *)
+type init_sty = string option
+type init_rty = state_id
+
+type about_sty = unit
+type about_rty = coq_info
+
+type handle_exn_sty = Exninfo.iexn
+type handle_exn_rty = state_id * location * string
+
+(* Retrocompatibility stuff *)
+type interp_sty = (raw * verbose) * string
+(* spiwack: [Inl] for safe and [Inr] for unsafe. *)
+type interp_rty = state_id * (string,string) Util.union
+
+type stop_worker_sty = string
+type stop_worker_rty = unit
+
+type print_ast_sty = state_id
+type print_ast_rty = Xml_datatype.xml
+
+type annotate_sty = string
+type annotate_rty = Xml_datatype.xml
+
+type handler = {
+ add : add_sty -> add_rty;
+ edit_at : edit_at_sty -> edit_at_rty;
+ query : query_sty -> query_rty;
+ goals : goals_sty -> goals_rty;
+ evars : evars_sty -> evars_rty;
+ hints : hints_sty -> hints_rty;
+ status : status_sty -> status_rty;
+ search : search_sty -> search_rty;
+ get_options : get_options_sty -> get_options_rty;
+ set_options : set_options_sty -> set_options_rty;
+ mkcases : mkcases_sty -> mkcases_rty;
+ about : about_sty -> about_rty;
+ stop_worker : stop_worker_sty -> stop_worker_rty;
+ print_ast : print_ast_sty -> print_ast_rty;
+ annotate : annotate_sty -> annotate_rty;
+ handle_exn : handle_exn_sty -> handle_exn_rty;
+ init : init_sty -> init_rty;
+ quit : quit_sty -> quit_rty;
+ (* Retrocompatibility stuff *)
+ interp : interp_sty -> interp_rty;
+}
+
diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml
new file mode 100644
index 00000000..d6687889
--- /dev/null
+++ b/ide/macos_prehook.ml
@@ -0,0 +1,37 @@
+let append_to_var var value =
+ let new_val =
+ try value ^ ":" ^ Unix.getenv var
+ with Not_found -> value in
+ Unix.putenv var new_val
+
+let resources_dir =
+ let working_dir = Sys.getcwd () in
+ let () = Sys.chdir (Filename.dirname (Sys.executable_name)) in
+ let app_root_dir = Filename.dirname (Sys.getcwd ()) in
+ let () = Sys.chdir working_dir in
+ Filename.concat app_root_dir "Resources"
+
+let lib_dir = Filename.concat resources_dir "lib"
+let etc_dir = Filename.concat resources_dir "etc"
+let xdg_home = Filename.concat (Sys.getenv "HOME") "Library/Application Support"
+
+let () = Unix.putenv "DYLD_LIBRARY_PATH" lib_dir
+let () = Unix.putenv "XDG_DATA_HOME" xdg_home
+let () = Unix.putenv "XDG_CONFIG_HOME" xdg_home
+let () = append_to_var "XDG_DATA_DIRS" (Filename.concat resources_dir "share")
+let () = append_to_var "XDG_CONFIG_DIRS" (Filename.concat etc_dir "xdg")
+let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir
+let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir
+let () = Unix.putenv "GTK_PATH" resources_dir
+let () =
+ Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc")
+let () =
+ Unix.putenv "GTK_IM_MODULE_FILE"
+ (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders")
+let () =
+ Unix.putenv "GDK_PIXBUF_MODULE_FILE"
+ (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders")
+let () = Unix.putenv "PANGO_LIBDIR" lib_dir
+let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir
+let () = Unix.putenv "CHARSETALIASDIR" lib_dir
+let () = append_to_var "PATH" (Filename.concat resources_dir "bin")
diff --git a/ide/minilib.ml b/ide/minilib.ml
index 74a42b23..d11e8c56 100644
--- a/ide/minilib.ml
+++ b/ide/minilib.ml
@@ -6,112 +6,23 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
+let rec print_list print fmt = function
+ | [] -> ()
+ | [x] -> print fmt x
+ | x :: r -> print fmt x; print_list print fmt r
+
+type level = [
+ | `DEBUG
+ | `INFO
+ | `NOTICE
+ | `WARNING
+ | `ERROR
+ | `FATAL ]
+
(** Some excerpt of Util and similar files to avoid loading the whole
module and its dependencies (and hence Compat and Camlp4) *)
-module Stringmap = Map.Make(String)
-
-let list_fold_left_i f =
- let rec it_list_f i a = function
- | [] -> a
- | b::l -> it_list_f (i+1) (f i a b) l
- in
- it_list_f
-
-(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that
- [l1++l2=l] and [l1] has length [i].
- It raises [Failure] when [i] is negative or greater than the length of [l] *)
-
-let list_chop n l =
- let rec chop_aux i acc = function
- | tl when i=0 -> (List.rev acc, tl)
- | h::t -> chop_aux (pred i) (h::acc) t
- | [] -> failwith "list_chop"
- in
- chop_aux n [] l
-
-
-let list_map_i f =
- let rec map_i_rec i = function
- | [] -> []
- | x::l -> let v = f i x in v :: map_i_rec (i+1) l
- in
- map_i_rec
-
-
-let list_index x =
- let rec index_x n = function
- | y::l -> if x = y then n else index_x (succ n) l
- | [] -> raise Not_found
- in
- index_x 1
-
-let list_index0 x l = list_index x l - 1
-
-let list_filter_i p =
- let rec filter_i_rec i = function
- | [] -> []
- | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
- in
- filter_i_rec 0
-
-let string_map f s =
- let l = String.length s in
- let r = String.create l in
- for i= 0 to (l - 1) do r.[i] <- f (s.[i]) done;
- r
-
-let subst_command_placeholder s t =
- Str.global_replace (Str.regexp_string "%s") t s
-
-(* Split the content of a variable such as $PATH in a list of directories.
- The separators are either ":" in unix or ";" in win32 *)
-
-let path_to_list = Str.split (Str.regexp "[:;]")
-
-(* On win32, the home directory is probably not in $HOME, but in
- some other environment variable *)
-
-let home =
- try Sys.getenv "HOME" with Not_found ->
- try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
- try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name
-
-let opt2list = function None -> [] | Some x -> [x]
-
-let (/) = Filename.concat
-
-let coqify d = d / "coq"
-
-let xdg_config_home =
- coqify (try Sys.getenv "XDG_CONFIG_HOME" with Not_found -> home / ".config")
-
-let relative_base =
- Filename.dirname (Filename.dirname Sys.executable_name)
-
-let xdg_config_dirs =
- let sys_dirs =
- try List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
- with
- | Not_found when Sys.os_type = "Win32" -> [relative_base / "config"]
- | Not_found -> ["/etc/xdg/coq"]
- in
- xdg_config_home :: sys_dirs @ opt2list Coq_config.configdir
-
-let xdg_data_home =
- coqify
- (try Sys.getenv "XDG_DATA_HOME" with Not_found -> home / ".local" / "share")
-
-let xdg_data_dirs =
- let sys_dirs =
- try List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
- with
- | Not_found when Sys.os_type = "Win32" -> [relative_base / "share"]
- | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]
- in
- xdg_data_home :: sys_dirs @ opt2list Coq_config.datadir
-
-let coqtop_path = ref ""
+let debug = ref false
(* On a Win32 application with no console, writing to stderr raise
a Sys_error "bad file descriptor", hence the "try" below.
@@ -119,68 +30,41 @@ let coqtop_path = ref ""
print in the response buffer.
*)
-let safe_prerr_endline s =
- try prerr_endline s;flush stderr with _ -> ()
-
-(* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p =
- let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
- let n = String.length curdir in
- let l = String.length p in
- if l > n && String.sub p 0 n = curdir then
- let n' =
- let sl = String.length Filename.dir_sep in
- let i = ref n in
- while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
- remove_path_dot (String.sub p n' (l - n'))
- else
- p
-
-let strip_path p =
- let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
- let n = String.length cwd in
- let l = String.length p in
- if l > n && String.sub p 0 n = cwd then
- let n' =
- let sl = String.length Filename.dir_sep in
- let i = ref n in
- while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
- remove_path_dot (String.sub p n' (l - n'))
- else
- remove_path_dot p
-
-let canonical_path_name p =
- let current = Sys.getcwd () in
- try
- Sys.chdir p;
- let p' = Sys.getcwd () in
- Sys.chdir current;
- p'
- with Sys_error _ ->
- (* We give up to find a canonical name and just simplify it... *)
- strip_path p
-
-let correct_path f dir = if Filename.is_relative f then Filename.concat dir f else f
-
-(*
- checks if two file names refer to the same (existing) file by
- comparing their device and inode.
- It seems that under Windows, inode is always 0, so we cannot
- accurately check if
+let log ?(level = `DEBUG) msg =
+ let prefix = match level with
+ | `DEBUG -> "DEBUG"
+ | `INFO -> "INFO"
+ | `NOTICE -> "NOTICE"
+ | `WARNING -> "WARNING"
+ | `ERROR -> "ERROR"
+ | `FATAL -> "FATAL"
+ in
+ if !debug then begin
+ try Printf.eprintf "[%s] %s\n%!" prefix msg
+ with _ -> ()
+ end
+
+let coqify d = Filename.concat d "coq"
+
+let coqide_config_home () =
+ coqify (Glib.get_user_config_dir ())
+
+let coqide_data_dirs () =
+ coqify (Glib.get_user_data_dir ())
+ :: List.map coqify (Glib.get_system_data_dirs ())
+ @ Option.List.cons Coq_config.datadir []
+
+let coqide_config_dirs () =
+ coqide_config_home ()
+ :: List.map coqify (Glib.get_system_config_dirs ())
+ @ Option.List.cons Coq_config.configdir []
+
+let is_prefix_of pre s =
+ let i = ref 0 in
+ let () = while (!i < (String.length pre)
+ && !i < (String.length s)
+ && pre.[!i] = s.[!i]) do
+ incr i
+ done
+ in !i = String.length pre
-*)
-(* Optimised for partial application (in case many candidates must be
- compared to f1). *)
-let same_file f1 =
- try
- let s1 = Unix.stat f1 in
- (fun f2 ->
- try
- let s2 = Unix.stat f2 in
- s1.Unix.st_dev = s2.Unix.st_dev &&
- if Sys.os_type = "Win32" then f1 = f2
- else s1.Unix.st_ino = s2.Unix.st_ino
- with
- Unix.Unix_error _ -> false)
- with
- Unix.Unix_error _ -> (fun _ -> false)
diff --git a/ide/minilib.mli b/ide/minilib.mli
index 53d6c87c..b7672c90 100644
--- a/ide/minilib.mli
+++ b/ide/minilib.mli
@@ -9,36 +9,22 @@
(** Some excerpts of Util and similar files to avoid depending on them
and hence on Compat and Camlp4 *)
-module Stringmap : Map.S with type key = string
+val print_list : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
-val list_fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
-val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
-val list_filter_i : (int -> 'a -> bool) -> 'a list -> 'a list
-val list_chop : int -> 'a list -> 'a list * 'a list
-val list_index0 : 'a -> 'a list -> int
+type level = [
+ | `DEBUG
+ | `INFO
+ | `NOTICE
+ | `WARNING
+ | `ERROR
+ | `FATAL ]
-val string_map : (char -> char) -> string -> string
+(** debug printing *)
+val debug : bool ref
-val subst_command_placeholder : string -> string -> string
-
-val home : string
-val xdg_config_home : string
-val xdg_config_dirs : string list
-val xdg_data_home : string
-val xdg_data_dirs : string list
-
-val coqtop_path : string ref
-
-(** safe version of Pervasives.prerr_endline
- (avoid exception in win32 without console) *)
-val safe_prerr_endline : string -> unit
-
-val remove_path_dot : string -> string
-val strip_path : string -> string
-val canonical_path_name : string -> string
-(** correct_path f dir = dir/f if f is relative *)
-val correct_path : string -> string -> string
-
-(** checks if two file names refer to the same (existing) file *)
-val same_file : string -> string -> bool
+val log : ?level:level -> string -> unit
+val coqide_config_home : unit -> string
+val coqide_config_dirs : unit -> string list
+val coqide_data_dirs : unit -> string list
+val is_prefix_of : string -> string -> bool
diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml
new file mode 100644
index 00000000..805ace93
--- /dev/null
+++ b/ide/nanoPG.ml
@@ -0,0 +1,321 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Ideutils
+open Session
+open Preferences
+open GdkKeysyms
+open Printf
+
+let eprintf x =
+ if !Flags.debug then Printf.eprintf x else Printf.ifprintf stderr x
+
+type gui = {
+ notebook : session Wg_Notebook.typed_notebook;
+ action_groups : GAction.action_group list;
+}
+
+let actiong gui name = List.find (fun ag -> ag#name = name) gui.action_groups
+let ct gui = gui.notebook#current_term
+
+let get_sel b = b#selection_bounds
+let sel_nonempty b = let i, j = get_sel b in not (i#equal j)
+let get_sel_txt b = let i, j = get_sel b in i#get_text ~stop:j
+
+type status = { move : int option; kill : (string * bool) option; sel: bool }
+
+let pr_status { move; kill; sel } =
+ let move = Option.cata (fun i -> string_of_int i) "" move in
+ let kill = Option.cata (fun (s,b) -> sprintf "kill(%b) %S" b s) "" kill in
+ let sel = string_of_bool sel in
+ Printf.sprintf "{ move: %s; kill: %s; sel: %s }" move kill sel
+let pr_key t =
+ let kv = GdkEvent.Key.keyval t in
+ let str = GdkEvent.Key.string t in
+ let str_of_mod = function
+ | `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL"
+ | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" | `MOD3 -> "MOD3" | `MOD4 -> "MOD4"
+ | `MOD5 -> "MOD5" | `BUTTON1 -> "BUTTON1" | `BUTTON2 -> "BUTTON2"
+ | `BUTTON3 -> "BUTTON3" | `BUTTON4 -> "BUTTON4" | `BUTTON5 -> "BUTTON5"
+ | `SUPER -> "SUPER" | `HYPER -> "HYPER" | `META -> "META"
+ | `RELEASE -> "RELEASE" in
+ let mods = String.concat " " (List.map str_of_mod (GdkEvent.Key.state t)) in
+ Printf.sprintf "'%s' (%d, %s)" str kv mods
+
+type action =
+ | Action of string * string
+ | Callback of (gui -> unit)
+ | Edit of (status -> GSourceView2.source_buffer -> GText.iter ->
+ (string -> string -> unit) -> status)
+ | Motion of (status -> GText.iter -> GText.iter * status)
+
+type 'c entry = {
+ mods : Gdk.Tags.modifier list;
+ key : Gdk.keysym;
+ keyname : string;
+ doc : string;
+ contents : 'c
+}
+
+let mC = [`CONTROL]
+let mM = [`MOD1]
+
+let mod_of t x = List.for_all (fun m -> List.mem m (GdkEvent.Key.state t)) x
+
+let pr_keymod l =
+ if l = mC then "C-"
+ else if l = mM then "M-"
+ else ""
+
+let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents =
+ List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents })
+ ((mods, key, keyname)::alias)
+
+type keypaths = Step of action entry list * keypaths entry list
+
+let print_keypaths kps =
+ let rec aux prefix (Step (l, konts)) =
+ String.concat "\n" (
+ (List.map (fun x ->
+ prefix ^ pr_keymod x.mods ^ x.keyname ^ " " ^ x.doc ) l) @
+ (List.map (fun x ->
+ aux (prefix^pr_keymod x.mods^x.keyname^" ") x.contents) konts)) in
+ aux " " kps
+
+let empty = Step([],[])
+
+let frontier (Step(l1,l2)) =
+ List.map (fun x -> pr_keymod x.mods ^ x.keyname) l1 @
+ List.map (fun x -> pr_keymod x.mods ^ x.keyname) l2
+
+let insert kps name enter_syms bindings =
+ let rec aux kps enter_syms =
+ match enter_syms, kps with
+ | [], Step (el, konts) -> Step (List.flatten bindings @ el, konts)
+ | (mods, key, keyname)::gs, Step (el, konts) ->
+ if List.exists (fun { key = k; mods = m } -> key = k && mods = m) konts
+ then
+ let konts =
+ List.map
+ (fun ({ key = k; contents } as x) ->
+ if key <> k then x else { x with contents = aux contents gs })
+ konts in
+ Step(el,konts)
+ else
+ let kont =
+ { mods; key; keyname; doc = name; contents = aux empty gs } in
+ Step(el, kont::konts) in
+ aux kps enter_syms
+
+let run_action gui group name =
+ ((actiong gui group)#get_action name)#activate ()
+
+let run key gui action status =
+ match action with
+ | Callback f -> f gui; status
+ | Action(group, name) -> run_action gui group name; status
+ | Edit f ->
+ let b = (ct gui).script#source_buffer in
+ let i = b#get_iter_at_mark `INSERT in
+ let status = f status b i (run_action gui) in
+ if not status.sel then
+ b#place_cursor ~where:(b#get_iter_at_mark `SEL_BOUND);
+ status
+ | Motion f ->
+ let b, script = (ct gui).script#source_buffer, (ct gui).script in
+ let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in
+ let i =
+ if sel_mode then b#get_iter_at_mark `SEL_BOUND
+ else b#get_iter_at_mark `INSERT in
+ let where, status = f status i in
+ let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in
+ if sel_mode then (b#move_mark `SEL_BOUND ~where; script#scroll_mark_onscreen `SEL_BOUND)
+ else (b#place_cursor ~where; script#scroll_mark_onscreen `INSERT);
+ status
+
+let emacs = empty
+
+let emacs = insert emacs "Emacs" [] [
+ (* motion *)
+ mkE _e "e" "Move to end of line" (Motion(fun s i ->
+ (if not i#ends_line then i#forward_to_line_end else i),
+ { s with move = None }));
+ mkE _a "a" "Move to beginning of line" (Motion(fun s i ->
+ (i#set_line_offset 0), { s with move = None }));
+ mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i ->
+ i#forward_sentence_end, { s with move = None }));
+ mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i ->
+ i#backward_sentence_start, { s with move = None }));
+ mkE _n "n" "Move to next line" ~alias:[[],_Down,"DOWN"] (Motion(fun s i ->
+ let orig_off = Option.default i#line_offset s.move in
+ let i = i#forward_line in
+ let new_off = min (i#chars_in_line - 1) orig_off in
+ (if new_off > 0 then i#set_line_offset new_off else i),
+ { s with move = Some orig_off }));
+ mkE _p "p" "Move to previous line" ~alias:[[],_Up,"UP"] (Motion(fun s i ->
+ let orig_off = Option.default i#line_offset s.move in
+ let i = i#backward_line in
+ let new_off = min (i#chars_in_line - 1) orig_off in
+ (if new_off > 0 then i#set_line_offset new_off else i),
+ { s with move = Some orig_off }));
+ mkE _f "f" "Forward char" ~alias:[[],_Right,"RIGHT"]
+ (Motion(fun s i -> i#forward_char, { s with move = None }));
+ mkE _b "b" "Backward char" ~alias:[[],_Left,"LEFT"]
+ (Motion(fun s i -> i#backward_char, { s with move = None }));
+ mkE ~mods:mM _f "f" "Forward word" ~alias:[mC,_Right,"RIGHT"]
+ (Motion(fun s i -> i#forward_word_end, { s with move = None }));
+ mkE ~mods:mM _b "b" "Backward word" ~alias:[mC,_Left,"LEFT"]
+ (Motion(fun s i -> i#backward_word_start, { s with move = None }));
+ mkE _space "SPC" "Set mark" ~alias:[mC,_at,"@"] (Motion(fun s i ->
+ if s.sel = false then i, { s with sel = true }
+ else i, { s with sel = false } ));
+ (* edits *)
+ mkE ~mods:mM _w "w" "Copy selected region" (Edit(fun s b i run ->
+ if sel_nonempty b then
+ let txt = get_sel_txt b in
+ run "Edit" "Copy";
+ { s with kill = Some(txt,false); sel = false }
+ else s));
+ mkE _w "w" "Kill selected region" (Edit(fun s b i run ->
+ if sel_nonempty b then
+ let txt = get_sel_txt b in
+ run "Edit" "Cut";
+ { s with kill = Some(txt,false); sel = false }
+ else s));
+ mkE _k "k" "Kill untill the end of line" (Edit(fun s b i _ ->
+ let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+ let k =
+ if i#ends_line then begin
+ b#delete ~start:i ~stop:i#forward_char; "\n"
+ end else begin
+ let k = b#get_text ~start:i ~stop:i#forward_to_line_end () in
+ b#delete ~start:i ~stop:i#forward_to_line_end; k
+ end in
+ { s with kill = Some (already_killed ^ k,true) }));
+ mkE ~mods:mM _d "d" "Kill next word" (Edit(fun s b i _ ->
+ let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+ let k =
+ let k = b#get_text ~start:i ~stop:i#forward_word_end () in
+ b#delete ~start:i ~stop:i#forward_word_end; k in
+ { s with kill = Some (already_killed ^ k,true) }));
+ mkE ~mods:mM _k "k" "Kill until sentence end" (Edit(fun s b i _ ->
+ let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+ let k =
+ let k = b#get_text ~start:i ~stop:i#forward_sentence_end () in
+ b#delete ~start:i ~stop:i#forward_sentence_end; k in
+ { s with kill = Some (already_killed ^ k,true) }));
+ mkE ~mods:mM _BackSpace "DELBACK" "Kill word before cursor"
+ (Edit(fun s b i _ ->
+ let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+ let k =
+ let k = b#get_text ~start:i ~stop:i#backward_word_start () in
+ b#delete ~start:i ~stop:i#backward_word_start; k in
+ { s with kill = Some (already_killed ^ k,true) }));
+ mkE _d "d" "Delete next character" (Edit(fun s b i _ ->
+ b#delete ~start:i ~stop:i#forward_char; s));
+ mkE _y "y" "Yank killed text back " (Edit(fun s b i _ ->
+ let k, s = match s.kill with
+ | Some (k,_) -> k, { s with kill = Some (k,false) }
+ | _ -> "", s in
+ b#insert ~iter:i k;
+ s));
+ (* misc *)
+ mkE _underscore "_" "Undo" (Action("Edit", "Undo"));
+ mkE _g "g" "Esc" (Callback(fun gui -> (ct gui).finder#hide ()));
+ mkE _s "s" "Search" (Callback(fun gui ->
+ if (ct gui).finder#coerce#misc#visible
+ then run_action gui "Edit" "Find Next"
+ else run_action gui "Edit" "Find"));
+ mkE _s "r" "Search backward" (Callback(fun gui ->
+ if (ct gui).finder#coerce#misc#visible
+ then run_action gui "Edit" "Find Previous"
+ else run_action gui "Edit" "Find"));
+ ]
+
+let emacs = insert emacs "Emacs" [mC,_x,"x"] [
+ mkE _s "s" "Save" (Action("File", "Save"));
+ mkE _c "c" "Quit" (Action("File", "Quit"));
+ mkE _f "f" "Open" (Action("File", "Open"));
+ mkE ~mods:[] _u "u" "Undo" (Action("Edit", "Undo"));
+ ]
+
+let pg = insert emacs "Proof General" [mC,_c,"c"] [
+ mkE _Return "RET" "Go to" (Action("Navigation", "Go to"));
+ mkE _n "n" "Advance 1 sentence" (Action("Navigation", "Forward"));
+ mkE _u "u" "Retract 1 sentence" (Action("Navigation", "Backward"));
+ mkE _b "b" "Advance" (Action("Navigation", "End"));
+ mkE _r "r" "Restart" (Action("Navigation", "Start"));
+ mkE _c "c" "Stop" (Action("Navigation", "Interrupt"));
+ ]
+
+let command gui c =
+ let command = (ct gui).command in
+ let script = (ct gui).script in
+ let term =
+ let i, j = script#source_buffer#selection_bounds in
+ if i#equal j then None
+ else Some (script#buffer#get_text ~start:i ~stop:j ()) in
+ command#show;
+ command#new_query ~command:c ?term ()
+
+let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [
+ mkE _p "p" "Print" (Callback (fun gui -> command gui "Print"));
+ mkE _c "c" "Check" (Callback (fun gui -> command gui "Check"));
+ mkE _b "b" "About" (Callback (fun gui -> command gui "About"));
+ mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout"));
+ mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern"));
+ mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate"));
+ mkE _Return "RET" "match template" (Action("Templates","match"));
+ ]
+
+let empty = { sel = false; kill = None; move = None }
+
+let find gui (Step(here,konts)) t =
+ (* hack: ^c does copy in clipboard *)
+ let sel_nonempty () = sel_nonempty (ct gui).script#source_buffer in
+ let k = GdkEvent.Key.keyval t in
+ if k = _x && mod_of t mC && sel_nonempty () then
+ ignore(run t gui (Action("Edit","Cut")) empty)
+ else
+ if k = _c && mod_of t mC && sel_nonempty () then
+ ignore(run t gui (Action("Edit","Copy")) empty);
+ let cmp { key; mods } = key = k && mod_of t mods in
+ try `Do (List.find cmp here) with Not_found ->
+ try `Cont (List.find cmp konts).contents with Not_found -> `NotFound
+
+let init w nb ags =
+ let gui = { notebook = nb; action_groups = ags } in
+ let cur = ref pg in
+ let status = ref empty in
+ let reset () = eprintf "reset\n%!"; cur := pg in
+ ignore(w#event#connect#key_press ~callback:(fun t ->
+ let on_current_term f =
+ let term = try Some nb#current_term with Invalid_argument _ -> None in
+ match term with None -> false | Some t -> f t
+ in
+ on_current_term (fun x ->
+ if x.script#misc#get_property "has-focus" <> `BOOL true
+ then false
+ else begin
+ eprintf "got key %s\n%!" (pr_key t);
+ if current.nanoPG then begin
+ match find gui !cur t with
+ | `Do e ->
+ eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status);
+ status := run t gui e.contents !status; reset (); true
+ | `Cont c ->
+ flash_info ("Waiting one of " ^ String.concat " " (frontier c));
+ cur := c; true
+ | `NotFound -> reset (); false
+ end else false
+ end)));
+ ignore(w#event#connect#button_press ~callback:(fun t -> reset (); false))
+
+
+
+let get_documentation () = print_keypaths pg
diff --git a/ide/preferences.ml b/ide/preferences.ml
index 9161d923..c8506132 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -1,32 +1,37 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
open Configwin
-open Printf
-let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc"
-let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys"
+let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc"
+let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys"
+let lang_manager = GSourceView2.source_language_manager ~default:true
+let () = lang_manager#set_search_path
+ ((Minilib.coqide_data_dirs ())@lang_manager#search_path)
+let style_manager = GSourceView2.source_style_scheme_manager ~default:true
+let () = style_manager#set_search_path
+ ((Minilib.coqide_data_dirs ())@style_manager#search_path)
let get_config_file name =
let find_config dir = Sys.file_exists (Filename.concat dir name) in
- let config_dir = List.find find_config Minilib.xdg_config_dirs in
+ let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in
Filename.concat config_dir name
(* Small hack to handle v8.3 to v8.4 change in configuration file *)
let loaded_pref_file =
try get_config_file "coqiderc"
- with Not_found -> Filename.concat Minilib.home ".coqiderc"
+ with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
let loaded_accel_file =
try get_config_file "coqide.keys"
- with Not_found -> Filename.concat Minilib.home ".coqide.keys"
+ with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
-let mod_to_str (m:Gdk.Tags.modifier) =
+let mod_to_str m =
match m with
| `MOD1 -> "<Alt>"
| `MOD2 -> "<Mod2>"
@@ -72,10 +77,10 @@ let inputenc_of_string s =
(** Hooks *)
-let refresh_font_hook = ref (fun () -> ())
-let refresh_background_color_hook = ref (fun () -> ())
+let refresh_style_hook = ref (fun () -> ())
+let refresh_language_hook = ref (fun () -> ())
+let refresh_editor_hook = ref (fun () -> ())
let refresh_toolbar_hook = ref (fun () -> ())
-let auto_complete_hook = ref (fun x -> ())
let contextual_menus_on_goal_hook = ref (fun x -> ())
let resize_window_hook = ref (fun () -> ())
let refresh_tabs_hook = ref (fun () -> ())
@@ -88,6 +93,9 @@ type pref =
mutable cmd_coqmakefile : string;
mutable cmd_coqdoc : string;
+ mutable source_language : string;
+ mutable source_style : string;
+
mutable global_auto_revert : bool;
mutable global_auto_revert_delay : int;
@@ -128,19 +136,32 @@ type pref =
*)
mutable auto_complete : bool;
mutable stop_before : bool;
+ mutable reset_on_tab_switch : bool;
mutable vertical_tabs : bool;
mutable opposite_tabs : bool;
mutable background_color : string;
mutable processing_color : string;
mutable processed_color : string;
+ mutable error_color : string;
+
+ mutable dynamic_word_wrap : bool;
+ mutable show_line_number : bool;
+ mutable auto_indent : bool;
+ mutable show_spaces : bool;
+ mutable show_right_margin : bool;
+ mutable show_progress_bar : bool;
+ mutable spaces_instead_of_tabs : bool;
+ mutable tab_length : int;
+ mutable highlight_current_line : bool;
+
+ mutable nanoPG : bool;
}
let use_default_doc_url = "(automatic)"
-let (current:pref ref) =
- ref {
+let current = {
cmd_coqtop = None;
cmd_coqc = "coqc";
cmd_make = "make";
@@ -155,6 +176,9 @@ let (current:pref ref) =
auto_save_delay = 10000;
auto_save_name = "#","#";
+ source_language = "coq";
+ source_style = "coq_style";
+
read_project = Ignore_args;
project_file_name = "_CoqProject";
@@ -192,29 +216,44 @@ let (current:pref ref) =
*)
auto_complete = false;
stop_before = true;
+ reset_on_tab_switch = false;
vertical_tabs = false;
opposite_tabs = false;
background_color = "cornsilk";
processed_color = "light green";
processing_color = "light blue";
-
+ error_color = "#FFCCCC";
+
+ dynamic_word_wrap = false;
+ show_line_number = false;
+ auto_indent = false;
+ show_spaces = true;
+ show_right_margin = false;
+ show_progress_bar = true;
+ spaces_instead_of_tabs = true;
+ tab_length = 2;
+ highlight_current_line = false;
+
+ nanoPG = false;
}
let save_pref () =
- if not (Sys.file_exists Minilib.xdg_config_home)
- then Unix.mkdir Minilib.xdg_config_home 0o700;
+ if not (Sys.file_exists (Minilib.coqide_config_home ()))
+ then Unix.mkdir (Minilib.coqide_config_home ()) 0o700;
let () = try GtkData.AccelMap.save accel_file with _ -> () in
- let p = !current in
+ let p = current in
- let add = Minilib.Stringmap.add in
+ let add = Util.String.Map.add in
let (++) x f = f x in
- Minilib.Stringmap.empty ++
+ Util.String.Map.empty ++
add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++
add "cmd_coqc" [p.cmd_coqc] ++
add "cmd_make" [p.cmd_make] ++
add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
add "cmd_coqdoc" [p.cmd_coqdoc] ++
+ add "source_language" [p.source_language] ++
+ add "source_style" [p.source_style] ++
add "global_auto_revert" [string_of_bool p.global_auto_revert] ++
add "global_auto_revert_delay"
[string_of_int p.global_auto_revert_delay] ++
@@ -250,20 +289,31 @@ let save_pref () =
add "query_window_width" [string_of_int p.query_window_width] ++
add "auto_complete" [string_of_bool p.auto_complete] ++
add "stop_before" [string_of_bool p.stop_before] ++
+ add "reset_on_tab_switch" [string_of_bool p.reset_on_tab_switch] ++
add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
add "background_color" [p.background_color] ++
add "processing_color" [p.processing_color] ++
add "processed_color" [p.processed_color] ++
+ add "error_color" [p.error_color] ++
+ add "dynamic_word_wrap" [string_of_bool p.dynamic_word_wrap] ++
+ add "show_line_number" [string_of_bool p.show_line_number] ++
+ add "auto_indent" [string_of_bool p.auto_indent] ++
+ add "show_spaces" [string_of_bool p.show_spaces] ++
+ add "show_right_margin" [string_of_bool p.show_right_margin] ++
+ add "show_progress_bar" [string_of_bool p.show_progress_bar] ++
+ add "spaces_instead_of_tabs" [string_of_bool p.spaces_instead_of_tabs] ++
+ add "tab_length" [string_of_int p.tab_length] ++
+ add "highlight_current_line" [string_of_bool p.highlight_current_line] ++
+ add "nanoPG" [string_of_bool p.nanoPG] ++
Config_lexer.print_file pref_file
let load_pref () =
let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
- let p = !current in
let m = Config_lexer.load_file loaded_pref_file in
- let np = { p with cmd_coqc = p.cmd_coqc } in
- let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in
+ let np = current in
+ let set k f = try let v = Util.String.Map.find k m in f v with _ -> () in
let set_hd k f = set k (fun v -> f (List.hd v)) in
let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in
let set_int k f = set_hd k (fun v -> f (int_of_string v)) in
@@ -277,6 +327,8 @@ let load_pref () =
set_hd "cmd_make" (fun v -> np.cmd_make <- v);
set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v);
+ set_hd "source_language" (fun v -> np.source_language <- v);
+ set_hd "source_style" (fun v -> np.source_style <- v);
set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v);
set_int "global_auto_revert_delay"
(fun v -> np.global_auto_revert_delay <- v);
@@ -299,7 +351,8 @@ let load_pref () =
set_hd "modifier_for_display"
(fun v -> np.modifier_for_display <- v);
set_hd "modifiers_valid"
- (fun v -> np.modifiers_valid <- v);
+ (fun v ->
+ np.modifiers_valid <- v);
set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v);
set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v);
set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v);
@@ -310,7 +363,7 @@ let load_pref () =
v <> Coq_config.wwwcoq ^ "doc" &&
v <> Coq_config.wwwcoq ^ "doc/"
then
- (*prerr_endline ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*)
+ (* ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*)
np.doc_url <- v);
set_hd "library_url" (fun v -> np.library_url <- v);
set_bool "show_toolbar" (fun v -> np.show_toolbar <- v);
@@ -322,41 +375,50 @@ let load_pref () =
set_int "query_window_height" (fun v -> np.query_window_height <- v);
set_bool "auto_complete" (fun v -> np.auto_complete <- v);
set_bool "stop_before" (fun v -> np.stop_before <- v);
+ set_bool "reset_on_tab_switch" (fun v -> np.reset_on_tab_switch <- v);
set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v);
set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v);
set_hd "background_color" (fun v -> np.background_color <- v);
set_hd "processing_color" (fun v -> np.processing_color <- v);
set_hd "processed_color" (fun v -> np.processed_color <- v);
- current := np
-(*
- Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
-*)
+ set_hd "error_color" (fun v -> np.error_color <- v);
+ set_bool "dynamic_word_wrap" (fun v -> np.dynamic_word_wrap <- v);
+ set_bool "show_line_number" (fun v -> np.show_line_number <- v);
+ set_bool "auto_indent" (fun v -> np.auto_indent <- v);
+ set_bool "show_spaces" (fun v -> np.show_spaces <- v);
+ set_bool "show_right_margin" (fun v -> np.show_right_margin <- v);
+ set_bool "show_progress_bar" (fun v -> np.show_progress_bar <- v);
+ set_bool "spaces_instead_of_tabs" (fun v -> np.spaces_instead_of_tabs <- v);
+ set_int "tab_length" (fun v -> np.tab_length <- v);
+ set_bool "highlight_current_line" (fun v -> np.highlight_current_line <- v);
+ set_bool "nanoPG" (fun v -> np.nanoPG <- v);
+ ()
let configure ?(apply=(fun () -> ())) () =
let cmd_coqtop =
string
- ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s)
- " coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
+ ~f:(fun s -> current.cmd_coqtop <- if s = "AUTO" then None else Some s)
+ " coqtop" (match current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
let cmd_coqc =
string
- ~f:(fun s -> !current.cmd_coqc <- s)
- " coqc" !current.cmd_coqc in
+ ~f:(fun s -> current.cmd_coqc <- s)
+ " coqc" current.cmd_coqc in
let cmd_make =
string
- ~f:(fun s -> !current.cmd_make <- s)
- " make" !current.cmd_make in
+ ~f:(fun s -> current.cmd_make <- s)
+ " make" current.cmd_make in
let cmd_coqmakefile =
string
- ~f:(fun s -> !current.cmd_coqmakefile <- s)
- "coqmakefile" !current.cmd_coqmakefile in
+ ~f:(fun s -> current.cmd_coqmakefile <- s)
+ "coqmakefile" current.cmd_coqmakefile in
let cmd_coqdoc =
string
- ~f:(fun s -> !current.cmd_coqdoc <- s)
- " coqdoc" !current.cmd_coqdoc in
+ ~f:(fun s -> current.cmd_coqdoc <- s)
+ " coqdoc" current.cmd_coqdoc in
let cmd_print =
string
- ~f:(fun s -> !current.cmd_print <- s)
- " Print ps" !current.cmd_print in
+ ~f:(fun s -> current.cmd_print <- s)
+ " Print ps" current.cmd_print in
let config_font =
let box = GPack.hbox () in
@@ -366,17 +428,17 @@ let configure ?(apply=(fun () -> ())) () =
box#pack ~expand:true w#coerce;
ignore (w#misc#connect#realize
~callback:(fun () -> w#set_font_name
- (Pango.Font.to_string !current.text_font)));
+ (Pango.Font.to_string current.text_font)));
custom
~label:"Fonts for text"
box
(fun () ->
let fd = w#font_name in
- !current.text_font <- (Pango.Font.from_string fd) ;
+ current.text_font <- (Pango.Font.from_string fd) ;
(*
- Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+ Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string current.text_font);
*)
- !refresh_font_hook ())
+ !refresh_editor_hook ())
true
in
@@ -400,11 +462,16 @@ let configure ?(apply=(fun () -> ())) () =
~text:"Background color of text being processed"
~packing:(table#attach ~expand:`X ~left:0 ~top:2) ()
in
+ let error_label = GMisc.label
+ ~text:"Background color of errors"
+ ~packing:(table#attach ~expand:`X ~left:0 ~top:3) ()
+ in
let () = background_label#set_xalign 0. in
let () = processed_label#set_xalign 0. in
let () = processing_label#set_xalign 0. in
+ let () = error_label#set_xalign 0. in
let background_button = GButton.color_button
- ~color:(Tags.color_of_string (!current.background_color))
+ ~color:(Tags.color_of_string (current.background_color))
~packing:(table#attach ~left:1 ~top:0) ()
in
let processed_button = GButton.color_button
@@ -415,6 +482,10 @@ let configure ?(apply=(fun () -> ())) () =
~color:(Tags.get_processing_color ())
~packing:(table#attach ~left:1 ~top:2) ()
in
+ let error_button = GButton.color_button
+ ~color:(Tags.get_error_color ())
+ ~packing:(table#attach ~left:1 ~top:3) ()
+ in
let reset_button = GButton.button
~label:"Reset"
~packing:box#pack ()
@@ -423,16 +494,65 @@ let configure ?(apply=(fun () -> ())) () =
background_button#set_color (Tags.color_of_string "cornsilk");
processing_button#set_color (Tags.color_of_string "light blue");
processed_button#set_color (Tags.color_of_string "light green");
+ error_button#set_color (Tags.color_of_string "#FFCCCC");
in
let _ = reset_button#connect#clicked ~callback:reset_cb in
let label = "Color configuration" in
let callback () =
- !current.background_color <- Tags.string_of_color background_button#color;
- !current.processing_color <- Tags.string_of_color processing_button#color;
- !current.processed_color <- Tags.string_of_color processed_button#color;
- !refresh_background_color_hook ();
+ current.background_color <- Tags.string_of_color background_button#color;
+ current.processing_color <- Tags.string_of_color processing_button#color;
+ current.processed_color <- Tags.string_of_color processed_button#color;
+ current.error_color <- Tags.string_of_color error_button#color;
+ !refresh_editor_hook ();
Tags.set_processing_color processing_button#color;
- Tags.set_processed_color processed_button#color
+ Tags.set_processed_color processed_button#color;
+ Tags.set_error_color error_button#color
+ in
+ custom ~label box callback true
+ in
+
+ let config_editor =
+ let label = "Editor configuration" in
+ let box = GPack.vbox () in
+ let gen_button text active =
+ GButton.check_button ~label:text ~active ~packing:box#pack () in
+ let wrap = gen_button "Dynamic word wrap" current.dynamic_word_wrap in
+ let line = gen_button "Show line number" current.show_line_number in
+ let auto_indent = gen_button "Auto indentation" current.auto_indent in
+ let auto_complete = gen_button "Auto completion" current.auto_complete in
+ let show_spaces = gen_button "Show spaces" current.show_spaces in
+ let show_right_margin = gen_button "Show right margin" current.show_right_margin in
+ let show_progress_bar = gen_button "Show progress bar" current.show_progress_bar in
+ let spaces_instead_of_tabs =
+ gen_button "Insert spaces instead of tabs"
+ current.spaces_instead_of_tabs
+ in
+ let highlight_current_line =
+ gen_button "Highlight current line"
+ current.highlight_current_line
+ in
+ let nanoPG = gen_button "Emacs/PG keybindings (μPG mode)" current.nanoPG in
+(* let lbox = GPack.hbox ~packing:box#pack () in *)
+(* let _ = GMisc.label ~text:"Tab width" *)
+(* ~xalign:0. *)
+(* ~packing:(lbox#pack ~expand:true) () *)
+(* in *)
+(* let tab_width = GEdit.spin_button *)
+(* ~digits:0 ~packing:lbox#pack () *)
+(* in *)
+ let callback () =
+ current.dynamic_word_wrap <- wrap#active;
+ current.show_line_number <- line#active;
+ current.auto_indent <- auto_indent#active;
+ current.show_spaces <- show_spaces#active;
+ current.show_right_margin <- show_right_margin#active;
+ current.show_progress_bar <- show_progress_bar#active;
+ current.spaces_instead_of_tabs <- spaces_instead_of_tabs#active;
+ current.highlight_current_line <- highlight_current_line#active;
+ current.nanoPG <- nanoPG#active;
+ current.auto_complete <- auto_complete#active;
+(* current.tab_length <- tab_width#value_as_int; *)
+ !refresh_editor_hook ()
in
custom ~label box callback true
in
@@ -441,40 +561,32 @@ let configure ?(apply=(fun () -> ())) () =
let show_toolbar =
bool
~f:(fun s ->
- !current.show_toolbar <- s;
+ current.show_toolbar <- s;
!show_toolbar s)
- "Show toolbar" !current.show_toolbar
+ "Show toolbar" current.show_toolbar
in
let window_height =
string
- ~f:(fun s -> !current.window_height <- (try int_of_string s with _ -> 600);
+ ~f:(fun s -> current.window_height <- (try int_of_string s with _ -> 600);
!resize_window ();
)
"Window height"
- (string_of_int !current.window_height)
+ (string_of_int current.window_height)
in
let window_width =
string
- ~f:(fun s -> !current.window_width <-
+ ~f:(fun s -> current.window_width <-
(try int_of_string s with _ -> 800))
"Window width"
- (string_of_int !current.window_width)
+ (string_of_int current.window_width)
in
*)
- let auto_complete =
- bool
- ~f:(fun s ->
- !current.auto_complete <- s;
- !auto_complete_hook s)
- "Auto Complete" !current.auto_complete
- in
-
(* let use_utf8_notation =
bool
~f:(fun b ->
- !current.use_utf8_notation <- b;
+ current.use_utf8_notation <- b;
)
- "Use Unicode Notation: " !current.use_utf8_notation
+ "Use Unicode Notation: " current.use_utf8_notation
in
*)
(*
@@ -482,113 +594,144 @@ let configure ?(apply=(fun () -> ())) () =
*)
let global_auto_revert =
bool
- ~f:(fun s -> !current.global_auto_revert <- s)
- "Enable global auto revert" !current.global_auto_revert
+ ~f:(fun s -> current.global_auto_revert <- s)
+ "Enable global auto revert" current.global_auto_revert
in
let global_auto_revert_delay =
string
- ~f:(fun s -> !current.global_auto_revert_delay <-
+ ~f:(fun s -> current.global_auto_revert_delay <-
(try int_of_string s with _ -> 10000))
"Global auto revert delay (ms)"
- (string_of_int !current.global_auto_revert_delay)
+ (string_of_int current.global_auto_revert_delay)
in
let auto_save =
bool
- ~f:(fun s -> !current.auto_save <- s)
- "Enable auto save" !current.auto_save
+ ~f:(fun s -> current.auto_save <- s)
+ "Enable auto save" current.auto_save
in
let auto_save_delay =
string
- ~f:(fun s -> !current.auto_save_delay <-
+ ~f:(fun s -> current.auto_save_delay <-
(try int_of_string s with _ -> 10000))
"Auto save delay (ms)"
- (string_of_int !current.auto_save_delay)
+ (string_of_int current.auto_save_delay)
in
let stop_before =
bool
- ~f:(fun s -> !current.stop_before <- s)
- "Stop interpreting before the current point" !current.stop_before
+ ~f:(fun s -> current.stop_before <- s)
+ "Stop interpreting before the current point" current.stop_before
+ in
+
+ let reset_on_tab_switch =
+ bool
+ ~f:(fun s -> current.reset_on_tab_switch <- s)
+ "Reset coqtop on tab switch" current.reset_on_tab_switch
in
let vertical_tabs =
bool
- ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ())
- "Vertical tabs" !current.vertical_tabs
+ ~f:(fun s -> current.vertical_tabs <- s; !refresh_tabs_hook ())
+ "Vertical tabs" current.vertical_tabs
in
let opposite_tabs =
bool
- ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ())
- "Tabs on opposite side" !current.opposite_tabs
+ ~f:(fun s -> current.opposite_tabs <- s; !refresh_tabs_hook ())
+ "Tabs on opposite side" current.opposite_tabs
in
let encodings =
combo
"File charset encoding "
- ~f:(fun s -> !current.encoding <- (inputenc_of_string s))
+ ~f:(fun s -> current.encoding <- (inputenc_of_string s))
~new_allowed: true
- ("UTF-8"::"LOCALE":: match !current.encoding with
+ ("UTF-8"::"LOCALE":: match current.encoding with
|Emanual s -> [s]
|_ -> []
)
- (string_of_inputenc !current.encoding)
+ (string_of_inputenc current.encoding)
in
+
+ let source_style =
+ let f s =
+ current.source_style <- s;
+ !refresh_style_hook ()
+ in
+ combo "Highlighting style:"
+ ~f ~new_allowed:false
+ style_manager#style_scheme_ids current.source_style
+ in
+
+ let source_language =
+ let f s =
+ current.source_language <- s;
+ !refresh_language_hook ()
+ in
+ combo "Language:"
+ ~f ~new_allowed:false
+ (List.filter
+ (fun x -> Str.string_match (Str.regexp "^coq") x 0)
+ lang_manager#language_ids)
+ current.source_language
+ in
+
let read_project =
combo
"Project file options are"
- ~f:(fun s -> !current.read_project <- project_behavior_of_string s)
+ ~f:(fun s -> current.read_project <- project_behavior_of_string s)
~editable:false
[string_of_project_behavior Subst_args;
string_of_project_behavior Append_args;
string_of_project_behavior Ignore_args]
- (string_of_project_behavior !current.read_project)
+ (string_of_project_behavior current.read_project)
in
let project_file_name =
string "Default name for project file"
- ~f:(fun s -> !current.project_file_name <- s)
- !current.project_file_name
+ ~f:(fun s -> current.project_file_name <- s)
+ current.project_file_name
in
let help_string =
"restart to apply"
in
- let the_valid_mod = str_to_mod_list !current.modifiers_valid in
+ let the_valid_mod = str_to_mod_list current.modifiers_valid in
let modifier_for_tactics =
modifiers
~allow:the_valid_mod
- ~f:(fun l -> !current.modifier_for_tactics <- mod_list_to_str l)
+ ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l)
~help:help_string
"Modifiers for Tactics Menu"
- (str_to_mod_list !current.modifier_for_tactics)
+ (str_to_mod_list current.modifier_for_tactics)
in
let modifier_for_templates =
modifiers
~allow:the_valid_mod
- ~f:(fun l -> !current.modifier_for_templates <- mod_list_to_str l)
+ ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l)
~help:help_string
"Modifiers for Templates Menu"
- (str_to_mod_list !current.modifier_for_templates)
+ (str_to_mod_list current.modifier_for_templates)
in
let modifier_for_navigation =
modifiers
~allow:the_valid_mod
- ~f:(fun l -> !current.modifier_for_navigation <- mod_list_to_str l)
+ ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l)
~help:help_string
"Modifiers for Navigation Menu"
- (str_to_mod_list !current.modifier_for_navigation)
+ (str_to_mod_list current.modifier_for_navigation)
in
let modifier_for_display =
modifiers
~allow:the_valid_mod
- ~f:(fun l -> !current.modifier_for_display <- mod_list_to_str l)
+ ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l)
~help:help_string
- "Modifiers for Display Menu"
- (str_to_mod_list !current.modifier_for_display)
+ "Modifiers for View Menu"
+ (str_to_mod_list current.modifier_for_display)
in
let modifiers_valid =
modifiers
- ~f:(fun l -> !current.modifiers_valid <- mod_list_to_str l)
+ ~f:(fun l ->
+ current.modifiers_valid <- mod_list_to_str l)
"Allowed modifiers"
the_valid_mod
in
@@ -597,11 +740,11 @@ let configure ?(apply=(fun () -> ())) () =
combo
~help:"(%s for file name)"
"External editor"
- ~f:(fun s -> !current.cmd_editor <- s)
+ ~f:(fun s -> current.cmd_editor <- s)
~new_allowed: true
- (predefined@[if List.mem !current.cmd_editor predefined then ""
- else !current.cmd_editor])
- !current.cmd_editor
+ (predefined@[if List.mem current.cmd_editor predefined then ""
+ else current.cmd_editor])
+ current.cmd_editor
in
let cmd_browse =
let predefined = [
@@ -614,11 +757,11 @@ let configure ?(apply=(fun () -> ())) () =
combo
~help:"(%s for url)"
"Browser"
- ~f:(fun s -> !current.cmd_browse <- s)
+ ~f:(fun s -> current.cmd_browse <- s)
~new_allowed: true
- (predefined@[if List.mem !current.cmd_browse predefined then ""
- else !current.cmd_browse])
- !current.cmd_browse
+ (predefined@[if List.mem current.cmd_browse predefined then ""
+ else current.cmd_browse])
+ current.cmd_browse
in
let doc_url =
let predefined = [
@@ -628,11 +771,11 @@ let configure ?(apply=(fun () -> ())) () =
] in
combo
"Manual URL"
- ~f:(fun s -> !current.doc_url <- s)
+ ~f:(fun s -> current.doc_url <- s)
~new_allowed: true
- (predefined@[if List.mem !current.doc_url predefined then ""
- else !current.doc_url])
- !current.doc_url in
+ (predefined@[if List.mem current.doc_url predefined then ""
+ else current.doc_url])
+ current.doc_url in
let library_url =
let predefined = [
"file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]);
@@ -640,30 +783,30 @@ let configure ?(apply=(fun () -> ())) () =
] in
combo
"Library URL"
- ~f:(fun s -> !current.library_url <- s)
+ ~f:(fun s -> current.library_url <- s)
~new_allowed: true
- (predefined@[if List.mem !current.library_url predefined then ""
- else !current.library_url])
- !current.library_url
+ (predefined@[if List.mem current.library_url predefined then ""
+ else current.library_url])
+ current.library_url
in
let automatic_tactics =
strings
- ~f:(fun l -> !current.automatic_tactics <- l)
+ ~f:(fun l -> current.automatic_tactics <- l)
~add:(fun () -> ["<edit me>"])
"Wizard tactics to try in order"
- !current.automatic_tactics
+ current.automatic_tactics
in
let contextual_menus_on_goal =
bool
~f:(fun s ->
- !current.contextual_menus_on_goal <- s;
+ current.contextual_menus_on_goal <- s;
!contextual_menus_on_goal_hook s)
- "Contextual menus on goal" !current.contextual_menus_on_goal
+ "Contextual menus on goal" current.contextual_menus_on_goal
in
- let misc = [contextual_menus_on_goal;auto_complete;stop_before;
+ let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch;
vertical_tabs;opposite_tabs] in
(* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
@@ -671,7 +814,9 @@ let configure ?(apply=(fun () -> ())) () =
let cmds =
[Section("Fonts", Some `SELECT_FONT,
[config_font]);
- Section("Colors", Some `SELECT_COLOR, [config_color]);
+ Section("Colors", Some `SELECT_COLOR,
+ [config_color; source_language; source_style]);
+ Section("Editor", Some `EDIT, [config_editor]);
Section("Files", Some `DIRECTORY,
[global_auto_revert;global_auto_revert_delay;
auto_save; auto_save_delay; (* auto_save_name*)
@@ -696,11 +841,11 @@ let configure ?(apply=(fun () -> ())) () =
misc)]
in
(*
- Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+ Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font);
*)
let x = edit ~apply "Customizations" cmds in
(*
- Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+ Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string current.text_font);
*)
match x with
| Return_apply | Return_ok -> save_pref ()
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 3ba10a84..1b52d20a 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -1,11 +1,14 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+val lang_manager : GSourceView2.source_language_manager
+val style_manager : GSourceView2.source_style_scheme_manager
+
type project_behavior = Ignore_args | Append_args | Subst_args
type inputenc = Elocale | Eutf8 | Emanual of string
@@ -17,6 +20,9 @@ type pref =
mutable cmd_coqmakefile : string;
mutable cmd_coqdoc : string;
+ mutable source_language : string;
+ mutable source_style : string;
+
mutable global_auto_revert : bool;
mutable global_auto_revert_delay : int;
@@ -57,24 +63,40 @@ type pref =
*)
mutable auto_complete : bool;
mutable stop_before : bool;
+ mutable reset_on_tab_switch : bool;
mutable vertical_tabs : bool;
mutable opposite_tabs : bool;
mutable background_color : string;
mutable processing_color : string;
mutable processed_color : string;
+ mutable error_color : string;
+
+ mutable dynamic_word_wrap : bool;
+ mutable show_line_number : bool;
+ mutable auto_indent : bool;
+ mutable show_spaces : bool;
+ mutable show_right_margin : bool;
+ mutable show_progress_bar : bool;
+ mutable spaces_instead_of_tabs : bool;
+ mutable tab_length : int;
+ mutable highlight_current_line : bool;
+
+ mutable nanoPG : bool;
+
}
val save_pref : unit -> unit
val load_pref : unit -> unit
-val current : pref ref
+val current : pref
val configure : ?apply:(unit -> unit) -> unit -> unit
(* Hooks *)
-val refresh_font_hook : (unit -> unit) ref
-val refresh_background_color_hook : (unit -> unit) ref
+val refresh_editor_hook : (unit -> unit) ref
+val refresh_style_hook : (unit -> unit) ref
+val refresh_language_hook : (unit -> unit) ref
val refresh_toolbar_hook : (unit -> unit) ref
val resize_window_hook : (unit -> unit) ref
val refresh_tabs_hook : (unit -> unit) ref
diff --git a/ide/project_file.ml4 b/ide/project_file.ml4
index aa1189ce..41dc1bef 100644
--- a/ide/project_file.ml4
+++ b/ide/project_file.ml4
@@ -6,10 +6,12 @@ type target =
| MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *)
| V of string (* V file : foo.v -> (V "foo") *)
| Arg of string
- | Special of string * string * string (* file, dependencies, command *)
+ | Special of string * string * bool * string
+ (* file, dependencies, is_phony, command *)
| Subdir of string
| Def of string * string (* X=foo -> Def ("X","foo") *)
- | Include of string
+ | MLInclude of string (* -I physicalpath *)
+ | Include of string * string (* -Q physicalpath logicalpath *)
| RInclude of string * string (* -R physicalpath logicalpath *)
type install =
@@ -53,36 +55,47 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
| ("-full"|"-opt") :: r ->
process_cmd_line orig_dir (project_file,makefile,install,true) l r
| "-impredicative-set" :: r ->
- Minilib.safe_prerr_endline "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.";
+ Pp.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.");
process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r
| "-no-install" :: r ->
- Minilib.safe_prerr_endline "Option -no-install is deprecated. Use \"-install none\" instead";
+ Pp.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead")));
process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r
| "-install" :: d :: r ->
- if install <> UnspecInstall then Minilib.safe_prerr_endline "Warning: -install sets more than once.";
+ if install <> UnspecInstall then Pp.msg_warning (Pp.str "-install sets more than once.");
let install =
match d with
| "user" -> UserInstall
| "none" -> NoInstall
| "global" -> TraditionalInstall
- | _ -> Minilib.safe_prerr_endline (String.concat "" ["Warning: invalid option '"; d; "' passed to -install."]);
+ | _ -> Pp.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install.")));
install
in
process_cmd_line orig_dir (project_file,makefile,install,opt) l r
| "-custom" :: com :: dependencies :: file :: r ->
- process_cmd_line orig_dir opts (Special (file,dependencies,com) :: l) r
+ Pp.msg_warning (Pp.app
+ (Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".")
+ (Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.")
+ );
+ process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r
+ | "-extra" :: file :: dependencies :: com :: r ->
+ process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r
+ | "-extra-phony" :: target :: dependencies :: com :: r ->
+ process_cmd_line orig_dir opts (Special (target,dependencies,true,com) :: l) r
+ | "-Q" :: d :: lp :: r ->
+ process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r
| "-I" :: d :: r ->
- process_cmd_line orig_dir opts ((Include (Minilib.correct_path d orig_dir)) :: l) r
+ process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r
+ | "-R" :: p :: "-as" :: lp :: r
| "-R" :: p :: lp :: r ->
- process_cmd_line orig_dir opts (RInclude (Minilib.correct_path p orig_dir,lp) :: l) r
- | ("-I"|"-custom") :: _ ->
+ process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r
+ | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ ->
raise Parsing_error
| "-f" :: file :: r ->
- let file = Minilib.remove_path_dot (Minilib.correct_path file orig_dir) in
+ let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in
let () = match project_file with
| None -> ()
- | Some _ -> Minilib.safe_prerr_endline
- "Warning: Several features will not work with multiple project files."
+ | Some _ -> Pp.msg_warning (Pp.str
+ "Several features will not work with multiple project files.")
in
let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in
process_cmd_line orig_dir opts' l' r
@@ -96,7 +109,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
let () = match makefile with
|None -> ()
|Some f ->
- Minilib.safe_prerr_endline ("Warning: Only one output file is genererated. "^f^" will not be.")
+ Pp.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be.")))
in process_cmd_line orig_dir (project_file,Some file,install,opt) l r
end
| v :: "=" :: def :: r ->
@@ -104,7 +117,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
| "-arg" :: a :: r ->
process_cmd_line orig_dir opts (Arg a :: l) r
| f :: r ->
- let f = Minilib.correct_path f orig_dir in
+ let f = CUnix.correct_path f orig_dir in
process_cmd_line orig_dir opts ((
if Filename.check_suffix f ".v" then V f
else if (Filename.check_suffix f ".ml") then ML f
@@ -120,41 +133,48 @@ let rec post_canonize f =
if dir = Filename.current_dir_name then f else post_canonize dir
else f
-(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(i_inc,r_inc),(args,defs)) *)
+(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *)
let split_arguments =
let rec aux = function
| V n :: r ->
- let (v,m,o,s),i,d = aux r in ((Minilib.remove_path_dot n::v,m,o,s),i,d)
+ let (v,m,o,s),i,d = aux r in ((CUnix.remove_path_dot n::v,m,o,s),i,d)
| ML n :: r ->
let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
- ((v,(mli,ml4,Minilib.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
+ ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
| MLI n :: r ->
let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
- ((v,(Minilib.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
+ ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
| ML4 n :: r ->
let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
- ((v,(mli,Minilib.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
+ ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
| MLLIB n :: r ->
let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
- ((v,(mli,ml4,ml,Minilib.remove_path_dot n::mllib,mlpack),o,s),i,d)
+ ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d)
| MLPACK n :: r ->
let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
- ((v,(mli,ml4,ml,mllib,Minilib.remove_path_dot n::mlpack),o,s),i,d)
- | Special (n,dep,c) :: r ->
- let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,c)::o,s),i,d)
+ ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d)
+ | Special (n,dep,is_phony,c) :: r ->
+ let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,c)::o,s),i,d)
| Subdir n :: r ->
let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d)
- | Include p :: r ->
- let t,(i,r),d = aux r in (t,((Minilib.remove_path_dot (post_canonize p),
- Minilib.canonical_path_name p)::i,r),d)
+ | MLInclude p :: r ->
+ let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p),
+ CUnix.canonical_path_name p)::ml,q,r),d)
+ | Include (p,l) :: r ->
+ let t,(ml,i,r),d = aux r in
+ let i_new = (CUnix.remove_path_dot (post_canonize p),l,
+ CUnix.canonical_path_name p) in
+ (t,(ml,i_new::i,r),d)
| RInclude (p,l) :: r ->
- let t,(i,r),d = aux r in (t,(i,(Minilib.remove_path_dot (post_canonize p),l,
- Minilib.canonical_path_name p)::r),d)
+ let t,(ml,i,r),d = aux r in
+ let r_new = (CUnix.remove_path_dot (post_canonize p),l,
+ CUnix.canonical_path_name p) in
+ (t,(ml,i,r_new::r),d)
| Def (v,def) :: r ->
let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs))
| Arg a :: r ->
let t,i,(args,defs) = aux r in (t,i,(a::args,defs))
- | [] -> ([],([],[],[],[],[]),[],[]),([],[]),([],[])
+ | [] -> ([],([],[],[],[],[]),[],[]),([],[],[]),([],[])
in aux
let read_project_file f =
@@ -162,27 +182,27 @@ let read_project_file f =
(snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f)))
let args_from_project file project_files default_name =
- let is_f = Minilib.same_file file in
+ let is_f = CUnix.same_file file in
let contains_file dir =
- List.exists (fun x -> is_f (Minilib.correct_path x dir))
+ List.exists (fun x -> is_f (CUnix.correct_path x dir))
in
- let build_cmd_line i_inc r_inc args =
- List.fold_right (fun (_,i) o -> "-I" :: i :: o) i_inc
- (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc
- (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))
+ let build_cmd_line ml_inc i_inc r_inc args =
+ List.fold_right (fun (_,i) o -> "-I" :: i :: o) ml_inc
+ (List.fold_right (fun (_,l,i) o -> "-Q" :: i :: l :: o) i_inc
+ (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc
+ (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args [])))
in try
- let (_,(_,(i_inc,r_inc),(args,_))) =
+ let (_,(_,(ml_inc,i_inc,r_inc),(args,_))) =
List.find (fun (dir,((v_files,_,_,_),_,_)) ->
contains_file dir v_files) project_files in
- build_cmd_line i_inc r_inc args
+ build_cmd_line ml_inc i_inc r_inc args
with Not_found ->
let rec find_project_file dir = try
- let ((v_files,_,_,_),(i_inc,r_inc),(args,_)) =
+ let ((v_files,_,_,_),(ml_inc,i_inc,r_inc),(args,_)) =
read_project_file (Filename.concat dir default_name) in
if contains_file dir v_files
- then build_cmd_line i_inc r_inc args
+ then build_cmd_line ml_inc i_inc r_inc args
else let newdir = Filename.dirname dir in
- Minilib.safe_prerr_endline newdir;
if dir = newdir then [] else find_project_file newdir
with Sys_error s ->
let newdir = Filename.dirname dir in
diff --git a/ide/sentence.ml b/ide/sentence.ml
new file mode 100644
index 00000000..dd6b10a4
--- /dev/null
+++ b/ide/sentence.ml
@@ -0,0 +1,126 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** {1 Sentences in coqide buffers } *)
+
+(** Cut a part of the buffer in sentences and tag them.
+ Invariant: either this slice ends the buffer, or it ends with ".".
+ May raise [Coq_lex.Unterminated] when the zone ends with
+ an unterminated sentence. *)
+
+let split_slice_lax (buffer:GText.buffer) start stop =
+ buffer#remove_tag ~start ~stop Tags.Script.sentence;
+ buffer#remove_tag ~start ~stop Tags.Script.error;
+ buffer#remove_tag ~start ~stop Tags.Script.error_bg;
+ let slice = buffer#get_text ~start ~stop () in
+ let apply_tag off tag =
+ (* off is now a utf8-compliant char offset, cf Coq_lex.utf8_adjust *)
+ let iter = start#forward_chars off in
+ buffer#apply_tag ~start:iter ~stop:iter#forward_char tag
+ in
+ Coq_lex.delimit_sentences apply_tag slice
+
+(** Searching forward and backward a position fulfilling some condition *)
+
+let rec forward_search cond (iter:GText.iter) =
+ if iter#is_end || cond iter then iter
+ else forward_search cond iter#forward_char
+
+let rec backward_search cond (iter:GText.iter) =
+ if iter#is_start || cond iter then iter
+ else backward_search cond iter#backward_char
+
+let is_sentence_end s =
+ s#has_tag Tags.Script.sentence
+
+let is_char s c = s#char = Char.code c
+
+(** Search backward the first character of a sentence, starting at [iter]
+ and going at most up to [soi] (meant to be the end of the locked zone).
+ Raise [StartError] when no proper sentence start has been found.
+ A character following a ending "." is considered as a sentence start
+ only if this character is a blank. In particular, when a final "."
+ at the end of the locked zone isn't followed by a blank, then this
+ non-blank character will be signaled as erroneous in [tag_on_insert] below.
+*)
+
+exception StartError
+
+let grab_sentence_start (iter:GText.iter) soi =
+ let cond iter =
+ if iter#compare soi < 0 then raise StartError;
+ let prev = iter#backward_char in
+ is_sentence_end prev &&
+ (not (is_char prev '.') ||
+ List.exists (is_char iter) [' ';'\n';'\r';'\t'])
+ in
+ backward_search cond iter
+
+(** Search forward the first character immediately after a sentence end *)
+
+let rec grab_sentence_stop (start:GText.iter) =
+ (forward_search is_sentence_end start)#forward_char
+
+(** Search forward the first character immediately after a "." sentence end
+ (and not just a "\{" or "\}" or comment end *)
+
+let rec grab_ending_dot (start:GText.iter) =
+ let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in
+ (forward_search is_ending_dot start)#forward_char
+
+(** Retag a zone that has been edited *)
+
+let tag_on_insert buffer =
+ (* the start of the non-locked zone *)
+ let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+ (* the inserted zone is between [prev_insert] and [insert] *)
+ let insert = buffer#get_iter_at_mark `INSERT in
+ let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in
+ (* [prev] is normally always before [insert] even when deleting.
+ Let's check this nonetheless *)
+ let prev, insert =
+ if insert#compare prev < 0 then insert, prev else prev, insert
+ in
+ try
+ let start = grab_sentence_start prev soi in
+ (** The status of "{" "}" as sentence delimiters is too fragile.
+ We retag up to the next "." instead. *)
+ let stop = grab_ending_dot insert in
+ try split_slice_lax buffer start#backward_char stop
+ with Coq_lex.Unterminated ->
+ (* This shouldn't happen frequently. Either:
+ - we are at eof, with indeed an unfinished sentence.
+ - we have just inserted an opening of comment or string.
+ - the inserted text ends with a "." that interacts with the "."
+ found by [grab_ending_dot] to form a non-ending "..".
+ In any case, we retag up to eof, since this isn't that costly. *)
+ if not stop#is_end then
+ let eoi = buffer#get_iter_at_mark (`NAME "stop_of_input") in
+ try split_slice_lax buffer start eoi
+ with Coq_lex.Unterminated -> ()
+ with StartError ->
+ buffer#apply_tag ~start:soi ~stop:soi#forward_char Tags.Script.error
+
+let tag_all buffer =
+ let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+ let eoi = buffer#get_iter_at_mark (`NAME "stop_of_input") in
+ try split_slice_lax buffer soi eoi
+ with Coq_lex.Unterminated -> ()
+
+(** Search a sentence around some position *)
+
+let find buffer (start:GText.iter) =
+ let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+ try
+ let start = grab_sentence_start start soi in
+ let stop = grab_sentence_stop start in
+ (* Is this phrase non-empty and complete ? *)
+ if stop#compare start > 0 && is_sentence_end stop#backward_char
+ then Some (start,stop)
+ else None
+ with StartError -> None
diff --git a/ide/undo_lablgtk_ge26.mli b/ide/sentence.mli
index 12396fca..f0ba5d22 100644
--- a/ide/undo_lablgtk_ge26.mli
+++ b/ide/sentence.mli
@@ -1,33 +1,19 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* An undoable view class *)
+(** Retag the ends of sentences around an inserted zone *)
-class undoable_view : [> Gtk.text_view] Gtk.obj ->
-object
- inherit GText.view
- method undo : bool
- method redo : bool
- method clear_undo : unit
-end
+val tag_on_insert : GText.buffer -> unit
-val undoable_view :
- ?buffer:GText.buffer ->
- ?editable:bool ->
- ?cursor_visible:bool ->
- ?justification:GtkEnums.justification ->
- ?wrap_mode:GtkEnums.wrap_mode ->
- ?border_width:int ->
- ?width:int ->
- ?height:int ->
- ?packing:(GObj.widget -> unit) ->
- ?show:bool ->
- unit ->
- undoable_view
+(** Retag the ends of sentences in the non-locked part of the buffer *)
+val tag_all : GText.buffer -> unit
+(** Search a sentence around some position *)
+
+val find : GText.buffer -> GText.iter -> (GText.iter * GText.iter) option
diff --git a/ide/session.ml b/ide/session.ml
new file mode 100644
index 00000000..29363211
--- /dev/null
+++ b/ide/session.ml
@@ -0,0 +1,517 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Preferences
+
+let prefs = Preferences.current
+
+(** A session is a script buffer + proof + messages,
+ interacting with a coqtop, and a few other elements around *)
+
+class type ['a] page =
+ object
+ inherit GObj.widget
+ method update : 'a -> unit
+ method on_update : callback:('a -> unit) -> unit
+ end
+
+class type control =
+ object
+ method detach : unit -> unit
+ end
+
+type errpage = (int * string) list page
+type jobpage = string CString.Map.t page
+
+type session = {
+ buffer : GText.buffer;
+ script : Wg_ScriptView.script_view;
+ proof : Wg_ProofView.proof_view;
+ messages : Wg_MessageView.message_view;
+ segment : Wg_Segment.segment;
+ fileops : FileOps.ops;
+ coqops : CoqOps.ops;
+ coqtop : Coq.coqtop;
+ command : Wg_Command.command_window;
+ finder : Wg_Find.finder;
+ tab_label : GMisc.label;
+ errpage : errpage;
+ jobpage : jobpage;
+ mutable control : control;
+}
+
+let create_buffer () =
+ let buffer = GSourceView2.source_buffer
+ ~tag_table:Tags.Script.table
+ ~highlight_matching_brackets:true
+ ?language:(lang_manager#language prefs.source_language)
+ ?style_scheme:(style_manager#style_scheme prefs.source_style)
+ ()
+ in
+ let _ = buffer#create_mark ~name:"start_of_input" buffer#start_iter in
+ let _ = buffer#create_mark
+ ~left_gravity:false ~name:"stop_of_input" buffer#end_iter in
+ let _ = buffer#create_mark ~name:"prev_insert" buffer#start_iter in
+ let _ = buffer#place_cursor ~where:buffer#start_iter in
+ let _ = buffer#add_selection_clipboard Ideutils.cb in
+ buffer
+
+let create_script coqtop source_buffer =
+ let script = Wg_ScriptView.script_view coqtop ~source_buffer
+ ~show_line_numbers:true ~wrap_mode:`NONE ()
+ in
+ let _ = script#misc#set_name "ScriptWindow"
+ in
+ script
+
+(** NB: Events during text edition:
+
+ - [begin_user_action]
+ - [insert_text] (or [delete_range] when deleting)
+ - [changed]
+ - [end_user_action]
+
+ When pasting a text containing tags (e.g. the sentence terminators),
+ there is actually many [insert_text] and [changed]. For instance,
+ for "a. b.":
+
+ - [begin_user_action]
+ - [insert_text] (for "a")
+ - [changed]
+ - [insert_text] (for ".")
+ - [changed]
+ - [apply_tag] (for the tag of ".")
+ - [insert_text] (for " b")
+ - [changed]
+ - [insert_text] (for ".")
+ - [changed]
+ - [apply_tag] (for the tag of ".")
+ - [end_user_action]
+
+ Since these copy-pasted tags may interact badly with the retag mechanism,
+ we now don't monitor the "changed" event, but rather the "begin_user_action"
+ and "end_user_action". We begin by setting a mark at the initial cursor
+ point. At the end, the zone between the mark and the cursor is to be
+ untagged and then retagged. *)
+
+let set_buffer_handlers
+ (buffer : GText.buffer) script (coqops : CoqOps.ops) coqtop
+=
+ let action_was_cancelled = ref true in
+ let no_coq_action_required = ref true in
+ let cur_action = ref 0 in
+ let new_action_id =
+ let id = ref 0 in
+ fun () -> incr id; !id in
+ let running_action = ref None in
+ let cancel_signal reason =
+ Minilib.log ("user_action cancelled: "^reason);
+ action_was_cancelled := true;
+ GtkSignal.stop_emit () in
+ let del_mark () =
+ try buffer#delete_mark (`NAME "target")
+ with GText.No_such_mark _ -> () in
+ let add_mark it = del_mark (); buffer#create_mark ~name:"target" it in
+ let call_coq_or_cancel_action f =
+ no_coq_action_required := false;
+ let action = !cur_action in
+ let action, fallback =
+ Coq.seq (Coq.lift (fun () -> running_action := Some action)) f,
+ fun () -> (* If Coq is busy due to the current action, we don't cancel *)
+ match !running_action with
+ | Some aid when aid = action -> ()
+ | _ -> cancel_signal "Coq busy" in
+ Coq.try_grab coqtop action fallback in
+ let get_start () = buffer#get_iter_at_mark (`NAME "start_of_input") in
+ let get_stop () = buffer#get_iter_at_mark (`NAME "stop_of_input") in
+ let ensure_marks_exist () =
+ try ignore(buffer#get_mark (`NAME "stop_of_input"))
+ with GText.No_such_mark _ -> assert false in
+ let get_insert () = buffer#get_iter_at_mark `INSERT in
+ let debug_edit_zone () = if false (*!Minilib.debug*) then begin
+ buffer#remove_tag Tags.Script.edit_zone
+ ~start:buffer#start_iter ~stop:buffer#end_iter;
+ buffer#apply_tag Tags.Script.edit_zone
+ ~start:(get_start()) ~stop:(get_stop())
+ end in
+ let backto_before_error it =
+ let rec aux old it =
+ if it#is_start || not(it#has_tag Tags.Script.error_bg) then old
+ else aux it it#backward_char in
+ aux it it in
+ let insert_cb it s = if String.length s = 0 then () else begin
+ Minilib.log ("insert_cb " ^ string_of_int it#offset);
+ let text_mark = add_mark it in
+ if it#has_tag Tags.Script.to_process then
+ cancel_signal "Altering the script being processed in not implemented"
+ else if it#has_tag Tags.Script.read_only then
+ cancel_signal "Altering read_only text not allowed"
+ else if it#has_tag Tags.Script.processed then
+ call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+ else if it#has_tag Tags.Script.error_bg then begin
+ let prev_sentence_end = backto_before_error it in
+ let text_mark = add_mark prev_sentence_end in
+ call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+ end end in
+ let delete_cb ~start ~stop =
+ Minilib.log (Printf.sprintf "delete_cb %d %d" start#offset stop#offset);
+ cur_action := new_action_id ();
+ let min_iter, max_iter =
+ if start#compare stop < 0 then start, stop else stop, start in
+ let text_mark = add_mark min_iter in
+ let rec aux min_iter =
+ if min_iter#equal max_iter then ()
+ else if min_iter#has_tag Tags.Script.to_process then
+ cancel_signal "Altering the script being processed in not implemented"
+ else if min_iter#has_tag Tags.Script.read_only then
+ cancel_signal "Altering read_only text not allowed"
+ else if min_iter#has_tag Tags.Script.processed then
+ call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+ else if min_iter#has_tag Tags.Script.error_bg then
+ let prev_sentence_end = backto_before_error min_iter in
+ let text_mark = add_mark prev_sentence_end in
+ call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+ else aux min_iter#forward_char in
+ aux min_iter in
+ let begin_action_cb () =
+ Minilib.log "begin_action_cb";
+ action_was_cancelled := false;
+ no_coq_action_required := true;
+ cur_action := new_action_id ();
+ let where = get_insert () in
+ buffer#move_mark (`NAME "prev_insert") ~where in
+ let end_action_cb () =
+ Minilib.log "end_action_cb";
+ ensure_marks_exist ();
+ if not !action_was_cancelled then begin
+ (* If coq was asked to backtrack, the clenup must be done by the
+ backtrack_until function, since it may move the stop_of_input
+ to a point indicated by coq. *)
+ if !no_coq_action_required then begin
+ let start, stop = get_start (), get_stop () in
+ buffer#remove_tag Tags.Script.error ~start ~stop;
+ buffer#remove_tag Tags.Script.error_bg ~start ~stop;
+ buffer#remove_tag Tags.Script.tooltip ~start ~stop;
+ buffer#remove_tag Tags.Script.processed ~start ~stop;
+ buffer#remove_tag Tags.Script.to_process ~start ~stop;
+ buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+ Sentence.tag_on_insert buffer
+ end;
+ end in
+ let mark_deleted_cb m =
+ match GtkText.Mark.get_name m with
+ | Some "insert" -> ()
+ | Some s -> Minilib.log (s^" deleted")
+ | None -> ()
+ in
+ let mark_set_cb it m =
+ debug_edit_zone ();
+ let ins = get_insert () in
+ let line = ins#line + 1 in
+ let off = ins#line_offset + 1 in
+ let msg = Printf.sprintf "Line: %5d Char: %3d" line off in
+ let () = !Ideutils.set_location msg in
+ match GtkText.Mark.get_name m with
+ | Some "insert" -> ()
+ | Some s -> Minilib.log (s^" moved")
+ | None -> ()
+ in
+ (** Pluging callbacks *)
+ let _ = buffer#connect#insert_text ~callback:insert_cb in
+ let _ = buffer#connect#delete_range ~callback:delete_cb in
+ let _ = buffer#connect#begin_user_action ~callback:begin_action_cb in
+ let _ = buffer#connect#end_user_action ~callback:end_action_cb in
+ let _ = buffer#connect#after#mark_set ~callback:mark_set_cb in
+ let _ = buffer#connect#after#mark_deleted ~callback:mark_deleted_cb in
+ ()
+
+let find_int_col s l =
+ match List.assoc s l with `IntC c -> c | _ -> assert false
+
+let find_string_col s l =
+ match List.assoc s l with `StringC c -> c | _ -> assert false
+
+let make_table_widget cd cb =
+ let frame = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () in
+ let columns, store =
+ let cols = new GTree.column_list in
+ let columns = List.map (function
+ | (`Int,n,_) -> n, `IntC (cols#add Gobject.Data.int)
+ | (`String,n,_) -> n, `StringC (cols#add Gobject.Data.string))
+ cd in
+ columns, GTree.list_store cols in
+ let data = GTree.view
+ ~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment
+ ~rules_hint:true ~headers_visible:false
+ ~model:store ~packing:frame#add () in
+ let () = data#set_headers_visible true in
+ let mk_rend c = GTree.cell_renderer_text [], ["text",c] in
+ let cols =
+ List.map2 (fun (_,c) (_,n,v) ->
+ let c = match c with
+ | `IntC c -> GTree.view_column ~renderer:(mk_rend c) ()
+ | `StringC c -> GTree.view_column ~renderer:(mk_rend c) () in
+ c#set_title n;
+ c#set_visible v;
+ c#set_sizing `AUTOSIZE;
+ c)
+ columns cd in
+ List.iter (fun c -> ignore(data#append_column c)) cols;
+ ignore(
+ data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc)
+ );
+ frame, (fun f -> f columns store)
+
+let create_errpage (script : Wg_ScriptView.script_view) : errpage =
+ let table, access =
+ make_table_widget
+ [`Int,"Line",true; `String,"Error message",true]
+ (fun columns store tp vc ->
+ let row = store#get_iter tp in
+ let lno = store#get ~row ~column:(find_int_col "Line" columns) in
+ let where = script#buffer#get_iter (`LINE (lno-1)) in
+ script#buffer#place_cursor ~where;
+ ignore (script#scroll_to_iter
+ ~use_align:false ~yalign:0.75 ~within_margin:0.25 where)) in
+ let tip = GMisc.label ~text:"Double click to jump to error line" () in
+ let box = GPack.vbox ~homogeneous:false () in
+ let () = box#pack ~expand:true table#coerce in
+ let () = box#pack ~expand:false ~padding:2 tip#coerce in
+ let last_update = ref [] in
+ let callback = ref (fun _ -> ()) in
+ object (self)
+ inherit GObj.widget box#as_widget
+ method update errs =
+ if !last_update = errs then ()
+ else begin
+ last_update := errs;
+ access (fun _ store -> store#clear ());
+ !callback errs;
+ List.iter (fun (lno, msg) -> access (fun columns store ->
+ let line = store#append () in
+ store#set line (find_int_col "Line" columns) lno;
+ store#set line (find_string_col "Error message" columns) msg))
+ errs
+ end
+ method on_update ~callback:cb = callback := cb
+ end
+
+let create_jobpage coqtop coqops : jobpage =
+ let table, access =
+ make_table_widget
+ [`String,"Worker",true; `String,"Job name",true]
+ (fun columns store tp vc ->
+ let row = store#get_iter tp in
+ let w = store#get ~row ~column:(find_string_col "Worker" columns) in
+ let info () = Minilib.log ("Coq busy, discarding query") in
+ Coq.try_grab coqtop (coqops#stop_worker w) info
+ ) in
+ let tip = GMisc.label ~text:"Double click to interrupt worker" () in
+ let box = GPack.vbox ~homogeneous:false () in
+ let () = box#pack ~expand:true table#coerce in
+ let () = box#pack ~expand:false ~padding:2 tip#coerce in
+ let last_update = ref CString.Map.empty in
+ let callback = ref (fun _ -> ()) in
+ object (self)
+ inherit GObj.widget box#as_widget
+ method update jobs =
+ if !last_update = jobs then ()
+ else begin
+ last_update := jobs;
+ access (fun _ store -> store#clear ());
+ !callback jobs;
+ CString.Map.iter (fun id job -> access (fun columns store ->
+ let column = find_string_col "Worker" columns in
+ if job = "Dead" then
+ store#foreach (fun _ row ->
+ if store#get ~row ~column = id then store#remove row || true
+ else false)
+ else
+ let line = store#append () in
+ store#set line column id;
+ store#set line (find_string_col "Job name" columns) job))
+ jobs
+ end
+ method on_update ~callback:cb = callback := cb
+ end
+
+let create_proof () =
+ let proof = Wg_ProofView.proof_view () in
+ let _ = proof#misc#set_can_focus true in
+ let _ = GtkBase.Widget.add_events proof#as_widget
+ [`ENTER_NOTIFY;`POINTER_MOTION]
+ in
+ proof
+
+let create_messages () =
+ let messages = Wg_MessageView.message_view () in
+ let _ = messages#misc#set_can_focus true in
+ messages
+
+let dummy_control : control =
+ object
+ method detach () = ()
+ end
+
+let create file coqtop_args =
+ let basename = match file with
+ |None -> "*scratch*"
+ |Some f -> Glib.Convert.filename_to_utf8 (Filename.basename f)
+ in
+ let coqtop = Coq.spawn_coqtop coqtop_args in
+ let reset () = Coq.reset_coqtop coqtop in
+ let buffer = create_buffer () in
+ let script = create_script coqtop buffer in
+ let proof = create_proof () in
+ let messages = create_messages () in
+ let segment = new Wg_Segment.segment () in
+ let command = new Wg_Command.command_window basename coqtop in
+ let finder = new Wg_Find.finder basename (script :> GText.view) in
+ let fops = new FileOps.fileops (buffer :> GText.buffer) file reset in
+ let _ = fops#update_stats in
+ let cops =
+ new CoqOps.coqops script proof messages segment coqtop (fun () -> fops#filename) in
+ let errpage = create_errpage script in
+ let jobpage = create_jobpage coqtop cops in
+ let _ = set_buffer_handlers (buffer :> GText.buffer) script cops coqtop in
+ let _ = Coq.set_reset_handler coqtop cops#handle_reset_initial in
+ let _ = Coq.init_coqtop coqtop cops#initialize in
+ {
+ buffer = (buffer :> GText.buffer);
+ script=script;
+ proof=proof;
+ messages=messages;
+ segment=segment;
+ fileops=fops;
+ coqops=cops;
+ coqtop=coqtop;
+ command=command;
+ finder=finder;
+ tab_label= GMisc.label ~text:basename ();
+ errpage=errpage;
+ jobpage=jobpage;
+ control = dummy_control;
+ }
+
+let kill (sn:session) =
+ (* To close the detached views of this script, we call manually
+ [destroy] on it, triggering some callbacks in [detach_view].
+ In a more modern lablgtk, rather use the page-removed signal ? *)
+ sn.coqops#destroy ();
+ sn.script#destroy ();
+ Coq.close_coqtop sn.coqtop
+
+let build_layout (sn:session) =
+ let session_paned = GPack.paned `VERTICAL () in
+ let session_box =
+ GPack.vbox ~packing:(session_paned#pack1 ~shrink:false ~resize:true) ()
+ in
+
+ (** Right part of the window. *)
+
+ let eval_paned = GPack.paned `HORIZONTAL ~border_width:5
+ ~packing:(session_box#pack ~expand:true) () in
+ let script_frame = GBin.frame ~shadow_type:`IN
+ ~packing:eval_paned#add1 () in
+ let script_scroll = GBin.scrolled_window
+ ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in
+ let state_paned = GPack.paned `VERTICAL
+ ~packing:eval_paned#add2 () in
+
+ (** Proof buffer. *)
+
+ let title = Printf.sprintf "Proof (%s)" sn.tab_label#text in
+ let proof_detachable = Wg_Detachable.detachable ~title () in
+ let () = proof_detachable#button#misc#hide () in
+ let () = proof_detachable#frame#set_shadow_type `IN in
+ let () = state_paned#add1 proof_detachable#coerce in
+ let callback _ = proof_detachable#show in
+ let () = proof_detachable#connect#attached ~callback in
+ let callback _ =
+ sn.proof#coerce#misc#set_size_request ~width:500 ~height:400 ()
+ in
+ let () = proof_detachable#connect#detached ~callback in
+ let proof_scroll = GBin.scrolled_window
+ ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in
+
+ (** Message buffer. *)
+
+ let message_frame = GPack.notebook ~packing:state_paned#add () in
+ let add_msg_page pos name text (w : GObj.widget) =
+ let detachable =
+ Wg_Detachable.detachable ~title:(text^" ("^name^")") () in
+ detachable#add w#coerce;
+ let label = GPack.hbox ~spacing:5 () in
+ let lbl = GMisc.label ~text ~packing:label#add () in
+ let but = GButton.button () in
+ but#add (GMisc.label ~markup:"<small>↗</small>" ())#coerce;
+ label#add but#coerce;
+ ignore(message_frame#insert_page ~pos
+ ~tab_label:label#coerce detachable#coerce);
+ ignore(but#connect#clicked ~callback:(fun _ ->
+ message_frame#remove_page (message_frame#page_num detachable#coerce);
+ detachable#button#clicked ()));
+ detachable#connect#detached ~callback:(fun _ ->
+ if message_frame#all_children = [] then message_frame#misc#hide ();
+ w#misc#set_size_request ~width:500 ~height:400 ());
+ detachable#connect#attached ~callback:(fun _ ->
+ ignore(message_frame#insert_page ~pos
+ ~tab_label:label#coerce detachable#coerce);
+ message_frame#misc#show ();
+ detachable#show);
+ detachable#button#misc#hide ();
+ lbl in
+ let session_tab = GPack.hbox ~homogeneous:false () in
+ let img = GMisc.image ~icon_size:`SMALL_TOOLBAR
+ ~packing:session_tab#pack () in
+ let _ =
+ sn.buffer#connect#modified_changed
+ ~callback:(fun () -> if sn.buffer#modified
+ then img#set_stock `SAVE
+ else img#set_stock `YES) in
+ let _ =
+ eval_paned#misc#connect#size_allocate
+ ~callback:
+ (let old_paned_width = ref 2 in
+ let old_paned_height = ref 2 in
+ fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
+ if !old_paned_width <> paned_width ||
+ !old_paned_height <> paned_height
+ then begin
+ eval_paned#set_position
+ (eval_paned#position * paned_width / !old_paned_width);
+ state_paned#set_position
+ (state_paned#position * paned_height / !old_paned_height);
+ old_paned_width := paned_width;
+ old_paned_height := paned_height;
+ end)
+ in
+ session_box#pack sn.finder#coerce;
+ session_box#pack sn.segment#coerce;
+ sn.command#pack_in (session_paned#pack2 ~shrink:false ~resize:false);
+ script_scroll#add sn.script#coerce;
+ proof_scroll#add sn.proof#coerce;
+ ignore(add_msg_page 0 sn.tab_label#text "Messages" sn.messages#coerce);
+ let label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in
+ ignore(add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce);
+ let txt = label#text in
+ let red s = "<span foreground=\"#FF0000\">" ^ s ^ "</span>" in
+ sn.errpage#on_update ~callback:(fun l ->
+ if l = [] then (label#set_use_markup false; label#set_text txt)
+ else (label#set_text (red txt);label#set_use_markup true));
+ session_tab#pack sn.tab_label#coerce;
+ img#set_stock `YES;
+ eval_paned#set_position 1;
+ state_paned#set_position 1;
+ let control =
+ object
+ method detach () = proof_detachable#detach ()
+ end
+ in
+ let () = sn.control <- control in
+ (Some session_tab#coerce,None,session_paned#coerce)
diff --git a/ide/session.mli b/ide/session.mli
new file mode 100644
index 00000000..3a6b4585
--- /dev/null
+++ b/ide/session.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** A session is a script buffer + proof + messages,
+ interacting with a coqtop, and a few other elements around *)
+
+class type ['a] page =
+ object
+ inherit GObj.widget
+ method update : 'a -> unit
+ method on_update : callback:('a -> unit) -> unit
+ end
+
+class type control =
+ object
+ method detach : unit -> unit
+ end
+
+type errpage = (int * string) list page
+type jobpage = string CString.Map.t page
+
+type session = {
+ buffer : GText.buffer;
+ script : Wg_ScriptView.script_view;
+ proof : Wg_ProofView.proof_view;
+ messages : Wg_MessageView.message_view;
+ segment : Wg_Segment.segment;
+ fileops : FileOps.ops;
+ coqops : CoqOps.ops;
+ coqtop : Coq.coqtop;
+ command : Wg_Command.command_window;
+ finder : Wg_Find.finder;
+ tab_label : GMisc.label;
+ errpage : errpage;
+ jobpage : jobpage;
+ mutable control : control;
+}
+
+(** [create filename coqtop_args] *)
+val create : string option -> string list -> session
+
+val kill : session -> unit
+
+val build_layout : session ->
+ GObj.widget option * GObj.widget option * GObj.widget
diff --git a/ide/tags.ml b/ide/tags.ml
index 955dfa96..04ad9a51 100644
--- a/ide/tags.ml
+++ b/ide/tags.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -15,25 +15,37 @@ let make_tag (tt:GText.tag_table) ~name prop =
let processed_color = ref "light green"
let processing_color = ref "light blue"
+let error_color = ref "#FFCCCC"
module Script =
struct
let table = GText.tag_table ()
- let kwd = make_tag table ~name:"kwd" [`FOREGROUND "blue"]
- let qed = make_tag table ~name:"qed" [`FOREGROUND "blue"]
- let decl = make_tag table ~name:"decl" [`FOREGROUND "orange red"]
- let proof_decl = make_tag table ~name:"proof_decl" [`FOREGROUND "orange red"]
- let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"]
- let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"]
- let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"]
- let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false]
- let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false]
- let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false]
+ let comment = make_tag table ~name:"comment" []
+ let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND "red"]
+ let error_bg = make_tag table ~name:"error_bg" [`BACKGROUND !error_color]
+ let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color]
+ let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color]
+ let incomplete = make_tag table ~name:"incomplete" [
+ `BACKGROUND !processing_color;
+ `BACKGROUND_STIPPLE_SET true;
+ ]
+ let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"]
let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"]
- let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false]
- let folded = make_tag table ~name:"locked" [`EDITABLE false; `BACKGROUND "light grey"]
- let paren = make_tag table ~name:"paren" [`BACKGROUND "purple"]
let sentence = make_tag table ~name:"sentence" []
+ let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *)
+
+ let all =
+ [comment; error; error_bg; to_process; processed; incomplete; unjustified;
+ found; sentence; tooltip]
+
+ let edit_zone =
+ let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in
+ t#set_priority (List.length all);
+ t
+ let all = edit_zone :: all
+
+ let read_only = make_tag table ~name:"read_only" [`EDITABLE false ]
+
end
module Proof =
struct
@@ -46,6 +58,8 @@ module Message =
struct
let table = GText.tag_table ()
let error = make_tag table ~name:"error" [`FOREGROUND "red"]
+ let warning = make_tag table ~name:"warning" [`FOREGROUND "orange"]
+ let item = make_tag table ~name:"item" [`WEIGHT `BOLD]
end
let string_of_color clr =
@@ -71,4 +85,12 @@ let get_processing_color () = color_of_string !processing_color
let set_processing_color clr =
let s = string_of_color clr in
processing_color := s;
+ Script.incomplete#set_property (`BACKGROUND s);
Script.to_process#set_property (`BACKGROUND s)
+
+let get_error_color () = color_of_string !error_color
+
+let set_error_color clr =
+ let s = string_of_color clr in
+ error_color := s;
+ Script.error_bg#set_property (`BACKGROUND s)
diff --git a/ide/tags.mli b/ide/tags.mli
index 3cc4920a..9c3261d6 100644
--- a/ide/tags.mli
+++ b/ide/tags.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -9,21 +9,21 @@
module Script :
sig
val table : GText.tag_table
- val kwd : GText.tag
- val qed : GText.tag
- val decl : GText.tag
- val proof_decl : GText.tag
val comment : GText.tag
- val reserved : GText.tag
val error : GText.tag
+ val error_bg : GText.tag
val to_process : GText.tag
val processed : GText.tag
+ val incomplete : GText.tag
val unjustified : GText.tag
val found : GText.tag
- val hidden : GText.tag
- val folded : GText.tag
- val paren : GText.tag
val sentence : GText.tag
+ val tooltip : GText.tag
+ val edit_zone : GText.tag (* for debugging *)
+ val all : GText.tag list
+
+ (* Not part of the all list. Special tags! *)
+ val read_only : GText.tag
end
module Proof :
@@ -38,6 +38,8 @@ module Message :
sig
val table : GText.tag_table
val error : GText.tag
+ val warning : GText.tag
+ val item : GText.tag
end
val string_of_color : Gdk.color -> string
@@ -48,3 +50,6 @@ val set_processed_color : Gdk.color -> unit
val get_processing_color : unit -> Gdk.color
val set_processing_color : Gdk.color -> unit
+
+val get_error_color : unit -> Gdk.color
+val set_error_color : Gdk.color -> unit
diff --git a/ide/undo.ml b/ide/undo.ml
deleted file mode 100644
index 8456cf9f..00000000
--- a/ide/undo.ml
+++ /dev/null
@@ -1,175 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Ideutils
-open GText
-type action =
- | Insert of string * int * int (* content*pos*length *)
- | Delete of string * int * int (* content*pos*length *)
-
-let neg act = match act with
- | Insert (s,i,l) -> Delete (s,i,l)
- | Delete (s,i,l) -> Insert (s,i,l)
-
-class undoable_view (tv:[>Gtk.text_view] Gtk.obj) =
- let undo_lock = ref true in
-object(self)
- inherit GText.view tv as super
- val history = (Stack.create () : action Stack.t)
- val redo = (Queue.create () : action Queue.t)
- val nredo = (Stack.create () : action Stack.t)
-
- method private dump_debug =
- if false (* !debug *) then begin
- prerr_endline "==========Stack top=============";
- Stack.iter
- (fun e -> match e with
- | Insert(s,p,l) ->
- Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
- | Delete(s,p,l) ->
- Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
- history;
- Printf.eprintf "Stack size %d\n" (Stack.length history);
- prerr_endline "==========Stack Bottom==========";
- prerr_endline "==========Queue start=============";
- Queue.iter
- (fun e -> match e with
- | Insert(s,p,l) ->
- Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
- | Delete(s,p,l) ->
- Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
- redo;
- Printf.eprintf "Stack size %d\n" (Queue.length redo);
- prerr_endline "==========Queue End=========="
-
- end
-
- method clear_undo = Stack.clear history; Stack.clear nredo; Queue.clear redo
-
- method undo = if !undo_lock then begin
- undo_lock := false;
- prerr_endline "UNDO";
- try begin
- let r =
- match Stack.pop history with
- | Insert(s,p,l) as act ->
- let start = self#buffer#get_iter_at_char p in
- (self#buffer#delete_interactive
- ~start
- ~stop:(start#forward_chars l)
- ()) or
- (Stack.push act history; false)
- | Delete(s,p,l) as act ->
- let iter = self#buffer#get_iter_at_char p in
- (self#buffer#insert_interactive ~iter s) or
- (Stack.push act history; false)
- in if r then begin
- let act = Stack.pop history in
- Queue.push act redo;
- Stack.push act nredo
- end;
- undo_lock := true;
- r
- end
- with Stack.Empty ->
- undo_lock := true;
- false
- end else
- (prerr_endline "UNDO DISCARDED"; true)
-
- method redo = prerr_endline "REDO"; true
- initializer
-(* INCORRECT: is called even while undoing...
- ignore (self#buffer#connect#mark_set
- ~callback:
- (fun it tm -> if !undo_lock && not (Queue.is_empty redo) then begin
- Stack.iter (fun e -> Stack.push (neg e) history) nredo;
- Stack.clear nredo;
- Queue.iter (fun e -> Stack.push e history) redo;
- Queue.clear redo;
- end)
- );
-*)
- ignore (self#buffer#connect#insert_text
- ~callback:
- (fun it s ->
- if !undo_lock && not (Queue.is_empty redo) then begin
- Stack.iter (fun e -> Stack.push (neg e) history) nredo;
- Stack.clear nredo;
- Queue.iter (fun e -> Stack.push e history) redo;
- Queue.clear redo;
- end;
-(* let pos = it#offset in
- if Stack.is_empty history or
- s=" " or s="\t" or s="\n" or
- (match Stack.top history with
- | Insert(old,opos,olen) ->
- opos + olen <> pos
- | _ -> true)
- then *)
- Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history
- (*else begin
- match Stack.pop history with
- | Insert(olds,offset,len) ->
- Stack.push
- (Insert(olds^s,
- offset,
- len+(Glib.Utf8.length s)))
- history
- | _ -> assert false
- end*);
- self#dump_debug
- ));
- ignore (self#buffer#connect#delete_range
- ~callback:
- (fun ~start ~stop ->
- if !undo_lock && not (Queue.is_empty redo) then begin
- Queue.iter (fun e -> Stack.push e history) redo;
- Queue.clear redo;
- end;
- let start_offset = start#offset in
- let stop_offset = stop#offset in
- let s = self#buffer#get_text ~start ~stop () in
-(* if Stack.is_empty history or (match Stack.top history with
- | Delete(old,opos,olen) ->
- olen=1 or opos <> start_offset
- | _ -> true
- )
- then
-*) Stack.push
- (Delete(s,
- start_offset,
- stop_offset - start_offset
- ))
- history
- (* else begin
- match Stack.pop history with
- | Delete(olds,offset,len) ->
- Stack.push
- (Delete(olds^s,
- offset,
- len+(Glib.Utf8.length s)))
- history
- | _ -> assert false
-
- end*);
- self#dump_debug
- ))
-end
-
-let undoable_view ?(buffer:GText.buffer option) =
- GtkText.View.make_params []
- ~cont:(GContainer.pack_container
- ~create:
- (fun pl -> let w = match buffer with
- | None -> GtkText.View.create []
- | Some b -> GtkText.View.create_with_buffer b#as_buffer
- in
- Gobject.set_params w pl; ((new undoable_view w):undoable_view)))
-
-
diff --git a/ide/undo_lablgtk_ge212.mli b/ide/undo_lablgtk_ge212.mli
deleted file mode 100644
index ea7f85ef..00000000
--- a/ide/undo_lablgtk_ge212.mli
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* An undoable view class *)
-
-class undoable_view : ([> Gtk.text_view] as 'a) Gtk.obj ->
-object
- inherit GText.view
- val obj : 'a Gtk.obj
- method undo : bool
- method redo : bool
- method clear_undo : unit
-end
-
-val undoable_view :
- ?buffer:GText.buffer ->
- ?editable:bool ->
- ?cursor_visible:bool ->
- ?justification:GtkEnums.justification ->
- ?wrap_mode:GtkEnums.wrap_mode ->
- ?accepts_tab:bool ->
- ?border_width:int ->
- ?width:int ->
- ?height:int ->
- ?packing:(GObj.widget -> unit) ->
- ?show:bool ->
- unit ->
- undoable_view
-
-
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
index dac519eb..621833dd 100644
--- a/ide/utf8_convert.mll
+++ b/ide/utf8_convert.mll
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml
index 921d3d9c..4d0aabeb 100644
--- a/ide/utils/config_file.ml
+++ b/ide/utils/config_file.ml
@@ -128,8 +128,8 @@ Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allo
open Format
(* formating convention: the caller has to open the box, close it and flush the output *)
(* remarks on Format:
- set_margin impose un appel à set_max_indent
- sprintf et bprintf sont flushées à chaque appel*)
+ set_margin forces a call to set_max_indent
+ sprintf et bprintf are flushed at each call*)
(* pretty print a Raw.cp *)
let rec save formatter = function
diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli
index b9c77682..22328e7f 100644
--- a/ide/utils/config_file.mli
+++ b/ide/utils/config_file.mli
@@ -141,8 +141,8 @@ exception Missing_cp of groupable_cp
or used to generate command line arguments.
The basic usage is to have only one group and one configuration file,
-but this mechanism allows to have more,
-for instance to have another smaller group for the options to pass on the command line.
+but this mechanism allows having more,
+for instance having another smaller group for the options to pass on the command line.
*)
class group : object
(** Adds a cp to the group.
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml
index 7dbd0452..c1062a9d 100644
--- a/ide/utils/configwin_ihm.ml
+++ b/ide/utils/configwin_ihm.ml
@@ -38,7 +38,7 @@ class type widget =
let file_html_config = Filename.concat Configwin_messages.home ".configwin_html"
let debug = false
-let dbg = if debug then prerr_endline else (fun _ -> ())
+let dbg s = if debug then Minilib.log s else ()
(** Return the config group for the html config file,
and the option for bindings. *)
@@ -67,7 +67,7 @@ let html_config_file_and_option () =
let last_dir = ref "";;
(** This function allows the user to select a file and returns the
- selected file name. An optional function allows to change the
+ selected file name. An optional function allows changing the
behaviour of the ok button.
A VOIR : mutli-selection ? *)
let select_files ?dir
@@ -1015,7 +1015,7 @@ class configuration_box (tt : GData.tooltips) conf_struct =
let set_icon iter = function
| None -> ()
- | Some icon -> tree#set iter icon_col icon
+ | Some icon -> tree#set ~row:iter ~column:icon_col icon
in
(* Populate the tree *)
@@ -1036,9 +1036,9 @@ class configuration_box (tt : GData.tooltips) conf_struct =
method apply () = List.iter (fun param -> param#apply) params
end
in
- let () = tree#set new_iter label_col label in
+ let () = tree#set ~row:new_iter ~column:label_col label in
let () = set_icon new_iter icon in
- let () = tree#set new_iter box_col widget in
+ let () = tree#set ~row:new_iter ~column:box_col widget in
()
| Section_list (label, icon, struct_list) ->
let widget =
@@ -1049,9 +1049,9 @@ class configuration_box (tt : GData.tooltips) conf_struct =
method box = box#coerce
end
in
- let () = tree#set new_iter label_col label in
+ let () = tree#set ~row:new_iter ~column:label_col label in
let () = set_icon new_iter icon in
- let () = tree#set new_iter box_col widget in
+ let () = tree#set ~row:new_iter ~column:box_col widget in
List.iter (make_tree (Some new_iter)) struct_list
in
diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml
index de292431..de1b4721 100644
--- a/ide/utils/configwin_messages.ml
+++ b/ide/utils/configwin_messages.ml
@@ -30,7 +30,7 @@ let version = "1.2";;
let html_config = "Configwin bindings configurator for html parameters"
-let home = Minilib.home
+let home = Option.default "" (Glib.get_home_dir ())
let mCapture = "Capture";;
let mType_key = "Type key" ;;
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml
index 5e2b1e7c..ace751c6 100644
--- a/ide/utils/configwin_types.ml
+++ b/ide/utils/configwin_types.ml
@@ -52,7 +52,7 @@ let string_to_key s =
| '4' -> `MOD4
| '5' -> `MOD5
| _ ->
- prerr_endline s;
+ Minilib.log s;
raise Not_found
in
mask := m :: !mask
@@ -65,7 +65,7 @@ let string_to_key s =
!mask, List.assoc key name_to_keysym
with
e ->
- prerr_endline s;
+ Minilib.log s;
raise e
let key_to_string (m, k) =
@@ -116,7 +116,7 @@ let value_to_key v =
match v with
Raw.String s -> string_to_key s
| _ ->
- prerr_endline "value_to_key";
+ Minilib.log "value_to_key";
raise Not_found
let key_to_value k =
diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml
index 1ab107c7..33968b8d 100644
--- a/ide/utils/editable_cells.ml
+++ b/ide/utils/editable_cells.ml
@@ -1,4 +1,3 @@
-open GTree
open Gobject
let create l =
diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml
index 905c3485..580f1fbc 100644
--- a/ide/utils/okey.ml
+++ b/ide/utils/okey.ml
@@ -115,7 +115,7 @@ let key_press w ev =
(fun h ->
if h.cond () then
try h.cback ()
- with e -> prerr_endline (Printexc.to_string e)
+ with e -> Minilib.log (Printexc.to_string e)
else ()
)
l;
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
new file mode 100644
index 00000000..7dad92ed
--- /dev/null
+++ b/ide/wg_Command.ml
@@ -0,0 +1,166 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Preferences
+
+class command_window name coqtop =
+ let frame = Wg_Detachable.detachable
+ ~title:(Printf.sprintf "Query pane (%s)" name) () in
+ let _ = frame#hide in
+ let _ = GtkData.AccelGroup.create () in
+ let notebook =
+ GPack.notebook ~height:200 ~scrollable:true ~packing:frame#add () in
+ let _ = frame#connect#attached ~callback:(fun _ ->
+ notebook#misc#set_size_request ~height:200 ()) in
+ let _ = frame#connect#detached ~callback:(fun _ ->
+ notebook#misc#set_size_request ~width:600 ~height:500 ();
+ notebook#misc#grab_focus ()) in
+
+object(self)
+ val frame = frame
+
+ val notebook = notebook
+
+ method pack_in (f : GObj.widget -> unit) = f frame#coerce
+
+ val mutable new_page : GObj.widget = (GMisc.label ())#coerce
+
+ val mutable views = []
+
+ method private new_page_maker =
+ let page = notebook#append_page
+ (GMisc.label ~text:"No query" ())#coerce in
+ let page = notebook#get_nth_page page in
+ let b = GButton.button () in
+ b#add (Ideutils.stock_to_widget ~size:(`CUSTOM(12,12)) `NEW);
+ ignore(b#connect#clicked ~callback:self#new_query);
+ notebook#set_page ~tab_label:b#coerce page;
+ new_page <- page
+
+ method new_query ?command ?term () = self#new_query_aux ?command ?term ()
+
+ method private new_query_aux ?command ?term ?(grab_now=true) () =
+ let frame = GBin.frame ~shadow_type:`NONE () in
+ ignore(notebook#insert_page ~pos:(notebook#page_num new_page) frame#coerce);
+ let new_tab_lbl text =
+ let hbox = GPack.hbox ~homogeneous:false () in
+ ignore(GMisc.label ~width:100 ~ellipsize:`END ~text ~packing:hbox#pack());
+ let b = GButton.button ~packing:hbox#pack () in
+ ignore(b#connect#clicked ~callback:(fun () ->
+ views <-
+ List.filter (fun (f,_,_) -> f#get_oid <> frame#coerce#get_oid) views;
+ notebook#remove_page (notebook#page_num frame#coerce)));
+ b#add (Ideutils.stock_to_widget ~size:(`CUSTOM(12,10)) `CLOSE);
+ hbox#coerce in
+ notebook#set_page ~tab_label:(new_tab_lbl "New query") frame#coerce;
+ notebook#goto_page (notebook#page_num frame#coerce);
+ let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
+ let combo, entry, ok_b =
+ let bar =
+ GButton.toolbar ~style:`ICONS ~packing:(vbox#pack ~expand:false) () in
+ let bar_add ~expand w =
+ let item = GButton.tool_item ~expand () in
+ item#add w#coerce;
+ bar#insert item in
+ let combo, _ =
+ GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving () in
+ combo#entry#set_text "Search";
+ let entry = GEdit.entry () in
+ entry#misc#set_can_default true;
+ let ok_b = GButton.button () in
+ ok_b#add (Ideutils.stock_to_widget `OK);
+ bar_add ~expand:false combo;
+ bar_add ~expand:true entry;
+ bar_add ~expand:false ok_b;
+ combo, entry, ok_b in
+ let r_bin =
+ GBin.scrolled_window
+ ~vpolicy:`AUTOMATIC
+ ~hpolicy:`AUTOMATIC
+ ~packing:(vbox#pack ~fill:true ~expand:true) () in
+ let result = GText.view ~packing:r_bin#add () in
+ views <- (frame#coerce, result, combo#entry) :: views;
+ result#misc#modify_font current.text_font;
+ let clr = Tags.color_of_string current.background_color in
+ result#misc#modify_base [`NORMAL, `COLOR clr];
+ result#misc#set_can_focus true; (* false causes problems for selection *)
+ result#set_editable false;
+ let callback () =
+ let com = combo#entry#text in
+ let arg = entry#text in
+ if Str.string_match (Str.regexp "^ *$") (com^arg) 0 then () else
+ let phrase =
+ if Str.string_match (Str.regexp "\\. *$") com 0 then com
+ else com ^ " " ^ arg ^" . "
+ in
+ let log level message = result#buffer#insert (message^"\n") in
+ let process =
+ Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
+ | Interface.Fail (_,l,str) ->
+ result#buffer#insert str;
+ notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
+ Coq.return ()
+ | Interface.Good res ->
+ result#buffer#insert res;
+ notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce;
+ Coq.return ())
+ in
+ result#buffer#set_text ("Result for command " ^ phrase ^ ":\n");
+ Coq.try_grab coqtop process ignore
+ in
+ ignore (combo#entry#connect#activate ~callback);
+ ignore (ok_b#connect#clicked ~callback);
+ begin match command with
+ | None -> ()
+ | Some c -> combo#entry#set_text c
+ end;
+ begin match term with
+ | None -> ()
+ | Some t -> entry#set_text t
+ end;
+ combo#entry#misc#grab_focus ();
+ if grab_now then entry#misc#grab_default ();
+ ignore (entry#connect#activate ~callback);
+ ignore (combo#entry#connect#activate ~callback);
+ ignore (combo#entry#event#connect#key_press ~callback:(fun ev ->
+ if GdkEvent.Key.keyval ev = GdkKeysyms._Tab then
+ (entry#misc#grab_focus ();true)
+ else false))
+
+ method show =
+ frame#show;
+ let cur_page = notebook#get_nth_page notebook#current_page in
+ let _, _, e =
+ List.find (fun (p,_,_) -> p#get_oid == cur_page#get_oid) views in
+ e#misc#grab_focus ()
+
+ method hide =
+ frame#hide
+
+ method visible =
+ frame#visible
+
+ method refresh_font () =
+ let iter (_,view,_) = view#misc#modify_font current.text_font in
+ List.iter iter views
+
+ method refresh_color () =
+ let clr = Tags.color_of_string current.background_color in
+ let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in
+ List.iter iter views
+
+ initializer
+ self#new_page_maker;
+ self#new_query_aux ~grab_now:false ();
+ frame#misc#hide ();
+ ignore(notebook#event#connect#key_press ~callback:(fun ev ->
+ if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true)
+ else false
+ ));
+
+end
diff --git a/ide/command_windows.mli b/ide/wg_Command.mli
index 4ac480c9..91a8f26c 100644
--- a/ide/command_windows.mli
+++ b/ide/wg_Command.mli
@@ -1,16 +1,18 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-class command_window :
- Coq.coqtop ref -> Preferences.pref ref ->
+class command_window : string -> Coq.coqtop ->
object
- method new_command : ?command:string -> ?term:string -> unit -> unit
- method frame : GBin.frame
+ method new_query : ?command:string -> ?term:string -> unit -> unit
+ method pack_in : (GObj.widget -> unit) -> unit
method refresh_font : unit -> unit
method refresh_color : unit -> unit
+ method show : unit
+ method hide : unit
+ method visible : bool
end
diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml
new file mode 100644
index 00000000..3f5ae4bd
--- /dev/null
+++ b/ide/wg_Completion.ml
@@ -0,0 +1,453 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module StringOrd =
+struct
+ type t = string
+ let compare s1 s2 =
+ (* we use first size, then usual comparison *)
+ let d = String.length s1 - String.length s2 in
+ if d <> 0 then d
+ else Pervasives.compare s1 s2
+end
+
+module Proposals = Set.Make(StringOrd)
+
+(** Retrieve completion proposals in the buffer *)
+let get_syntactic_completion (buffer : GText.buffer) pattern accu =
+ let rec get_aux accu (iter : GText.iter) =
+ match iter#forward_search pattern with
+ | None -> accu
+ | Some (start, stop) ->
+ if Gtk_parsing.starts_word start then
+ let ne = Gtk_parsing.find_word_end stop in
+ if ne#compare stop = 0 then get_aux accu stop
+ else
+ let proposal = buffer#get_text ~start ~stop:ne () in
+ let accu = Proposals.add proposal accu in
+ get_aux accu stop
+ else get_aux accu stop
+ in
+ get_aux accu buffer#start_iter
+
+(** Retrieve completion proposals in Coq libraries *)
+let get_semantic_completion pattern accu =
+ let flags = [Interface.Name_Pattern ("^" ^ pattern), true] in
+ (** Only get the last part of the qualified name *)
+ let rec last accu = function
+ | [] -> accu
+ | [basename] -> Proposals.add basename accu
+ | _ :: l -> last accu l
+ in
+ let next = function
+ | Interface.Good l ->
+ let fold accu elt = last accu elt.Interface.coq_object_qualid in
+ let ans = List.fold_left fold accu l in
+ Coq.return ans
+ | _ -> Coq.return accu
+ in
+ Coq.bind (Coq.search flags) next
+
+let is_substring s1 s2 =
+ let s1 = Glib.Utf8.to_unistring s1 in
+ let s2 = Glib.Utf8.to_unistring s2 in
+ let break = ref true in
+ let i = ref 0 in
+ let len1 = Array.length s1 in
+ let len2 = Array.length s2 in
+ while !break && !i < len1 && !i < len2 do
+ break := s1.(!i) = s2.(!i);
+ incr i;
+ done;
+ if !break then len2 - len1
+ else -1
+
+class type complete_model_signals =
+ object ('a)
+ method after : 'a
+ method disconnect : GtkSignal.id -> unit
+ method start_completion : callback:(int -> unit) -> GtkSignal.id
+ method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id
+ method end_completion : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+let complete_model_signals
+ (start_s : int GUtil.signal)
+ (update_s : (int * string * Proposals.t) GUtil.signal)
+ (end_s : unit GUtil.signal) : complete_model_signals =
+let signals = [
+ start_s#disconnect;
+ update_s#disconnect;
+ end_s#disconnect;
+] in
+object (self : 'a)
+ inherit GUtil.ml_signals signals as super
+ method start_completion = start_s#connect ~after
+ method update_completion = update_s#connect ~after
+ method end_completion = end_s#connect ~after
+end
+
+class complete_model coqtop (buffer : GText.buffer) =
+ let cols = new GTree.column_list in
+ let column = cols#add Gobject.Data.string in
+ let store = GTree.list_store cols in
+ let filtered_store = GTree.model_filter store in
+ let start_completion_signal = new GUtil.signal () in
+ let update_completion_signal = new GUtil.signal () in
+ let end_completion_signal = new GUtil.signal () in
+object (self)
+
+ val signals = complete_model_signals
+ start_completion_signal update_completion_signal end_completion_signal
+ val mutable active = false
+ val mutable auto_complete_length = 3
+ (* this variable prevents CoqIDE from autocompleting when we have deleted something *)
+ val mutable is_auto_completing = false
+ (* this mutex ensure that CoqIDE will not try to autocomplete twice *)
+ val mutable cache = (-1, "", Proposals.empty)
+ val mutable insert_offset = -1
+ val mutable current_completion = ("", Proposals.empty)
+ val mutable lock_auto_completing = true
+
+ method connect = signals
+
+ method active = active
+
+ method set_active b = active <- b
+
+ method private handle_insert iter s =
+ (* we're inserting, so we may autocomplete *)
+ is_auto_completing <- true
+
+ method private handle_delete ~start ~stop =
+ (* disable autocomplete *)
+ is_auto_completing <- false
+
+ method store = filtered_store
+
+ method column = column
+
+ method handle_proposal path =
+ let row = filtered_store#get_iter path in
+ let proposal = filtered_store#get ~row ~column in
+ let (start_offset, _, _) = cache in
+ (* [iter] might be invalid now, get a new one to please gtk *)
+ let iter = buffer#get_iter `INSERT in
+ (* We cancel completion when the buffer has changed recently *)
+ if iter#offset = insert_offset then begin
+ let suffix =
+ let len1 = String.length proposal in
+ let len2 = insert_offset - start_offset in
+ String.sub proposal len2 (len1 - len2)
+ in
+ buffer#begin_user_action ();
+ ignore (buffer#insert_interactive ~iter suffix);
+ buffer#end_user_action ();
+ end
+
+ method private init_proposals pref props =
+ let () = store#clear () in
+ let iter prop =
+ let iter = store#append () in
+ store#set iter column prop
+ in
+ let () = current_completion <- (pref, props) in
+ Proposals.iter iter props
+
+ method private update_proposals pref =
+ let (_, _, props) = cache in
+ let filter prop = 0 <= is_substring pref prop in
+ let props = Proposals.filter filter props in
+ let () = current_completion <- (pref, props) in
+ let () = filtered_store#refilter () in
+ props
+
+ method private do_auto_complete k =
+ let iter = buffer#get_iter `INSERT in
+ let () = insert_offset <- iter#offset in
+ let log = Printf.sprintf "Completion at offset: %i" insert_offset in
+ let () = Minilib.log log in
+ let prefix =
+ if Gtk_parsing.ends_word iter#backward_char then
+ let start = Gtk_parsing.find_word_start iter in
+ let w = buffer#get_text ~start ~stop:iter () in
+ if String.length w >= auto_complete_length then Some (w, start)
+ else None
+ else None
+ in
+ match prefix with
+ | Some (w, start) ->
+ let () = Minilib.log ("Completion of prefix: '" ^ w ^ "'") in
+ let (off, prefix, props) = cache in
+ let start_offset = start#offset in
+ (* check whether we have the last request in cache *)
+ if (start_offset = off) && (0 <= is_substring prefix w) then
+ let props = self#update_proposals w in
+ let () = update_completion_signal#call (start_offset, w, props) in
+ k ()
+ else
+ let () = start_completion_signal#call start_offset in
+ let update props =
+ let () = cache <- (start_offset, w, props) in
+ let () = self#init_proposals w props in
+ update_completion_signal#call (start_offset, w, props)
+ in
+ (** If not in the cache, we recompute it: first syntactic *)
+ let synt = get_syntactic_completion buffer w Proposals.empty in
+ (** Then semantic *)
+ let next prop =
+ let () = update prop in
+ Coq.lift k
+ in
+ let query = Coq.bind (get_semantic_completion w synt) next in
+ (** If coqtop is computing, do the syntactic completion altogether *)
+ let occupied () =
+ let () = update synt in
+ k ()
+ in
+ Coq.try_grab coqtop query occupied
+ | None -> end_completion_signal#call (); k ()
+
+ method private may_auto_complete () =
+ if active && is_auto_completing && lock_auto_completing then begin
+ let () = lock_auto_completing <- false in
+ let unlock () = lock_auto_completing <- true in
+ self#do_auto_complete unlock
+ end
+
+ initializer
+ let filter_prop model row =
+ let (_, props) = current_completion in
+ let prop = store#get ~row ~column in
+ Proposals.mem prop props
+ in
+ let () = filtered_store#set_visible_func filter_prop in
+ (* Install auto-completion *)
+ ignore (buffer#connect#insert_text ~callback:self#handle_insert);
+ ignore (buffer#connect#delete_range ~callback:self#handle_delete);
+ ignore (buffer#connect#after#end_user_action ~callback:self#may_auto_complete);
+
+end
+
+class complete_popup (model : complete_model) (view : GText.view) =
+ let obj = GWindow.window ~kind:`POPUP ~show:false () in
+ let frame = GBin.scrolled_window
+ ~hpolicy:`NEVER ~vpolicy:`NEVER
+ ~shadow_type:`OUT ~packing:obj#add ()
+ in
+(* let frame = GBin.frame ~shadow_type:`OUT ~packing:obj#add () in *)
+ let data = GTree.view
+ ~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment
+ ~rules_hint:true ~headers_visible:false
+ ~model:model#store ~packing:frame#add ()
+ in
+ let renderer = GTree.cell_renderer_text [], ["text", model#column] in
+ let col = GTree.view_column ~renderer () in
+ let _ = data#append_column col in
+ let () = col#set_sizing `AUTOSIZE in
+ let page_size = 16 in
+
+object (self)
+
+ method coerce = view#coerce
+
+ method private refresh_style () =
+ let (renderer, _) = renderer in
+ let font = Preferences.current.Preferences.text_font in
+ renderer#set_properties [`FONT_DESC font; `XPAD 10]
+
+ method private coordinates pos =
+ (** Toplevel position w.r.t. screen *)
+ let (x, y) = Gdk.Window.get_position view#misc#toplevel#misc#window in
+ (** Position of view w.r.t. window *)
+ let (ux, uy) = Gdk.Window.get_position view#misc#window in
+ (** Relative buffer position to view *)
+ let (dx, dy) = view#window_to_buffer_coords `WIDGET 0 0 in
+ (** Iter position *)
+ let iter = view#buffer#get_iter pos in
+ let coords = view#get_iter_location iter in
+ let lx = Gdk.Rectangle.x coords in
+ let ly = Gdk.Rectangle.y coords in
+ let w = Gdk.Rectangle.width coords in
+ let h = Gdk.Rectangle.height coords in
+ (** Absolute position *)
+ (x + lx + ux - dx, y + ly + uy - dy, w, h)
+
+ method private select_any f =
+ let sel = data#selection#get_selected_rows in
+ let path = match sel with
+ | [] ->
+ begin match model#store#get_iter_first with
+ | None -> None
+ | Some iter -> Some (model#store#get_path iter)
+ end
+ | path :: _ -> Some path
+ in
+ match path with
+ | None -> ()
+ | Some path ->
+ let path = f path in
+ let _ = data#selection#select_path path in
+ data#scroll_to_cell ~align:(0.,0.) path col
+
+ method private select_previous () =
+ let prev path =
+ let copy = GTree.Path.copy path in
+ if GTree.Path.prev path then path
+ else copy
+ in
+ self#select_any prev
+
+ method private select_next () =
+ let next path =
+ let () = GTree.Path.next path in
+ path
+ in
+ self#select_any next
+
+ method private select_previous_page () =
+ let rec up i path =
+ if i = 0 then path
+ else
+ let copy = GTree.Path.copy path in
+ let has_prev = GTree.Path.prev path in
+ if has_prev then up (pred i) path
+ else copy
+ in
+ self#select_any (up page_size)
+
+ method private select_next_page () =
+ let rec down i path =
+ if i = 0 then path
+ else
+ let copy = GTree.Path.copy path in
+ let iter = model#store#get_iter path in
+ let has_next = model#store#iter_next iter in
+ if has_next then down (pred i) (model#store#get_path iter)
+ else copy
+ in
+ self#select_any (down page_size)
+
+ method private select_first () =
+ let rec up path =
+ let copy = GTree.Path.copy path in
+ let has_prev = GTree.Path.prev path in
+ if has_prev then up path
+ else copy
+ in
+ self#select_any up
+
+ method private select_last () =
+ let rec down path =
+ let copy = GTree.Path.copy path in
+ let iter = model#store#get_iter path in
+ let has_next = model#store#iter_next iter in
+ if has_next then down (model#store#get_path iter)
+ else copy
+ in
+ self#select_any down
+
+ method private select_enter () =
+ let sel = data#selection#get_selected_rows in
+ match sel with
+ | [] -> ()
+ | path :: _ ->
+ let () = model#handle_proposal path in
+ self#hide ()
+
+ method proposal =
+ let sel = data#selection#get_selected_rows in
+ if obj#misc#visible then match sel with
+ | [] -> None
+ | path :: _ ->
+ let row = model#store#get_iter path in
+ let column = model#column in
+ let proposal = model#store#get ~row ~column in
+ Some proposal
+ else None
+
+ method private manage_scrollbar () =
+ (** HACK: we don't have access to the treeview size because of the lack of
+ LablGTK binding for certain functions, so we bypass it by approximating
+ it through the size of the proposals *)
+ let height = match model#store#get_iter_first with
+ | None -> -1
+ | Some iter ->
+ let path = model#store#get_path iter in
+ let area = data#get_cell_area ~path ~col () in
+ let height = Gdk.Rectangle.height area in
+ let height = page_size * height in
+ height
+ in
+ let len = ref 0 in
+ let () = model#store#foreach (fun _ _ -> incr len; false) in
+ if !len > page_size then
+ let () = frame#set_vpolicy `ALWAYS in
+ data#misc#set_size_request ~height ()
+ else
+ data#misc#set_size_request ~height:(-1) ()
+
+ method private refresh () =
+ let () = frame#set_vpolicy `NEVER in
+ let () = self#select_first () in
+ let () = obj#misc#show () in
+ let () = self#manage_scrollbar () in
+ obj#resize 1 1
+
+ method private start_callback off =
+ let (x, y, w, h) = self#coordinates (`OFFSET off) in
+ let () = obj#move x (y + 3 * h / 2) in
+ ()
+
+ method private update_callback (off, word, props) =
+ if Proposals.is_empty props then self#hide ()
+ else if Proposals.mem word props then self#hide ()
+ else self#refresh ()
+
+ method private end_callback () =
+ obj#misc#hide ()
+
+ method private hide () = self#end_callback ()
+
+ initializer
+ let move_cb _ _ ~extend = self#hide () in
+ let key_cb ev =
+ let eval cb = cb (); true in
+ let ev_key = GdkEvent.Key.keyval ev in
+ if obj#misc#visible then
+ if ev_key = GdkKeysyms._Up then eval self#select_previous
+ else if ev_key = GdkKeysyms._Down then eval self#select_next
+ else if ev_key = GdkKeysyms._Tab then eval self#select_enter
+ else if ev_key = GdkKeysyms._Return then eval self#select_enter
+ else if ev_key = GdkKeysyms._Escape then eval self#hide
+ else if ev_key = GdkKeysyms._Page_Down then eval self#select_next_page
+ else if ev_key = GdkKeysyms._Page_Up then eval self#select_previous_page
+ else if ev_key = GdkKeysyms._Home then eval self#select_first
+ else if ev_key = GdkKeysyms._End then eval self#select_last
+ else false
+ else false
+ in
+ (** Style handling *)
+ let _ = view#misc#connect#style_set self#refresh_style in
+ let _ = self#refresh_style () in
+ let _ = data#set_resize_mode `PARENT in
+ let _ = frame#set_resize_mode `PARENT in
+ (** Callback to model *)
+ let _ = model#connect#start_completion self#start_callback in
+ let _ = model#connect#update_completion self#update_callback in
+ let _ = model#connect#end_completion self#end_callback in
+ (** Popup interaction *)
+ let _ = view#event#connect#key_press key_cb in
+ (** Hiding the popup when necessary*)
+ let _ = view#misc#connect#hide obj#misc#hide in
+ let _ = view#event#connect#button_press (fun _ -> self#hide (); false) in
+ let _ = view#connect#move_cursor move_cb in
+ let _ = view#event#connect#focus_out (fun _ -> self#hide (); false) in
+ ()
+
+end
diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli
new file mode 100644
index 00000000..c3cb230d
--- /dev/null
+++ b/ide/wg_Completion.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module Proposals : sig type t end
+
+class type complete_model_signals =
+ object ('a)
+ method after : 'a
+ method disconnect : GtkSignal.id -> unit
+ method start_completion : callback:(int -> unit) -> GtkSignal.id
+ method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id
+ method end_completion : callback:(unit -> unit) -> GtkSignal.id
+ end
+
+class complete_model : Coq.coqtop -> GText.buffer ->
+object
+ method active : bool
+ method connect : complete_model_signals
+ method set_active : bool -> unit
+ method store : GTree.model_filter
+ method column : string GTree.column
+ method handle_proposal : Gtk.tree_path -> unit
+end
+
+class complete_popup : complete_model -> GText.view ->
+object
+ method coerce : GObj.widget
+ method proposal : string option
+end
diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml
new file mode 100644
index 00000000..53c634d7
--- /dev/null
+++ b/ide/wg_Detachable.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class type detachable_signals =
+ object
+ inherit GContainer.container_signals
+ method attached : callback:(GObj.widget -> unit) -> unit
+ method detached : callback:(GObj.widget -> unit) -> unit
+ end
+
+class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) =
+
+ object(self)
+ inherit GPack.box_skel (obj :> Gtk.box Gobject.obj) as super
+
+ val but = GButton.button ()
+ val win = GWindow.window ()
+ val frame = GBin.frame ~shadow_type:`NONE ()
+ val mutable detached = false
+ val mutable detached_cb = (fun _ -> ())
+ val mutable attached_cb = (fun _ -> ())
+
+ method child = frame#child
+ method add = frame#add
+ method pack ?from ?expand ?fill ?padding w =
+ if frame#all_children = [] then self#add w
+ else raise (Invalid_argument "detachable#pack")
+
+ method title = win#title
+ method set_title = win#set_title
+
+ method connect : detachable_signals = object
+ inherit GContainer.container_signals_impl obj
+ method attached ~callback = attached_cb <- callback
+ method detached ~callback = detached_cb <- callback
+ end
+
+ method show =
+ if detached then win#present ()
+ else self#misc#show ();
+
+ method hide =
+ if detached then win#misc#hide ()
+ else self#misc#hide ()
+
+ method visible = win#misc#visible || self#misc#visible
+
+ method frame = frame
+
+ method button = but
+
+ method attach () =
+ win#misc#hide ();
+ frame#misc#reparent self#coerce;
+ detached <- false;
+ attached_cb self#child
+
+ method detach () =
+ frame#misc#reparent win#coerce;
+ self#misc#hide ();
+ win#present ();
+ detached <- true;
+ detached_cb self#child
+
+ initializer
+ self#set_homogeneous false;
+ super#pack ~expand:false but#coerce;
+ super#pack ~expand:true ~fill:true frame#coerce;
+ win#misc#hide ();
+ but#add (GMisc.label
+ ~markup:"<span size='x-small'>D\nE\nT\nA\nC\nH</span>" ())#coerce;
+ ignore(win#event#connect#delete ~callback:(fun _ -> self#attach (); true));
+ ignore(but#connect#clicked ~callback:(fun _ -> self#detach ()))
+
+ end
+
+let detachable ?title =
+ GtkPack.Box.make_params [] ~cont:(
+ GContainer.pack_container
+ ~create:(fun p ->
+ let d = new detachable (GtkPack.Box.create `HORIZONTAL p) in
+ Option.iter d#set_title title;
+ d))
+
diff --git a/ide/wg_Detachable.mli b/ide/wg_Detachable.mli
new file mode 100644
index 00000000..71f85ad8
--- /dev/null
+++ b/ide/wg_Detachable.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class type detachable_signals =
+ object
+ inherit GContainer.container_signals
+ method attached : callback:(GObj.widget -> unit) -> unit
+ method detached : callback:(GObj.widget -> unit) -> unit
+ end
+
+class detachable : ([> Gtk.box] as 'a) Gobject.obj ->
+ object
+ inherit GPack.box_skel
+ val obj : Gtk.box Gobject.obj
+ method connect : detachable_signals
+ method child : GObj.widget
+ method show : unit
+ method hide : unit
+ method visible : bool
+ method title : string
+ method set_title : string -> unit
+ method button : GButton.button
+ method frame : GBin.frame
+ method detach : unit -> unit
+ method attach : unit -> unit
+ end
+
+val detachable :
+ ?title:string ->
+ ?homogeneous:bool ->
+ ?spacing:int ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> detachable
+
+
diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml
new file mode 100644
index 00000000..b6f63a3b
--- /dev/null
+++ b/ide/wg_Find.ml
@@ -0,0 +1,199 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type mode = [ `FIND | `REPLACE ]
+
+class finder name (view : GText.view) =
+
+ let widget = Wg_Detachable.detachable
+ ~title:(Printf.sprintf "Find & Replace (%s)" name) () in
+ let replace_box = GPack.table ~columns:4 ~rows:2 ~homogeneous:false
+ ~packing:widget#add () in
+ let hb = GPack.hbox ~packing:(replace_box#attach
+ ~left:1 ~top:0 ~expand:`X ~fill:`X) () in
+ let use_regex =
+ GButton.check_button ~label:"Regular expression"
+ ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in
+ let use_nocase =
+ GButton.check_button ~label:"Case insensitive"
+ ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in
+ let _ = GMisc.label ~text:"Find:" ~xalign:1.0
+ ~packing:(replace_box#attach
+ ~xpadding:3 ~ypadding:3 ~left:0 ~top:1 ~fill:`X) () in
+ let _ = GMisc.label ~text:"Replace:" ~xalign:1.0
+ ~packing:(replace_box#attach
+ ~xpadding:3 ~ypadding:3 ~left:0 ~top:2 ~fill:`X) () in
+ let find_entry = GEdit.entry ~editable:true
+ ~packing:(replace_box#attach
+ ~xpadding:3 ~ypadding:3 ~left:1 ~top:1 ~expand:`X ~fill:`X) () in
+ let replace_entry = GEdit.entry ~editable:true
+ ~packing:(replace_box#attach
+ ~xpadding:3 ~ypadding:3 ~left:1 ~top:2 ~expand:`X ~fill:`X) () in
+ let next_button = GButton.button ~label:"_Next" ~use_mnemonic:true
+ ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:1) () in
+ let previous_button = GButton.button ~label:"_Previous" ~use_mnemonic:true
+ ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:1) () in
+ let replace_button = GButton.button ~label:"_Replace" ~use_mnemonic:true
+ ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:2) () in
+ let replace_all_button =
+ GButton.button ~label:"Replace _All" ~use_mnemonic:true
+ ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:2) () in
+
+ object (self)
+ val mutable last_found = None
+
+ method coerce = widget#coerce
+
+ method private get_selected_word () =
+ let start = view#buffer#get_iter `INSERT in
+ let stop = view#buffer#get_iter `SEL_BOUND in
+ view#buffer#get_text ~start ~stop ()
+
+ method private may_replace () =
+ (self#search_text <> "") &&
+ (Str.string_match self#regex (self#get_selected_word ()) 0)
+
+ method replace () =
+ if self#may_replace () then
+ let txt = self#get_selected_word () in
+ let _ = view#buffer#delete_selection () in
+ let _ = view#buffer#insert_interactive (self#replacement txt) in
+ self#find_forward ()
+ else self#find_forward ()
+
+ method private regex =
+ let rex = self#search_text in
+ if use_regex#active then
+ if use_nocase#active then Str.regexp_case_fold rex
+ else Str.regexp rex
+ else
+ if use_nocase#active then Str.regexp_string_case_fold rex
+ else Str.regexp_string rex
+
+ method private replacement txt =
+ if use_regex#active then Str.replace_matched replace_entry#text txt
+ else replace_entry#text
+
+ method private backward_search starti =
+ let text = view#buffer#start_iter#get_text ~stop:starti in
+ let regexp = self#regex in
+ try
+ let i = Str.search_backward regexp text (String.length text - 1) in
+ let j = Str.match_end () in
+ Some(view#buffer#start_iter#forward_chars i,
+ view#buffer#start_iter#forward_chars j)
+ with Not_found -> None
+
+ method private forward_search starti =
+ let text = starti#get_text ~stop:view#buffer#end_iter in
+ let regexp = self#regex in
+ try
+ let i = Str.search_forward regexp text 0 in
+ let j = Str.match_end () in
+ Some(starti#forward_chars i, starti#forward_chars j)
+ with Not_found -> None
+
+ method replace_all () =
+ let rec replace_at (iter : GText.iter) =
+ let found = self#forward_search iter in
+ match found with
+ | None -> ()
+ | Some (start, stop) ->
+ let text = iter#get_text ~stop:view#buffer#end_iter in
+ let start_mark = view#buffer#create_mark start in
+ let stop_mark = view#buffer#create_mark ~left_gravity:false stop in
+ let _ = view#buffer#delete_interactive ~start ~stop () in
+ let iter = view#buffer#get_iter_at_mark (`MARK start_mark) in
+ let _ = view#buffer#insert_interactive ~iter (self#replacement text)in
+ let next = view#buffer#get_iter_at_mark (`MARK stop_mark) in
+ let () = view#buffer#delete_mark (`MARK start_mark) in
+ let () = view#buffer#delete_mark (`MARK stop_mark) in
+ replace_at next
+ in
+ replace_at view#buffer#start_iter
+
+ method private set_not_found () =
+ find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"];
+
+ method private set_found () =
+ find_entry#misc#modify_base [`NORMAL, `NAME "#BAF9CE"]
+
+ method private set_normal () =
+ find_entry#misc#modify_base [`NORMAL, `NAME "white"]
+
+ method private find_from backward (starti : GText.iter) =
+ let found =
+ if backward then self#backward_search starti
+ else self#forward_search starti in
+ match found with
+ | None ->
+ if not backward && not (starti#equal view#buffer#start_iter) then
+ self#find_from backward view#buffer#start_iter
+ else if backward && not (starti#equal view#buffer#end_iter) then
+ self#find_from backward view#buffer#end_iter
+ else
+ self#set_not_found ()
+ | Some (start, stop) ->
+ let _ = view#buffer#select_range start stop in
+ let scroll = `MARK (view#buffer#create_mark stop) in
+ let _ = view#scroll_to_mark ~use_align:false scroll in
+ self#set_found ()
+
+ method find_forward () =
+ let starti = view#buffer#get_iter `SEL_BOUND in
+ self#find_from false starti
+
+ method find_backward () =
+ let starti = view#buffer#get_iter `INSERT in
+ self#find_from true starti
+
+ method private search_text = find_entry#text
+
+ method hide () =
+ widget#hide;
+ view#coerce#misc#grab_focus ()
+
+ method show () =
+ widget#show;
+ find_entry#misc#grab_focus ()
+
+ initializer
+ let _ = self#hide () in
+
+ (** Widget button interaction *)
+ let _ = next_button#connect#clicked ~callback:self#find_forward in
+ let _ = previous_button#connect#clicked ~callback:self#find_backward in
+ let _ = replace_button#connect#clicked ~callback:self#replace in
+ let _ = replace_all_button#connect#clicked ~callback:self#replace_all in
+
+ (** Keypress interaction *)
+ let generic_cb esc_cb ret_cb ev =
+ let ev_key = GdkEvent.Key.keyval ev in
+ let (return, _) = GtkData.AccelGroup.parse "Return" in
+ let (esc, _) = GtkData.AccelGroup.parse "Escape" in
+ if ev_key = return then (ret_cb (); true)
+ else if ev_key = esc then (esc_cb (); true)
+ else false
+ in
+ let find_cb = generic_cb self#hide self#find_forward in
+ let replace_cb = generic_cb self#hide self#replace in
+ let _ = find_entry#event#connect#key_press find_cb in
+ let _ = replace_entry#event#connect#key_press replace_cb in
+
+ (** TextView interaction *)
+ let view_cb ev =
+ if widget#visible then
+ let ev_key = GdkEvent.Key.keyval ev in
+ if ev_key = GdkKeysyms._Escape then (widget#hide; true)
+ else false
+ else false
+ in
+ let _ = view#event#connect#key_press view_cb in
+ ()
+
+ end
diff --git a/ide/wg_Find.mli b/ide/wg_Find.mli
new file mode 100644
index 00000000..7811fc43
--- /dev/null
+++ b/ide/wg_Find.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class finder : string -> GText.view ->
+ object
+ method coerce : GObj.widget
+ method hide : unit -> unit
+ method show : unit -> unit
+ method replace : unit -> unit
+ method replace_all : unit -> unit
+ method find_backward : unit -> unit
+ method find_forward : unit -> unit
+ end
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
new file mode 100644
index 00000000..9acda53f
--- /dev/null
+++ b/ide/wg_MessageView.ml
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class type message_view =
+ object
+ inherit GObj.widget
+ method clear : unit
+ method add : string -> unit
+ method set : string -> unit
+ method push : Pp.message_level -> string -> unit
+ (** same as [add], but with an explicit level instead of [Notice] *)
+ method buffer : GText.buffer
+ (** for more advanced text edition *)
+ method modify_font : Pango.font_description -> unit
+ end
+
+let message_view () : message_view =
+ let buffer = GSourceView2.source_buffer
+ ~highlight_matching_brackets:true
+ ~tag_table:Tags.Message.table ()
+ in
+ let text_buffer = new GText.buffer buffer#as_buffer in
+ let box = GPack.vbox () in
+ let scroll = GBin.scrolled_window
+ ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in
+ let view = GSourceView2.source_view
+ ~source_buffer:buffer ~packing:scroll#add
+ ~editable:false ~cursor_visible:false ~wrap_mode:`WORD ()
+ in
+ let default_clipboard = GData.clipboard Gdk.Atom.primary in
+ let _ = buffer#add_selection_clipboard default_clipboard in
+ let () = view#set_left_margin 2 in
+ object (self)
+ inherit GObj.widget box#as_widget
+
+ method clear =
+ buffer#set_text ""
+
+ method push level msg =
+ let tags = match level with
+ | Pp.Error -> [Tags.Message.error]
+ | Pp.Warning -> [Tags.Message.warning]
+ | _ -> []
+ in
+ if msg <> "" then begin
+ buffer#insert ~tags msg;
+ buffer#insert ~tags "\n"
+ end
+
+ method add msg = self#push Pp.Notice msg
+
+ method set msg = self#clear; self#add msg
+
+ method buffer = text_buffer
+
+ method modify_font fd = view#misc#modify_font fd
+
+ end
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
new file mode 100644
index 00000000..cd3f00c9
--- /dev/null
+++ b/ide/wg_MessageView.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class type message_view =
+ object
+ inherit GObj.widget
+ method clear : unit
+ method add : string -> unit
+ method set : string -> unit
+ method push : Pp.message_level -> string -> unit
+ (** same as [add], but with an explicit level instead of [Notice] *)
+ method buffer : GText.buffer
+ (** for more advanced text edition *)
+ method modify_font : Pango.font_description -> unit
+ end
+
+val message_view : unit -> message_view
diff --git a/ide/typed_notebook.ml b/ide/wg_Notebook.ml
index dde86625..0611c3f3 100644
--- a/ide/typed_notebook.ml
+++ b/ide/wg_Notebook.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -16,14 +16,14 @@ object(self)
(* XXX - Temporary hack to compile with archaic lablgtk *)
ignore (super#append_page ?tab_label ?menu_label page);
let real_pos = super#page_num page in
- let lower,higher = Minilib.list_chop real_pos term_list in
+ let lower,higher = Util.List.chop real_pos term_list in
term_list <- lower@[term]@higher;
real_pos
(* XXX - Temporary hack to compile with archaic lablgtk
method insert_term ?(build=default_build) ?pos (term:'a) =
let tab_label,menu_label,page = build term in
let real_pos = super#insert_page ?tab_label ?menu_label ?pos page in
- let lower,higher = Minilib.list_chop real_pos term_list in
+ let lower,higher = Util.List.chop real_pos term_list in
term_list <- lower@[term]@higher;
real_pos
*)
@@ -32,26 +32,26 @@ object(self)
(* XXX - Temporary hack to compile with archaic lablgtk *)
ignore (super#prepend_page ?tab_label ?menu_label page);
let real_pos = super#page_num page in
- let lower,higher = Minilib.list_chop real_pos term_list in
+ let lower,higher = Util.List.chop real_pos term_list in
term_list <- lower@[term]@higher;
real_pos
method set_term (term:'a) =
let tab_label,menu_label,page = make_page term in
let real_pos = super#current_page in
- term_list <- Minilib.list_map_i (fun i x -> if i = real_pos then term else x) 0 term_list;
+ term_list <- Util.List.map_i (fun i x -> if i = real_pos then term else x) 0 term_list;
super#set_page ?tab_label ?menu_label page
method get_nth_term i =
List.nth term_list i
- method term_num p =
- Minilib.list_index0 p term_list
+ method term_num f p =
+ Util.List.index0 f p term_list
method pages = term_list
method remove_page index =
- term_list <- Minilib.list_filter_i (fun i x -> if i = index then kill_page x; i <> index) term_list;
+ term_list <- Util.List.filteri (fun i x -> if i = index then kill_page x; i <> index) term_list;
super#remove_page index
method current_term =
diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli
new file mode 100644
index 00000000..15a2ba41
--- /dev/null
+++ b/ide/wg_Notebook.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class ['a] typed_notebook :
+ ('a -> GObj.widget option * GObj.widget option * GObj.widget) ->
+ ('a -> unit) ->
+ Gtk.notebook Gtk.obj ->
+object
+ inherit GPack.notebook
+ method append_term : 'a -> int
+ method prepend_term : 'a -> int
+ method set_term : 'a -> unit
+ method get_nth_term : int -> 'a
+ method term_num : ('a -> 'a -> bool) -> 'a -> int
+ method pages : 'a list
+ method remove_page : int -> unit
+ method current_term : 'a
+end
+
+val create :
+ ('a -> GObj.widget option * GObj.widget option * GObj.widget) ->
+ ('a -> unit) ->
+ ?enable_popup:bool ->
+ ?homogeneous_tabs:bool ->
+ ?scrollable:bool ->
+ ?show_border:bool ->
+ ?show_tabs:bool ->
+ ?tab_border:int ->
+ ?tab_pos:Gtk.Tags.position ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> 'a typed_notebook
diff --git a/ide/ideproof.ml b/ide/wg_ProofView.ml
index 5244bf04..7e7a311e 100644
--- a/ide/ideproof.ml
+++ b/ide/wg_ProofView.ml
@@ -1,11 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+class type proof_view =
+ object
+ inherit GObj.widget
+ method refresh : unit -> unit
+ method clear : unit -> unit
+ method set_goals : Interface.goals option -> unit
+ method set_evars : Interface.evar list option -> unit
+ method width : int
+ end
(* tag is the tag to be hooked, item is the item covered by this tag, make_menu
* * is the template for building menu if needed, sel_cb is the callback if
@@ -34,7 +43,7 @@ let hook_tag_cb tag menu_content sel_cb hover_cb =
hover_cb start stop; false
| _ -> false))
-let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
+let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
| [] -> assert false
| { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: rem_goals ->
let on_hover sel_start sel_stop =
@@ -50,7 +59,7 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
in
let goals_cnt = List.length rem_goals + 1 in
let head_str = Printf.sprintf
- "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s")
+ "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "")
in
let goal_str index total = Printf.sprintf
"______________________________________(%d/%d)\n" index total
@@ -84,21 +93,21 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
in
proof#buffer#insert (goal_str 1 goals_cnt);
proof#buffer#insert ~tags cur_goal;
- proof#buffer#insert "\n"
+ proof#buffer#insert "\n"
in
(* Insert remaining goals (no hypotheses) *)
let fold_goal i _ { Interface.goal_ccl = g } =
proof#buffer#insert (goal_str i goals_cnt);
proof#buffer#insert (g ^ "\n")
in
- let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in
+ let () = Util.List.fold_left_i fold_goal 2 () rem_goals in
ignore(proof#buffer#place_cursor
~where:(proof#buffer#end_iter#backward_to_tag_toggle
- (Some Tags.Proof.goal)));
+ (Some Tags.Proof.goal)));
ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT)
-let mode_cesar (proof:GText.view) = function
+let mode_cesar (proof : #GText.view_skel) = function
| [] -> assert false
| { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ ->
proof#buffer#insert " *** Declarative Mode ***\n";
@@ -115,18 +124,18 @@ let rec flatten = function
let inner = flatten l in
List.rev_append lg inner @ rg
-let display mode (view:GText.view) goals hints evars =
+let display mode (view : #GText.view_skel) goals hints evars =
let () = view#buffer#set_text "" in
match goals with
| None -> ()
(* No proof in progress *)
- | Some { Interface.fg_goals = []; Interface.bg_goals = bg } ->
+ | Some { Interface.fg_goals = []; bg_goals = bg; shelved_goals; given_up_goals; } ->
let bg = flatten (List.rev bg) in
let evars = match evars with None -> [] | Some evs -> evs in
- begin match (bg, evars) with
- | [], [] ->
+ begin match (bg, shelved_goals,given_up_goals, evars) with
+ | [], [], [], [] ->
view#buffer#insert "No more subgoals."
- | [], _ :: _ ->
+ | [], [], [], _ :: _ ->
(* A proof has been finished, but not concluded *)
view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n";
let iter evar =
@@ -134,7 +143,23 @@ let display mode (view:GText.view) goals hints evars =
view#buffer#insert msg
in
List.iter iter evars
- | _, _ ->
+ | [], [], _, _ ->
+ (* The proof is finished, with the exception of given up goals. *)
+ view#buffer#insert "No more, however there are goals you gave up. You need to go back and solve them:\n\n";
+ let iter goal =
+ let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
+ view#buffer#insert msg
+ in
+ List.iter iter given_up_goals
+ | [], _, _, _ ->
+ (* All the goals have been resolved but those on the shelf. *)
+ view#buffer#insert "All the remaining goals are on the shelf:\n\n";
+ let iter goal =
+ let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
+ view#buffer#insert msg
+ in
+ List.iter iter shelved_goals
+ | _, _, _, _ ->
(* No foreground proofs, but still unfocused ones *)
view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n";
let iter goal =
@@ -145,3 +170,33 @@ let display mode (view:GText.view) goals hints evars =
end
| Some { Interface.fg_goals = fg } ->
mode view fg hints
+
+let proof_view () =
+ let buffer = GSourceView2.source_buffer
+ ~highlight_matching_brackets:true
+ ~tag_table:Tags.Proof.table ()
+ in
+ let view = GSourceView2.source_view
+ ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD ()
+ in
+ let default_clipboard = GData.clipboard Gdk.Atom.primary in
+ let _ = buffer#add_selection_clipboard default_clipboard in
+ object
+ inherit GObj.widget view#as_widget
+ val mutable goals = None
+ val mutable evars = None
+
+ method clear () = buffer#set_text ""
+
+ method set_goals gls = goals <- gls
+
+ method set_evars evs = evars <- evs
+
+ method refresh () =
+ let dummy _ () = () in
+ display (mode_tactic dummy) (view :> GText.view_skel) goals None evars
+
+ method width = Ideutils.textview_width (view :> GText.view_skel)
+ end
+
+(* ignore (proof_buffer#add_selection_clipboard cb); *)
diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli
new file mode 100644
index 00000000..1fbf9900
--- /dev/null
+++ b/ide/wg_ProofView.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+class type proof_view =
+ object
+ inherit GObj.widget
+ method refresh : unit -> unit
+ method clear : unit -> unit
+ method set_goals : Interface.goals option -> unit
+ method set_evars : Interface.evar list option -> unit
+ method width : int
+ end
+
+val proof_view : unit -> proof_view
diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml
new file mode 100644
index 00000000..1f399070
--- /dev/null
+++ b/ide/wg_ScriptView.ml
@@ -0,0 +1,467 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type insert_action = {
+ ins_val : string;
+ ins_off : int;
+ ins_len : int;
+ ins_mrg : bool;
+}
+
+type delete_action = {
+ del_val : string; (** Contents *)
+ del_off : int; (** Absolute offset of the modification *)
+ del_len : int; (** Length *)
+ del_mrg : bool; (** Is the modification mergeable? *)
+}
+
+type action =
+ | Insert of insert_action
+ | Delete of delete_action
+ | Action of action list
+ | EndGrp (** pending begin_user_action *)
+
+let merge_insert ins = function
+| Insert ins' :: rem ->
+ if ins.ins_mrg && ins'.ins_mrg &&
+ (ins'.ins_off + ins'.ins_len = ins.ins_off) then
+ let nins = {
+ ins_val = ins'.ins_val ^ ins.ins_val;
+ ins_off = ins'.ins_off;
+ ins_len = ins'.ins_len + ins.ins_len;
+ ins_mrg = true;
+ } in
+ Insert nins :: rem
+ else
+ Insert ins :: Insert ins' :: rem
+| l ->
+ Insert ins :: l
+
+let merge_delete del = function
+| Delete del' :: rem ->
+ if del.del_mrg && del'.del_mrg &&
+ (del.del_off + del.del_len = del'.del_off) then
+ let ndel = {
+ del_val = del.del_val ^ del'.del_val;
+ del_off = del.del_off;
+ del_len = del.del_len + del'.del_len;
+ del_mrg = true;
+ } in
+ Delete ndel :: rem
+ else
+ Delete del :: Delete del' :: rem
+| l ->
+ Delete del :: l
+
+let rec negate_action act = match act with
+ | Insert act ->
+ let act = {
+ del_len = act.ins_len;
+ del_off = act.ins_off;
+ del_val = act.ins_val;
+ del_mrg = act.ins_mrg;
+ } in
+ Delete act
+ | Delete act ->
+ let act = {
+ ins_len = act.del_len;
+ ins_off = act.del_off;
+ ins_val = act.del_val;
+ ins_mrg = act.del_mrg;
+ } in
+ Insert act
+ | Action acts ->
+ Action (List.rev_map negate_action acts)
+ | EndGrp -> assert false
+
+type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj
+
+class undo_manager (buffer : GText.buffer) =
+object(self)
+ val mutable lock_undo = true
+ val mutable history = []
+ val mutable redo = []
+
+ method with_lock_undo : 'a. ('a -> unit) -> 'a -> unit =
+ fun f x ->
+ if lock_undo then
+ let () = lock_undo <- false in
+ try (f x; lock_undo <- true)
+ with e -> (lock_undo <- true; raise e)
+ else ()
+
+ method private dump_debug () =
+ let rec iter = function
+ | Insert act ->
+ Printf.eprintf "Insert of '%s' at %d (length %d, mergeable %b)\n%!"
+ act.ins_val act.ins_off act.ins_len act.ins_mrg
+ | Delete act ->
+ Printf.eprintf "Delete '%s' from %d (length %d, mergeable %b)\n%!"
+ act.del_val act.del_off act.del_len act.del_mrg
+ | Action l ->
+ Printf.eprintf "Action\n%!";
+ List.iter iter l;
+ Printf.eprintf "//Action\n%!";
+ | EndGrp ->
+ Printf.eprintf "End Group\n%!"
+ in
+ if false (* !debug *) then begin
+ Printf.eprintf "+++++++++++++++++++++++++++++++++++++\n%!";
+ Printf.eprintf "==========Undo Stack top=============\n%!";
+ List.iter iter history;
+ Printf.eprintf "Stack size %d\n" (List.length history);
+ Printf.eprintf "==========Undo Stack Bottom==========\n%!";
+ Printf.eprintf "==========Redo Stack start===========\n%!";
+ List.iter iter redo;
+ Printf.eprintf "Stack size %d\n" (List.length redo);
+ Printf.eprintf "==========Redo Stack End=============\n%!";
+ Printf.eprintf "+++++++++++++++++++++++++++++++++++++\n%!";
+ end
+
+ method clear_undo () =
+ history <- [];
+ redo <- []
+
+ (** Warning: processing actually undo the action *)
+ method private process_insert_action ins =
+ let start = buffer#get_iter (`OFFSET ins.ins_off) in
+ let stop = start#forward_chars ins.ins_len in
+ buffer#delete_interactive ~start ~stop ()
+
+ method private process_delete_action del =
+ let iter = buffer#get_iter (`OFFSET del.del_off) in
+ buffer#insert_interactive ~iter del.del_val
+
+ (** We don't care about atomicity. Return:
+ 1. `OK when there was no error, `FAIL otherwise
+ 2. `NOOP if no write occured, `WRITE otherwise
+ *)
+ method private process_action = function
+ | Insert ins ->
+ if self#process_insert_action ins then (`OK, `WRITE) else (`FAIL, `NOOP)
+ | Delete del ->
+ if self#process_delete_action del then (`OK, `WRITE) else (`FAIL, `NOOP)
+ | Action lst ->
+ let fold accu action = match accu with
+ | (`FAIL, _) -> accu (** we stop now! *)
+ | (`OK, status) ->
+ let (res, nstatus) = self#process_action action in
+ let merge op1 op2 = match op1, op2 with
+ | `NOOP, `NOOP -> `NOOP (** only a noop when both are *)
+ | _ -> `WRITE
+ in
+ (res, merge status nstatus)
+ in
+ List.fold_left fold (`OK, `NOOP) lst
+ | EndGrp -> assert false
+
+ method perform_undo () = match history with
+ | [] -> ()
+ | action :: rem ->
+ let ans = self#process_action action in
+ begin match ans with
+ | (`OK, _) ->
+ history <- rem;
+ redo <- (negate_action action) :: redo
+ | (`FAIL, `NOOP) -> () (** we do nothing *)
+ | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed, so start off *)
+ end
+
+ method perform_redo () = match redo with
+ | [] -> ()
+ | action :: rem ->
+ let ans = self#process_action action in
+ begin match ans with
+ | (`OK, _) ->
+ redo <- rem;
+ history <- (negate_action action) :: history;
+ | (`FAIL, `NOOP) -> () (** we do nothing *)
+ | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed *)
+ end
+
+ method undo () =
+ Minilib.log "UNDO";
+ self#with_lock_undo self#perform_undo ();
+
+ method redo () =
+ Minilib.log "REDO";
+ self#with_lock_undo self#perform_redo ();
+
+ method process_begin_user_action () =
+ (* Push a new level of event on history stack *)
+ history <- EndGrp :: history
+
+ method begin_user_action () =
+ self#with_lock_undo self#process_begin_user_action ()
+
+ method process_end_user_action () =
+ (** Search for the pending action *)
+ let rec split accu = function
+ | [] -> raise Not_found (** no pending begin action! *)
+ | EndGrp :: rem ->
+ let grp = List.rev accu in
+ let rec flatten = function
+ | [] -> rem
+ | [Insert ins] -> merge_insert ins rem
+ | [Delete del] -> merge_delete del rem
+ | [Action l] -> flatten l
+ | _ -> Action grp :: rem
+ in
+ flatten grp
+ | action :: rem ->
+ split (action :: accu) rem
+ in
+ try (history <- split [] history; self#dump_debug ())
+ with Not_found ->
+ Minilib.log "Error: Badly parenthezised user action";
+ self#clear_undo ()
+
+ method end_user_action () =
+ self#with_lock_undo self#process_end_user_action ()
+
+ method private process_handle_insert iter s =
+ (* Save the insert action *)
+ let len = Glib.Utf8.length s in
+ let mergeable =
+ (** heuristic: split at newline and atomic pastes *)
+ len = 1 && (s <> "\n")
+ in
+ let ins = {
+ ins_val = s;
+ ins_off = iter#offset;
+ ins_len = len;
+ ins_mrg = mergeable;
+ } in
+ let () = history <- Insert ins :: history in
+ ()
+
+ method private handle_insert iter s =
+ self#with_lock_undo (self#process_handle_insert iter) s
+
+ method private process_handle_delete start stop =
+ (* Save the delete action *)
+ let text = buffer#get_text ~start ~stop () in
+ let len = Glib.Utf8.length text in
+ let mergeable = len = 1 && (text <> "\n") in
+ let del = {
+ del_val = text;
+ del_off = start#offset;
+ del_len = stop#offset - start#offset;
+ del_mrg = mergeable;
+ } in
+ let action = Delete del in
+ history <- action :: history;
+ redo <- [];
+
+ method private handle_delete ~start ~stop =
+ self#with_lock_undo (self#process_handle_delete start) stop
+
+ initializer
+ let _ = buffer#connect#after#begin_user_action ~callback:self#begin_user_action in
+ let _ = buffer#connect#after#end_user_action ~callback:self#end_user_action in
+ let _ = buffer#connect#insert_text ~callback:self#handle_insert in
+ let _ = buffer#connect#delete_range ~callback:self#handle_delete in
+ ()
+
+end
+
+class script_view (tv : source_view) (ct : Coq.coqtop) =
+
+let view = new GSourceView2.source_view (Gobject.unsafe_cast tv) in
+let completion = new Wg_Completion.complete_model ct view#buffer in
+let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in
+
+object (self)
+ inherit GSourceView2.source_view (Gobject.unsafe_cast tv) as super
+
+ val undo_manager = new undo_manager view#buffer
+
+ method auto_complete = completion#active
+
+ method set_auto_complete flag =
+ completion#set_active flag
+
+ method recenter_insert =
+ self#scroll_to_mark
+ ~use_align:false ~yalign:0.75 ~within_margin:0.25 `INSERT
+
+ (* HACK: missing gtksourceview features *)
+ method right_margin_position =
+ let prop = {
+ Gobject.name = "right-margin-position";
+ conv = Gobject.Data.int;
+ } in
+ Gobject.get prop obj
+
+ method set_right_margin_position pos =
+ let prop = {
+ Gobject.name = "right-margin-position";
+ conv = Gobject.Data.int;
+ } in
+ Gobject.set prop obj pos
+
+ method show_right_margin =
+ let prop = {
+ Gobject.name = "show-right-margin";
+ conv = Gobject.Data.boolean;
+ } in
+ Gobject.get prop obj
+
+ method set_show_right_margin show =
+ let prop = {
+ Gobject.name = "show-right-margin";
+ conv = Gobject.Data.boolean;
+ } in
+ Gobject.set prop obj show
+
+ method comment () =
+ let rec get_line_start iter =
+ if iter#starts_line then iter
+ else get_line_start iter#backward_char
+ in
+ let (start, stop) =
+ if self#buffer#has_selection then
+ self#buffer#selection_bounds
+ else
+ let insert = self#buffer#get_iter `INSERT in
+ (get_line_start insert, insert#forward_to_line_end)
+ in
+ let stop_mark = self#buffer#create_mark ~left_gravity:false stop in
+ let () = self#buffer#begin_user_action () in
+ let was_inserted = self#buffer#insert_interactive ~iter:start "(* " in
+ let stop = self#buffer#get_iter_at_mark (`MARK stop_mark) in
+ let () = if was_inserted then ignore (self#buffer#insert_interactive ~iter:stop " *)") in
+ let () = self#buffer#end_user_action () in
+ self#buffer#delete_mark (`MARK stop_mark)
+
+ method uncomment () =
+ let rec get_left_iter depth (iter : GText.iter) =
+ let prev_close = iter#backward_search "*)" in
+ let prev_open = iter#backward_search "(*" in
+ let prev_object = match prev_close, prev_open with
+ | None, None | Some _, None -> `NONE
+ | None, Some (po, _) -> `OPEN po
+ | Some (co, _), Some (po, _) -> if co#compare po < 0 then `OPEN po else `CLOSE co
+ in
+ match prev_object with
+ | `NONE -> None
+ | `OPEN po ->
+ if depth <= 0 then Some po
+ else get_left_iter (pred depth) po
+ | `CLOSE co ->
+ get_left_iter (succ depth) co
+ in
+ let rec get_right_iter depth (iter : GText.iter) =
+ let next_close = iter#forward_search "*)" in
+ let next_open = iter#forward_search "(*" in
+ let next_object = match next_close, next_open with
+ | None, None | None, Some _ -> `NONE
+ | Some (_, co), None -> `CLOSE co
+ | Some (_, co), Some (_, po) ->
+ if co#compare po > 0 then `OPEN po else `CLOSE co
+ in
+ match next_object with
+ | `NONE -> None
+ | `OPEN po ->
+ get_right_iter (succ depth) po
+ | `CLOSE co ->
+ if depth <= 0 then Some co
+ else get_right_iter (pred depth) co
+ in
+ let insert = self#buffer#get_iter `INSERT in
+ let left_elt = get_left_iter 0 insert in
+ let right_elt = get_right_iter 0 insert in
+ match left_elt, right_elt with
+ | Some liter, Some riter ->
+ let stop_mark = self#buffer#create_mark ~left_gravity:false riter in
+ (* We remove one trailing/leading space if it exists *)
+ let lcontent = self#buffer#get_text ~start:liter ~stop:(liter#forward_chars 3) () in
+ let rcontent = self#buffer#get_text ~start:(riter#backward_chars 3) ~stop:riter () in
+ let llen = if lcontent = "(* " then 3 else 2 in
+ let rlen = if rcontent = " *)" then 3 else 2 in
+ (* Atomic operation for the user *)
+ let () = self#buffer#begin_user_action () in
+ let was_deleted = self#buffer#delete_interactive ~start:liter ~stop:(liter#forward_chars llen) () in
+ let riter = self#buffer#get_iter_at_mark (`MARK stop_mark) in
+ if was_deleted then ignore (self#buffer#delete_interactive ~start:(riter#backward_chars rlen) ~stop:riter ());
+ let () = self#buffer#end_user_action () in
+ self#buffer#delete_mark (`MARK stop_mark)
+ | _ -> ()
+
+ method complete_popup = popup
+
+ method undo = undo_manager#undo
+ method redo = undo_manager#redo
+ method clear_undo = undo_manager#clear_undo
+
+ method private paste () =
+ let cb = GData.clipboard Gdk.Atom.clipboard in
+ match cb#text with
+ | None -> ()
+ | Some text ->
+ let () = self#buffer#begin_user_action () in
+ let _ = self#buffer#delete_selection () in
+ let _ = self#buffer#insert_interactive text in
+ self#buffer#end_user_action ()
+
+ initializer
+ let supersed cb _ =
+ let _ = cb () in
+ GtkSignal.stop_emit()
+ in
+ (* HACK: Redirect the undo/redo signals of the underlying GtkSourceView *)
+ let _ = self#connect#undo ~callback:(supersed self#undo) in
+ let _ = self#connect#redo ~callback:(supersed self#redo) in
+ (* HACK: Redirect the paste signal *)
+ let _ = self#connect#paste_clipboard ~callback:(supersed self#paste) in
+ (* HACK: Redirect the move_line signal of the underlying GtkSourceView *)
+ let move_line_marshal = GtkSignal.marshal2
+ Gobject.Data.boolean Gobject.Data.int "move_line_marshal"
+ in
+ let move_line_signal = {
+ GtkSignal.name = "move-lines";
+ classe = Obj.magic 0;
+ marshaller = move_line_marshal; }
+ in
+ let callback b i =
+ let rec start_line iter =
+ if iter#starts_line then iter
+ else start_line iter#backward_char
+ in
+ let iter = start_line (self#buffer#get_iter `INSERT) in
+ (* do we forward the signal? *)
+ let proceed =
+ if not b && i = 1 then
+ iter#editable ~default:true &&
+ iter#forward_line#editable ~default:true
+ else if not b && i = -1 then
+ iter#editable ~default:true &&
+ iter#backward_line#editable ~default:true
+ else false
+ in
+ if not proceed then GtkSignal.stop_emit ()
+ in
+ let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in
+ ()
+
+end
+
+let script_view ct ?(source_buffer:GSourceView2.source_buffer option) ?draw_spaces =
+ GtkSourceView2.SourceView.make_params [] ~cont:(
+ GtkText.View.make_params ~cont:(
+ GContainer.pack_container ~create:
+ (fun pl ->
+ let w = match source_buffer with
+ | None -> GtkSourceView2.SourceView.new_ ()
+ | Some buf -> GtkSourceView2.SourceView.new_with_buffer
+ (Gobject.try_cast buf#as_buffer "GtkSourceBuffer")
+ in
+ let w = Gobject.unsafe_cast w in
+ Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl;
+ Gaux.may ~f:(GtkSourceView2.SourceView.set_draw_spaces w) draw_spaces;
+ ((new script_view w ct) : script_view))))
diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli
new file mode 100644
index 00000000..6e54c445
--- /dev/null
+++ b/ide/wg_ScriptView.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* An undoable view class *)
+
+type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj
+
+class script_view : source_view -> Coq.coqtop ->
+object
+ inherit GSourceView2.source_view
+ method undo : unit -> unit
+ method redo : unit -> unit
+ method clear_undo : unit -> unit
+ method auto_complete : bool
+ method set_auto_complete : bool -> unit
+ method right_margin_position : int
+ method set_right_margin_position : int -> unit
+ method show_right_margin : bool
+ method set_show_right_margin : bool -> unit
+ method comment : unit -> unit
+ method uncomment : unit -> unit
+ method recenter_insert : unit
+ method complete_popup : Wg_Completion.complete_popup
+end
+
+val script_view : Coq.coqtop ->
+ ?source_buffer:GSourceView2.source_buffer ->
+ ?draw_spaces:SourceView2Enums.source_draw_spaces_flags list ->
+ ?auto_indent:bool ->
+ ?highlight_current_line:bool ->
+ ?indent_on_tab:bool ->
+ ?indent_width:int ->
+ ?insert_spaces_instead_of_tabs:bool ->
+ ?right_margin_position:int ->
+ ?show_line_marks:bool ->
+ ?show_line_numbers:bool ->
+ ?show_right_margin:bool ->
+ ?smart_home_end:SourceView2Enums.source_smart_home_end_type ->
+ ?tab_width:int ->
+ ?editable:bool ->
+ ?cursor_visible:bool ->
+ ?justification:GtkEnums.justification ->
+ ?wrap_mode:GtkEnums.wrap_mode ->
+ ?accepts_tab:bool ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) ->
+ ?show:bool -> unit -> script_view
diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml
new file mode 100644
index 00000000..8520727a
--- /dev/null
+++ b/ide/wg_Segment.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Util
+
+type color = GDraw.color
+
+module Segment :
+sig
+ type +'a t
+ val length : 'a t -> int
+ val resize : 'a t -> int -> 'a t
+ val empty : 'a t
+ val add : int -> 'a -> 'a t -> 'a t
+ val remove : int -> 'a t -> 'a t
+ val fold : ('a -> 'a -> bool) -> (int -> int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end =
+struct
+ type 'a t = {
+ length : int;
+ content : 'a Int.Map.t;
+ }
+
+ let empty = { length = 0; content = Int.Map.empty }
+
+ let length s = s.length
+
+ let resize s len =
+ if s.length <= len then { s with length = len }
+ else
+ let filter i v = i < len in
+ { length = len; content = Int.Map.filter filter s.content }
+
+ let add i v s =
+ if i < s.length then
+ { s with content = Int.Map.add i v s.content }
+ else s
+
+ let remove i s = { s with content = Int.Map.remove i s.content }
+
+ let fold eq f s accu =
+ let make k v (cur, accu) = match cur with
+ | None -> Some (k, k, v), accu
+ | Some (i, j, w) ->
+ if k = j + 1 && eq v w then Some (i, k, w), accu
+ else Some (k, k, v), (i, j, w) :: accu
+ in
+ let p, segments = Int.Map.fold make s.content (None, []) in
+ let segments = match p with
+ | None -> segments
+ | Some p -> p :: segments
+ in
+ List.fold_left (fun accu (i, j, v) -> f i j v accu) accu segments
+
+end
+
+let i2f = float_of_int
+let f2i = int_of_float
+
+let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with
+| `BLACK, `BLACK -> true
+| `COLOR c1, `COLOR c2 -> c1 == c2
+| `NAME s1, `NAME s2 -> String.equal s1 s2
+| `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2
+| `WHITE, `WHITE -> true
+| _ -> false
+
+class segment () =
+let box = GBin.frame () in
+let draw = GMisc.image ~packing:box#add () in
+object (self)
+
+ inherit GObj.widget box#as_widget
+
+ val mutable width = 1
+ val mutable height = 20
+ val mutable data = Segment.empty
+ val mutable default : color = `WHITE
+ val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 ()
+
+ initializer
+ box#misc#set_size_request ~height ();
+ let cb rect =
+ let w = rect.Gtk.width in
+ let h = rect.Gtk.height in
+ (** Only refresh when size actually changed, otherwise loops *)
+ if self#misc#visible && (width <> w || height <> h) then begin
+ width <- w;
+ height <- h;
+ self#redraw ();
+ end
+ in
+ let _ = box#misc#connect#size_allocate cb in
+ (** Initial pixmap *)
+ draw#set_pixmap pixmap
+
+ method length = Segment.length data
+
+ method set_length len =
+ data <- Segment.resize data len;
+ if self#misc#visible then self#refresh ()
+
+ method private fill_range color i j =
+ let i = i2f i in
+ let j = i2f j in
+ let width = i2f width in
+ let len = i2f (Segment.length data) in
+ let x = f2i ((i *. width) /. len) in
+ let x' = f2i ((j *. width) /. len) in
+ let w = x' - x in
+ pixmap#set_foreground color;
+ pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true ();
+ draw#set_mask None;
+
+ method add i color =
+ data <- Segment.add i color data;
+ if self#misc#visible then self#fill_range color i (i + 1)
+
+ method remove i =
+ data <- Segment.remove i data;
+ if self#misc#visible then self#fill_range default i (i + 1)
+
+ method set_default_color color = default <- color
+ method default_color = default
+
+ method private redraw () =
+ pixmap <- GDraw.pixmap ~width ~height ();
+ draw#set_pixmap pixmap;
+ self#refresh ();
+
+ method private refresh () =
+ pixmap#set_foreground default;
+ pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
+ let fold i j v () = self#fill_range v i (j + 1) in
+ Segment.fold color_eq fold data ();
+ draw#set_mask None;
+
+end
diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli
new file mode 100644
index 00000000..ecb45147
--- /dev/null
+++ b/ide/wg_Segment.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type color = GDraw.color
+
+class segment : unit ->
+ object
+ inherit GObj.widget
+ val obj : Gtk.widget Gtk.obj
+ method length : int
+ method set_length : int -> unit
+ method default_color : color
+ method set_default_color : color -> unit
+ method add : int -> color -> unit
+ method remove : int -> unit
+ end
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
new file mode 100644
index 00000000..d337a911
--- /dev/null
+++ b/ide/xmlprotocol.ml
@@ -0,0 +1,737 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Protocol version of this file. This is the date of the last modification. *)
+
+(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
+
+let protocol_version = "20140312"
+
+(** * Interface of calls to Coq by CoqIde *)
+
+open Util
+open Interface
+open Serialize
+open Xml_datatype
+
+(* Marshalling of basic types and type constructors *)
+module Xml_marshalling = struct
+
+let of_search_cst = function
+ | Name_Pattern s ->
+ constructor "search_cst" "name_pattern" [of_string s]
+ | Type_Pattern s ->
+ constructor "search_cst" "type_pattern" [of_string s]
+ | SubType_Pattern s ->
+ constructor "search_cst" "subtype_pattern" [of_string s]
+ | In_Module m ->
+ constructor "search_cst" "in_module" [of_list of_string m]
+ | Include_Blacklist ->
+ constructor "search_cst" "include_blacklist" []
+let to_search_cst = do_match "search_cst" (fun s args -> match s with
+ | "name_pattern" -> Name_Pattern (to_string (singleton args))
+ | "type_pattern" -> Type_Pattern (to_string (singleton args))
+ | "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
+ | "in_module" -> In_Module (to_list to_string (singleton args))
+ | "include_blacklist" -> Include_Blacklist
+ | _ -> raise Marshal_error)
+
+let of_coq_object f ans =
+ let prefix = of_list of_string ans.coq_object_prefix in
+ let qualid = of_list of_string ans.coq_object_qualid in
+ let obj = f ans.coq_object_object in
+ Element ("coq_object", [], [prefix; qualid; obj])
+
+let to_coq_object f = function
+| Element ("coq_object", [], [prefix; qualid; obj]) ->
+ let prefix = to_list to_string prefix in
+ let qualid = to_list to_string qualid in
+ let obj = f obj in {
+ coq_object_prefix = prefix;
+ coq_object_qualid = qualid;
+ coq_object_object = obj;
+ }
+| _ -> raise Marshal_error
+
+let of_option_value = function
+ | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i]
+ | BoolValue b -> constructor "option_value" "boolvalue" [of_bool b]
+ | StringValue s -> constructor "option_value" "stringvalue" [of_string s]
+let to_option_value = do_match "option_value" (fun s args -> match s with
+ | "intvalue" -> IntValue (to_option to_int (singleton args))
+ | "boolvalue" -> BoolValue (to_bool (singleton args))
+ | "stringvalue" -> StringValue (to_string (singleton args))
+ | _ -> raise Marshal_error)
+
+let of_option_state s =
+ Element ("option_state", [], [
+ of_bool s.opt_sync;
+ of_bool s.opt_depr;
+ of_string s.opt_name;
+ of_option_value s.opt_value])
+let to_option_state = function
+ | Element ("option_state", [], [sync; depr; name; value]) -> {
+ opt_sync = to_bool sync;
+ opt_depr = to_bool depr;
+ opt_name = to_string name;
+ opt_value = to_option_value value }
+ | _ -> raise Marshal_error
+
+
+let of_value f = function
+| Good x -> Element ("value", ["val", "good"], [f x])
+| Fail (id,loc, msg) ->
+ let loc = match loc with
+ | None -> []
+ | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in
+ let id = Stateid.to_xml id in
+ Element ("value", ["val", "fail"] @ loc, [id;PCData msg])
+let to_value f = function
+| Element ("value", attrs, l) ->
+ let ans = massoc "val" attrs in
+ if ans = "good" then Good (f (singleton l))
+ else if ans = "fail" then
+ let loc =
+ try
+ let loc_s = int_of_string (Serialize.massoc "loc_s" attrs) in
+ let loc_e = int_of_string (Serialize.massoc "loc_e" attrs) in
+ Some (loc_s, loc_e)
+ with Marshal_error | Failure _ -> None
+ in
+ let id = Stateid.of_xml (List.hd l) in
+ let msg = raw_string (List.tl l) in
+ Fail (id, loc, msg)
+ else raise Marshal_error
+| _ -> raise Marshal_error
+
+let of_status s =
+ let of_so = of_option of_string in
+ let of_sl = of_list of_string in
+ Element ("status", [], [
+ of_sl s.status_path;
+ of_so s.status_proofname;
+ of_sl s.status_allproofs;
+ of_int s.status_proofnum; ])
+let to_status = function
+ | Element ("status", [], [path; name; prfs; pnum]) -> {
+ status_path = to_list to_string path;
+ status_proofname = to_option to_string name;
+ status_allproofs = to_list to_string prfs;
+ status_proofnum = to_int pnum; }
+ | _ -> raise Marshal_error
+
+let of_evar s = Element ("evar", [], [PCData s.evar_info])
+let to_evar = function
+ | Element ("evar", [], data) -> { evar_info = raw_string data; }
+ | _ -> raise Marshal_error
+
+let of_goal g =
+ let hyp = of_list of_string g.goal_hyp in
+ let ccl = of_string g.goal_ccl in
+ let id = of_string g.goal_id in
+ Element ("goal", [], [id; hyp; ccl])
+let to_goal = function
+ | Element ("goal", [], [id; hyp; ccl]) ->
+ let hyp = to_list to_string hyp in
+ let ccl = to_string ccl in
+ let id = to_string id in
+ { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
+ | _ -> raise Marshal_error
+
+let of_goals g =
+ let of_glist = of_list of_goal in
+ let fg = of_list of_goal g.fg_goals in
+ let bg = of_list (of_pair of_glist of_glist) g.bg_goals in
+ let shelf = of_list of_goal g.shelved_goals in
+ let given_up = of_list of_goal g.given_up_goals in
+ Element ("goals", [], [fg; bg; shelf; given_up])
+let to_goals = function
+ | Element ("goals", [], [fg; bg; shelf; given_up]) ->
+ let to_glist = to_list to_goal in
+ let fg = to_list to_goal fg in
+ let bg = to_list (to_pair to_glist to_glist) bg in
+ let shelf = to_list to_goal shelf in
+ let given_up = to_list to_goal given_up in
+ { fg_goals = fg; bg_goals = bg; shelved_goals = shelf;
+ given_up_goals = given_up }
+ | _ -> raise Marshal_error
+
+let of_coq_info info =
+ let version = of_string info.coqtop_version in
+ let protocol = of_string info.protocol_version in
+ let release = of_string info.release_date in
+ let compile = of_string info.compile_date in
+ Element ("coq_info", [], [version; protocol; release; compile])
+let to_coq_info = function
+ | Element ("coq_info", [], [version; protocol; release; compile]) -> {
+ coqtop_version = to_string version;
+ protocol_version = to_string protocol;
+ release_date = to_string release;
+ compile_date = to_string compile; }
+ | _ -> raise Marshal_error
+
+end
+include Xml_marshalling
+
+(* Reification of basic types and type constructors, and functions
+ from to xml *)
+module ReifType : sig
+
+ type 'a val_t
+
+ val unit_t : unit val_t
+ val string_t : string val_t
+ val int_t : int val_t
+ val bool_t : bool val_t
+ val xml_t : Xml_datatype.xml val_t
+
+ val option_t : 'a val_t -> 'a option val_t
+ val list_t : 'a val_t -> 'a list val_t
+ val pair_t : 'a val_t -> 'b val_t -> ('a * 'b) val_t
+ val union_t : 'a val_t -> 'b val_t -> ('a ,'b) union val_t
+
+ val goals_t : goals val_t
+ val evar_t : evar val_t
+ val state_t : status val_t
+ val option_state_t : option_state val_t
+ val option_value_t : option_value val_t
+ val coq_info_t : coq_info val_t
+ val coq_object_t : 'a val_t -> 'a coq_object val_t
+ val state_id_t : state_id val_t
+ val search_cst_t : search_constraint val_t
+
+ val of_value_type : 'a val_t -> 'a -> xml
+ val to_value_type : 'a val_t -> xml -> 'a
+
+ val print : 'a val_t -> 'a -> string
+
+ type value_type
+ val erase : 'a val_t -> value_type
+ val print_type : value_type -> string
+
+ val document_type_encoding : (xml -> string) -> unit
+
+end = struct
+
+ type value_type =
+ | Unit | String | Int | Bool | Xml
+
+ | Option of value_type
+ | List of value_type
+ | Pair of value_type * value_type
+ | Union of value_type * value_type
+
+ | Goals | Evar | State | Option_state | Option_value | Coq_info
+ | Coq_object of value_type
+ | State_id
+ | Search_cst
+
+ type 'a val_t = value_type
+
+ let erase (x : 'a val_t) : value_type = x
+
+ let unit_t = Unit
+ let string_t = String
+ let int_t = Int
+ let bool_t = Bool
+ let xml_t = Xml
+
+ let option_t x = Option x
+ let list_t x = List x
+ let pair_t x y = Pair (x, y)
+ let union_t x y = Union (x, y)
+
+ let goals_t = Goals
+ let evar_t = Evar
+ let state_t = State
+ let option_state_t = Option_state
+ let option_value_t = Option_value
+ let coq_info_t = Coq_info
+ let coq_object_t x = Coq_object x
+ let state_id_t = State_id
+ let search_cst_t = Search_cst
+
+ let of_value_type (ty : 'a val_t) : 'a -> xml =
+ let rec convert ty : 'a -> xml = match ty with
+ | Unit -> Obj.magic of_unit
+ | Bool -> Obj.magic of_bool
+ | Xml -> Obj.magic (fun x -> x)
+ | String -> Obj.magic of_string
+ | Int -> Obj.magic of_int
+ | State -> Obj.magic of_status
+ | Option_state -> Obj.magic of_option_state
+ | Option_value -> Obj.magic of_option_value
+ | Coq_info -> Obj.magic of_coq_info
+ | Goals -> Obj.magic of_goals
+ | Evar -> Obj.magic of_evar
+ | List t -> Obj.magic (of_list (convert t))
+ | Option t -> Obj.magic (of_option (convert t))
+ | Coq_object t -> Obj.magic (of_coq_object (convert t))
+ | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2))
+ | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2))
+ | State_id -> Obj.magic Stateid.to_xml
+ | Search_cst -> Obj.magic of_search_cst
+ in
+ convert ty
+
+ let to_value_type (ty : 'a val_t) : xml -> 'a =
+ let rec convert ty : xml -> 'a = match ty with
+ | Unit -> Obj.magic to_unit
+ | Bool -> Obj.magic to_bool
+ | Xml -> Obj.magic (fun x -> x)
+ | String -> Obj.magic to_string
+ | Int -> Obj.magic to_int
+ | State -> Obj.magic to_status
+ | Option_state -> Obj.magic to_option_state
+ | Option_value -> Obj.magic to_option_value
+ | Coq_info -> Obj.magic to_coq_info
+ | Goals -> Obj.magic to_goals
+ | Evar -> Obj.magic to_evar
+ | List t -> Obj.magic (to_list (convert t))
+ | Option t -> Obj.magic (to_option (convert t))
+ | Coq_object t -> Obj.magic (to_coq_object (convert t))
+ | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2))
+ | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2))
+ | State_id -> Obj.magic Stateid.of_xml
+ | Search_cst -> Obj.magic to_search_cst
+ in
+ convert ty
+
+ let pr_unit () = ""
+ let pr_string s = Printf.sprintf "%S" s
+ let pr_int i = string_of_int i
+ let pr_bool b = Printf.sprintf "%B" b
+ let pr_goal (g : goals) =
+ if g.fg_goals = [] then
+ if g.bg_goals = [] then "Proof completed."
+ else
+ let rec pr_focus _ = function
+ | [] -> assert false
+ | [lg, rg] -> Printf.sprintf "%i" (List.length lg + List.length rg)
+ | (lg, rg) :: l ->
+ Printf.sprintf "%i:%a"
+ (List.length lg + List.length rg) pr_focus l in
+ Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
+ else
+ let pr_menu s = s in
+ let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
+ "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^
+ pr_menu goal ^ "]" in
+ String.concat " " (List.map pr_goal g.fg_goals)
+ let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
+ let pr_status (s : status) =
+ let path =
+ let l = String.concat "." s.status_path in
+ "path=" ^ l ^ ";" in
+ let name = match s.status_proofname with
+ | None -> "no proof;"
+ | Some n -> "proof = " ^ n ^ ";" in
+ "Status: " ^ path ^ name
+ let pr_coq_info (i : coq_info) = "FIXME"
+ let pr_option_value = function
+ | IntValue None -> "none"
+ | IntValue (Some i) -> string_of_int i
+ | StringValue s -> s
+ | BoolValue b -> if b then "true" else "false"
+ let pr_option_state (s : option_state) =
+ Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n"
+ s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value)
+ let pr_list pr l = "["^String.concat ";" (List.map pr l)^"]"
+ let pr_option pr = function None -> "None" | Some x -> "Some("^pr x^")"
+ let pr_coq_object (o : 'a coq_object) = "FIXME"
+ let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")"
+ let pr_union pr1 pr2 = function Inl x -> "Inl "^pr1 x | Inr x -> "Inr "^pr2 x
+
+ let pr_search_cst = function
+ | Name_Pattern s -> "Name_Pattern " ^ s
+ | Type_Pattern s -> "Type_Pattern " ^ s
+ | SubType_Pattern s -> "SubType_Pattern " ^ s
+ | In_Module s -> "In_Module " ^ String.concat "." s
+ | Include_Blacklist -> "Include_Blacklist"
+
+ let rec print = function
+ | Unit -> Obj.magic pr_unit
+ | Bool -> Obj.magic pr_bool
+ | String -> Obj.magic pr_string
+ | Xml -> Obj.magic Xml_printer.to_string_fmt
+ | Int -> Obj.magic pr_int
+ | State -> Obj.magic pr_status
+ | Option_state -> Obj.magic pr_option_state
+ | Option_value -> Obj.magic pr_option_value
+ | Search_cst -> Obj.magic pr_search_cst
+ | Coq_info -> Obj.magic pr_coq_info
+ | Goals -> Obj.magic pr_goal
+ | Evar -> Obj.magic pr_evar
+ | List t -> Obj.magic (pr_list (print t))
+ | Option t -> Obj.magic (pr_option (print t))
+ | Coq_object t -> Obj.magic pr_coq_object
+ | Pair (t1,t2) -> Obj.magic (pr_pair (print t1) (print t2))
+ | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2))
+ | State_id -> Obj.magic pr_int
+
+ (* This is to break if a rename/refactoring makes the strings below outdated *)
+ type 'a exists = bool
+
+ let rec print_type = function
+ | Unit -> "unit"
+ | Bool -> "bool"
+ | String -> "string"
+ | Xml -> "xml"
+ | Int -> "int"
+ | State -> assert(true : status exists); "Interface.status"
+ | Option_state -> assert(true : option_state exists); "Interface.option_state"
+ | Option_value -> assert(true : option_value exists); "Interface.option_value"
+ | Search_cst -> assert(true : search_constraint exists); "Interface.search_constraint"
+ | Coq_info -> assert(true : coq_info exists); "Interface.coq_info"
+ | Goals -> assert(true : goals exists); "Interface.goals"
+ | Evar -> assert(true : evar exists); "Interface.evar"
+ | List t -> Printf.sprintf "(%s list)" (print_type t)
+ | Option t -> Printf.sprintf "(%s option)" (print_type t)
+ | Coq_object t -> assert(true : 'a coq_object exists);
+ Printf.sprintf "(%s Interface.coq_object)" (print_type t)
+ | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2)
+ | Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists);
+ Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2)
+ | State_id -> assert(true : Stateid.t exists); "Stateid.t"
+
+ let document_type_encoding pr_xml =
+ Printf.printf "\n=== Data encoding by examples ===\n\n";
+ Printf.printf "%s:\n\n%s\n\n" (print_type Unit) (pr_xml (of_unit ()));
+ Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool)
+ (pr_xml (of_bool true)) (pr_xml (of_bool false));
+ Printf.printf "%s:\n\n%s\n\n" (print_type String) (pr_xml (of_string "hello"));
+ Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256));
+ Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial));
+ Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5]));
+ Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int))
+ (pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None));
+ Printf.printf "%s:\n\n%s\n\n" (print_type (Pair (Bool,Int)))
+ (pr_xml (of_pair of_bool of_int (false,3)));
+ Printf.printf "%s:\n\n%s\n\n" (print_type (Union (Bool,Int)))
+ (pr_xml (of_union of_bool of_int (Inl false)));
+ print_endline ("All other types are records represented by a node named like the OCaml\n"^
+ "type which contains a flattened n-tuple. We provide one example.\n");
+ Printf.printf "%s:\n\n%s\n\n" (print_type Option_state)
+ (pr_xml (of_option_state { opt_sync = true; opt_depr = false;
+ opt_name = "name1"; opt_value = IntValue (Some 37) }));
+
+end
+open ReifType
+
+(** Types reification, checked with explicit casts *)
+let add_sty_t : add_sty val_t =
+ pair_t (pair_t string_t int_t) (pair_t state_id_t bool_t)
+let edit_at_sty_t : edit_at_sty val_t = state_id_t
+let query_sty_t : query_sty val_t = pair_t string_t state_id_t
+let goals_sty_t : goals_sty val_t = unit_t
+let evars_sty_t : evars_sty val_t = unit_t
+let hints_sty_t : hints_sty val_t = unit_t
+let status_sty_t : status_sty val_t = bool_t
+let search_sty_t : search_sty val_t = list_t (pair_t search_cst_t bool_t)
+let get_options_sty_t : get_options_sty val_t = unit_t
+let set_options_sty_t : set_options_sty val_t =
+ list_t (pair_t (list_t string_t) option_value_t)
+let mkcases_sty_t : mkcases_sty val_t = string_t
+let quit_sty_t : quit_sty val_t = unit_t
+let about_sty_t : about_sty val_t = unit_t
+let init_sty_t : init_sty val_t = option_t string_t
+let interp_sty_t : interp_sty val_t = pair_t (pair_t bool_t bool_t) string_t
+let stop_worker_sty_t : stop_worker_sty val_t = string_t
+let print_ast_sty_t : print_ast_sty val_t = state_id_t
+let annotate_sty_t : annotate_sty val_t = string_t
+
+let add_rty_t : add_rty val_t =
+ pair_t state_id_t (pair_t (union_t unit_t state_id_t) string_t)
+let edit_at_rty_t : edit_at_rty val_t =
+ union_t unit_t (pair_t state_id_t (pair_t state_id_t state_id_t))
+let query_rty_t : query_rty val_t = string_t
+let goals_rty_t : goals_rty val_t = option_t goals_t
+let evars_rty_t : evars_rty val_t = option_t (list_t evar_t)
+let hints_rty_t : hints_rty val_t =
+ let hint = list_t (pair_t string_t string_t) in
+ option_t (pair_t (list_t hint) hint)
+let status_rty_t : status_rty val_t = state_t
+let search_rty_t : search_rty val_t = list_t (coq_object_t string_t)
+let get_options_rty_t : get_options_rty val_t =
+ list_t (pair_t (list_t string_t) option_state_t)
+let set_options_rty_t : set_options_rty val_t = unit_t
+let mkcases_rty_t : mkcases_rty val_t = list_t (list_t string_t)
+let quit_rty_t : quit_rty val_t = unit_t
+let about_rty_t : about_rty val_t = coq_info_t
+let init_rty_t : init_rty val_t = state_id_t
+let interp_rty_t : interp_rty val_t = pair_t state_id_t (union_t string_t string_t)
+let stop_worker_rty_t : stop_worker_rty val_t = unit_t
+let print_ast_rty_t : print_ast_rty val_t = xml_t
+let annotate_rty_t : annotate_rty val_t = xml_t
+
+let ($) x = erase x
+let calls = [|
+ "Add", ($)add_sty_t, ($)add_rty_t;
+ "Edit_at", ($)edit_at_sty_t, ($)edit_at_rty_t;
+ "Query", ($)query_sty_t, ($)query_rty_t;
+ "Goal", ($)goals_sty_t, ($)goals_rty_t;
+ "Evars", ($)evars_sty_t, ($)evars_rty_t;
+ "Hints", ($)hints_sty_t, ($)hints_rty_t;
+ "Status", ($)status_sty_t, ($)status_rty_t;
+ "Search", ($)search_sty_t, ($)search_rty_t;
+ "GetOptions", ($)get_options_sty_t, ($)get_options_rty_t;
+ "SetOptions", ($)set_options_sty_t, ($)set_options_rty_t;
+ "MkCases", ($)mkcases_sty_t, ($)mkcases_rty_t;
+ "Quit", ($)quit_sty_t, ($)quit_rty_t;
+ "About", ($)about_sty_t, ($)about_rty_t;
+ "Init", ($)init_sty_t, ($)init_rty_t;
+ "Interp", ($)interp_sty_t, ($)interp_rty_t;
+ "StopWorker", ($)stop_worker_sty_t, ($)stop_worker_rty_t;
+ "PrintAst", ($)print_ast_sty_t, ($)print_ast_rty_t;
+ "Annotate", ($)annotate_sty_t, ($)annotate_rty_t;
+|]
+
+type 'a call =
+ | Add of add_sty
+ | Edit_at of edit_at_sty
+ | Query of query_sty
+ | Goal of goals_sty
+ | Evars of evars_sty
+ | Hints of hints_sty
+ | Status of status_sty
+ | Search of search_sty
+ | GetOptions of get_options_sty
+ | SetOptions of set_options_sty
+ | MkCases of mkcases_sty
+ | Quit of quit_sty
+ | About of about_sty
+ | Init of init_sty
+ | StopWorker of stop_worker_sty
+ (* retrocompatibility *)
+ | Interp of interp_sty
+ | PrintAst of print_ast_sty
+ | Annotate of annotate_sty
+
+let id_of_call = function
+ | Add _ -> 0
+ | Edit_at _ -> 1
+ | Query _ -> 2
+ | Goal _ -> 3
+ | Evars _ -> 4
+ | Hints _ -> 5
+ | Status _ -> 6
+ | Search _ -> 7
+ | GetOptions _ -> 8
+ | SetOptions _ -> 9
+ | MkCases _ -> 10
+ | Quit _ -> 11
+ | About _ -> 12
+ | Init _ -> 13
+ | Interp _ -> 14
+ | StopWorker _ -> 15
+ | PrintAst _ -> 16
+ | Annotate _ -> 17
+
+let str_of_call c = pi1 calls.(id_of_call c)
+
+type unknown
+
+(** We use phantom types and GADT to protect ourselves against wild casts *)
+let add x : add_rty call = Add x
+let edit_at x : edit_at_rty call = Edit_at x
+let query x : query_rty call = Query x
+let goals x : goals_rty call = Goal x
+let evars x : evars_rty call = Evars x
+let hints x : hints_rty call = Hints x
+let status x : status_rty call = Status x
+let get_options x : get_options_rty call = GetOptions x
+let set_options x : set_options_rty call = SetOptions x
+let mkcases x : mkcases_rty call = MkCases x
+let search x : search_rty call = Search x
+let quit x : quit_rty call = Quit x
+let init x : init_rty call = Init x
+let interp x : interp_rty call = Interp x
+let stop_worker x : stop_worker_rty call = StopWorker x
+let print_ast x : print_ast_rty call = PrintAst x
+let annotate x : annotate_rty call = Annotate x
+
+let abstract_eval_call handler (c : 'a call) : 'a value =
+ let mkGood x : 'a value = Good (Obj.magic x) in
+ try
+ match c with
+ | Add x -> mkGood (handler.add x)
+ | Edit_at x -> mkGood (handler.edit_at x)
+ | Query x -> mkGood (handler.query x)
+ | Goal x -> mkGood (handler.goals x)
+ | Evars x -> mkGood (handler.evars x)
+ | Hints x -> mkGood (handler.hints x)
+ | Status x -> mkGood (handler.status x)
+ | Search x -> mkGood (handler.search x)
+ | GetOptions x -> mkGood (handler.get_options x)
+ | SetOptions x -> mkGood (handler.set_options x)
+ | MkCases x -> mkGood (handler.mkcases x)
+ | Quit x -> mkGood (handler.quit x)
+ | About x -> mkGood (handler.about x)
+ | Init x -> mkGood (handler.init x)
+ | Interp x -> mkGood (handler.interp x)
+ | StopWorker x -> mkGood (handler.stop_worker x)
+ | PrintAst x -> mkGood (handler.print_ast x)
+ | Annotate x -> mkGood (handler.annotate x)
+ with any ->
+ let any = Errors.push any in
+ Fail (handler.handle_exn any)
+
+(** brain dead code, edit if protocol messages are added/removed *)
+let of_answer (q : 'a call) (v : 'a value) : xml = match q with
+ | Add _ -> of_value (of_value_type add_rty_t ) (Obj.magic v)
+ | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) (Obj.magic v)
+ | Query _ -> of_value (of_value_type query_rty_t ) (Obj.magic v)
+ | Goal _ -> of_value (of_value_type goals_rty_t ) (Obj.magic v)
+ | Evars _ -> of_value (of_value_type evars_rty_t ) (Obj.magic v)
+ | Hints _ -> of_value (of_value_type hints_rty_t ) (Obj.magic v)
+ | Status _ -> of_value (of_value_type status_rty_t ) (Obj.magic v)
+ | Search _ -> of_value (of_value_type search_rty_t ) (Obj.magic v)
+ | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v)
+ | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v)
+ | MkCases _ -> of_value (of_value_type mkcases_rty_t ) (Obj.magic v)
+ | Quit _ -> of_value (of_value_type quit_rty_t ) (Obj.magic v)
+ | About _ -> of_value (of_value_type about_rty_t ) (Obj.magic v)
+ | Init _ -> of_value (of_value_type init_rty_t ) (Obj.magic v)
+ | Interp _ -> of_value (of_value_type interp_rty_t ) (Obj.magic v)
+ | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v)
+ | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) (Obj.magic v)
+ | Annotate _ -> of_value (of_value_type annotate_rty_t ) (Obj.magic v)
+
+let to_answer (q : 'a call) (x : xml) : 'a value = match q with
+ | Add _ -> Obj.magic (to_value (to_value_type add_rty_t ) x)
+ | Edit_at _ -> Obj.magic (to_value (to_value_type edit_at_rty_t ) x)
+ | Query _ -> Obj.magic (to_value (to_value_type query_rty_t ) x)
+ | Goal _ -> Obj.magic (to_value (to_value_type goals_rty_t ) x)
+ | Evars _ -> Obj.magic (to_value (to_value_type evars_rty_t ) x)
+ | Hints _ -> Obj.magic (to_value (to_value_type hints_rty_t ) x)
+ | Status _ -> Obj.magic (to_value (to_value_type status_rty_t ) x)
+ | Search _ -> Obj.magic (to_value (to_value_type search_rty_t ) x)
+ | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x)
+ | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x)
+ | MkCases _ -> Obj.magic (to_value (to_value_type mkcases_rty_t ) x)
+ | Quit _ -> Obj.magic (to_value (to_value_type quit_rty_t ) x)
+ | About _ -> Obj.magic (to_value (to_value_type about_rty_t ) x)
+ | Init _ -> Obj.magic (to_value (to_value_type init_rty_t ) x)
+ | Interp _ -> Obj.magic (to_value (to_value_type interp_rty_t ) x)
+ | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x)
+ | PrintAst _ -> Obj.magic (to_value (to_value_type print_ast_rty_t ) x)
+ | Annotate _ -> Obj.magic (to_value (to_value_type annotate_rty_t ) x)
+
+let of_call (q : 'a call) : xml =
+ let mkCall x = constructor "call" (str_of_call q) [x] in
+ match q with
+ | Add x -> mkCall (of_value_type add_sty_t x)
+ | Edit_at x -> mkCall (of_value_type edit_at_sty_t x)
+ | Query x -> mkCall (of_value_type query_sty_t x)
+ | Goal x -> mkCall (of_value_type goals_sty_t x)
+ | Evars x -> mkCall (of_value_type evars_sty_t x)
+ | Hints x -> mkCall (of_value_type hints_sty_t x)
+ | Status x -> mkCall (of_value_type status_sty_t x)
+ | Search x -> mkCall (of_value_type search_sty_t x)
+ | GetOptions x -> mkCall (of_value_type get_options_sty_t x)
+ | SetOptions x -> mkCall (of_value_type set_options_sty_t x)
+ | MkCases x -> mkCall (of_value_type mkcases_sty_t x)
+ | Quit x -> mkCall (of_value_type quit_sty_t x)
+ | About x -> mkCall (of_value_type about_sty_t x)
+ | Init x -> mkCall (of_value_type init_sty_t x)
+ | Interp x -> mkCall (of_value_type interp_sty_t x)
+ | StopWorker x -> mkCall (of_value_type stop_worker_sty_t x)
+ | PrintAst x -> mkCall (of_value_type print_ast_sty_t x)
+ | Annotate x -> mkCall (of_value_type annotate_sty_t x)
+
+let to_call : xml -> unknown call =
+ do_match "call" (fun s a ->
+ let mkCallArg vt a = to_value_type vt (singleton a) in
+ match s with
+ | "Add" -> Add (mkCallArg add_sty_t a)
+ | "Edit_at" -> Edit_at (mkCallArg edit_at_sty_t a)
+ | "Query" -> Query (mkCallArg query_sty_t a)
+ | "Goal" -> Goal (mkCallArg goals_sty_t a)
+ | "Evars" -> Evars (mkCallArg evars_sty_t a)
+ | "Hints" -> Hints (mkCallArg hints_sty_t a)
+ | "Status" -> Status (mkCallArg status_sty_t a)
+ | "Search" -> Search (mkCallArg search_sty_t a)
+ | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a)
+ | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a)
+ | "MkCases" -> MkCases (mkCallArg mkcases_sty_t a)
+ | "Quit" -> Quit (mkCallArg quit_sty_t a)
+ | "About" -> About (mkCallArg about_sty_t a)
+ | "Init" -> Init (mkCallArg init_sty_t a)
+ | "Interp" -> Interp (mkCallArg interp_sty_t a)
+ | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a)
+ | "PrintAst" -> PrintAst (mkCallArg print_ast_sty_t a)
+ | "Annotate" -> Annotate (mkCallArg annotate_sty_t a)
+ | _ -> raise Marshal_error)
+
+(** Debug printing *)
+
+let pr_value_gen pr = function
+ | Good v -> "GOOD " ^ pr v
+ | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^str^"]"
+ | Fail (id,Some(i,j),str) ->
+ "FAIL "^Stateid.to_string id^
+ " ("^string_of_int i^","^string_of_int j^")["^str^"]"
+let pr_value v = pr_value_gen (fun _ -> "FIXME") v
+let pr_full_value call value = match call with
+ | Add _ -> pr_value_gen (print add_rty_t ) (Obj.magic value)
+ | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) (Obj.magic value)
+ | Query _ -> pr_value_gen (print query_rty_t ) (Obj.magic value)
+ | Goal _ -> pr_value_gen (print goals_rty_t ) (Obj.magic value)
+ | Evars _ -> pr_value_gen (print evars_rty_t ) (Obj.magic value)
+ | Hints _ -> pr_value_gen (print hints_rty_t ) (Obj.magic value)
+ | Status _ -> pr_value_gen (print status_rty_t ) (Obj.magic value)
+ | Search _ -> pr_value_gen (print search_rty_t ) (Obj.magic value)
+ | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value)
+ | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value)
+ | MkCases _ -> pr_value_gen (print mkcases_rty_t ) (Obj.magic value)
+ | Quit _ -> pr_value_gen (print quit_rty_t ) (Obj.magic value)
+ | About _ -> pr_value_gen (print about_rty_t ) (Obj.magic value)
+ | Init _ -> pr_value_gen (print init_rty_t ) (Obj.magic value)
+ | Interp _ -> pr_value_gen (print interp_rty_t ) (Obj.magic value)
+ | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value)
+ | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) (Obj.magic value)
+ | Annotate _ -> pr_value_gen (print annotate_rty_t ) (Obj.magic value)
+let pr_call call =
+ let return what x = str_of_call call ^ " " ^ print what x in
+ match call with
+ | Add x -> return add_sty_t x
+ | Edit_at x -> return edit_at_sty_t x
+ | Query x -> return query_sty_t x
+ | Goal x -> return goals_sty_t x
+ | Evars x -> return evars_sty_t x
+ | Hints x -> return hints_sty_t x
+ | Status x -> return status_sty_t x
+ | Search x -> return search_sty_t x
+ | GetOptions x -> return get_options_sty_t x
+ | SetOptions x -> return set_options_sty_t x
+ | MkCases x -> return mkcases_sty_t x
+ | Quit x -> return quit_sty_t x
+ | About x -> return about_sty_t x
+ | Init x -> return init_sty_t x
+ | Interp x -> return interp_sty_t x
+ | StopWorker x -> return stop_worker_sty_t x
+ | PrintAst x -> return print_ast_sty_t x
+ | Annotate x -> return annotate_sty_t x
+
+let document to_string_fmt =
+ Printf.printf "=== Available calls ===\n\n";
+ Array.iter (fun (cname, csty, crty) ->
+ Printf.printf "%12s : %s\n %14s %s\n"
+ ("\""^cname^"\"") (print_type csty) "->" (print_type crty))
+ calls;
+ Printf.printf "\n=== Calls XML encoding ===\n\n";
+ Printf.printf "A call \"C\" carrying input a is encoded as:\n\n%s\n\n"
+ (to_string_fmt (constructor "call" "C" [PCData "a"]));
+ Printf.printf "A response carrying output b can either be:\n\n%s\n\n"
+ (to_string_fmt (of_value (fun _ -> PCData "b") (Good ())));
+ Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n"
+ (to_string_fmt (of_value (fun _ -> PCData "b")
+ (Fail (Stateid.initial,Some (15,34),"error message"))));
+ document_type_encoding to_string_fmt
+
+(* vim: set foldmethod=marker: *)
diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli
new file mode 100644
index 00000000..2c8ebc65
--- /dev/null
+++ b/ide/xmlprotocol.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** * Applicative part of the interface of CoqIde calls to Coq *)
+
+open Interface
+open Xml_datatype
+
+type 'a call
+
+type unknown
+
+val add : add_sty -> add_rty call
+val edit_at : edit_at_sty -> edit_at_rty call
+val query : query_sty -> query_rty call
+val goals : goals_sty -> goals_rty call
+val hints : hints_sty -> hints_rty call
+val status : status_sty -> status_rty call
+val mkcases : mkcases_sty -> mkcases_rty call
+val evars : evars_sty -> evars_rty call
+val search : search_sty -> search_rty call
+val get_options : get_options_sty -> get_options_rty call
+val set_options : set_options_sty -> set_options_rty call
+val quit : quit_sty -> quit_rty call
+val init : init_sty -> init_rty call
+val stop_worker : stop_worker_sty -> stop_worker_rty call
+(* retrocompatibility *)
+val interp : interp_sty -> interp_rty call
+val print_ast : print_ast_sty -> print_ast_rty call
+val annotate : annotate_sty -> annotate_rty call
+
+val abstract_eval_call : handler -> 'a call -> 'a value
+
+(** * Protocol version *)
+
+val protocol_version : string
+
+(** * XML data marshalling *)
+
+val of_call : 'a call -> xml
+val to_call : xml -> unknown call
+
+val of_answer : 'a call -> 'a value -> xml
+val to_answer : 'a call -> xml -> 'a value
+
+(* Prints the documentation of this module *)
+val document : (xml -> string) -> unit
+
+(** * Debug printing *)
+
+val pr_call : 'a call -> string
+val pr_value : 'a value -> string
+val pr_full_value : 'a call -> 'a value -> string